chapter\<open>Pseudo-Coding: Section 7 Material\<close>

theory Pseudo_Coding
imports II_Prelims
begin

section\<open>General Lemmas\<close>

lemma Collect_disj_Un: "{f i |i. P i \<or> Q i} = {f i |i. P i} \<union> {f i |i. Q i}"
by auto

abbreviation Q_Subset :: "tm \<Rightarrow> tm \<Rightarrow> tm"
  where "Q_Subset t u \<equiv> (Q_All (Q_Imp (Q_Mem (Q_Ind Zero) t) (Q_Mem (Q_Ind Zero) u)))"

lemma NEQ_quot_tm: "i\<noteq>j \<Longrightarrow> {} \<turnstile> \<guillemotleft>Var i\<guillemotright> NEQ \<guillemotleft>Var j\<guillemotright>"
  using VarP_Var[of "{}" i] VarP_Var[of "{}" j]
  by (intro OrdNotEqP_I) (auto simp: VarP_def quot_Var ORD_OF_EQ_diff dest!: Conj_E1)

lemma EQ_quot_tm_Fls: "i\<noteq>j \<Longrightarrow> insert (\<guillemotleft>Var i\<guillemotright> EQ \<guillemotleft>Var j\<guillemotright>) H \<turnstile> Fls"
  by (metis (full_types) NEQ_quot_tm Assume OrdNotEqP_E cut2 thin0)

lemma perm_commute: "a \<sharp> p \<Longrightarrow> a' \<sharp> p \<Longrightarrow> (a \<rightleftharpoons> a') + p = p + (a \<rightleftharpoons> a')"
  by (rule plus_perm_eq) (simp add: supp_swap fresh_def)

lemma perm_self_inverseI: "\<lbrakk>-p = q; a \<sharp> p; a' \<sharp> p\<rbrakk> \<Longrightarrow> - ((a \<rightleftharpoons> a') + p) = (a \<rightleftharpoons> a') + q"
  by (simp_all add: perm_commute fresh_plus_perm minus_add)

lemma fresh_image:
  fixes f :: "'a \<Rightarrow> 'b::fs"  shows "finite A \<Longrightarrow> i \<sharp> f ` A \<longleftrightarrow> (\<forall>x\<in>A. i \<sharp> f x)"
  by (induct rule: finite_induct) (auto simp: fresh_finite_insert)

lemma atom_in_atom_image [simp]: "atom j \<in> atom ` V \<longleftrightarrow> j \<in> V"
  by auto

lemma fresh_star_empty [simp]: "{} \<sharp>* bs"
  by (simp add: fresh_star_def)

declare fresh_star_insert [simp]

lemma fresh_star_finite_insert:
  fixes S :: "('a::fs) set"  shows "finite S \<Longrightarrow> a \<sharp>* insert x S \<longleftrightarrow> a \<sharp>* x \<and> a \<sharp>* S"
  by (auto simp: fresh_star_def fresh_finite_insert)

lemma fresh_finite_Diff_single [simp]:
  fixes V :: "name set"   shows "finite V \<Longrightarrow> a \<sharp> (V - {j}) \<longleftrightarrow> (a \<sharp> j \<longrightarrow> a \<sharp> V)"
apply (auto simp: fresh_finite_insert)
apply (metis finite_Diff fresh_finite_insert insert_Diff_single)
apply (metis Diff_iff finite_Diff fresh_atom fresh_atom_at_base fresh_finite_set_at_base insertI1)
apply (metis Diff_idemp Diff_insert_absorb finite_Diff fresh_finite_insert insert_Diff_single insert_absorb)
done

lemma fresh_image_atom [simp]: "finite A \<Longrightarrow> i \<sharp> atom ` A \<longleftrightarrow> i \<sharp> A"
  by (induct rule: finite_induct) (auto simp: fresh_finite_insert)

lemma atom_fresh_star_atom_set_conv: "\<lbrakk>atom i \<sharp> bs; finite bs\<rbrakk> \<Longrightarrow> bs \<sharp>* i"
by (metis fresh_finite_atom_set fresh_ineq_at_base fresh_star_def)

lemma notin_V:
  assumes p: "atom i \<sharp> p" and V: "finite V" "atom ` (p \<bullet> V) \<sharp>* V"
  shows "i \<notin> V" "i \<notin> p \<bullet> V"
  using V
  apply (auto simp: fresh_def fresh_star_def supp_finite_set_at_base)
  apply (metis p mem_permute_iff fresh_at_base_permI)+
  done

section\<open>Simultaneous Substitution\<close>

definition ssubst :: "tm \<Rightarrow> name set \<Rightarrow> (name \<Rightarrow> tm) \<Rightarrow> tm"
  where "ssubst t V F = Finite_Set.fold (\<lambda>i. subst i (F i)) t V"

definition make_F :: "name set \<Rightarrow> perm \<Rightarrow> name \<Rightarrow> tm"
  where "make_F Vs p \<equiv> \<lambda>i. if i \<in> Vs then Var (p \<bullet> i) else Var i"

lemma ssubst_empty [simp]: "ssubst t {} F = t"
  by (simp add: ssubst_def)

text\<open>Renaming a finite set of variables. Based on the theorem \<open>at_set_avoiding\<close>\<close>
locale quote_perm =
  fixes p :: perm and Vs :: "name set" and F :: "name \<Rightarrow> tm"
  assumes p: "atom ` (p \<bullet> Vs) \<sharp>* Vs"
      and pinv: "-p = p"
      and Vs:  "finite Vs"
  defines "F \<equiv> make_F Vs p"
begin

lemma F_unfold: "F i = (if i \<in> Vs then Var (p \<bullet> i) else Var i)"
  by (simp add: F_def make_F_def)

lemma finite_V [simp]: "V \<subseteq> Vs \<Longrightarrow> finite V"
  by (metis Vs finite_subset)

lemma perm_exits_Vs: "i \<in> Vs \<Longrightarrow> (p \<bullet> i) \<notin> Vs"
  by (metis Vs fresh_finite_set_at_base imageI fresh_star_def mem_permute_iff p)

lemma atom_fresh_perm: "\<lbrakk>x \<in> Vs; y \<in> Vs\<rbrakk> \<Longrightarrow> atom x \<sharp> p \<bullet> y"
  by (metis imageI Vs p fresh_finite_set_at_base fresh_star_def mem_permute_iff fresh_at_base(2))

lemma fresh_pj: "\<lbrakk>a \<sharp> p; j \<in> Vs\<rbrakk> \<Longrightarrow> a \<sharp> p \<bullet> j"
  by (metis atom_fresh_perm fresh_at_base(2) fresh_perm fresh_permute_left pinv)

lemma fresh_Vs: "a \<sharp> p \<Longrightarrow> a \<sharp> Vs"
  by (metis Vs fresh_def fresh_perm fresh_permute_iff fresh_star_def p permute_finite supp_finite_set_at_base)

lemma fresh_pVs: "a \<sharp> p \<Longrightarrow> a \<sharp> p \<bullet> Vs"
  by (metis fresh_Vs fresh_perm fresh_permute_left pinv)

lemma assumes "V \<subseteq> Vs" "a \<sharp> p"
      shows fresh_pV [simp]: "a \<sharp> p \<bullet> V" and fresh_V [simp]: "a \<sharp> V"
  using fresh_pVs fresh_Vs assms
  apply (auto simp: fresh_def)
  apply (metis (full_types) Vs finite_V permute_finite set_mp subset_Un_eq supp_of_finite_union union_eqvt)
  by (metis Vs finite_V set_mp subset_Un_eq supp_of_finite_union)

lemma qp_insert:
  fixes i::name and i'::name
  assumes "atom i \<sharp> p" "atom i' \<sharp> (i,p)"
    shows  "quote_perm ((atom i \<rightleftharpoons> atom i') + p) (insert i Vs)"
using p pinv Vs assms
  by (auto simp: quote_perm_def fresh_at_base_permI atom_fresh_star_atom_set_conv swap_fresh_fresh
                 fresh_star_finite_insert fresh_finite_insert perm_self_inverseI)

lemma subst_F_left_commute: "subst x (F x) (subst y (F y) t) = subst y (F y) (subst x (F x) t)"
  by (metis subst_tm_commute2 F_unfold subst_tm_id F_unfold atom_fresh_perm tm.fresh(2))

lemma
  assumes "finite V" "i \<notin> V"
  shows ssubst_insert:  "ssubst t (insert i V) F = subst i (F i) (ssubst t V F)"  (is ?thesis1)
    and ssubst_insert2: "ssubst t (insert i V) F = ssubst (subst i (F i) t) V F"  (is ?thesis2)
proof -
  interpret comp_fun_commute "(\<lambda>i. subst i (F i))"
  proof qed (simp add: subst_F_left_commute fun_eq_iff)
  show ?thesis1 using assms Vs
    by (simp add: ssubst_def)
  show ?thesis2 using assms Vs
    by (simp add: ssubst_def fold_insert2 del: fold_insert)
qed

lemma ssubst_insert_if:
  "finite V \<Longrightarrow>
     ssubst t (insert i V) F = (if i \<in> V then ssubst t V F
                                         else subst i (F i) (ssubst t V F))"
  by (simp add: ssubst_insert insert_absorb)

lemma ssubst_single [simp]: "ssubst t {i} F = subst i (F i) t"
  by (simp add: ssubst_insert)

lemma ssubst_Var_if [simp]:
  assumes "finite V"
    shows "ssubst (Var i) V F = (if i \<in> V then F i else Var i)"
using assms
  apply (induction V, auto)
  apply (metis ssubst_insert subst.simps(2))
  apply (metis ssubst_insert2 subst.simps(2))+
  done

lemma ssubst_Zero [simp]: "finite V \<Longrightarrow> ssubst Zero V F = Zero"
  by (induct V rule: finite_induct) (auto simp: ssubst_insert)

lemma ssubst_Eats [simp]: "finite V \<Longrightarrow> ssubst (Eats t u) V F = Eats (ssubst t V F) (ssubst u V F)"
  by (induct V rule: finite_induct) (auto simp: ssubst_insert)

lemma ssubst_SUCC [simp]: "finite V \<Longrightarrow> ssubst (SUCC t) V F = SUCC (ssubst t V F)"
  by (metis SUCC_def ssubst_Eats)

lemma ssubst_ORD_OF [simp]: "finite V \<Longrightarrow> ssubst (ORD_OF n) V F = ORD_OF n"
  by (induction n) auto

lemma ssubst_HPair [simp]:
  "finite V \<Longrightarrow> ssubst (HPair t u) V F = HPair (ssubst t V F) (ssubst u V F)"
  by (simp add: HPair_def)

lemma ssubst_HTuple [simp]: "finite V \<Longrightarrow> ssubst (HTuple n) V F = (HTuple n)"
  by (induction n) (auto simp: HTuple.simps)

lemma ssubst_Subset:
  assumes "finite V" shows "ssubst \<lfloor>t SUBS u\<rfloor>V V F = Q_Subset (ssubst \<lfloor>t\<rfloor>V V F) (ssubst \<lfloor>u\<rfloor>V V F)"
proof -
  obtain i::name where "atom i \<sharp> (t,u)"
    by (rule obtain_fresh)
  thus ?thesis using assms
    by (auto simp: Subset.simps [of i] vquot_fm_def vquot_tm_def trans_tm_forget)
qed

lemma fresh_ssubst:
  assumes "finite V" "a \<sharp> p \<bullet> V" "a \<sharp> t"
    shows "a \<sharp> ssubst t V F"
using assms
  by (induct V)
     (auto simp: ssubst_insert_if fresh_finite_insert F_unfold intro: fresh_ineq_at_base)

lemma fresh_ssubst':
  assumes "finite V" "atom i \<sharp> t" "atom (p \<bullet> i) \<sharp> t"
    shows "atom i \<sharp> ssubst t V F"
using assms
  by (induct t rule: tm.induct) (auto simp: F_unfold fresh_permute_left pinv)

lemma ssubst_vquot_Ex:
  "\<lbrakk>finite V; atom i \<sharp> p \<bullet> V\<rbrakk>
   \<Longrightarrow> ssubst \<lfloor>Ex i A\<rfloor>(insert i V) (insert i V) F = ssubst \<lfloor>Ex i A\<rfloor>V V F"
   by (simp add: ssubst_insert_if insert_absorb vquot_fm_insert fresh_ssubst)

lemma ground_ssubst_eq: "\<lbrakk>finite V; supp t = {}\<rbrakk> \<Longrightarrow> ssubst t V F = t"
  by (induct V rule: finite_induct) (auto simp: ssubst_insert fresh_def)

lemma ssubst_quot_fm [simp]:
  fixes A::fm shows "finite V \<Longrightarrow> ssubst \<guillemotleft>A\<guillemotright> V F = \<guillemotleft>A\<guillemotright>"
  by (simp add: ground_ssubst_eq supp_conv_fresh)

lemma atom_in_p_Vs: "\<lbrakk>i \<in> p \<bullet> V; V \<subseteq> Vs\<rbrakk> \<Longrightarrow> i \<in> p \<bullet> Vs"
  by (metis (full_types) True_eqvt set_mp subset_eqvt)

section\<open>The Main Theorems of Section 7\<close>

lemma SubstTermP_vquot_dbtm:
  assumes w: "w \<in> Vs - V" and V: "V \<subseteq> Vs" "V' = p \<bullet> V"
      and s: "supp dbtm \<subseteq> atom ` Vs"
  shows
  "insert (ConstP (F w)) {ConstP (F i) | i. i \<in> V}
   \<turnstile> SubstTermP \<guillemotleft>Var w\<guillemotright> (F w)
                (ssubst (vquot_dbtm V dbtm) V F)
                (subst w (F w) (ssubst (vquot_dbtm (insert w V) dbtm) V F))"
using s
proof (induct dbtm rule: dbtm.induct)
  case DBZero thus ?case using V w
    by (auto intro: SubstTermP_Zero [THEN cut1] ConstP_imp_TermP [THEN cut1])
next
  case (DBInd n) thus ?case using V
    apply auto
    apply (rule thin [of "{ConstP (F w)}"])
    apply (rule SubstTermP_Ind [THEN cut3])
    apply (auto simp: IndP_Q_Ind OrdP_ORD_OF ConstP_imp_TermP)
    done
next
  case (DBVar i) show ?case
  proof (cases "i \<in> V'")
    case True hence "i \<notin> Vs" using assms
      by (metis p Vs atom_in_atom_image atom_in_p_Vs fresh_finite_set_at_base fresh_star_def)
    thus ?thesis using DBVar True V
      by auto
  next
    case False thus ?thesis using DBVar V w
      apply (auto simp: quot_Var [symmetric])
        apply (blast intro: thin [of "{ConstP (F w)}"] ConstP_imp_TermP
                            SubstTermP_Var_same [THEN cut2])
       apply (subst forget_subst_tm, metis F_unfold atom_fresh_perm tm.fresh(2))
       apply (blast intro: Hyp thin [of "{ConstP (F w)}"] ConstP_imp_TermP
                           SubstTermP_Const [THEN cut2])
       apply (blast intro: Hyp thin [of "{ConstP (F w)}"] ConstP_imp_TermP EQ_quot_tm_Fls
                           SubstTermP_Var_diff [THEN cut4])
      done
  qed
next
  case (DBEats tm1 tm2) thus ?case using V
    by (auto simp: SubstTermP_Eats [THEN cut2])
qed

lemma SubstFormP_vquot_dbfm:
  assumes w: "w \<in> Vs - V" and V: "V \<subseteq> Vs" "V' = p \<bullet> V"
      and s: "supp dbfm \<subseteq> atom ` Vs"
  shows
  "insert (ConstP (F w)) {ConstP (F i) | i. i \<in> V}
   \<turnstile> SubstFormP \<guillemotleft>Var w\<guillemotright> (F w)
                (ssubst (vquot_dbfm V dbfm) V F)
                (subst w (F w) (ssubst (vquot_dbfm (insert w V) dbfm) V F))"
using w s
proof (induct dbfm rule: dbfm.induct)
  case (DBMem t u) thus ?case using V
    by (auto intro: SubstTermP_vquot_dbtm SubstFormP_Mem [THEN cut2])
next
  case (DBEq t u) thus ?case using V
    by (auto intro: SubstTermP_vquot_dbtm SubstFormP_Eq [THEN cut2])
next
  case (DBDisj A B) thus ?case using V
    by (auto intro: SubstFormP_Disj [THEN cut2])
next
  case (DBNeg A) thus ?case using V
    by (auto intro: SubstFormP_Neg [THEN cut1])
next
  case (DBEx A) thus ?case using V
    by (auto intro: SubstFormP_Ex [THEN cut1])
qed

text\<open>Lemmas 7.5 and 7.6\<close>
lemma ssubst_SubstFormP:
  fixes A::fm
  assumes w: "w \<in> Vs - V" and V: "V \<subseteq> Vs" "V' = p \<bullet> V"
      and s: "supp A \<subseteq> atom ` Vs"
  shows
  "insert (ConstP (F w)) {ConstP (F i) | i. i \<in> V}
   \<turnstile> SubstFormP \<guillemotleft>Var w\<guillemotright> (F w)
                (ssubst \<lfloor>A\<rfloor>V V F)
                (ssubst \<lfloor>A\<rfloor>(insert w V) (insert w V) F)"
proof -
  have "w \<notin> V" using assms
    by auto
  thus ?thesis using assms
    by (simp add: vquot_fm_def supp_conv_fresh ssubst_insert_if SubstFormP_vquot_dbfm)
qed

text\<open>Theorem 7.3\<close>
theorem PfP_implies_PfP_ssubst:
  fixes \<beta>::fm
  assumes \<beta>: "{} \<turnstile> PfP \<guillemotleft>\<beta>\<guillemotright>"
      and V: "V \<subseteq> Vs"
      and s: "supp \<beta> \<subseteq> atom ` Vs"
    shows    "{ConstP (F i) | i. i \<in> V} \<turnstile> PfP (ssubst \<lfloor>\<beta>\<rfloor>V V F)"
proof -
  show ?thesis using finite_V [OF V] V
  proof induction
    case empty thus ?case
      by (auto simp: \<beta>)
  next
    case (insert i V)
    thus ?case using assms
      by (auto simp: Collect_disj_Un fresh_finite_set_at_base
               intro: PfP_implies_SubstForm_PfP thin1 ssubst_SubstFormP)
  qed
qed

end

end


(*  Title:       Implementing field extensions of the form Q[sqrt(b)]
    Author:      René Thiemann       <rene.thiemann@uibk.ac.at>
    Maintainer:  René Thiemann
    License:     LGPL
*)

(*
Copyright 2009-2014 René Thiemann

This file is part of IsaFoR/CeTA.

IsaFoR/CeTA is free software: you can redistribute it and/or modify it under the
terms of the GNU Lesser General Public License as published by the Free Software
Foundation, either version 3 of the License, or (at your option) any later
version.

IsaFoR/CeTA is distributed in the hope that it will be useful, but WITHOUT ANY
WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A
PARTICULAR PURPOSE.  See the GNU Lesser General Public License for more details.

You should have received a copy of the GNU Lesser General Public License along
with IsaFoR/CeTA. If not, see <http://www.gnu.org/licenses/>.
*)
header {* Prime products *}

theory Prime_Product
imports
  Real_Impl_Auxiliary
  "../Sqrt_Babylonian/Sqrt_Babylonian"
begin

text {*
  Prime products are natural numbers where no prime factor occurs more than once.
*}
definition prime_product where "prime_product (n :: nat) = (\<forall> p. multiplicity p n \<le> 1)"

text {*
  The main property is that whenever $b_1$ and $b_2$ are different prime products,
  then $p_1 + q_1 \sqrt{b_1} = p_2 + q_2 \sqrt{b_2}$ implies $(p_1,q_1,b_1) = (p_2,q_2,b_2)$
  for all rational numbers $p_1,q_1,p_2,q_2$. This is the key property to uniquely
  represent numbers in $\ratsb$ by triples. In the following we develop an algorithm
  to decompose any natural number $n$ into $n = s^2 \cdot p$ for some $s$ and prime product $p$.
*}

(* factor a number into square * a prime product *)
function prime_product_factor_main :: "nat \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> nat \<times> nat" where
  "prime_product_factor_main factor_sq factor_pr limit n i =
    (if i \<le> limit \<and> i \<ge> 2 then
       (if i dvd n
           then (let n' = n div i in
             (if i dvd n' then
                let n'' = n' div i in
                  prime_product_factor_main (factor_sq * i) factor_pr (nat (root_nat_floor 3 n'')) n'' i
                else
                  (case sqrt_nat n' of
                    Cons sn _ \<Rightarrow> (factor_sq * sn, factor_pr * i)
                  | [] \<Rightarrow> prime_product_factor_main factor_sq (factor_pr * i) (nat (root_nat_floor 3 n')) n' (Suc i)
                  )
             )
           )
         else
           prime_product_factor_main factor_sq factor_pr limit n (Suc i))
       else
         (factor_sq, factor_pr * n))" by pat_completeness auto

termination
proof -
  let ?m1 = "\<lambda> (factor_sq :: nat,factor_pr :: nat,limit :: nat,n :: nat,i :: nat). n"
  let ?m2 = "\<lambda> (factor_sq,factor_pr,limit,n,i). (Suc limit - i)"
  {
    fix i
    have "2 \<le> i \<Longrightarrow> Suc 0 < i * i" using one_less_mult[of i i] by auto
  } note * = this
  show ?thesis
    by (rule, rule wf_measures[of "[?m1,?m2]"], auto split: if_splits simp: * dvd_eq_mod_eq_0)
qed

lemma prime_product_factor_main: assumes "\<not> (\<exists> s. s * s = n)"
  and "limit = nat (root_nat_floor 3 n)"
  and "m = factor_sq * factor_sq * factor_pr * n"
  and "prime_product_factor_main factor_sq factor_pr limit n i = (sq, p)"
  and "i \<ge> 2"
  and "\<And> j. j \<ge> 2 \<Longrightarrow> j < i \<Longrightarrow> \<not> j dvd n"
  and "\<And> j. j < i \<Longrightarrow> multiplicity j factor_pr \<le> 1"
  and "\<And> j. j \<ge> i \<Longrightarrow> multiplicity j factor_pr = 0"
  and "factor_pr > 0"
  shows "m = sq * sq * p \<and> prime_product p"
  using assms
proof (induct factor_sq factor_pr limit n i rule: prime_product_factor_main.induct)
  case (1 factor_sq factor_pr limit n i)
  note IH = 1(1-3)
  note prems = 1(4-)
  note simp = prems(4)[unfolded prime_product_factor_main.simps[of factor_sq factor_pr limit n i]]
  show ?case
  proof (cases "i \<le> limit")
    case True note i = this
    with prems(5) have cond: "i \<le> limit \<and> i \<ge> 2" and *: "(i \<le> limit \<and> i \<ge> 2) = True" by blast+
    note IH = IH[OF cond]
    note simp = simp[unfolded * if_True]
    show ?thesis
    proof (cases "i dvd n")
      case False
      hence *: "(i dvd n) = False" by simp
      note simp = simp[unfolded * if_False]
      note IH = IH(3)[OF False prems(1-3) simp]
      show ?thesis
      proof (rule IH)
        fix j
        assume 2: "2 \<le> j" and j: "j < Suc i"
        from prems(6)[OF 2] j False
        show "\<not> j dvd n" by (cases "j = i", auto)
      next
        fix j
        assume j: "j < Suc i"
        with prems(7-8)[of j]
        show "multiplicity j factor_pr \<le> 1" by (cases "j = i", auto)
      qed (insert prems(8-9) cond, auto)
    next
      case True note mod = this
      hence "(i dvd n) = True" by simp
      note simp = simp[unfolded this if_True Let_def]
      note IH = IH(1,2)[OF True refl]
      show ?thesis
      proof (cases "i dvd n div i")
        case True
        hence *: "(i dvd n div i) = True" by auto
        def n' \<equiv> "n div i div i"
        from mod True have n: "n = n' * i * i" by (auto simp: n'_def dvd_eq_mod_eq_0)
        note simp = simp[unfolded * if_True split]
        note IH = IH(1)[OF True refl _ refl _ simp prems(5) _ prems(7-9)]
        show ?thesis
        proof (rule IH)
          show "m = factor_sq * i * (factor_sq * i) * factor_pr * (n div i div i)"
            unfolding prems(3) n'_def[symmetric]
            unfolding n by (auto simp: field_simps)
        next
          fix j
          assume "2 \<le> j" "j < i"
          from prems(6)[OF this] have "\<not> j dvd n" by auto
          thus "\<not> j dvd n div i div i"
            by (metis dvd_mult n n'_def mult.assoc mult.commute)
        next
          show "\<not> (\<exists> s. s * s = n div i div i)"
          proof
            assume "\<exists> s. s * s = n div i div i"
            then obtain s where "s * s = n div i div i" by auto
            hence "(s * i) * (s * i) = n" unfolding n by auto
            with prems(1) show False by blast
          qed
        qed
      next
        case False
        def n' \<equiv> "n div i"
        from mod True have n: "n = n' * i" by (auto simp: n'_def dvd_eq_mod_eq_0)
        have prime: "prime i"
          unfolding prime_nat_def
        proof (intro conjI allI impI)
          fix m
          assume m: "m dvd i"
          hence "m dvd n" unfolding n by auto
          with prems(6)[of m] have choice: "m \<le> 1 \<or> m \<ge> i" by arith
          from m prems(5) have "m > 0"
            by (metis dvd_0_left_iff le0 le_antisym neq0_conv zero_neq_numeral)
          with choice have choice: "m = 1 \<or> m \<ge> i" by arith
          from m prems(5) have "m \<le> i"
            by (metis False div_by_0 dvd.dual_order.refl dvd_imp_le gr0I)
          with choice
          show "m = 1 \<or> m = i" by auto
        qed (insert prems(5), auto)
        from False have "(i dvd n div i) = False" by auto
        note simp = simp[unfolded this if_False]
        note IH = IH(2)[OF False _ _ refl]
        from prime have "i > 0" by auto
        note mult = multiplicity_product_nat[OF prems(9) this]
        note mult_i = multiplicity_prime_nat[OF prime] multiplicity_prime[OF prime]
        show ?thesis
        proof (cases "sqrt_nat (n div i)")
          case (Cons s)
          note simp = simp[unfolded Cons list.simps]
          hence sq: "sq = factor_sq * s" and p: "p = factor_pr * i" by auto
          from arg_cong[OF Cons, of set] have s: "s * s = n div i" by auto
          have pp: "prime_product (factor_pr * i)"
            unfolding prime_product_def
          proof
            fix m
            show "multiplicity m (factor_pr * i) \<le> 1"
              unfolding mult using prems(7)[of m] prems(8)[of m] mult_i(1) mult_i(2)[of m] by fastforce
          qed
          show ?thesis unfolding sq p prems(3) n unfolding n'_def s[symmetric]
            using pp by auto
        next
          case Nil
          note simp = simp[unfolded Nil list.simps]
          from arg_cong[OF Nil, of set] have "\<not> (\<exists> x. x * x = n div i)" by simp
          note IH = IH[OF Nil this  _ simp]
          show ?thesis
          proof (rule IH)
            show "m = factor_sq * factor_sq * (factor_pr * i) * (n div i)"
              unfolding prems(3) n by auto
          next
            fix j
            assume *: "2 \<le> j" "j < Suc i"
            show "\<not> j dvd n div i"
            proof
              assume j: "j dvd n div i"
              with False have "j \<noteq> i" by auto
              with * have "2 \<le> j" "j < i" by auto
              from prems(6)[OF this] j
              show False unfolding n
                by (metis dvd_mult n n'_def mult.commute)
            qed
          next
            fix j
            assume "Suc i \<le> j"
            hence ij: "i \<le> j" and j: "j \<noteq> i" by auto
            have 0: "multiplicity j i = 0" using prime j by (rule multiplicity_prime)
            show "multiplicity j (factor_pr * i) = 0" unfolding mult prems(8)[OF ij] 0 by simp
          next
            fix j
            assume "j < Suc i"
            hence "j < i \<or> j = i" by auto
            thus "multiplicity j (factor_pr * i) \<le> 1"
            proof
              assume "j = i"
              with prems(8)[of i] prime show ?thesis unfolding mult
                by (auto)
            next
              assume ji: "j < i"
              hence "j \<noteq> i" by auto
              from prems(7)[OF ji] multiplicity_prime[OF prime this]
              show ?thesis unfolding mult by auto
            qed
          qed (insert prems(5,9), auto)
        qed
      qed
    qed
  next
    case False
    hence "(i \<le> limit \<and> i \<ge> 2) = False" by auto
    note simp = simp[unfolded this if_False]
    hence sq: "sq = factor_sq" and p: "p = factor_pr * n" by auto
    show ?thesis
    proof
      show "m = sq * sq * p" unfolding sq p prems(3) by simp
      show "prime_product p" unfolding prime_product_def
      proof
        fix m
        from prems(1) have n1: "n > 1" by (cases n, auto, case_tac nat, auto)
        hence n0: "n > 0" by auto
        have "i > limit" using False by auto
        from this[unfolded prems(2)] have less: "int i \<ge> root_nat_floor 3 n + 1" by auto
        have "int n < (root_nat_floor 3 n + 1) ^ 3" by (rule root_nat_floor_upper, auto)
        also have "\<dots> \<le> int i ^ 3" by (rule power_mono[OF less, of 3], auto)
        finally have n_i3: "n < i ^ 3"
          by (metis zless_int zpower_int)
        {
          fix m
          assume m: "multiplicity m n > 0"
          hence mp: "m \<in> prime_factors n"
            by (metis less_not_refl multiplicity_not_factor_nat)
          hence md: "m dvd n"
            by (metis n0 prime_factors_altdef2_nat)
          then obtain k where n: "n = m * k" ..
          from mp have pm: "prime m" by auto
          hence m2: "m \<ge> 2" and m0: "m > 0" by auto
          from prems(6)[OF m2] md have mi: "m \<ge> i" by force
          {
            assume "multiplicity m n \<noteq> 1"
            with m have "\<exists> k. multiplicity m n = 2 + k" by presburger
            then obtain j where mult: "multiplicity m n = 2 + j" ..
            from n0 n have k: "k > 0" by auto
            from mult[unfolded n multiplicity_product_nat[OF m0 k]] pm
            have "multiplicity m k > 0" by auto
            hence mp: "m \<in> prime_factors k"
              by (metis less_not_refl multiplicity_not_factor_nat)
            hence md: "m dvd k"
              by (metis k prime_factors_altdef2_nat)
            then obtain l where kml: "k = m * l" ..
            note n = n[unfolded kml]
            from n have "l dvd n" by auto
            with prems(6)[of l] have "l \<le> 1 \<or> l \<ge> i" by arith
            with n n0 have l: "l = 1 \<or> l \<ge> i" by auto
            from n prems(1) have "l \<noteq> 1" by auto
            with l have l: "l \<ge> i" by auto
            from mult_le_mono[OF mult_le_mono[OF mi mi] l]
            have "n \<ge> i^3" unfolding n by (auto simp: power3_eq_cube)
            with n_i3 have False by auto
          }
          with mi m
          have "multiplicity m n = 1 \<and> m \<ge> i" by auto
        } note n = this
        have "multiplicity m p = multiplicity m factor_pr + multiplicity m n"
          unfolding p
          by (rule multiplicity_product_nat[OF prems(9)], insert prems(1), cases n, auto)
        also have "\<dots> \<le> 1"
        proof (cases "m < i")
          case True
          from prems(7)[of m] n[of m] True show ?thesis by force
        next
          case False
          hence "m \<ge> i" by auto
          from prems(8)[OF this] n[of m] show ?thesis by force
        qed
        finally show "multiplicity m p \<le> 1" .
      qed
    qed
  qed
qed

definition prime_product_factor :: "nat \<Rightarrow> nat \<times> nat" where
  "prime_product_factor n = (case sqrt_nat n of
     (Cons s _) \<Rightarrow> (s,1)
   | [] \<Rightarrow> prime_product_factor_main 1 1 (nat (root_nat_floor 3 n)) n 2)"

lemma prime_product_one[simp, intro]: "prime_product 1"
  unfolding prime_product_def multiplicity_one_nat by auto

lemma prime_product_factor: assumes pf: "prime_product_factor n = (sq,p)"
  shows "n = sq * sq * p \<and> prime_product p"
proof (cases "sqrt_nat n")
  case (Cons s)
  from pf[unfolded prime_product_factor_def Cons] arg_cong[OF Cons, of set]
    prime_product_one
  show ?thesis by auto
next
  case Nil
  from arg_cong[OF Nil, of set] have nsq: "\<not> (\<exists>s. s * s = n)" by auto
  show ?thesis
    by (rule prime_product_factor_main[OF nsq refl, of _ 1 1 2], unfold multiplicity_one_nat',
    insert pf[unfolded prime_product_factor_def Nil], auto)
qed

end


subsection \<open>Miscellaneous Parametricity Theorems\<close>

theory State_Heap_Misc
  imports Main
begin
context  includes lifting_syntax begin

lemma rel_fun_comp1:
  assumes "(R1 ===> S1) f g" "(R2 ===> S2) g h" "R' = R1 OO R2"
  shows "(R' ===> S1 OO S2) f h"
  using assms rel_fun_comp by metis

lemma rel_fun_comp2:
  assumes "(R1 ===> S1) f g" "(R2 ===> S2) g h" "S' = S1 OO S2"
  shows "(R1 OO R2 ===> S') f h"
  using assms rel_fun_comp by metis

lemma rel_fun_relcompp:
  "((R1 ===> S1) OO (R2 ===> S2)) a b \<Longrightarrow> ((R1 OO R2) ===> (S1 OO S2)) a b"
  unfolding OO_def rel_fun_def by blast

lemma rel_fun_comp1':
  assumes "(R1 ===> S1) f g" "(R2 ===> S2) g h" "\<And> a b. R' a b \<Longrightarrow> (R1 OO R2) a b"
  shows "(R' ===> S1 OO S2) f h"
  by (auto intro: assms rel_fun_mono[OF rel_fun_comp1])

lemma rel_fun_comp2':
  assumes "(R1 ===> S1) f g" "(R2 ===> S2) g h" "\<And> a b. (S1 OO S2) a b \<Longrightarrow> S' a b"
  shows "(R1 OO R2 ===> S') f h"
  by (auto intro: assms rel_fun_mono[OF rel_fun_comp1])

end
end


(*  Title:      HOL/Datatype_Examples/Derivation_Trees/Gram_Lang.thy
    Author:     Andrei Popescu, TU Muenchen
    Copyright   2012

Language of a grammar.
*)

section {* Language of a Grammar *}

theory Gram_Lang
imports DTree "~~/src/HOL/Library/Infinite_Set"
begin

(* We assume that the sets of terminals, and the left-hand sides of
productions are finite and that the grammar has no unused nonterminals. *)
consts P :: "(N \<times> (T + N) set) set"
axiomatization where
    finite_N: "finite (UNIV::N set)"
and finite_in_P: "\<And> n tns. (n,tns) \<in> P \<longrightarrow> finite tns"
and used: "\<And> n. \<exists> tns. (n,tns) \<in> P"

subsection{* Tree Basics: frontier, interior, etc. *}

(* Frontier *)

inductive inFr :: "N set \<Rightarrow> dtree \<Rightarrow> T \<Rightarrow> bool" where
Base: "\<lbrakk>root tr \<in> ns; Inl t \<in> cont tr\<rbrakk> \<Longrightarrow> inFr ns tr t"
|
Ind: "\<lbrakk>root tr \<in> ns; Inr tr1 \<in> cont tr; inFr ns tr1 t\<rbrakk> \<Longrightarrow> inFr ns tr t"

definition "Fr ns tr \<equiv> {t. inFr ns tr t}"

lemma inFr_root_in: "inFr ns tr t \<Longrightarrow> root tr \<in> ns"
by (metis inFr.simps)

lemma inFr_mono:
assumes "inFr ns tr t" and "ns \<subseteq> ns'"
shows "inFr ns' tr t"
using assms apply(induct arbitrary: ns' rule: inFr.induct)
using Base Ind by (metis inFr.simps set_mp)+

lemma inFr_Ind_minus:
assumes "inFr ns1 tr1 t" and "Inr tr1 \<in> cont tr"
shows "inFr (insert (root tr) ns1) tr t"
using assms apply(induct rule: inFr.induct)
  apply (metis inFr.simps insert_iff)
  by (metis inFr.simps inFr_mono insertI1 subset_insertI)

(* alternative definition *)
inductive inFr2 :: "N set \<Rightarrow> dtree \<Rightarrow> T \<Rightarrow> bool" where
Base: "\<lbrakk>root tr \<in> ns; Inl t \<in> cont tr\<rbrakk> \<Longrightarrow> inFr2 ns tr t"
|
Ind: "\<lbrakk>Inr tr1 \<in> cont tr; inFr2 ns1 tr1 t\<rbrakk>
      \<Longrightarrow> inFr2 (insert (root tr) ns1) tr t"

lemma inFr2_root_in: "inFr2 ns tr t \<Longrightarrow> root tr \<in> ns"
apply(induct rule: inFr2.induct) by auto

lemma inFr2_mono:
assumes "inFr2 ns tr t" and "ns \<subseteq> ns'"
shows "inFr2 ns' tr t"
using assms apply(induct arbitrary: ns' rule: inFr2.induct)
using Base Ind
apply (metis subsetD) by (metis inFr2.simps insert_absorb insert_subset)

lemma inFr2_Ind:
assumes "inFr2 ns tr1 t" and "root tr \<in> ns" and "Inr tr1 \<in> cont tr"
shows "inFr2 ns tr t"
using assms apply(induct rule: inFr2.induct)
  apply (metis inFr2.simps insert_absorb)
  by (metis inFr2.simps insert_absorb)

lemma inFr_inFr2:
"inFr = inFr2"
apply (rule ext)+  apply(safe)
  apply(erule inFr.induct)
    apply (metis (lifting) inFr2.Base)
    apply (metis (lifting) inFr2_Ind)
  apply(erule inFr2.induct)
    apply (metis (lifting) inFr.Base)
    apply (metis (lifting) inFr_Ind_minus)
done

lemma not_root_inFr:
assumes "root tr \<notin> ns"
shows "\<not> inFr ns tr t"
by (metis assms inFr_root_in)

lemma not_root_Fr:
assumes "root tr \<notin> ns"
shows "Fr ns tr = {}"
using not_root_inFr[OF assms] unfolding Fr_def by auto

(* Interior *)

inductive inItr :: "N set \<Rightarrow> dtree \<Rightarrow> N \<Rightarrow> bool" where
Base: "root tr \<in> ns \<Longrightarrow> inItr ns tr (root tr)"
|
Ind: "\<lbrakk>root tr \<in> ns; Inr tr1 \<in> cont tr; inItr ns tr1 n\<rbrakk> \<Longrightarrow> inItr ns tr n"

definition "Itr ns tr \<equiv> {n. inItr ns tr n}"

lemma inItr_root_in: "inItr ns tr n \<Longrightarrow> root tr \<in> ns"
by (metis inItr.simps)

lemma inItr_mono:
assumes "inItr ns tr n" and "ns \<subseteq> ns'"
shows "inItr ns' tr n"
using assms apply(induct arbitrary: ns' rule: inItr.induct)
using Base Ind by (metis inItr.simps set_mp)+

(* The subtree relation *)

inductive subtr where
Refl: "root tr \<in> ns \<Longrightarrow> subtr ns tr tr"
|
Step: "\<lbrakk>root tr3 \<in> ns; subtr ns tr1 tr2; Inr tr2 \<in> cont tr3\<rbrakk> \<Longrightarrow> subtr ns tr1 tr3"

lemma subtr_rootL_in:
assumes "subtr ns tr1 tr2"
shows "root tr1 \<in> ns"
using assms apply(induct rule: subtr.induct) by auto

lemma subtr_rootR_in:
assumes "subtr ns tr1 tr2"
shows "root tr2 \<in> ns"
using assms apply(induct rule: subtr.induct) by auto

lemmas subtr_roots_in = subtr_rootL_in subtr_rootR_in

lemma subtr_mono:
assumes "subtr ns tr1 tr2" and "ns \<subseteq> ns'"
shows "subtr ns' tr1 tr2"
using assms apply(induct arbitrary: ns' rule: subtr.induct)
using Refl Step by (metis subtr.simps set_mp)+

lemma subtr_trans_Un:
assumes "subtr ns12 tr1 tr2" and "subtr ns23 tr2 tr3"
shows "subtr (ns12 \<union> ns23) tr1 tr3"
proof-
  have "subtr ns23 tr2 tr3  \<Longrightarrow>
        (\<forall> ns12 tr1. subtr ns12 tr1 tr2 \<longrightarrow> subtr (ns12 \<union> ns23) tr1 tr3)"
  apply(induct  rule: subtr.induct, safe)
    apply (metis subtr_mono sup_commute sup_ge2)
    by (metis (lifting) Step UnI2)
  thus ?thesis using assms by auto
qed

lemma subtr_trans:
assumes "subtr ns tr1 tr2" and "subtr ns tr2 tr3"
shows "subtr ns tr1 tr3"
using subtr_trans_Un[OF assms] by simp

lemma subtr_StepL:
assumes r: "root tr1 \<in> ns" and tr12: "Inr tr1 \<in> cont tr2" and s: "subtr ns tr2 tr3"
shows "subtr ns tr1 tr3"
apply(rule subtr_trans[OF _ s])
apply(rule Step[of tr2 ns tr1 tr1])
apply(rule subtr_rootL_in[OF s])
apply(rule Refl[OF r])
apply(rule tr12)
done

(* alternative definition: *)
inductive subtr2 where
Refl: "root tr \<in> ns \<Longrightarrow> subtr2 ns tr tr"
|
Step: "\<lbrakk>root tr1 \<in> ns; Inr tr1 \<in> cont tr2; subtr2 ns tr2 tr3\<rbrakk> \<Longrightarrow> subtr2 ns tr1 tr3"

lemma subtr2_rootL_in:
assumes "subtr2 ns tr1 tr2"
shows "root tr1 \<in> ns"
using assms apply(induct rule: subtr2.induct) by auto

lemma subtr2_rootR_in:
assumes "subtr2 ns tr1 tr2"
shows "root tr2 \<in> ns"
using assms apply(induct rule: subtr2.induct) by auto

lemmas subtr2_roots_in = subtr2_rootL_in subtr2_rootR_in

lemma subtr2_mono:
assumes "subtr2 ns tr1 tr2" and "ns \<subseteq> ns'"
shows "subtr2 ns' tr1 tr2"
using assms apply(induct arbitrary: ns' rule: subtr2.induct)
using Refl Step by (metis subtr2.simps set_mp)+

lemma subtr2_trans_Un:
assumes "subtr2 ns12 tr1 tr2" and "subtr2 ns23 tr2 tr3"
shows "subtr2 (ns12 \<union> ns23) tr1 tr3"
proof-
  have "subtr2 ns12 tr1 tr2  \<Longrightarrow>
        (\<forall> ns23 tr3. subtr2 ns23 tr2 tr3 \<longrightarrow> subtr2 (ns12 \<union> ns23) tr1 tr3)"
  apply(induct  rule: subtr2.induct, safe)
    apply (metis subtr2_mono sup_commute sup_ge2)
    by (metis Un_iff subtr2.simps)
  thus ?thesis using assms by auto
qed

lemma subtr2_trans:
assumes "subtr2 ns tr1 tr2" and "subtr2 ns tr2 tr3"
shows "subtr2 ns tr1 tr3"
using subtr2_trans_Un[OF assms] by simp

lemma subtr2_StepR:
assumes r: "root tr3 \<in> ns" and tr23: "Inr tr2 \<in> cont tr3" and s: "subtr2 ns tr1 tr2"
shows "subtr2 ns tr1 tr3"
apply(rule subtr2_trans[OF s])
apply(rule Step[of _ _ tr3])
apply(rule subtr2_rootR_in[OF s])
apply(rule tr23)
apply(rule Refl[OF r])
done

lemma subtr_subtr2:
"subtr = subtr2"
apply (rule ext)+  apply(safe)
  apply(erule subtr.induct)
    apply (metis (lifting) subtr2.Refl)
    apply (metis (lifting) subtr2_StepR)
  apply(erule subtr2.induct)
    apply (metis (lifting) subtr.Refl)
    apply (metis (lifting) subtr_StepL)
done

lemma subtr_inductL[consumes 1, case_names Refl Step]:
assumes s: "subtr ns tr1 tr2" and Refl: "\<And>ns tr. \<phi> ns tr tr"
and Step:
"\<And>ns tr1 tr2 tr3.
   \<lbrakk>root tr1 \<in> ns; Inr tr1 \<in> cont tr2; subtr ns tr2 tr3; \<phi> ns tr2 tr3\<rbrakk> \<Longrightarrow> \<phi> ns tr1 tr3"
shows "\<phi> ns tr1 tr2"
using s unfolding subtr_subtr2 apply(rule subtr2.induct)
using Refl Step unfolding subtr_subtr2 by auto

lemma subtr_UNIV_inductL[consumes 1, case_names Refl Step]:
assumes s: "subtr UNIV tr1 tr2" and Refl: "\<And>tr. \<phi> tr tr"
and Step:
"\<And>tr1 tr2 tr3.
   \<lbrakk>Inr tr1 \<in> cont tr2; subtr UNIV tr2 tr3; \<phi> tr2 tr3\<rbrakk> \<Longrightarrow> \<phi> tr1 tr3"
shows "\<phi> tr1 tr2"
using s apply(induct rule: subtr_inductL)
apply(rule Refl) using Step subtr_mono by (metis subset_UNIV)

(* Subtree versus frontier: *)
lemma subtr_inFr:
assumes "inFr ns tr t" and "subtr ns tr tr1"
shows "inFr ns tr1 t"
proof-
  have "subtr ns tr tr1 \<Longrightarrow> (\<forall> t. inFr ns tr t \<longrightarrow> inFr ns tr1 t)"
  apply(induct rule: subtr.induct, safe) by (metis inFr.Ind)
  thus ?thesis using assms by auto
qed

corollary Fr_subtr:
"Fr ns tr = \<Union> {Fr ns tr' | tr'. subtr ns tr' tr}"
unfolding Fr_def proof safe
  fix t assume t: "inFr ns tr t"  hence "root tr \<in> ns" by (rule inFr_root_in)
  thus "t \<in> \<Union>{{t. inFr ns tr' t} |tr'. subtr ns tr' tr}"
  apply(intro UnionI[of "{t. inFr ns tr t}" _ t]) using t subtr.Refl by auto
qed(metis subtr_inFr)

lemma inFr_subtr:
assumes "inFr ns tr t"
shows "\<exists> tr'. subtr ns tr' tr \<and> Inl t \<in> cont tr'"
using assms apply(induct rule: inFr.induct) apply safe
  apply (metis subtr.Refl)
  by (metis (lifting) subtr.Step)

corollary Fr_subtr_cont:
"Fr ns tr = \<Union> {Inl -` cont tr' | tr'. subtr ns tr' tr}"
unfolding Fr_def
apply safe
apply (frule inFr_subtr)
apply auto
by (metis inFr.Base subtr_inFr subtr_rootL_in)

(* Subtree versus interior: *)
lemma subtr_inItr:
assumes "inItr ns tr n" and "subtr ns tr tr1"
shows "inItr ns tr1 n"
proof-
  have "subtr ns tr tr1 \<Longrightarrow> (\<forall> t. inItr ns tr n \<longrightarrow> inItr ns tr1 n)"
  apply(induct rule: subtr.induct, safe) by (metis inItr.Ind)
  thus ?thesis using assms by auto
qed

corollary Itr_subtr:
"Itr ns tr = \<Union> {Itr ns tr' | tr'. subtr ns tr' tr}"
unfolding Itr_def apply safe
apply (metis (lifting, mono_tags) UnionI inItr_root_in mem_Collect_eq subtr.Refl)
by (metis subtr_inItr)

lemma inItr_subtr:
assumes "inItr ns tr n"
shows "\<exists> tr'. subtr ns tr' tr \<and> root tr' = n"
using assms apply(induct rule: inItr.induct) apply safe
  apply (metis subtr.Refl)
  by (metis (lifting) subtr.Step)

corollary Itr_subtr_cont:
"Itr ns tr = {root tr' | tr'. subtr ns tr' tr}"
unfolding Itr_def apply safe
  apply (metis (lifting, mono_tags) inItr_subtr)
  by (metis inItr.Base subtr_inItr subtr_rootL_in)

subsection{* The Immediate Subtree Function *}

(* production of: *)
abbreviation "prodOf tr \<equiv> (id \<oplus> root) ` (cont tr)"
(* subtree of: *)
definition "subtrOf tr n \<equiv> SOME tr'. Inr tr' \<in> cont tr \<and> root tr' = n"

lemma subtrOf:
assumes n: "Inr n \<in> prodOf tr"
shows "Inr (subtrOf tr n) \<in> cont tr \<and> root (subtrOf tr n) = n"
proof-
  obtain tr' where "Inr tr' \<in> cont tr \<and> root tr' = n"
  using n unfolding image_def by (metis (lifting) Inr_oplus_elim assms)
  thus ?thesis unfolding subtrOf_def by(rule someI)
qed

lemmas Inr_subtrOf = subtrOf[THEN conjunct1]
lemmas root_subtrOf[simp] = subtrOf[THEN conjunct2]

lemma Inl_prodOf: "Inl -` (prodOf tr) = Inl -` (cont tr)"
proof safe
  fix t ttr assume "Inl t = (id \<oplus> root) ttr" and "ttr \<in> cont tr"
  thus "t \<in> Inl -` cont tr" by(cases ttr, auto)
next
  fix t assume "Inl t \<in> cont tr" thus "t \<in> Inl -` prodOf tr"
  by (metis (lifting) id_def image_iff map_sum.simps(1) vimageI2)
qed

lemma root_prodOf:
assumes "Inr tr' \<in> cont tr"
shows "Inr (root tr') \<in> prodOf tr"
by (metis (lifting) assms image_iff map_sum.simps(2))

subsection{* Well-Formed Derivation Trees *}

hide_const wf

coinductive wf where
dtree: "\<lbrakk>(root tr, (id \<oplus> root) ` (cont tr)) \<in> P; inj_on root (Inr -` cont tr);
        \<And> tr'. tr' \<in> Inr -` (cont tr) \<Longrightarrow> wf tr'\<rbrakk> \<Longrightarrow> wf tr"

(* destruction rules: *)
lemma wf_P:
assumes "wf tr"
shows "(root tr, (id \<oplus> root) ` (cont tr)) \<in> P"
using assms wf.simps[of tr] by auto

lemma wf_inj_on:
assumes "wf tr"
shows "inj_on root (Inr -` cont tr)"
using assms wf.simps[of tr] by auto

lemma wf_inj[simp]:
assumes "wf tr" and "Inr tr1 \<in> cont tr" and "Inr tr2 \<in> cont tr"
shows "root tr1 = root tr2 \<longleftrightarrow> tr1 = tr2"
using assms wf_inj_on unfolding inj_on_def by auto

lemma wf_cont:
assumes "wf tr" and "Inr tr' \<in> cont tr"
shows "wf tr'"
using assms wf.simps[of tr] by auto

(* coinduction:*)
lemma wf_coind[elim, consumes 1, case_names Hyp]:
assumes phi: "\<phi> tr"
and Hyp:
"\<And> tr. \<phi> tr \<Longrightarrow>
       (root tr, image (id \<oplus> root) (cont tr)) \<in> P \<and>
       inj_on root (Inr -` cont tr) \<and>
       (\<forall> tr' \<in> Inr -` (cont tr). \<phi> tr' \<or> wf tr')"
shows "wf tr"
apply(rule wf.coinduct[of \<phi> tr, OF phi])
using Hyp by blast

lemma wf_raw_coind[elim, consumes 1, case_names Hyp]:
assumes phi: "\<phi> tr"
and Hyp:
"\<And> tr. \<phi> tr \<Longrightarrow>
       (root tr, image (id \<oplus> root) (cont tr)) \<in> P \<and>
       inj_on root (Inr -` cont tr) \<and>
       (\<forall> tr' \<in> Inr -` (cont tr). \<phi> tr')"
shows "wf tr"
using phi apply(induct rule: wf_coind)
using Hyp by (metis (mono_tags))

lemma wf_subtr_inj_on:
assumes d: "wf tr1" and s: "subtr ns tr tr1"
shows "inj_on root (Inr -` cont tr)"
using s d apply(induct rule: subtr.induct)
apply (metis (lifting) wf_inj_on) by (metis wf_cont)

lemma wf_subtr_P:
assumes d: "wf tr1" and s: "subtr ns tr tr1"
shows "(root tr, (id \<oplus> root) ` cont tr) \<in> P"
using s d apply(induct rule: subtr.induct)
apply (metis (lifting) wf_P) by (metis wf_cont)

lemma subtrOf_root[simp]:
assumes tr: "wf tr" and cont: "Inr tr' \<in> cont tr"
shows "subtrOf tr (root tr') = tr'"
proof-
  have 0: "Inr (subtrOf tr (root tr')) \<in> cont tr" using Inr_subtrOf
  by (metis (lifting) cont root_prodOf)
  have "root (subtrOf tr (root tr')) = root tr'"
  using root_subtrOf by (metis (lifting) cont root_prodOf)
  thus ?thesis unfolding wf_inj[OF tr 0 cont] .
qed

lemma surj_subtrOf:
assumes "wf tr" and 0: "Inr tr' \<in> cont tr"
shows "\<exists> n. Inr n \<in> prodOf tr \<and> subtrOf tr n = tr'"
apply(rule exI[of _ "root tr'"])
using root_prodOf[OF 0] subtrOf_root[OF assms] by simp

lemma wf_subtr:
assumes "wf tr1" and "subtr ns tr tr1"
shows "wf tr"
proof-
  have "(\<exists> ns tr1. wf tr1 \<and> subtr ns tr tr1) \<Longrightarrow> wf tr"
  proof (induct rule: wf_raw_coind)
    case (Hyp tr)
    then obtain ns tr1 where tr1: "wf tr1" and tr_tr1: "subtr ns tr tr1" by auto
    show ?case proof safe
      show "(root tr, (id \<oplus> root) ` cont tr) \<in> P" using wf_subtr_P[OF tr1 tr_tr1] .
    next
      show "inj_on root (Inr -` cont tr)" using wf_subtr_inj_on[OF tr1 tr_tr1] .
    next
      fix tr' assume tr': "Inr tr' \<in> cont tr"
      have tr_tr1: "subtr (ns \<union> {root tr'}) tr tr1" using subtr_mono[OF tr_tr1] by auto
      have "subtr (ns \<union> {root tr'}) tr' tr1" using subtr_StepL[OF _ tr' tr_tr1] by auto
      thus "\<exists>ns' tr1. wf tr1 \<and> subtr ns' tr' tr1" using tr1 by blast
    qed
  qed
  thus ?thesis using assms by auto
qed

subsection{* Default Trees *}

(* Pick a left-hand side of a production for each nonterminal *)
definition S where "S n \<equiv> SOME tns. (n,tns) \<in> P"

lemma S_P: "(n, S n) \<in> P"
using used unfolding S_def by(rule someI_ex)

lemma finite_S: "finite (S n)"
using S_P finite_in_P by auto

(* The default tree of a nonterminal *)
definition deftr :: "N \<Rightarrow> dtree" where
"deftr \<equiv> unfold id S"

lemma deftr_simps[simp]:
"root (deftr n) = n"
"cont (deftr n) = image (id \<oplus> deftr) (S n)"
using unfold(1)[of id S n] unfold(2)[of S n id, OF finite_S]
unfolding deftr_def by simp_all

lemmas root_deftr = deftr_simps(1)
lemmas cont_deftr = deftr_simps(2)

lemma root_o_deftr[simp]: "root o deftr = id"
by (rule ext, auto)

lemma wf_deftr: "wf (deftr n)"
proof-
  {fix tr assume "\<exists> n. tr = deftr n" hence "wf tr"
   apply(induct rule: wf_raw_coind) apply safe
   unfolding deftr_simps image_comp map_sum.comp id_comp
   root_o_deftr map_sum.id image_id id_apply apply(rule S_P)
   unfolding inj_on_def by auto
  }
  thus ?thesis by auto
qed

subsection{* Hereditary Substitution *}

(* Auxiliary concept: The root-ommiting frontier: *)
definition "inFrr ns tr t \<equiv> \<exists> tr'. Inr tr' \<in> cont tr \<and> inFr ns tr' t"
definition "Frr ns tr \<equiv> {t. \<exists> tr'. Inr tr' \<in> cont tr \<and> t \<in> Fr ns tr'}"

context
fixes tr0 :: dtree
begin

definition "hsubst_r tr \<equiv> root tr"
definition "hsubst_c tr \<equiv> if root tr = root tr0 then cont tr0 else cont tr"

(* Hereditary substitution: *)
definition hsubst :: "dtree \<Rightarrow> dtree" where
"hsubst \<equiv> unfold hsubst_r hsubst_c"

lemma finite_hsubst_c: "finite (hsubst_c n)"
unfolding hsubst_c_def by (metis (full_types) finite_cont)

lemma root_hsubst[simp]: "root (hsubst tr) = root tr"
using unfold(1)[of hsubst_r hsubst_c tr] unfolding hsubst_def hsubst_r_def by simp

lemma root_o_subst[simp]: "root o hsubst = root"
unfolding comp_def root_hsubst ..

lemma cont_hsubst_eq[simp]:
assumes "root tr = root tr0"
shows "cont (hsubst tr) = (id \<oplus> hsubst) ` (cont tr0)"
apply(subst id_comp[symmetric, of id]) unfolding id_comp
using unfold(2)[of hsubst_c tr hsubst_r, OF finite_hsubst_c]
unfolding hsubst_def hsubst_c_def using assms by simp

lemma hsubst_eq:
assumes "root tr = root tr0"
shows "hsubst tr = hsubst tr0"
apply(rule dtree_cong) using assms cont_hsubst_eq by auto

lemma cont_hsubst_neq[simp]:
assumes "root tr \<noteq> root tr0"
shows "cont (hsubst tr) = (id \<oplus> hsubst) ` (cont tr)"
apply(subst id_comp[symmetric, of id]) unfolding id_comp
using unfold(2)[of hsubst_c tr hsubst_r, OF finite_hsubst_c]
unfolding hsubst_def hsubst_c_def using assms by simp

lemma Inl_cont_hsubst_eq[simp]:
assumes "root tr = root tr0"
shows "Inl -` cont (hsubst tr) = Inl -` (cont tr0)"
unfolding cont_hsubst_eq[OF assms] by simp

lemma Inr_cont_hsubst_eq[simp]:
assumes "root tr = root tr0"
shows "Inr -` cont (hsubst tr) = hsubst ` Inr -` cont tr0"
unfolding cont_hsubst_eq[OF assms] by simp

lemma Inl_cont_hsubst_neq[simp]:
assumes "root tr \<noteq> root tr0"
shows "Inl -` cont (hsubst tr) = Inl -` (cont tr)"
unfolding cont_hsubst_neq[OF assms] by simp

lemma Inr_cont_hsubst_neq[simp]:
assumes "root tr \<noteq> root tr0"
shows "Inr -` cont (hsubst tr) = hsubst ` Inr -` cont tr"
unfolding cont_hsubst_neq[OF assms] by simp

lemma wf_hsubst:
assumes tr0: "wf tr0" and tr: "wf tr"
shows "wf (hsubst tr)"
proof-
  {fix tr1 have "(\<exists> tr. wf tr \<and> tr1 = hsubst tr) \<Longrightarrow> wf tr1"
   proof (induct rule: wf_raw_coind)
     case (Hyp tr1) then obtain tr
     where dtr: "wf tr" and tr1: "tr1 = hsubst tr" by auto
     show ?case unfolding tr1 proof safe
       show "(root (hsubst tr), prodOf (hsubst tr)) \<in> P"
       unfolding tr1 apply(cases "root tr = root tr0")
       using  wf_P[OF dtr] wf_P[OF tr0]
       by (auto simp add: image_comp map_sum.comp)
       show "inj_on root (Inr -` cont (hsubst tr))"
       apply(cases "root tr = root tr0") using wf_inj_on[OF dtr] wf_inj_on[OF tr0]
       unfolding inj_on_def by (auto, blast)
       fix tr' assume "Inr tr' \<in> cont (hsubst tr)"
       thus "\<exists>tra. wf tra \<and> tr' = hsubst tra"
       apply(cases "root tr = root tr0", simp_all)
         apply (metis wf_cont tr0)
         by (metis dtr wf_cont)
     qed
   qed
  }
  thus ?thesis using assms by blast
qed

lemma Frr: "Frr ns tr = {t. inFrr ns tr t}"
unfolding inFrr_def Frr_def Fr_def by auto

lemma inFr_hsubst_imp:
assumes "inFr ns (hsubst tr) t"
shows "t \<in> Inl -` (cont tr0) \<or> inFrr (ns - {root tr0}) tr0 t \<or>
       inFr (ns - {root tr0}) tr t"
proof-
  {fix tr1
   have "inFr ns tr1 t \<Longrightarrow>
   (\<And> tr. tr1 = hsubst tr \<Longrightarrow> (t \<in> Inl -` (cont tr0) \<or> inFrr (ns - {root tr0}) tr0 t \<or>
                              inFr (ns - {root tr0}) tr t))"
   proof(induct rule: inFr.induct)
     case (Base tr1 ns t tr)
     hence rtr: "root tr1 \<in> ns" and t_tr1: "Inl t \<in> cont tr1" and tr1: "tr1 = hsubst tr"
     by auto
     show ?case
     proof(cases "root tr1 = root tr0")
       case True
       hence "t \<in> Inl -` (cont tr0)" using t_tr1 unfolding tr1 by auto
       thus ?thesis by simp
     next
       case False
       hence "inFr (ns - {root tr0}) tr t" using t_tr1 unfolding tr1 apply simp
       by (metis Base.prems Diff_iff root_hsubst inFr.Base rtr singletonE)
       thus ?thesis by simp
     qed
   next
     case (Ind tr1 ns tr1' t) note IH = Ind(4)
     have rtr1: "root tr1 \<in> ns" and tr1'_tr1: "Inr tr1' \<in> cont tr1"
     and t_tr1': "inFr ns tr1' t" and tr1: "tr1 = hsubst tr" using Ind by auto
     have rtr1: "root tr1 = root tr" unfolding tr1 by simp
     show ?case
     proof(cases "root tr1 = root tr0")
       case True
       then obtain tr' where tr'_tr0: "Inr tr' \<in> cont tr0" and tr1': "tr1' = hsubst tr'"
       using tr1'_tr1 unfolding tr1 by auto
       show ?thesis using IH[OF tr1'] proof (elim disjE)
         assume "inFr (ns - {root tr0}) tr' t"
         thus ?thesis using tr'_tr0 unfolding inFrr_def by auto
       qed auto
     next
       case False
       then obtain tr' where tr'_tr: "Inr tr' \<in> cont tr" and tr1': "tr1' = hsubst tr'"
       using tr1'_tr1 unfolding tr1 by auto
       show ?thesis using IH[OF tr1'] proof (elim disjE)
         assume "inFr (ns - {root tr0}) tr' t"
         thus ?thesis using tr'_tr unfolding inFrr_def
         by (metis Diff_iff False Ind(1) empty_iff inFr2_Ind inFr_inFr2 insert_iff rtr1)
       qed auto
     qed
   qed
  }
  thus ?thesis using assms by auto
qed

lemma inFr_hsubst_notin:
assumes "inFr ns tr t" and "root tr0 \<notin> ns"
shows "inFr ns (hsubst tr) t"
using assms apply(induct rule: inFr.induct)
apply (metis Inl_cont_hsubst_neq inFr2.Base inFr_inFr2 root_hsubst vimageD vimageI2)
by (metis (lifting) Inr_cont_hsubst_neq inFr.Ind rev_image_eqI root_hsubst vimageD vimageI2)

lemma inFr_hsubst_minus:
assumes "inFr (ns - {root tr0}) tr t"
shows "inFr ns (hsubst tr) t"
proof-
  have 1: "inFr (ns - {root tr0}) (hsubst tr) t"
  using inFr_hsubst_notin[OF assms] by simp
  show ?thesis using inFr_mono[OF 1] by auto
qed

lemma inFr_self_hsubst:
assumes "root tr0 \<in> ns"
shows
"inFr ns (hsubst tr0) t \<longleftrightarrow>
 t \<in> Inl -` (cont tr0) \<or> inFrr (ns - {root tr0}) tr0 t"
(is "?A \<longleftrightarrow> ?B \<or> ?C")
apply(intro iffI)
apply (metis inFr_hsubst_imp Diff_iff inFr_root_in insertI1) proof(elim disjE)
  assume ?B thus ?A apply(intro inFr.Base) using assms by auto
next
  assume ?C then obtain tr where
  tr_tr0: "Inr tr \<in> cont tr0" and t_tr: "inFr (ns - {root tr0}) tr t"
  unfolding inFrr_def by auto
  def tr1 \<equiv> "hsubst tr"
  have 1: "inFr ns tr1 t" using t_tr unfolding tr1_def using inFr_hsubst_minus by auto
  have "Inr tr1 \<in> cont (hsubst tr0)" unfolding tr1_def using tr_tr0 by auto
  thus ?A using 1 inFr.Ind assms by (metis root_hsubst)
qed

lemma Fr_self_hsubst:
assumes "root tr0 \<in> ns"
shows "Fr ns (hsubst tr0) = Inl -` (cont tr0) \<union> Frr (ns - {root tr0}) tr0"
using inFr_self_hsubst[OF assms] unfolding Frr Fr_def by auto

end (* context *)

subsection{* Regular Trees *}

definition "reg f tr \<equiv> \<forall> tr'. subtr UNIV tr' tr \<longrightarrow> tr' = f (root tr')"
definition "regular tr \<equiv> \<exists> f. reg f tr"

lemma reg_def2: "reg f tr \<longleftrightarrow> (\<forall> ns tr'. subtr ns tr' tr \<longrightarrow> tr' = f (root tr'))"
unfolding reg_def using subtr_mono by (metis subset_UNIV)

lemma regular_def2: "regular tr \<longleftrightarrow> (\<exists> f. reg f tr \<and> (\<forall> n. root (f n) = n))"
unfolding regular_def proof safe
  fix f assume f: "reg f tr"
  def g \<equiv> "\<lambda> n. if inItr UNIV tr n then f n else deftr n"
  show "\<exists>g. reg g tr \<and> (\<forall>n. root (g n) = n)"
  apply(rule exI[of _ g])
  using f deftr_simps(1) unfolding g_def reg_def apply safe
    apply (metis (lifting) inItr.Base subtr_inItr subtr_rootL_in)
    by (metis (full_types) inItr_subtr)
qed auto

lemma reg_root:
assumes "reg f tr"
shows "f (root tr) = tr"
using assms unfolding reg_def
by (metis (lifting) iso_tuple_UNIV_I subtr.Refl)

lemma reg_Inr_cont:
assumes "reg f tr" and "Inr tr' \<in> cont tr"
shows "reg f tr'"
by (metis (lifting) assms iso_tuple_UNIV_I reg_def subtr.Step)

lemma reg_subtr:
assumes "reg f tr" and "subtr ns tr' tr"
shows "reg f tr'"
using assms unfolding reg_def using subtr_trans[of UNIV tr] UNIV_I
by (metis UNIV_eq_I UnCI Un_upper1 iso_tuple_UNIV_I subtr_mono subtr_trans)

lemma regular_subtr:
assumes r: "regular tr" and s: "subtr ns tr' tr"
shows "regular tr'"
using r reg_subtr[OF _ s] unfolding regular_def by auto

lemma subtr_deftr:
assumes "subtr ns tr' (deftr n)"
shows "tr' = deftr (root tr')"
proof-
  {fix tr have "subtr ns tr' tr \<Longrightarrow> (\<forall> n. tr = deftr n \<longrightarrow> tr' = deftr (root tr'))"
   apply (induct rule: subtr.induct)
   proof(metis (lifting) deftr_simps(1), safe)
     fix tr3 ns tr1 tr2 n
     assume 1: "root (deftr n) \<in> ns" and 2: "subtr ns tr1 tr2"
     and IH: "\<forall>n. tr2 = deftr n \<longrightarrow> tr1 = deftr (root tr1)"
     and 3: "Inr tr2 \<in> cont (deftr n)"
     have "tr2 \<in> deftr ` UNIV"
     using 3 unfolding deftr_simps image_def
     by (metis (lifting, full_types) 3 CollectI Inr_oplus_iff cont_deftr
         iso_tuple_UNIV_I)
     then obtain n where "tr2 = deftr n" by auto
     thus "tr1 = deftr (root tr1)" using IH by auto
   qed
  }
  thus ?thesis using assms by auto
qed

lemma reg_deftr: "reg deftr (deftr n)"
unfolding reg_def using subtr_deftr by auto

lemma wf_subtrOf_Union:
assumes "wf tr"
shows "\<Union>{K tr' |tr'. Inr tr' \<in> cont tr} =
       \<Union>{K (subtrOf tr n) |n. Inr n \<in> prodOf tr}"
unfolding Union_eq Bex_def mem_Collect_eq proof safe
  fix x xa tr'
  assume x: "x \<in> K tr'" and tr'_tr: "Inr tr' \<in> cont tr"
  show "\<exists>X. (\<exists>n. X = K (subtrOf tr n) \<and> Inr n \<in> prodOf tr) \<and> x \<in> X"
  apply(rule exI[of _ "K (subtrOf tr (root tr'))"]) apply(intro conjI)
    apply(rule exI[of _ "root tr'"]) apply (metis (lifting) root_prodOf tr'_tr)
    by (metis (lifting) assms subtrOf_root tr'_tr x)
next
  fix x X n ttr
  assume x: "x \<in> K (subtrOf tr n)" and n: "Inr n = (id \<oplus> root) ttr" and ttr: "ttr \<in> cont tr"
  show "\<exists>X. (\<exists>tr'. X = K tr' \<and> Inr tr' \<in> cont tr) \<and> x \<in> X"
  apply(rule exI[of _ "K (subtrOf tr n)"]) apply(intro conjI)
    apply(rule exI[of _ "subtrOf tr n"]) apply (metis imageI n subtrOf ttr)
    using x .
qed

subsection {* Paths in a Regular Tree *}

inductive path :: "(N \<Rightarrow> dtree) \<Rightarrow> N list \<Rightarrow> bool" for f where
Base: "path f [n]"
|
Ind: "\<lbrakk>path f (n1 # nl); Inr (f n1) \<in> cont (f n)\<rbrakk>
      \<Longrightarrow> path f (n # n1 # nl)"

lemma path_NE:
assumes "path f nl"
shows "nl \<noteq> Nil"
using assms apply(induct rule: path.induct) by auto

lemma path_post:
assumes f: "path f (n # nl)" and nl: "nl \<noteq> []"
shows "path f nl"
proof-
  obtain n1 nl1 where nl: "nl = n1 # nl1" using nl by (cases nl, auto)
  show ?thesis using assms unfolding nl using path.simps by (metis (lifting) list.inject)
qed

lemma path_post_concat:
assumes "path f (nl1 @ nl2)" and "nl2 \<noteq> Nil"
shows "path f nl2"
using assms apply (induct nl1)
apply (metis append_Nil) by (metis Nil_is_append_conv append_Cons path_post)

lemma path_concat:
assumes "path f nl1" and "path f ((last nl1) # nl2)"
shows "path f (nl1 @ nl2)"
using assms apply(induct rule: path.induct) apply simp
by (metis append_Cons last.simps list.simps(3) path.Ind)

lemma path_distinct:
assumes "path f nl"
shows "\<exists> nl'. path f nl' \<and> hd nl' = hd nl \<and> last nl' = last nl \<and>
              set nl' \<subseteq> set nl \<and> distinct nl'"
using assms proof(induct rule: length_induct)
  case (1 nl)  hence p_nl: "path f nl" by simp
  then obtain n nl1 where nl: "nl = n # nl1" by (metis list.exhaust path_NE)
  show ?case
  proof(cases nl1)
    case Nil
    show ?thesis apply(rule exI[of _ nl]) using path.Base unfolding nl Nil by simp
  next
    case (Cons n1 nl2)
    hence p1: "path f nl1" by (metis list.simps(3) nl p_nl path_post)
    show ?thesis
    proof(cases "n \<in> set nl1")
      case False
      obtain nl1' where p1': "path f nl1'" and hd_nl1': "hd nl1' = hd nl1" and
      l_nl1': "last nl1' = last nl1" and d_nl1': "distinct nl1'"
      and s_nl1': "set nl1' \<subseteq> set nl1"
      using 1(1)[THEN allE[of _ nl1]] p1 unfolding nl by auto
      obtain nl2' where nl1': "nl1' = n1 # nl2'" using path_NE[OF p1'] hd_nl1'
      unfolding Cons by(cases nl1', auto)
      show ?thesis apply(intro exI[of _ "n # nl1'"]) unfolding nl proof safe
        show "path f (n # nl1')" unfolding nl1'
        apply(rule path.Ind, metis nl1' p1')
        by (metis (lifting) Cons list.inject nl p1 p_nl path.simps path_NE)
      qed(insert l_nl1' Cons nl1' s_nl1' d_nl1' False, auto)
    next
      case True
      then obtain nl11 nl12 where nl1: "nl1 = nl11 @ n # nl12"
      by (metis split_list)
      have p12: "path f (n # nl12)"
      apply(rule path_post_concat[of _ "n # nl11"]) using p_nl[unfolded nl nl1] by auto
      obtain nl12' where p1': "path f nl12'" and hd_nl12': "hd nl12' = n" and
      l_nl12': "last nl12' = last (n # nl12)" and d_nl12': "distinct nl12'"
      and s_nl12': "set nl12' \<subseteq> {n} \<union> set nl12"
      using 1(1)[THEN allE[of _ "n # nl12"]] p12 unfolding nl nl1 by auto
      thus ?thesis apply(intro exI[of _ nl12']) unfolding nl nl1 by auto
    qed
  qed
qed

lemma path_subtr:
assumes f: "\<And> n. root (f n) = n"
and p: "path f nl"
shows "subtr (set nl) (f (last nl)) (f (hd nl))"
using p proof (induct rule: path.induct)
  case (Ind n1 nl n)  let ?ns1 = "insert n1 (set nl)"
  have "path f (n1 # nl)"
  and "subtr ?ns1 (f (last (n1 # nl))) (f n1)"
  and fn1: "Inr (f n1) \<in> cont (f n)" using Ind by simp_all
  hence fn1_flast:  "subtr (insert n ?ns1) (f (last (n1 # nl))) (f n1)"
  by (metis subset_insertI subtr_mono)
  have 1: "last (n # n1 # nl) = last (n1 # nl)" by auto
  have "subtr (insert n ?ns1) (f (last (n1 # nl))) (f n)"
  using f subtr.Step[OF _ fn1_flast fn1] by auto
  thus ?case unfolding 1 by simp
qed (metis f list.sel(1) last_ConsL last_in_set not_Cons_self2 subtr.Refl)

lemma reg_subtr_path_aux:
assumes f: "reg f tr" and n: "subtr ns tr1 tr"
shows "\<exists> nl. path f nl \<and> f (hd nl) = tr \<and> f (last nl) = tr1 \<and> set nl \<subseteq> ns"
using n f proof(induct rule: subtr.induct)
  case (Refl tr ns)
  thus ?case
  apply(intro exI[of _ "[root tr]"]) apply simp by (metis (lifting) path.Base reg_root)
next
  case (Step tr ns tr2 tr1)
  hence rtr: "root tr \<in> ns" and tr1_tr: "Inr tr1 \<in> cont tr"
  and tr2_tr1: "subtr ns tr2 tr1" and tr: "reg f tr" by auto
  have tr1: "reg f tr1" using reg_subtr[OF tr] rtr tr1_tr
  by (metis (lifting) Step.prems iso_tuple_UNIV_I reg_def subtr.Step)
  obtain nl where nl: "path f nl" and f_nl: "f (hd nl) = tr1"
  and last_nl: "f (last nl) = tr2" and set: "set nl \<subseteq> ns" using Step(3)[OF tr1] by auto
  have 0: "path f (root tr # nl)" apply (subst path.simps)
  using f_nl nl reg_root tr tr1_tr by (metis list.sel(1) neq_Nil_conv)
  show ?case apply(rule exI[of _ "(root tr) # nl"])
  using 0 reg_root tr last_nl nl path_NE rtr set by auto
qed

lemma reg_subtr_path:
assumes f: "reg f tr" and n: "subtr ns tr1 tr"
shows "\<exists> nl. distinct nl \<and> path f nl \<and> f (hd nl) = tr \<and> f (last nl) = tr1 \<and> set nl \<subseteq> ns"
using reg_subtr_path_aux[OF assms] path_distinct[of f]
by (metis (lifting) order_trans)

lemma subtr_iff_path:
assumes r: "reg f tr" and f: "\<And> n. root (f n) = n"
shows "subtr ns tr1 tr \<longleftrightarrow>
       (\<exists> nl. distinct nl \<and> path f nl \<and> f (hd nl) = tr \<and> f (last nl) = tr1 \<and> set nl \<subseteq> ns)"
proof safe
  fix nl assume p: "path f nl" and nl: "set nl \<subseteq> ns"
  have "subtr (set nl) (f (last nl)) (f (hd nl))"
  apply(rule path_subtr) using p f by simp_all
  thus "subtr ns (f (last nl)) (f (hd nl))"
  using subtr_mono nl by auto
qed(insert reg_subtr_path[OF r], auto)

lemma inFr_iff_path:
assumes r: "reg f tr" and f: "\<And> n. root (f n) = n"
shows
"inFr ns tr t \<longleftrightarrow>
 (\<exists> nl tr1. distinct nl \<and> path f nl \<and> f (hd nl) = tr \<and> f (last nl) = tr1 \<and>
            set nl \<subseteq> ns \<and> Inl t \<in> cont tr1)"
apply safe
apply (metis (no_types) inFr_subtr r reg_subtr_path)
by (metis f inFr.Base path_subtr subtr_inFr subtr_mono subtr_rootL_in)

subsection{* The Regular Cut of a Tree *}

context fixes tr0 :: dtree
begin

(* Picking a subtree of a certain root: *)
definition "pick n \<equiv> SOME tr. subtr UNIV tr tr0 \<and> root tr = n"

lemma pick:
assumes "inItr UNIV tr0 n"
shows "subtr UNIV (pick n) tr0 \<and> root (pick n) = n"
proof-
  have "\<exists> tr. subtr UNIV tr tr0 \<and> root tr = n"
  using assms by (metis (lifting) inItr_subtr)
  thus ?thesis unfolding pick_def by(rule someI_ex)
qed

lemmas subtr_pick = pick[THEN conjunct1]
lemmas root_pick = pick[THEN conjunct2]

lemma wf_pick:
assumes tr0: "wf tr0" and n: "inItr UNIV tr0 n"
shows "wf (pick n)"
using wf_subtr[OF tr0 subtr_pick[OF n]] .

definition "H_r n \<equiv> root (pick n)"
definition "H_c n \<equiv> (id \<oplus> root) ` cont (pick n)"

(* The regular tree of a function: *)
definition H :: "N \<Rightarrow> dtree" where
"H \<equiv> unfold H_r H_c"

lemma finite_H_c: "finite (H_c n)"
unfolding H_c_def by (metis finite_cont finite_imageI)

lemma root_H_pick: "root (H n) = root (pick n)"
using unfold(1)[of H_r H_c n] unfolding H_def H_r_def by simp

lemma root_H[simp]:
assumes "inItr UNIV tr0 n"
shows "root (H n) = n"
unfolding root_H_pick root_pick[OF assms] ..

lemma cont_H[simp]:
"cont (H n) = (id \<oplus> (H o root)) ` cont (pick n)"
apply(subst id_comp[symmetric, of id]) unfolding map_sum.comp[symmetric]
unfolding image_comp [symmetric] H_c_def [symmetric]
using unfold(2) [of H_c n H_r, OF finite_H_c]
unfolding H_def ..

lemma Inl_cont_H[simp]:
"Inl -` (cont (H n)) = Inl -` (cont (pick n))"
unfolding cont_H by simp

lemma Inr_cont_H:
"Inr -` (cont (H n)) = (H \<circ> root) ` (Inr -` cont (pick n))"
unfolding cont_H by simp

lemma subtr_H:
assumes n: "inItr UNIV tr0 n" and "subtr UNIV tr1 (H n)"
shows "\<exists> n1. inItr UNIV tr0 n1 \<and> tr1 = H n1"
proof-
  {fix tr ns assume "subtr UNIV tr1 tr"
   hence "tr = H n \<longrightarrow> (\<exists> n1. inItr UNIV tr0 n1 \<and> tr1 = H n1)"
   proof (induct rule: subtr_UNIV_inductL)
     case (Step tr2 tr1 tr)
     show ?case proof
       assume "tr = H n"
       then obtain n1 where tr2: "Inr tr2 \<in> cont tr1"
       and tr1_tr: "subtr UNIV tr1 tr" and n1: "inItr UNIV tr0 n1" and tr1: "tr1 = H n1"
       using Step by auto
       obtain tr2' where tr2: "tr2 = H (root tr2')"
       and tr2': "Inr tr2' \<in> cont (pick n1)"
       using tr2 Inr_cont_H[of n1]
       unfolding tr1 image_def comp_def using vimage_eq by auto
       have "inItr UNIV tr0 (root tr2')"
       using inItr.Base inItr.Ind n1 pick subtr_inItr tr2' by (metis iso_tuple_UNIV_I)
       thus "\<exists>n2. inItr UNIV tr0 n2 \<and> tr2 = H n2" using tr2 by blast
     qed
   qed(insert n, auto)
  }
  thus ?thesis using assms by auto
qed

lemma root_H_root:
assumes n: "inItr UNIV tr0 n" and t_tr: "t_tr \<in> cont (pick n)"
shows "(id \<oplus> (root \<circ> H \<circ> root)) t_tr = (id \<oplus> root) t_tr"
using assms apply(cases t_tr)
  apply (metis (lifting) map_sum.simps(1))
  using pick H_def H_r_def unfold(1)
      inItr.Base comp_apply subtr_StepL subtr_inItr map_sum.simps(2)
  by (metis UNIV_I)

lemma H_P:
assumes tr0: "wf tr0" and n: "inItr UNIV tr0 n"
shows "(n, (id \<oplus> root) ` cont (H n)) \<in> P" (is "?L \<in> P")
proof-
  have "?L = (n, (id \<oplus> root) ` cont (pick n))"
  unfolding cont_H image_comp map_sum.comp id_comp comp_assoc[symmetric]
  unfolding Pair_eq apply(rule conjI[OF refl]) apply(rule image_cong[OF refl])
  by (rule root_H_root[OF n])
  moreover have "... \<in> P" by (metis (lifting) wf_pick root_pick wf_P n tr0)
  ultimately show ?thesis by simp
qed

lemma wf_H:
assumes tr0: "wf tr0" and "inItr UNIV tr0 n"
shows "wf (H n)"
proof-
  {fix tr have "\<exists> n. inItr UNIV tr0 n \<and> tr = H n \<Longrightarrow> wf tr"
   proof (induct rule: wf_raw_coind)
     case (Hyp tr)
     then obtain n where n: "inItr UNIV tr0 n" and tr: "tr = H n" by auto
     show ?case apply safe
     apply (metis (lifting) H_P root_H n tr tr0)
     unfolding tr Inr_cont_H unfolding inj_on_def apply clarsimp using root_H
     apply (metis UNIV_I inItr.Base n pick subtr2.simps subtr_inItr subtr_subtr2)
     by (metis n subtr.Refl subtr_StepL subtr_H tr UNIV_I)
   qed
  }
  thus ?thesis using assms by blast
qed

(* The regular cut of a tree: *)
definition "rcut \<equiv> H (root tr0)"

lemma reg_rcut: "reg H rcut"
unfolding reg_def rcut_def
by (metis inItr.Base root_H subtr_H UNIV_I)

lemma rcut_reg:
assumes "reg H tr0"
shows "rcut = tr0"
using assms unfolding rcut_def reg_def by (metis subtr.Refl UNIV_I)

lemma rcut_eq: "rcut = tr0 \<longleftrightarrow> reg H tr0"
using reg_rcut rcut_reg by metis

lemma regular_rcut: "regular rcut"
using reg_rcut unfolding regular_def by blast

lemma Fr_rcut: "Fr UNIV rcut \<subseteq> Fr UNIV tr0"
proof safe
  fix t assume "t \<in> Fr UNIV rcut"
  then obtain tr where t: "Inl t \<in> cont tr" and tr: "subtr UNIV tr (H (root tr0))"
  using Fr_subtr[of UNIV "H (root tr0)"] unfolding rcut_def
  by (metis (full_types) Fr_def inFr_subtr mem_Collect_eq)
  obtain n where n: "inItr UNIV tr0 n" and tr: "tr = H n" using tr
  by (metis (lifting) inItr.Base subtr_H UNIV_I)
  have "Inl t \<in> cont (pick n)" using t using Inl_cont_H[of n] unfolding tr
  by (metis (lifting) vimageD vimageI2)
  moreover have "subtr UNIV (pick n) tr0" using subtr_pick[OF n] ..
  ultimately show "t \<in> Fr UNIV tr0" unfolding Fr_subtr_cont by auto
qed

lemma wf_rcut:
assumes "wf tr0"
shows "wf rcut"
unfolding rcut_def using wf_H[OF assms inItr.Base] by simp

lemma root_rcut[simp]: "root rcut = root tr0"
unfolding rcut_def
by (metis (lifting) root_H inItr.Base reg_def reg_root subtr_rootR_in)

end (* context *)

subsection{* Recursive Description of the Regular Tree Frontiers *}

lemma regular_inFr:
assumes r: "regular tr" and In: "root tr \<in> ns"
and t: "inFr ns tr t"
shows "t \<in> Inl -` (cont tr) \<or>
       (\<exists> tr'. Inr tr' \<in> cont tr \<and> inFr (ns - {root tr}) tr' t)"
(is "?L \<or> ?R")
proof-
  obtain f where r: "reg f tr" and f: "\<And>n. root (f n) = n"
  using r unfolding regular_def2 by auto
  obtain nl tr1 where d_nl: "distinct nl" and p: "path f nl" and hd_nl: "f (hd nl) = tr"
  and l_nl: "f (last nl) = tr1" and s_nl: "set nl \<subseteq> ns" and t_tr1: "Inl t \<in> cont tr1"
  using t unfolding inFr_iff_path[OF r f] by auto
  obtain n nl1 where nl: "nl = n # nl1" by (metis (lifting) p path.simps)
  hence f_n: "f n = tr" using hd_nl by simp
  have n_nl1: "n \<notin> set nl1" using d_nl unfolding nl by auto
  show ?thesis
  proof(cases nl1)
    case Nil hence "tr = tr1" using f_n l_nl unfolding nl by simp
    hence ?L using t_tr1 by simp thus ?thesis by simp
  next
    case (Cons n1 nl2) note nl1 = Cons
    have 1: "last nl1 = last nl" "hd nl1 = n1" unfolding nl nl1 by simp_all
    have p1: "path f nl1" and n1_tr: "Inr (f n1) \<in> cont tr"
    using path.simps[of f nl] p f_n unfolding nl nl1 by auto
    have r1: "reg f (f n1)" using reg_Inr_cont[OF r n1_tr] .
    have 0: "inFr (set nl1) (f n1) t" unfolding inFr_iff_path[OF r1 f]
    apply(intro exI[of _ nl1], intro exI[of _ tr1])
    using d_nl unfolding 1 l_nl unfolding nl using p1 t_tr1 by auto
    have root_tr: "root tr = n" by (metis f f_n)
    have "inFr (ns - {root tr}) (f n1) t" apply(rule inFr_mono[OF 0])
    using s_nl unfolding root_tr unfolding nl using n_nl1 by auto
    thus ?thesis using n1_tr by auto
  qed
qed

lemma regular_Fr:
assumes r: "regular tr" and In: "root tr \<in> ns"
shows "Fr ns tr =
       Inl -` (cont tr) \<union>
       \<Union> {Fr (ns - {root tr}) tr' | tr'. Inr tr' \<in> cont tr}"
unfolding Fr_def
using In inFr.Base regular_inFr[OF assms] apply safe
apply (simp, metis (full_types) mem_Collect_eq)
apply simp
by (simp, metis (lifting) inFr_Ind_minus insert_Diff)

subsection{* The Generated Languages *}

(* The (possibly inifinite tree) generated language *)
definition "L ns n \<equiv> {Fr ns tr | tr. wf tr \<and> root tr = n}"

(* The regular-tree generated language *)
definition "Lr ns n \<equiv> {Fr ns tr | tr. wf tr \<and> root tr = n \<and> regular tr}"

lemma L_rec_notin:
assumes "n \<notin> ns"
shows "L ns n = {{}}"
using assms unfolding L_def apply safe
  using not_root_Fr apply force
  apply(rule exI[of _ "deftr n"])
  by (metis (no_types) wf_deftr not_root_Fr root_deftr)

lemma Lr_rec_notin:
assumes "n \<notin> ns"
shows "Lr ns n = {{}}"
using assms unfolding Lr_def apply safe
  using not_root_Fr apply force
  apply(rule exI[of _ "deftr n"])
  by (metis (no_types) regular_def wf_deftr not_root_Fr reg_deftr root_deftr)

lemma wf_subtrOf:
assumes "wf tr" and "Inr n \<in> prodOf tr"
shows "wf (subtrOf tr n)"
by (metis assms wf_cont subtrOf)

lemma Lr_rec_in:
assumes n: "n \<in> ns"
shows "Lr ns n \<subseteq>
{Inl -` tns \<union> (\<Union> {K n' | n'. Inr n' \<in> tns}) | tns K.
    (n,tns) \<in> P \<and>
    (\<forall> n'. Inr n' \<in> tns \<longrightarrow> K n' \<in> Lr (ns - {n}) n')}"
(is "Lr ns n \<subseteq> {?F tns K | tns K. (n,tns) \<in> P \<and> ?\<phi> tns K}")
proof safe
  fix ts assume "ts \<in> Lr ns n"
  then obtain tr where dtr: "wf tr" and r: "root tr = n" and tr: "regular tr"
  and ts: "ts = Fr ns tr" unfolding Lr_def by auto
  def tns \<equiv> "(id \<oplus> root) ` (cont tr)"
  def K \<equiv> "\<lambda> n'. Fr (ns - {n}) (subtrOf tr n')"
  show "\<exists>tns K. ts = ?F tns K \<and> (n, tns) \<in> P \<and> ?\<phi> tns K"
  apply(rule exI[of _ tns], rule exI[of _ K]) proof(intro conjI allI impI)
    show "ts = Inl -` tns \<union> \<Union>{K n' |n'. Inr n' \<in> tns}"
    unfolding ts regular_Fr[OF tr n[unfolded r[symmetric]]]
    unfolding tns_def K_def r[symmetric]
    unfolding Inl_prodOf wf_subtrOf_Union[OF dtr] ..
    show "(n, tns) \<in> P" unfolding tns_def r[symmetric] using wf_P[OF dtr] .
    fix n' assume "Inr n' \<in> tns" thus "K n' \<in> Lr (ns - {n}) n'"
    unfolding K_def Lr_def mem_Collect_eq apply(intro exI[of _ "subtrOf tr n'"])
    using dtr tr apply(intro conjI refl)  unfolding tns_def
      apply(erule wf_subtrOf[OF dtr])
      apply (metis subtrOf)
      by (metis Inr_subtrOf UNIV_I regular_subtr subtr.simps)
  qed
qed

lemma hsubst_aux:
fixes n ftr tns
assumes n: "n \<in> ns" and tns: "finite tns" and
1: "\<And> n'. Inr n' \<in> tns \<Longrightarrow> wf (ftr n')"
defines "tr \<equiv> Node n ((id \<oplus> ftr) ` tns)"  defines "tr' \<equiv> hsubst tr tr"
shows "Fr ns tr' = Inl -` tns \<union> \<Union>{Fr (ns - {n}) (ftr n') |n'. Inr n' \<in> tns}"
(is "_ = ?B") proof-
  have rtr: "root tr = n" and ctr: "cont tr = (id \<oplus> ftr) ` tns"
  unfolding tr_def using tns by auto
  have Frr: "Frr (ns - {n}) tr = \<Union>{Fr (ns - {n}) (ftr n') |n'. Inr n' \<in> tns}"
  unfolding Frr_def ctr by auto
  have "Fr ns tr' = Inl -` (cont tr) \<union> Frr (ns - {n}) tr"
  using Fr_self_hsubst[OF n[unfolded rtr[symmetric]]] unfolding tr'_def rtr ..
  also have "... = ?B" unfolding ctr Frr by simp
  finally show ?thesis .
qed

lemma L_rec_in:
assumes n: "n \<in> ns"
shows "
{Inl -` tns \<union> (\<Union> {K n' | n'. Inr n' \<in> tns}) | tns K.
    (n,tns) \<in> P \<and>
    (\<forall> n'. Inr n' \<in> tns \<longrightarrow> K n' \<in> L (ns - {n}) n')}
 \<subseteq> L ns n"
proof safe
  fix tns K
  assume P: "(n, tns) \<in> P" and 0: "\<forall>n'. Inr n' \<in> tns \<longrightarrow> K n' \<in> L (ns - {n}) n'"
  {fix n' assume "Inr n' \<in> tns"
   hence "K n' \<in> L (ns - {n}) n'" using 0 by auto
   hence "\<exists> tr'. K n' = Fr (ns - {n}) tr' \<and> wf tr' \<and> root tr' = n'"
   unfolding L_def mem_Collect_eq by auto
  }
  then obtain ftr where 0: "\<And> n'. Inr n' \<in> tns \<Longrightarrow>
  K n' = Fr (ns - {n}) (ftr n') \<and> wf (ftr n') \<and> root (ftr n') = n'"
  by metis
  def tr \<equiv> "Node n ((id \<oplus> ftr) ` tns)"  def tr' \<equiv> "hsubst tr tr"
  have rtr: "root tr = n" and ctr: "cont tr = (id \<oplus> ftr) ` tns"
  unfolding tr_def by (simp, metis P cont_Node finite_imageI finite_in_P)
  have prtr: "prodOf tr = tns" apply(rule Inl_Inr_image_cong)
  unfolding ctr apply simp apply simp apply safe
  using 0 unfolding image_def apply force apply simp by (metis 0 vimageI2)
  have 1: "{K n' |n'. Inr n' \<in> tns} = {Fr (ns - {n}) (ftr n') |n'. Inr n' \<in> tns}"
  using 0 by auto
  have dtr: "wf tr" apply(rule wf.dtree)
    apply (metis (lifting) P prtr rtr)
    unfolding inj_on_def ctr using 0 by auto
  hence dtr': "wf tr'" unfolding tr'_def by (metis wf_hsubst)
  have tns: "finite tns" using finite_in_P P by simp
  have "Inl -` tns \<union> \<Union>{Fr (ns - {n}) (ftr n') |n'. Inr n' \<in> tns} \<in> L ns n"
  unfolding L_def mem_Collect_eq apply(intro exI[of _ tr'] conjI)
  using dtr' 0 hsubst_aux[OF assms tns, of ftr] unfolding tr_def tr'_def by auto
  thus "Inl -` tns \<union> \<Union>{K n' |n'. Inr n' \<in> tns} \<in> L ns n" unfolding 1 .
qed

lemma card_N: "(n::N) \<in> ns \<Longrightarrow> card (ns - {n}) < card ns"
by (metis finite_N Diff_UNIV Diff_infinite_finite card_Diff1_less finite.emptyI)

function LL where
"LL ns n =
 (if n \<notin> ns then {{}} else
 {Inl -` tns \<union> (\<Union> {K n' | n'. Inr n' \<in> tns}) | tns K.
    (n,tns) \<in> P \<and>
    (\<forall> n'. Inr n' \<in> tns \<longrightarrow> K n' \<in> LL (ns - {n}) n')})"
by(pat_completeness, auto)
termination apply(relation "inv_image (measure card) fst")
using card_N by auto

declare LL.simps[code]
declare LL.simps[simp del]

lemma Lr_LL: "Lr ns n \<subseteq> LL ns n"
proof (induct ns arbitrary: n rule: measure_induct[of card])
  case (1 ns n) show ?case proof(cases "n \<in> ns")
    case False thus ?thesis unfolding Lr_rec_notin[OF False] by (simp add: LL.simps)
  next
    case True show ?thesis apply(rule subset_trans)
    using Lr_rec_in[OF True] apply assumption
    unfolding LL.simps[of ns n] using True 1 card_N proof clarsimp
      fix tns K
      assume "n \<in> ns" hence c: "card (ns - {n}) < card ns" using card_N by blast
      assume "(n, tns) \<in> P"
      and "\<forall>n'. Inr n' \<in> tns \<longrightarrow> K n' \<in> Lr (ns - {n}) n'"
      thus "\<exists>tnsa Ka.
             Inl -` tns \<union> \<Union>{K n' |n'. Inr n' \<in> tns} =
             Inl -` tnsa \<union> \<Union>{Ka n' |n'. Inr n' \<in> tnsa} \<and>
             (n, tnsa) \<in> P \<and> (\<forall>n'. Inr n' \<in> tnsa \<longrightarrow> Ka n' \<in> LL (ns - {n}) n')"
      apply(intro exI[of _ tns] exI[of _ K]) using c 1 by auto
    qed
  qed
qed

lemma LL_L: "LL ns n \<subseteq> L ns n"
proof (induct ns arbitrary: n rule: measure_induct[of card])
  case (1 ns n) show ?case proof(cases "n \<in> ns")
    case False thus ?thesis unfolding L_rec_notin[OF False] by (simp add: LL.simps)
  next
    case True show ?thesis apply(rule subset_trans)
    prefer 2 using L_rec_in[OF True] apply assumption
    unfolding LL.simps[of ns n] using True 1 card_N proof clarsimp
      fix tns K
      assume "n \<in> ns" hence c: "card (ns - {n}) < card ns" using card_N by blast
      assume "(n, tns) \<in> P"
      and "\<forall>n'. Inr n' \<in> tns \<longrightarrow> K n' \<in> LL (ns - {n}) n'"
      thus "\<exists>tnsa Ka.
             Inl -` tns \<union> \<Union>{K n' |n'. Inr n' \<in> tns} =
             Inl -` tnsa \<union> \<Union>{Ka n' |n'. Inr n' \<in> tnsa} \<and>
             (n, tnsa) \<in> P \<and> (\<forall>n'. Inr n' \<in> tnsa \<longrightarrow> Ka n' \<in> L (ns - {n}) n')"
      apply(intro exI[of _ tns] exI[of _ K]) using c 1 by auto
    qed
  qed
qed

(* The subsumpsion relation between languages *)
definition "subs L1 L2 \<equiv> \<forall> ts2 \<in> L2. \<exists> ts1 \<in> L1. ts1 \<subseteq> ts2"

lemma incl_subs[simp]: "L2 \<subseteq> L1 \<Longrightarrow> subs L1 L2"
unfolding subs_def by auto

lemma subs_refl[simp]: "subs L1 L1" unfolding subs_def by auto

lemma subs_trans: "\<lbrakk>subs L1 L2; subs L2 L3\<rbrakk> \<Longrightarrow> subs L1 L3"
unfolding subs_def by (metis subset_trans)

(* Language equivalence *)
definition "leqv L1 L2 \<equiv> subs L1 L2 \<and> subs L2 L1"

lemma subs_leqv[simp]: "leqv L1 L2 \<Longrightarrow> subs L1 L2"
unfolding leqv_def by auto

lemma subs_leqv_sym[simp]: "leqv L1 L2 \<Longrightarrow> subs L2 L1"
unfolding leqv_def by auto

lemma leqv_refl[simp]: "leqv L1 L1" unfolding leqv_def by auto

lemma leqv_trans:
assumes 12: "leqv L1 L2" and 23: "leqv L2 L3"
shows "leqv L1 L3"
using assms unfolding leqv_def by (metis (lifting) subs_trans)

lemma leqv_sym: "leqv L1 L2 \<Longrightarrow> leqv L2 L1"
unfolding leqv_def by auto

lemma leqv_Sym: "leqv L1 L2 \<longleftrightarrow> leqv L2 L1"
unfolding leqv_def by auto

lemma Lr_incl_L: "Lr ns ts \<subseteq> L ns ts"
unfolding Lr_def L_def by auto

lemma Lr_subs_L: "subs (Lr UNIV ts) (L UNIV ts)"
unfolding subs_def proof safe
  fix ts2 assume "ts2 \<in> L UNIV ts"
  then obtain tr where ts2: "ts2 = Fr UNIV tr" and dtr: "wf tr" and rtr: "root tr = ts"
  unfolding L_def by auto
  thus "\<exists>ts1\<in>Lr UNIV ts. ts1 \<subseteq> ts2"
  apply(intro bexI[of _ "Fr UNIV (rcut tr)"])
  unfolding Lr_def L_def using Fr_rcut wf_rcut root_rcut regular_rcut by auto
qed

lemma Lr_leqv_L: "leqv (Lr UNIV ts) (L UNIV ts)"
using Lr_subs_L unfolding leqv_def by (metis (lifting) Lr_incl_L incl_subs)

lemma LL_leqv_L: "leqv (LL UNIV ts) (L UNIV ts)"
by (metis (lifting) LL_L Lr_LL Lr_subs_L incl_subs leqv_def subs_trans)

lemma LL_leqv_Lr: "leqv (LL UNIV ts) (Lr UNIV ts)"
using Lr_leqv_L LL_leqv_L by (metis leqv_Sym leqv_trans)

end