(*  Title:      HOL/Cardinals/Wellorder_Constructions.thy
    Author:     Andrei Popescu, TU Muenchen
    Copyright   2012

Constructions on wellorders.
*)

section {* Constructions on Wellorders *}

theory Wellorder_Constructions
imports
  BNF_Wellorder_Constructions Wellorder_Embedding Order_Union
  "../Library/Cardinal_Notations"
begin

declare
  ordLeq_Well_order_simp[simp]
  not_ordLeq_iff_ordLess[simp]
  not_ordLess_iff_ordLeq[simp]
  Func_empty[simp]
  Func_is_emp[simp]

lemma Func_emp2[simp]: "A \<noteq> {} \<Longrightarrow> Func A {} = {}" by auto

subsection {* Restriction to a set *}

lemma Restr_incr2:
"r <= r' \<Longrightarrow> Restr r A <= Restr r' A"
by blast

lemma Restr_incr:
"\<lbrakk>r \<le> r'; A \<le> A'\<rbrakk> \<Longrightarrow> Restr r A \<le> Restr r' A'"
by blast

lemma Restr_Int:
"Restr (Restr r A) B = Restr r (A Int B)"
by blast

lemma Restr_iff: "(a,b) : Restr r A = (a : A \<and> b : A \<and> (a,b) : r)"
by (auto simp add: Field_def)

lemma Restr_subset1: "Restr r A \<le> r"
by auto

lemma Restr_subset2: "Restr r A \<le> A \<times> A"
by auto

lemma wf_Restr:
"wf r \<Longrightarrow> wf(Restr r A)"
using Restr_subset by (elim wf_subset) simp

lemma Restr_incr1:
"A \<le> B \<Longrightarrow> Restr r A \<le> Restr r B"
by blast

subsection {* Order filters versus restrictions and embeddings *}

lemma ofilter_Restr:
assumes WELL: "Well_order r" and
        OFA: "ofilter r A" and OFB: "ofilter r B" and SUB: "A \<le> B"
shows "ofilter (Restr r B) A"
proof-
  let ?rB = "Restr r B"
  have Well: "wo_rel r" unfolding wo_rel_def using WELL .
  hence Refl: "Refl r" by (auto simp add: wo_rel.REFL)
  hence Field: "Field ?rB = Field r Int B"
  using Refl_Field_Restr by blast
  have WellB: "wo_rel ?rB \<and> Well_order ?rB" using WELL
  by (auto simp add: Well_order_Restr wo_rel_def)
  (* Main proof *)
  show ?thesis
  proof(auto simp add: WellB wo_rel.ofilter_def)
    fix a assume "a \<in> A"
    hence "a \<in> Field r \<and> a \<in> B" using assms Well
    by (auto simp add: wo_rel.ofilter_def)
    with Field show "a \<in> Field(Restr r B)" by auto
  next
    fix a b assume *: "a \<in> A"  and "b \<in> under (Restr r B) a"
    hence "b \<in> under r a"
    using WELL OFB SUB ofilter_Restr_under[of r B a] by auto
    thus "b \<in> A" using * Well OFA by(auto simp add: wo_rel.ofilter_def)
  qed
qed

lemma ofilter_subset_iso:
assumes WELL: "Well_order r" and
        OFA: "ofilter r A" and OFB: "ofilter r B"
shows "(A = B) = iso (Restr r A) (Restr r B) id"
using assms
by (auto simp add: ofilter_subset_embedS_iso)

subsection {* Ordering the well-orders by existence of embeddings *}

corollary ordLeq_refl_on: "refl_on {r. Well_order r} ordLeq"
using ordLeq_reflexive unfolding ordLeq_def refl_on_def
by blast

corollary ordLeq_trans: "trans ordLeq"
using trans_def[of ordLeq] ordLeq_transitive by blast

corollary ordLeq_preorder_on: "preorder_on {r. Well_order r} ordLeq"
by(auto simp add: preorder_on_def ordLeq_refl_on ordLeq_trans)

corollary ordIso_refl_on: "refl_on {r. Well_order r} ordIso"
using ordIso_reflexive unfolding refl_on_def ordIso_def
by blast

corollary ordIso_trans: "trans ordIso"
using trans_def[of ordIso] ordIso_transitive by blast

corollary ordIso_sym: "sym ordIso"
by (auto simp add: sym_def ordIso_symmetric)

corollary ordIso_equiv: "equiv {r. Well_order r} ordIso"
by (auto simp add:  equiv_def ordIso_sym ordIso_refl_on ordIso_trans)

lemma ordLess_Well_order_simp[simp]:
assumes "r <o r'"
shows "Well_order r \<and> Well_order r'"
using assms unfolding ordLess_def by simp

lemma ordIso_Well_order_simp[simp]:
assumes "r =o r'"
shows "Well_order r \<and> Well_order r'"
using assms unfolding ordIso_def by simp

lemma ordLess_irrefl: "irrefl ordLess"
by(unfold irrefl_def, auto simp add: ordLess_irreflexive)

lemma ordLess_or_ordIso:
assumes WELL: "Well_order r" and WELL': "Well_order r'"
shows "r <o r' \<or> r' <o r \<or> r =o r'"
unfolding ordLess_def ordIso_def
using assms embedS_or_iso[of r r'] by auto

corollary ordLeq_ordLess_Un_ordIso:
"ordLeq = ordLess \<union> ordIso"
by (auto simp add: ordLeq_iff_ordLess_or_ordIso)

lemma not_ordLeq_ordLess:
"r \<le>o r' \<Longrightarrow> \<not> r' <o r"
using not_ordLess_ordLeq by blast

lemma ordIso_or_ordLess:
assumes WELL: "Well_order r" and WELL': "Well_order r'"
shows "r =o r' \<or> r <o r' \<or> r' <o r"
using assms ordLess_or_ordLeq ordLeq_iff_ordLess_or_ordIso by blast

lemmas ord_trans = ordIso_transitive ordLeq_transitive ordLess_transitive
                   ordIso_ordLeq_trans ordLeq_ordIso_trans
                   ordIso_ordLess_trans ordLess_ordIso_trans
                   ordLess_ordLeq_trans ordLeq_ordLess_trans

lemma ofilter_ordLeq:
assumes "Well_order r" and "ofilter r A"
shows "Restr r A \<le>o r"
proof-
  have "A \<le> Field r" using assms by (auto simp add: wo_rel_def wo_rel.ofilter_def)
  thus ?thesis using assms
  by (simp add: ofilter_subset_ordLeq wo_rel.Field_ofilter
      wo_rel_def Restr_Field)
qed

corollary under_Restr_ordLeq:
"Well_order r \<Longrightarrow> Restr r (under r a) \<le>o r"
by (auto simp add: ofilter_ordLeq wo_rel.under_ofilter wo_rel_def)

subsection {* Copy via direct images *}

lemma Id_dir_image: "dir_image Id f \<le> Id"
unfolding dir_image_def by auto

lemma Un_dir_image:
"dir_image (r1 \<union> r2) f = (dir_image r1 f) \<union> (dir_image r2 f)"
unfolding dir_image_def by auto

lemma Int_dir_image:
assumes "inj_on f (Field r1 \<union> Field r2)"
shows "dir_image (r1 Int r2) f = (dir_image r1 f) Int (dir_image r2 f)"
proof
  show "dir_image (r1 Int r2) f \<le> (dir_image r1 f) Int (dir_image r2 f)"
  using assms unfolding dir_image_def inj_on_def by auto
next
  show "(dir_image r1 f) Int (dir_image r2 f) \<le> dir_image (r1 Int r2) f"
  proof(clarify)
    fix a' b'
    assume "(a',b') \<in> dir_image r1 f" "(a',b') \<in> dir_image r2 f"
    then obtain a1 b1 a2 b2
    where 1: "a' = f a1 \<and> b' = f b1 \<and> a' = f a2 \<and> b' = f b2" and
          2: "(a1,b1) \<in> r1 \<and> (a2,b2) \<in> r2" and
          3: "{a1,b1} \<le> Field r1 \<and> {a2,b2} \<le> Field r2"
    unfolding dir_image_def Field_def by blast
    hence "a1 = a2 \<and> b1 = b2" using assms unfolding inj_on_def by auto
    hence "a' = f a1 \<and> b' = f b1 \<and> (a1,b1) \<in> r1 Int r2 \<and> (a2,b2) \<in> r1 Int r2"
    using 1 2 by auto
    thus "(a',b') \<in> dir_image (r1 \<inter> r2) f"
    unfolding dir_image_def by blast
  qed
qed

(* More facts on ordinal sum: *)

lemma Osum_embed:
assumes FLD: "Field r Int Field r' = {}" and
        WELL: "Well_order r" and WELL': "Well_order r'"
shows "embed r (r Osum r') id"
proof-
  have 1: "Well_order (r Osum r')"
  using assms by (auto simp add: Osum_Well_order)
  moreover
  have "compat r (r Osum r') id"
  unfolding compat_def Osum_def by auto
  moreover
  have "inj_on id (Field r)" by simp
  moreover
  have "ofilter (r Osum r') (Field r)"
  using 1 proof(auto simp add: wo_rel_def wo_rel.ofilter_def
                               Field_Osum under_def)
    fix a b assume 2: "a \<in> Field r" and 3: "(b,a) \<in> r Osum r'"
    moreover
    {assume "(b,a) \<in> r'"
     hence "a \<in> Field r'" using Field_def[of r'] by blast
     hence False using 2 FLD by blast
    }
    moreover
    {assume "a \<in> Field r'"
     hence False using 2 FLD by blast
    }
    ultimately
    show "b \<in> Field r" by (auto simp add: Osum_def Field_def)
  qed
  ultimately show ?thesis
  using assms by (auto simp add: embed_iff_compat_inj_on_ofilter)
qed

corollary Osum_ordLeq:
assumes FLD: "Field r Int Field r' = {}" and
        WELL: "Well_order r" and WELL': "Well_order r'"
shows "r \<le>o r Osum r'"
using assms Osum_embed Osum_Well_order
unfolding ordLeq_def by blast

lemma Well_order_embed_copy:
assumes WELL: "well_order_on A r" and
        INJ: "inj_on f A" and SUB: "f ` A \<le> B"
shows "\<exists>r'. well_order_on B r' \<and> r \<le>o r'"
proof-
  have "bij_betw f A (f ` A)"
  using INJ inj_on_imp_bij_betw by blast
  then obtain r'' where "well_order_on (f ` A) r''" and 1: "r =o r''"
  using WELL  Well_order_iso_copy by blast
  hence 2: "Well_order r'' \<and> Field r'' = (f ` A)"
  using well_order_on_Well_order by blast
  (*  *)
  let ?C = "B - (f ` A)"
  obtain r''' where "well_order_on ?C r'''"
  using well_order_on by blast
  hence 3: "Well_order r''' \<and> Field r''' = ?C"
  using well_order_on_Well_order by blast
  (*  *)
  let ?r' = "r'' Osum r'''"
  have "Field r'' Int Field r''' = {}"
  using 2 3 by auto
  hence "r'' \<le>o ?r'" using Osum_ordLeq[of r'' r'''] 2 3 by blast
  hence 4: "r \<le>o ?r'" using 1 ordIso_ordLeq_trans by blast
  (*  *)
  hence "Well_order ?r'" unfolding ordLeq_def by auto
  moreover
  have "Field ?r' = B" using 2 3 SUB by (auto simp add: Field_Osum)
  ultimately show ?thesis using 4 by blast
qed

subsection {* The maxim among a finite set of ordinals *}

text {* The correct phrasing would be ``a maxim of ...", as @{text "\<le>o"} is only a preorder. *}

definition isOmax :: "'a rel set \<Rightarrow> 'a rel \<Rightarrow> bool"
where
"isOmax  R r == r \<in> R \<and> (ALL r' : R. r' \<le>o r)"

definition omax :: "'a rel set \<Rightarrow> 'a rel"
where
"omax R == SOME r. isOmax R r"

lemma exists_isOmax:
assumes "finite R" and "R \<noteq> {}" and "\<forall> r \<in> R. Well_order r"
shows "\<exists> r. isOmax R r"
proof-
  have "finite R \<Longrightarrow> R \<noteq> {} \<longrightarrow> (\<forall> r \<in> R. Well_order r) \<longrightarrow> (\<exists> r. isOmax R r)"
  apply(erule finite_induct) apply(simp add: isOmax_def)
  proof(clarsimp)
    fix r :: "('a \<times> 'a) set" and R assume *: "finite R" and **: "r \<notin> R"
    and ***: "Well_order r" and ****: "\<forall>r\<in>R. Well_order r"
    and IH: "R \<noteq> {} \<longrightarrow> (\<exists>p. isOmax R p)"
    let ?R' = "insert r R"
    show "\<exists>p'. (isOmax ?R' p')"
    proof(cases "R = {}")
      assume Case1: "R = {}"
      thus ?thesis unfolding isOmax_def using ***
      by (simp add: ordLeq_reflexive)
    next
      assume Case2: "R \<noteq> {}"
      then obtain p where p: "isOmax R p" using IH by auto
      hence 1: "Well_order p" using **** unfolding isOmax_def by simp
      {assume Case21: "r \<le>o p"
       hence "isOmax ?R' p" using p unfolding isOmax_def by simp
       hence ?thesis by auto
      }
      moreover
      {assume Case22: "p \<le>o r"
       {fix r' assume "r' \<in> ?R'"
        moreover
        {assume "r' \<in> R"
         hence "r' \<le>o p" using p unfolding isOmax_def by simp
         hence "r' \<le>o r" using Case22 by(rule ordLeq_transitive)
        }
        moreover have "r \<le>o r" using *** by(rule ordLeq_reflexive)
        ultimately have "r' \<le>o r" by auto
       }
       hence "isOmax ?R' r" unfolding isOmax_def by simp
       hence ?thesis by auto
      }
      moreover have "r \<le>o p \<or> p \<le>o r"
      using 1 *** ordLeq_total by auto
      ultimately show ?thesis by blast
    qed
  qed
  thus ?thesis using assms by auto
qed

lemma omax_isOmax:
assumes "finite R" and "R \<noteq> {}" and "\<forall> r \<in> R. Well_order r"
shows "isOmax R (omax R)"
unfolding omax_def using assms
by(simp add: exists_isOmax someI_ex)

lemma omax_in:
assumes "finite R" and "R \<noteq> {}" and "\<forall> r \<in> R. Well_order r"
shows "omax R \<in> R"
using assms omax_isOmax unfolding isOmax_def by blast

lemma Well_order_omax:
assumes "finite R" and "R \<noteq> {}" and "\<forall>r\<in>R. Well_order r"
shows "Well_order (omax R)"
using assms apply - apply(drule omax_in) by auto

lemma omax_maxim:
assumes "finite R" and "\<forall> r \<in> R. Well_order r" and "r \<in> R"
shows "r \<le>o omax R"
using assms omax_isOmax unfolding isOmax_def by blast

lemma omax_ordLeq:
assumes "finite R" and "R \<noteq> {}" and *: "\<forall> r \<in> R. r \<le>o p"
shows "omax R \<le>o p"
proof-
  have "\<forall> r \<in> R. Well_order r" using * unfolding ordLeq_def by simp
  thus ?thesis using assms omax_in by auto
qed

lemma omax_ordLess:
assumes "finite R" and "R \<noteq> {}" and *: "\<forall> r \<in> R. r <o p"
shows "omax R <o p"
proof-
  have "\<forall> r \<in> R. Well_order r" using * unfolding ordLess_def by simp
  thus ?thesis using assms omax_in by auto
qed

lemma omax_ordLeq_elim:
assumes "finite R" and "\<forall> r \<in> R. Well_order r"
and "omax R \<le>o p" and "r \<in> R"
shows "r \<le>o p"
using assms omax_maxim[of R r] apply simp
using ordLeq_transitive by blast

lemma omax_ordLess_elim:
assumes "finite R" and "\<forall> r \<in> R. Well_order r"
and "omax R <o p" and "r \<in> R"
shows "r <o p"
using assms omax_maxim[of R r] apply simp
using ordLeq_ordLess_trans by blast

lemma ordLeq_omax:
assumes "finite R" and "\<forall> r \<in> R. Well_order r"
and "r \<in> R" and "p \<le>o r"
shows "p \<le>o omax R"
using assms omax_maxim[of R r] apply simp
using ordLeq_transitive by blast

lemma ordLess_omax:
assumes "finite R" and "\<forall> r \<in> R. Well_order r"
and "r \<in> R" and "p <o r"
shows "p <o omax R"
using assms omax_maxim[of R r] apply simp
using ordLess_ordLeq_trans by blast

lemma omax_ordLeq_mono:
assumes P: "finite P" and R: "finite R"
and NE_P: "P \<noteq> {}" and Well_R: "\<forall> r \<in> R. Well_order r"
and LEQ: "\<forall> p \<in> P. \<exists> r \<in> R. p \<le>o r"
shows "omax P \<le>o omax R"
proof-
  let ?mp = "omax P"  let ?mr = "omax R"
  {fix p assume "p : P"
   then obtain r where r: "r : R" and "p \<le>o r"
   using LEQ by blast
   moreover have "r <=o ?mr"
   using r R Well_R omax_maxim by blast
   ultimately have "p <=o ?mr"
   using ordLeq_transitive by blast
  }
  thus "?mp <=o ?mr"
  using NE_P P using omax_ordLeq by blast
qed

lemma omax_ordLess_mono:
assumes P: "finite P" and R: "finite R"
and NE_P: "P \<noteq> {}" and Well_R: "\<forall> r \<in> R. Well_order r"
and LEQ: "\<forall> p \<in> P. \<exists> r \<in> R. p <o r"
shows "omax P <o omax R"
proof-
  let ?mp = "omax P"  let ?mr = "omax R"
  {fix p assume "p : P"
   then obtain r where r: "r : R" and "p <o r"
   using LEQ by blast
   moreover have "r <=o ?mr"
   using r R Well_R omax_maxim by blast
   ultimately have "p <o ?mr"
   using ordLess_ordLeq_trans by blast
  }
  thus "?mp <o ?mr"
  using NE_P P omax_ordLess by blast
qed

subsection {* Limit and succesor ordinals *}

lemma embed_underS2:
assumes r: "Well_order r" and s: "Well_order s"  and g: "embed r s g" and a: "a \<in> Field r"
shows "g ` underS r a = underS s (g a)"
using embed_underS[OF assms] unfolding bij_betw_def by auto

lemma bij_betw_insert:
assumes "b \<notin> A" and "f b \<notin> A'" and "bij_betw f A A'"
shows "bij_betw f (insert b A) (insert (f b) A')"
using notIn_Un_bij_betw[OF assms] by auto

context wo_rel
begin

lemma underS_induct:
  assumes "\<And>a. (\<And> a1. a1 \<in> underS a \<Longrightarrow> P a1) \<Longrightarrow> P a"
  shows "P a"
  by (induct rule: well_order_induct) (rule assms, simp add: underS_def)

lemma suc_underS:
assumes B: "B \<subseteq> Field r" and A: "AboveS B \<noteq> {}" and b: "b \<in> B"
shows "b \<in> underS (suc B)"
using suc_AboveS[OF B A] b unfolding underS_def AboveS_def by auto

lemma underS_supr:
assumes bA: "b \<in> underS (supr A)" and A: "A \<subseteq> Field r"
shows "\<exists> a \<in> A. b \<in> underS a"
proof(rule ccontr, auto)
  have bb: "b \<in> Field r" using bA unfolding underS_def Field_def by auto
  assume "\<forall>a\<in>A.  b \<notin> underS a"
  hence 0: "\<forall>a \<in> A. (a,b) \<in> r" using A bA unfolding underS_def
  by simp (metis REFL in_mono max2_def max2_greater refl_on_domain)
  have "(supr A, b) \<in> r" apply(rule supr_least[OF A bb]) using 0 by auto
  thus False using bA unfolding underS_def by simp (metis ANTISYM antisymD)
qed

lemma underS_suc:
assumes bA: "b \<in> underS (suc A)" and A: "A \<subseteq> Field r"
shows "\<exists> a \<in> A. b \<in> under a"
proof(rule ccontr, auto)
  have bb: "b \<in> Field r" using bA unfolding underS_def Field_def by auto
  assume "\<forall>a\<in>A.  b \<notin> under a"
  hence 0: "\<forall>a \<in> A. a \<in> underS b" using A bA unfolding underS_def
  by simp (metis (lifting) bb max2_def max2_greater mem_Collect_eq under_def set_rev_mp)
  have "(suc A, b) \<in> r" apply(rule suc_least[OF A bb]) using 0 unfolding underS_def by auto
  thus False using bA unfolding underS_def by simp (metis ANTISYM antisymD)
qed

lemma (in wo_rel) in_underS_supr:
assumes j: "j \<in> underS i" and i: "i \<in> A" and A: "A \<subseteq> Field r" and AA: "Above A \<noteq> {}"
shows "j \<in> underS (supr A)"
proof-
  have "(i,supr A) \<in> r" using supr_greater[OF A AA i] .
  thus ?thesis using j unfolding underS_def
  by simp (metis REFL TRANS max2_def max2_equals1 refl_on_domain transD)
qed

lemma inj_on_Field:
assumes A: "A \<subseteq> Field r" and f: "\<And> a b. \<lbrakk>a \<in> A; b \<in> A; a \<in> underS b\<rbrakk> \<Longrightarrow> f a \<noteq> f b"
shows "inj_on f A"
unfolding inj_on_def proof safe
  fix a b assume a: "a \<in> A" and b: "b \<in> A" and fab: "f a = f b"
  {assume "a \<in> underS b"
   hence False using f[OF a b] fab by auto
  }
  moreover
  {assume "b \<in> underS a"
   hence False using f[OF b a] fab by auto
  }
  ultimately show "a = b" using TOTALS A a b unfolding underS_def by auto
qed

lemma in_notinI:
assumes "(j,i) \<notin> r \<or> j = i" and "i \<in> Field r" and "j \<in> Field r"
shows "(i,j) \<in> r" by (metis assms max2_def max2_greater_among)

lemma ofilter_init_seg_of:
assumes "ofilter F"
shows "Restr r F initial_segment_of r"
using assms unfolding ofilter_def init_seg_of_def under_def by auto

lemma underS_init_seg_of_Collect:
assumes "\<And>j1 j2. \<lbrakk>j2 \<in> underS i; (j1, j2) \<in> r\<rbrakk> \<Longrightarrow> R j1 initial_segment_of R j2"
shows "{R j |j. j \<in> underS i} \<in> Chains init_seg_of"
unfolding Chains_def proof safe
  fix j ja assume jS: "j \<in> underS i" and jaS: "ja \<in> underS i"
  and init: "(R ja, R j) \<notin> init_seg_of"
  hence jja: "{j,ja} \<subseteq> Field r" and j: "j \<in> Field r" and ja: "ja \<in> Field r"
  and jjai: "(j,i) \<in> r" "(ja,i) \<in> r"
  and i: "i \<notin> {j,ja}" unfolding Field_def underS_def by auto
  have jj: "(j,j) \<in> r" and jaja: "(ja,ja) \<in> r" using j ja by (metis in_notinI)+
  show "R j initial_segment_of R ja"
  using jja init jjai i
  by (elim cases_Total3 disjE) (auto elim: cases_Total3 intro!: assms simp: underS_def)
qed

lemma (in wo_rel) Field_init_seg_of_Collect:
assumes "\<And>j1 j2. \<lbrakk>j2 \<in> Field r; (j1, j2) \<in> r\<rbrakk> \<Longrightarrow> R j1 initial_segment_of R j2"
shows "{R j |j. j \<in> Field r} \<in> Chains init_seg_of"
unfolding Chains_def proof safe
  fix j ja assume jS: "j \<in> Field r" and jaS: "ja \<in> Field r"
  and init: "(R ja, R j) \<notin> init_seg_of"
  hence jja: "{j,ja} \<subseteq> Field r" and j: "j \<in> Field r" and ja: "ja \<in> Field r"
  unfolding Field_def underS_def by auto
  have jj: "(j,j) \<in> r" and jaja: "(ja,ja) \<in> r" using j ja by (metis in_notinI)+
  show "R j initial_segment_of R ja"
  using jja init
  by (elim cases_Total3 disjE) (auto elim: cases_Total3 intro!: assms simp: Field_def)
qed

subsubsection {* Successor and limit elements of an ordinal *}

definition "succ i \<equiv> suc {i}"

definition "isSucc i \<equiv> \<exists> j. aboveS j \<noteq> {} \<and> i = succ j"

definition "zero = minim (Field r)"

definition "isLim i \<equiv> \<not> isSucc i"

lemma zero_smallest[simp]:
assumes "j \<in> Field r" shows "(zero, j) \<in> r"
unfolding zero_def
by (metis AboveS_Field assms subset_AboveS_UnderS subset_antisym subset_refl suc_def suc_least_AboveS)

lemma zero_in_Field: assumes "Field r \<noteq> {}"  shows "zero \<in> Field r"
using assms unfolding zero_def by (metis Field_ofilter minim_in ofilter_def)

lemma leq_zero_imp[simp]:
"(x, zero) \<in> r \<Longrightarrow> x = zero"
by (metis ANTISYM WELL antisymD well_order_on_domain zero_smallest)

lemma leq_zero[simp]:
assumes "Field r \<noteq> {}"  shows "(x, zero) \<in> r \<longleftrightarrow> x = zero"
using zero_in_Field[OF assms] in_notinI[of x zero] by auto

lemma under_zero[simp]:
assumes "Field r \<noteq> {}" shows "under zero = {zero}"
using assms unfolding under_def by auto

lemma underS_zero[simp,intro]: "underS zero = {}"
unfolding underS_def by auto

lemma isSucc_succ: "aboveS i \<noteq> {} \<Longrightarrow> isSucc (succ i)"
unfolding isSucc_def succ_def by auto

lemma succ_in_diff:
assumes "aboveS i \<noteq> {}"  shows "(i,succ i) \<in> r \<and> succ i \<noteq> i"
using assms suc_greater[of "{i}"] unfolding succ_def AboveS_def aboveS_def Field_def by auto

lemmas succ_in[simp] = succ_in_diff[THEN conjunct1]
lemmas succ_diff[simp] = succ_in_diff[THEN conjunct2]

lemma succ_in_Field[simp]:
assumes "aboveS i \<noteq> {}"  shows "succ i \<in> Field r"
using succ_in[OF assms] unfolding Field_def by auto

lemma succ_not_in:
assumes "aboveS i \<noteq> {}" shows "(succ i, i) \<notin> r"
proof
  assume 1: "(succ i, i) \<in> r"
  hence "succ i \<in> Field r \<and> i \<in> Field r" unfolding Field_def by auto
  hence "(i, succ i) \<in> r \<and> succ i \<noteq> i" using assms by auto
  thus False using 1 by (metis ANTISYM antisymD)
qed

lemma not_isSucc_zero: "\<not> isSucc zero"
proof
  assume "isSucc zero"
  moreover
  then obtain i where "aboveS i \<noteq> {}" and 1: "minim (Field r) = succ i"
  unfolding isSucc_def zero_def by auto
  hence "succ i \<in> Field r" by auto
  ultimately show False by (metis REFL isSucc_def minim_least refl_on_domain
    subset_refl succ_in succ_not_in zero_def)
qed

lemma isLim_zero[simp]: "isLim zero"
  by (metis isLim_def not_isSucc_zero)

lemma succ_smallest:
assumes "(i,j) \<in> r" and "i \<noteq> j"
shows "(succ i, j) \<in> r"
unfolding succ_def apply(rule suc_least)
using assms unfolding Field_def by auto

lemma isLim_supr:
assumes f: "i \<in> Field r" and l: "isLim i"
shows "i = supr (underS i)"
proof(rule equals_supr)
  fix j assume j: "j \<in> Field r" and 1: "\<And> j'. j' \<in> underS i \<Longrightarrow> (j',j) \<in> r"
  show "(i,j) \<in> r" proof(intro in_notinI[OF _ f j], safe)
    assume ji: "(j,i) \<in> r" "j \<noteq> i"
    hence a: "aboveS j \<noteq> {}" unfolding aboveS_def by auto
    hence "i \<noteq> succ j" using l unfolding isLim_def isSucc_def by auto
    moreover have "(succ j, i) \<in> r" using succ_smallest[OF ji] by auto
    ultimately have "succ j \<in> underS i" unfolding underS_def by auto
    hence "(succ j, j) \<in> r" using 1 by auto
    thus False using succ_not_in[OF a] by simp
  qed
qed(insert f, unfold underS_def Field_def, auto)

definition "pred i \<equiv> SOME j. j \<in> Field r \<and> aboveS j \<noteq> {} \<and> succ j = i"

lemma pred_Field_succ:
assumes "isSucc i" shows "pred i \<in> Field r \<and> aboveS (pred i) \<noteq> {} \<and> succ (pred i) = i"
proof-
  obtain j where a: "aboveS j \<noteq> {}" and i: "i = succ j" using assms unfolding isSucc_def by auto
  have 1: "j \<in> Field r" "j \<noteq> i" unfolding Field_def i
  using succ_diff[OF a] a unfolding aboveS_def by auto
  show ?thesis unfolding pred_def apply(rule someI_ex) using 1 i a by auto
qed

lemmas pred_Field[simp] = pred_Field_succ[THEN conjunct1]
lemmas aboveS_pred[simp] = pred_Field_succ[THEN conjunct2, THEN conjunct1]
lemmas succ_pred[simp] = pred_Field_succ[THEN conjunct2, THEN conjunct2]

lemma isSucc_pred_in:
assumes "isSucc i"  shows "(pred i, i) \<in> r"
proof-
  def j \<equiv> "pred i"
  have i: "i = succ j" using assms unfolding j_def by simp
  have a: "aboveS j \<noteq> {}" unfolding j_def using assms by auto
  show ?thesis unfolding j_def[symmetric] unfolding i using succ_in[OF a] .
qed

lemma isSucc_pred_diff:
assumes "isSucc i"  shows "pred i \<noteq> i"
by (metis aboveS_pred assms succ_diff succ_pred)

(* todo: pred maximal, pred injective? *)

lemma succ_inj[simp]:
assumes "aboveS i \<noteq> {}" and "aboveS j \<noteq> {}"
shows "succ i = succ j \<longleftrightarrow> i = j"
proof safe
  assume s: "succ i = succ j"
  {assume "i \<noteq> j" and "(i,j) \<in> r"
   hence "(succ i, j) \<in> r" using assms by (metis succ_smallest)
   hence False using s assms by (metis succ_not_in)
  }
  moreover
  {assume "i \<noteq> j" and "(j,i) \<in> r"
   hence "(succ j, i) \<in> r" using assms by (metis succ_smallest)
   hence False using s assms by (metis succ_not_in)
  }
  ultimately show "i = j" by (metis TOTALS WELL assms(1) assms(2) succ_in_diff well_order_on_domain)
qed

lemma pred_succ[simp]:
assumes "aboveS j \<noteq> {}"  shows "pred (succ j) = j"
unfolding pred_def apply(rule some_equality)
using assms apply(force simp: Field_def aboveS_def)
by (metis assms succ_inj)

lemma less_succ[simp]:
assumes "aboveS i \<noteq> {}"
shows "(j, succ i) \<in> r \<longleftrightarrow> (j,i) \<in> r \<or> j = succ i"
apply safe
  apply (metis WELL assms in_notinI well_order_on_domain suc_singl_pred succ_def succ_in_diff)
  apply (metis (hide_lams, full_types) REFL TRANS assms max2_def max2_equals1 refl_on_domain succ_in_Field succ_not_in transD)
  apply (metis assms in_notinI succ_in_Field)
done

lemma underS_succ[simp]:
assumes "aboveS i \<noteq> {}"
shows "underS (succ i) = under i"
unfolding underS_def under_def by (auto simp: assms succ_not_in)

lemma succ_mono:
assumes "aboveS j \<noteq> {}" and "(i,j) \<in> r"
shows "(succ i, succ j) \<in> r"
by (metis (full_types) assms less_succ succ_smallest)

lemma under_succ[simp]:
assumes "aboveS i \<noteq> {}"
shows "under (succ i) = insert (succ i) (under i)"
using less_succ[OF assms] unfolding under_def by auto

definition mergeSL :: "('a \<Rightarrow> 'b \<Rightarrow> 'b) \<Rightarrow> (('a \<Rightarrow> 'b) \<Rightarrow> 'a \<Rightarrow> 'b) \<Rightarrow> ('a \<Rightarrow> 'b) \<Rightarrow> 'a \<Rightarrow> 'b"
where
"mergeSL S L f i \<equiv>
 if isSucc i then S (pred i) (f (pred i))
 else L f i"

subsubsection {* Well-order recursion with (zero), succesor, and limit *}

definition worecSL :: "('a \<Rightarrow> 'b \<Rightarrow> 'b) \<Rightarrow> (('a \<Rightarrow> 'b) \<Rightarrow> 'a \<Rightarrow> 'b) \<Rightarrow> 'a \<Rightarrow> 'b"
where "worecSL S L \<equiv> worec (mergeSL S L)"

definition "adm_woL L \<equiv> \<forall>f g i. isLim i \<and> (\<forall>j\<in>underS i. f j = g j) \<longrightarrow> L f i = L g i"

lemma mergeSL:
assumes "adm_woL L"  shows "adm_wo (mergeSL S L)"
unfolding adm_wo_def proof safe
  fix f g :: "'a => 'b" and i :: 'a
  assume 1: "\<forall>j\<in>underS i. f j = g j"
  show "mergeSL S L f i = mergeSL S L g i"
  proof(cases "isSucc i")
    case True
    hence "pred i \<in> underS i" unfolding underS_def using isSucc_pred_in isSucc_pred_diff by auto
    thus ?thesis using True 1 unfolding mergeSL_def by auto
  next
    case False hence "isLim i" unfolding isLim_def by auto
    thus ?thesis using assms False 1 unfolding mergeSL_def adm_woL_def by auto
  qed
qed

lemma worec_fixpoint1: "adm_wo H \<Longrightarrow> worec H i = H (worec H) i"
by (metis worec_fixpoint)

lemma worecSL_isSucc:
assumes a: "adm_woL L" and i: "isSucc i"
shows "worecSL S L i = S (pred i) (worecSL S L (pred i))"
proof-
  let ?H = "mergeSL S L"
  have "worecSL S L i = ?H (worec ?H) i"
  unfolding worecSL_def using worec_fixpoint1[OF mergeSL[OF a]] .
  also have "... = S (pred i) (worecSL S L (pred i))"
  unfolding worecSL_def mergeSL_def using i by simp
  finally show ?thesis .
qed

lemma worecSL_succ:
assumes a: "adm_woL L" and i: "aboveS j \<noteq> {}"
shows "worecSL S L (succ j) = S j (worecSL S L j)"
proof-
  def i \<equiv> "succ j"
  have i: "isSucc i" by (metis i i_def isSucc_succ)
  have ij: "j = pred i" unfolding i_def using assms by simp
  have 0: "succ (pred i) = i" using i by simp
  show ?thesis unfolding ij using worecSL_isSucc[OF a i] unfolding 0 .
qed

lemma worecSL_isLim:
assumes a: "adm_woL L" and i: "isLim i"
shows "worecSL S L i = L (worecSL S L) i"
proof-
  let ?H = "mergeSL S L"
  have "worecSL S L i = ?H (worec ?H) i"
  unfolding worecSL_def using worec_fixpoint1[OF mergeSL[OF a]] .
  also have "... = L (worecSL S L) i"
  using i unfolding worecSL_def mergeSL_def isLim_def by simp
  finally show ?thesis .
qed

definition worecZSL :: "'b \<Rightarrow> ('a \<Rightarrow> 'b \<Rightarrow> 'b) \<Rightarrow> (('a \<Rightarrow> 'b) \<Rightarrow> 'a \<Rightarrow> 'b) \<Rightarrow> 'a \<Rightarrow> 'b"
where "worecZSL Z S L \<equiv> worecSL S (\<lambda> f a. if a = zero then Z else L f a)"

lemma worecZSL_zero:
assumes a: "adm_woL L"
shows "worecZSL Z S L zero = Z"
proof-
  let ?L = "\<lambda> f a. if a = zero then Z else L f a"
  have "worecZSL Z S L zero = ?L (worecZSL Z S L) zero"
  unfolding worecZSL_def apply(rule worecSL_isLim)
  using assms unfolding adm_woL_def by auto
  also have "... = Z" by simp
  finally show ?thesis .
qed

lemma worecZSL_succ:
assumes a: "adm_woL L" and i: "aboveS j \<noteq> {}"
shows "worecZSL Z S L (succ j) = S j (worecZSL Z S L j)"
unfolding worecZSL_def apply(rule  worecSL_succ)
using assms unfolding adm_woL_def by auto

lemma worecZSL_isLim:
assumes a: "adm_woL L" and "isLim i" and "i \<noteq> zero"
shows "worecZSL Z S L i = L (worecZSL Z S L) i"
proof-
  let ?L = "\<lambda> f a. if a = zero then Z else L f a"
  have "worecZSL Z S L i = ?L (worecZSL Z S L) i"
  unfolding worecZSL_def apply(rule worecSL_isLim)
  using assms unfolding adm_woL_def by auto
  also have "... = L (worecZSL Z S L) i" using assms by simp
  finally show ?thesis .
qed

subsubsection {* Well-order succ-lim induction *}

lemma ord_cases:
obtains j where "i = succ j" and "aboveS j \<noteq> {}"  | "isLim i"
by (metis isLim_def isSucc_def)

lemma well_order_inductSL[case_names Suc Lim]:
assumes SUCC: "\<And>i. \<lbrakk>aboveS i \<noteq> {}; P i\<rbrakk> \<Longrightarrow> P (succ i)" and
LIM: "\<And>i. \<lbrakk>isLim i; \<And>j. j \<in> underS i \<Longrightarrow> P j\<rbrakk> \<Longrightarrow> P i"
shows "P i"
proof(induction rule: well_order_induct)
  fix i assume 0:  "\<forall>j. j \<noteq> i \<and> (j, i) \<in> r \<longrightarrow> P j"
  show "P i" proof(cases i rule: ord_cases)
    fix j assume i: "i = succ j" and j: "aboveS j \<noteq> {}"
    hence "j \<noteq> i \<and> (j, i) \<in> r" by (metis  succ_diff succ_in)
    hence 1: "P j" using 0 by simp
    show "P i" unfolding i apply(rule SUCC) using 1 j by auto
  qed(insert 0 LIM, unfold underS_def, auto)
qed

lemma well_order_inductZSL[case_names Zero Suc Lim]:
assumes ZERO: "P zero"
and SUCC: "\<And>i. \<lbrakk>aboveS i \<noteq> {}; P i\<rbrakk> \<Longrightarrow> P (succ i)" and
LIM: "\<And>i. \<lbrakk>isLim i; i \<noteq> zero; \<And>j. j \<in> underS i \<Longrightarrow> P j\<rbrakk> \<Longrightarrow> P i"
shows "P i"
apply(induction rule: well_order_inductSL) using assms by auto

(* Succesor and limit ordinals *)
definition "isSuccOrd \<equiv> \<exists> j \<in> Field r. \<forall> i \<in> Field r. (i,j) \<in> r"
definition "isLimOrd \<equiv> \<not> isSuccOrd"

lemma isLimOrd_succ:
assumes isLimOrd and "i \<in> Field r"
shows "succ i \<in> Field r"
using assms unfolding isLimOrd_def isSuccOrd_def
by (metis REFL in_notinI refl_on_domain succ_smallest)

lemma isLimOrd_aboveS:
assumes l: isLimOrd and i: "i \<in> Field r"
shows "aboveS i \<noteq> {}"
proof-
  obtain j where "j \<in> Field r" and "(j,i) \<notin> r"
  using assms unfolding isLimOrd_def isSuccOrd_def by auto
  hence "(i,j) \<in> r \<and> j \<noteq> i" by (metis i max2_def max2_greater)
  thus ?thesis unfolding aboveS_def by auto
qed

lemma succ_aboveS_isLimOrd:
assumes "\<forall> i \<in> Field r. aboveS i \<noteq> {} \<and> succ i \<in> Field r"
shows isLimOrd
unfolding isLimOrd_def isSuccOrd_def proof safe
  fix j assume j: "j \<in> Field r" "\<forall>i\<in>Field r. (i, j) \<in> r"
  hence "(succ j, j) \<in> r" using assms by auto
  moreover have "aboveS j \<noteq> {}" using assms j unfolding aboveS_def by auto
  ultimately show False by (metis succ_not_in)
qed

lemma isLim_iff:
assumes l: "isLim i" and j: "j \<in> underS i"
shows "\<exists> k. k \<in> underS i \<and> j \<in> underS k"
proof-
  have a: "aboveS j \<noteq> {}" using j unfolding underS_def aboveS_def by auto
  show ?thesis apply(rule exI[of _ "succ j"]) apply safe
  using assms a unfolding underS_def isLim_def
  apply (metis (lifting, full_types) isSucc_def mem_Collect_eq succ_smallest)
  by (metis (lifting, full_types) a mem_Collect_eq succ_diff succ_in)
qed

end (* context wo_rel *)

abbreviation "zero \<equiv> wo_rel.zero"
abbreviation "succ \<equiv> wo_rel.succ"
abbreviation "pred \<equiv> wo_rel.pred"
abbreviation "isSucc \<equiv> wo_rel.isSucc"
abbreviation "isLim \<equiv> wo_rel.isLim"
abbreviation "isLimOrd \<equiv> wo_rel.isLimOrd"
abbreviation "isSuccOrd \<equiv> wo_rel.isSuccOrd"
abbreviation "adm_woL \<equiv> wo_rel.adm_woL"
abbreviation "worecSL \<equiv> wo_rel.worecSL"
abbreviation "worecZSL \<equiv> wo_rel.worecZSL"

subsection {* Projections of wellorders *}

definition "oproj r s f \<equiv> Field s \<subseteq> f ` (Field r) \<and> compat r s f"

lemma oproj_in:
assumes "oproj r s f" and "(a,a') \<in> r"
shows "(f a, f a') \<in> s"
using assms unfolding oproj_def compat_def by auto

lemma oproj_Field:
assumes f: "oproj r s f" and a: "a \<in> Field r"
shows "f a \<in> Field s"
using oproj_in[OF f] a unfolding Field_def by auto

lemma oproj_Field2:
assumes f: "oproj r s f" and a: "b \<in> Field s"
shows "\<exists> a \<in> Field r. f a = b"
using assms unfolding oproj_def by auto

lemma oproj_under:
assumes f:  "oproj r s f" and a: "a \<in> under r a'"
shows "f a \<in> under s (f a')"
using oproj_in[OF f] a unfolding under_def by auto

(* An ordinal is embedded in another whenever it is embedded as an order
(not necessarily as initial segment):*)
theorem embedI:
assumes r: "Well_order r" and s: "Well_order s"
and f: "\<And> a. a \<in> Field r \<Longrightarrow> f a \<in> Field s \<and> f ` underS r a \<subseteq> underS s (f a)"
shows "\<exists> g. embed r s g"
proof-
  interpret r!: wo_rel r by unfold_locales (rule r)
  interpret s!: wo_rel s by unfold_locales (rule s)
  let ?G = "\<lambda> g a. suc s (g ` underS r a)"
  def g \<equiv> "worec r ?G"
  have adm: "adm_wo r ?G" unfolding r.adm_wo_def image_def by auto
  (*  *)
  {fix a assume "a \<in> Field r"
   hence "bij_betw g (under r a) (under s (g a)) \<and>
          g a \<in> under s (f a)"
   proof(induction a rule: r.underS_induct)
     case (1 a)
     hence a: "a \<in> Field r"
     and IH1a: "\<And> a1. a1 \<in> underS r a \<Longrightarrow> inj_on g (under r a1)"
     and IH1b: "\<And> a1. a1 \<in> underS r a \<Longrightarrow> g ` under r a1 = under s (g a1)"
     and IH2: "\<And> a1. a1 \<in> underS r a \<Longrightarrow> g a1 \<in> under s (f a1)"
     unfolding underS_def Field_def bij_betw_def by auto
     have fa: "f a \<in> Field s" using f[OF a] by auto
     have g: "g a = suc s (g ` underS r a)"
     using r.worec_fixpoint[OF adm] unfolding g_def fun_eq_iff by simp
     have A0: "g ` underS r a \<subseteq> Field s"
     using IH1b by (metis IH2 image_subsetI in_mono under_Field)
     {fix a1 assume a1: "a1 \<in> underS r a"
      from IH2[OF this] have "g a1 \<in> under s (f a1)" .
      moreover have "f a1 \<in> underS s (f a)" using f[OF a] a1 by auto
      ultimately have "g a1 \<in> underS s (f a)" by (metis s.ANTISYM s.TRANS under_underS_trans)
     }
     hence "f a \<in> AboveS s (g ` underS r a)" unfolding AboveS_def
     using fa by simp (metis (lifting, full_types) mem_Collect_eq underS_def)
     hence A: "AboveS s (g ` underS r a) \<noteq> {}" by auto
     have B: "\<And> a1. a1 \<in> underS r a \<Longrightarrow> g a1 \<in> underS s (g a)"
     unfolding g apply(rule s.suc_underS[OF A0 A]) by auto
     {fix a1 a2 assume a2: "a2 \<in> underS r a" and 1: "a1 \<in> underS r a2"
      hence a12: "{a1,a2} \<subseteq> under r a2" and "a1 \<noteq> a2" using r.REFL a
      unfolding underS_def under_def refl_on_def Field_def by auto
      hence "g a1 \<noteq> g a2" using IH1a[OF a2] unfolding inj_on_def by auto
      hence "g a1 \<in> underS s (g a2)" using IH1b[OF a2] a12
      unfolding underS_def under_def by auto
     } note C = this
     have ga: "g a \<in> Field s" unfolding g using s.suc_inField[OF A0 A] .
     have aa: "a \<in> under r a"
     using a r.REFL unfolding under_def underS_def refl_on_def by auto
     show ?case proof safe
       show "bij_betw g (under r a) (under s (g a))" unfolding bij_betw_def proof safe
         show "inj_on g (under r a)" proof(rule r.inj_on_Field)
           fix a1 a2 assume "a1 \<in> under r a" and a2: "a2 \<in> under r a" and a1: "a1 \<in> underS r a2"
           hence a22: "a2 \<in> under r a2" and a12: "a1 \<in> under r a2" "a1 \<noteq> a2"
           using a r.REFL unfolding under_def underS_def refl_on_def by auto
           show "g a1 \<noteq> g a2"
           proof(cases "a2 = a")
             case False hence "a2 \<in> underS r a"
             using a2 unfolding underS_def under_def by auto
             from IH1a[OF this] show ?thesis using a12 a22 unfolding inj_on_def by auto
           qed(insert B a1, unfold underS_def, auto)
         qed(unfold under_def Field_def, auto)
       next
         fix a1 assume a1: "a1 \<in> under r a"
         show "g a1 \<in> under s (g a)"
         proof(cases "a1 = a")
           case True thus ?thesis
           using ga s.REFL unfolding refl_on_def under_def by auto
         next
           case False
           hence a1: "a1 \<in> underS r a" using a1 unfolding underS_def under_def by auto
           thus ?thesis using B unfolding underS_def under_def by auto
         qed
       next
         fix b1 assume b1: "b1 \<in> under s (g a)"
         show "b1 \<in> g ` under r a"
         proof(cases "b1 = g a")
           case True thus ?thesis using aa by auto
         next
           case False
           hence "b1 \<in> underS s (g a)" using b1 unfolding underS_def under_def by auto
           from s.underS_suc[OF this[unfolded g] A0]
           obtain a1 where a1: "a1 \<in> underS r a" and b1: "b1 \<in> under s (g a1)" by auto
           obtain a2 where "a2 \<in> under r a1" and b1: "b1 = g a2" using IH1b[OF a1] b1 by auto
           hence "a2 \<in> under r a" using a1
           by (metis r.ANTISYM r.TRANS in_mono underS_subset_under under_underS_trans)
           thus ?thesis using b1 by auto
         qed
       qed
     next
       have "(g a, f a) \<in> s" unfolding g proof(rule s.suc_least[OF A0])
         fix b1 assume "b1 \<in> g ` underS r a"
         then obtain a1 where a1: "b1 = g a1" and a1: "a1 \<in> underS r a" by auto
         hence "b1 \<in> underS s (f a)"
         using a by (metis `\<And>a1. a1 \<in> underS r a \<Longrightarrow> g a1 \<in> underS s (f a)`)
         thus "f a \<noteq> b1 \<and> (b1, f a) \<in> s" unfolding underS_def by auto
       qed(insert fa, auto)
       thus "g a \<in> under s (f a)" unfolding under_def by auto
     qed
   qed
  }
  thus ?thesis unfolding embed_def by auto
qed

corollary ordLeq_def2:
  "r \<le>o s \<longleftrightarrow> Well_order r \<and> Well_order s \<and>
               (\<exists> f. \<forall> a \<in> Field r. f a \<in> Field s \<and> f ` underS r a \<subseteq> underS s (f a))"
using embed_in_Field[of r s] embed_underS2[of r s] embedI[of r s]
unfolding ordLeq_def by fast

lemma iso_oproj:
  assumes r: "Well_order r" and s: "Well_order s" and f: "iso r s f"
  shows "oproj r s f"
using assms unfolding oproj_def
by (subst (asm) iso_iff3) (auto simp: bij_betw_def)

theorem oproj_embed:
assumes r: "Well_order r" and s: "Well_order s" and f: "oproj r s f"
shows "\<exists> g. embed s r g"
proof (rule embedI[OF s r, of "inv_into (Field r) f"], unfold underS_def, safe)
  fix b assume "b \<in> Field s"
  thus "inv_into (Field r) f b \<in> Field r" using oproj_Field2[OF f] by (metis imageI inv_into_into)
next
  fix a b assume "b \<in> Field s" "a \<noteq> b" "(a, b) \<in> s"
    "inv_into (Field r) f a = inv_into (Field r) f b"
  with f show False by (auto dest!: inv_into_injective simp: Field_def oproj_def)
next
  fix a b assume *: "b \<in> Field s" "a \<noteq> b" "(a, b) \<in> s"
  { assume "(inv_into (Field r) f a, inv_into (Field r) f b) \<notin> r"
    moreover
    from *(3) have "a \<in> Field s" unfolding Field_def by auto
    with *(1,2) have
      "inv_into (Field r) f a \<in> Field r" "inv_into (Field r) f b \<in> Field r"
      "inv_into (Field r) f a \<noteq> inv_into (Field r) f b"
      by (auto dest!: oproj_Field2[OF f] inv_into_injective intro!: inv_into_into)
    ultimately have "(inv_into (Field r) f b, inv_into (Field r) f a) \<in> r"
      using r by (auto simp: well_order_on_def linear_order_on_def total_on_def)
    with f[unfolded oproj_def compat_def] *(1) `a \<in> Field s`
      f_inv_into_f[of b f "Field r"] f_inv_into_f[of a f "Field r"]
      have "(b, a) \<in> s" by (metis in_mono)
    with *(2,3) s have False
      by (auto simp: well_order_on_def linear_order_on_def partial_order_on_def antisym_def)
  } thus "(inv_into (Field r) f a, inv_into (Field r) f b) \<in> r" by blast
qed

corollary oproj_ordLeq:
assumes r: "Well_order r" and s: "Well_order s" and f: "oproj r s f"
shows "s \<le>o r"
using oproj_embed[OF assms] r s unfolding ordLeq_def by auto

end


theory Tangles
imports Preliminaries
begin

(* Time to split the file: Links and Tangles in another file*)

text{*well-defined wall as a type called diagram. The morphisms Abs_diagram maps a well defined wall to
its diagram type and Rep_diagram maps the diagram back to the wall *}

typedef Tangle_Diagram = "{(x::wall). is_tangle_diagram x}"
 apply (rule_tac x = "prod (cup#[]) (basic (cap#[]))" in exI)
 apply(auto)
 done

typedef Link_Diagram = "{(x::wall). is_link_diagram x}"
 apply (rule_tac x = "prod (cup#[]) (basic (cap#[]))" in exI)
 apply(auto)
 apply(simp add:is_link_diagram_def abs_def)
 done

text{*The next few lemmas list the properties of well defined diagrams*}

text{*For a well defined diagram, the morphism Rep-diagram acts as an inverse of Abs_diagram-
the morphism which maps a well defined wall to its representative in the type- diagram*}

lemma Abs_Rep_well_defined:
        assumes " is_tangle_diagram x"
        shows "Rep_Tangle_Diagram (Abs_Tangle_Diagram x) = x"
            using Rep_Tangle_Diagram Abs_Tangle_Diagram_inverse assms mem_Collect_eq  by auto

text{*The map Abs-diagram is injective*}
lemma Rep_Abs_well_defined:
  assumes "is_tangle_diagram x"
      and "is_tangle_diagram y"
      and  "(Abs_Tangle_Diagram x) = (Abs_Tangle_Diagram y)"
  shows "x = y"
     using Rep_Tangle_Diagram Abs_Tangle_Diagram_inverse assms mem_Collect_eq
     by metis

text{* restating the property of well-defined wall in terms of diagram*}

text{* In order to locally defined moves, it helps to prove that if composition of two wall is a
well defined wall then the number of outgoing strands of the wall below are equal to the number of
incoming strands of the wall above. The following lemmas prove that for a well defined wall, t
he number of incoming and outgoing strands are zero*}

(* All this should become cleaner with pattern matching *)

(*is-tangle-compose*)
lemma is_tangle_left_compose:
 "is_tangle_diagram (x \<circ> y) \<Longrightarrow> is_tangle_diagram x"
proof (induct x)
 case (basic z)
   have "is_tangle_diagram (basic z)" using is_tangle_diagram.simps(1)  by auto
   then show ?case using basic by auto
 next
 case (prod z zs)
   have "(z*zs)\<circ>y = (z*(zs \<circ> y))" by auto
   then have " is_tangle_diagram (z*(zs\<circ>y))" using assms prod by auto
   moreover then have 1: "is_tangle_diagram zs"
        using is_tangle_diagram.simps(2) prod.hyps prod.prems  by metis
  ultimately have "domain_wall (zs \<circ> y) = codomain_block z"
         by (metis is_tangle_diagram.simps(2))
  moreover have "domain_wall (zs \<circ> y) = domain_wall zs"
         using domain_wall_def domain_wall_compose by auto
  ultimately have "domain_wall zs = codomain_block z" by auto
  then have "is_tangle_diagram (z*zs)"
    by (metis "1" is_tangle_diagram.simps(2))
  then show ?case by auto
 qed

lemma is_tangle_right_compose:
 "is_tangle_diagram (x \<circ> y) \<Longrightarrow> is_tangle_diagram y"
proof (induct x)
 case (basic z)
  have "(basic z) \<circ> y = (z*y) " using basic  by auto
  then have "is_tangle_diagram y"
         unfolding is_tangle_diagram.simps(2) using basic.prems by (metis is_tangle_diagram.simps(2))
  then show ?case using basic.prems by auto
 next
 case (prod z zs)
  have "((z*zs) \<circ> y) = (z *(zs \<circ> y))" by auto
  then have " is_tangle_diagram (z*(zs \<circ> y))" using assms prod by auto
  then have "is_tangle_diagram (zs \<circ> y)" using is_tangle_diagram.simps(2) by metis
  then have "is_tangle_diagram y"  using prod.hyps by auto
  then show ?case by auto
 qed

(*
lemma list_sum_compose: assumes "list_sum (domain_codomain_list x) = 0"
       and "list_sum (domain_codomain_list y) = 0"
and "(codomain_wall x)= (domain_wall y)"
shows  "list_sum (domain_codomain_list (x\<circ>y)) = 0"
proof-
 from  domain_codomain_list_sum_compose and assms and abs_def
  have "list_sum (domain_codomain_list (x\<circ>y))
           = (list_sum (domain_codomain_list x))+(list_sum (domain_codomain_list y))"
       by auto
 from this and assms have "list_sum (domain_codomain_list (x\<circ>y)) = 0" by auto
 from this show ?thesis by auto
qed

lemma diagram_domain_codomain_list:
assumes "abs ((domain_wall y) - (codomain_wall x))>0"
shows "(list_sum (domain_codomain_list (x\<circ>y)) > 0)"
proof-
 have "(list_sum (domain_codomain_list x) \<ge>0)" and "(list_sum (domain_codomain_list y)\<ge>  0)"
      using domain_codomain_list_sum_non_negative by auto
 moreover have  "abs ((domain_wall y) - (codomain_wall x))>0"
      using assms by auto
 ultimately have "
  (
  (list_sum (domain_codomain_list x))
        + (abs ( (domain_wall y) - (codomain_wall x)))
        + (list_sum (domain_codomain_list y))
           )
             > 0"
      using  add_le_less_mono add_less_le_mono double_zero_sym by auto
 moreover then have "(list_sum (domain_codomain_list (x \<circ> y)))
             =  ((list_sum (domain_codomain_list x))
                + (abs ( (domain_wall y) - (codomain_wall x)))
               + (list_sum (domain_codomain_list y)))"
       using domain_codomain_list_sum_compose by auto
 ultimately show ?thesis by simp
qed

lemma diagram_wall_count_list_zero:
assumes "(list_sum (domain_codomain_list (x\<circ>y)) = 0)"
shows " abs ( (domain_wall y) - (codomain_wall x))=0"
  using diagram_domain_codomain_list list_sum_non_negative abs_non_negative assms less_le
  by (metis)

lemma diagram_list_sum_zero:
 assumes "well_defined x"
shows "list_sum (domain_codomain_list x) = 0"
proof-
 have 1:"list_sum (domain_codomain_list(Rep_diagram (Abs_diagram x))) = 0"
        using diagram_list_sum by metis
 then have "Rep_diagram (Abs_diagram x) = x"
        using Abs_diagram_inverse assms mem_Collect_eq by (auto)
 then show ?thesis using 1 by metis
qed

lemma diagram_compose:
assumes "well_defined (x\<circ>y)"
shows " (abs ( (domain_wall y) - (codomain_wall x)))=0"
      using diagram_list_sum_zero diagram_wall_count_list_zero assms
      by auto

lemma diagram_fst_equals_snd:
assumes "well_defined (x\<circ>y)"
shows " (domain_wall y) = (codomain_wall x)"
     using diagram_compose abs_zero_equality assms
     by auto

text{*if composition of two wall is a well defined wall then the two wall are well defined tangles
*}
lemma diagram_list_sum_subsequence:
assumes "well_defined (x\<circ>y)"
shows "(list_sum (domain_codomain_list x) = 0)\<and>(list_sum (domain_codomain_list y) = 0)"
proof-
  have "abs (( domain_wall y) - (codomain_wall x)) = 0"
       using diagram_compose assms by auto
  then have "(list_sum (domain_codomain_list x)) + (list_sum (domain_codomain_list y)) = 0"
       using diagram_list_sum_zero domain_codomain_list_sum_compose assms plus_int_code(1)
       by metis
  then have goal1: "(list_sum (domain_codomain_list x)) = 0"
        and goal2:"(list_sum (domain_codomain_list y)) = 0"
      using wall_count_list_list_sum_zero_add by auto
  then  have "(list_sum (domain_codomain_list x) = 0)\<and>(list_sum (domain_codomain_list y) = 0)"
      by auto
  from this show ?thesis by simp
qed
*)
(*tangle diagrams using composition*)
lemma comp_of_tangle_dgms: assumes"is_tangle_diagram y"
shows "((is_tangle_diagram x)\<and>(codomain_wall x = domain_wall y)) \<Longrightarrow> is_tangle_diagram (x \<circ> y)"
proof(induct x)
 case (basic z)
   have "codomain_block z = codomain_wall (basic z)"
      using domain_wall_def by auto
   moreover have "(basic z)\<circ>y= z*y"
      using compose_def by auto
   ultimately have "codomain_block z = domain_wall y"
      using basic.prems by auto
    moreover have "is_tangle_diagram y"
      using assms by auto
    ultimately have "is_tangle_diagram (z*y)"
      unfolding is_tangle_diagram_def by auto
     then show ?case by auto
 next
 case (prod z zs)
   have "is_tangle_diagram (z*zs)"
       using prod.prems by metis
   then have "codomain_block z = domain_wall zs"
      using is_tangle_diagram.simps(2) prod.prems  by metis
   then have "codomain_block z = domain_wall (zs \<circ> y)"
      using domain_wall.simps domain_wall_compose by auto
   moreover have "is_tangle_diagram (zs \<circ> y)"
      using prod.hyps by (metis codomain_wall.simps(2) is_tangle_diagram.simps(2) prod.prems)
   ultimately have "is_tangle_diagram (z*(zs \<circ> y))"
     unfolding is_tangle_diagram_def by auto
   then show ?case by auto
 qed

lemma composition_of_tangle_diagrams:assumes "is_tangle_diagram x" and "is_tangle_diagram y"
     and "(domain_wall y = codomain_wall x)" shows "is_tangle_diagram (x \<circ> y)"
    using comp_of_tangle_dgms using assms by auto

lemma converse_composition_of_tangle_diagrams:
  "is_tangle_diagram (x \<circ> y) \<Longrightarrow> (domain_wall y) = (codomain_wall x)"
 proof(induct x)
 case (basic z)
   have "(basic z) \<circ> y = z * y"
      using compose_def basic by auto
   then have
    "is_tangle_diagram ((basic z) \<circ> y) \<Longrightarrow>
              (is_tangle_diagram y)\<and> (codomain_block z = domain_wall y)"
     using is_tangle_diagram.simps(2)  by (metis)
   then have "(codomain_block z) = (domain_wall y)"
      using basic.prems by auto
   moreover have "codomain_wall (basic z) = codomain_block z"
      using domain_wall_compose by auto
   ultimately have "(codomain_wall (basic z)) = (domain_wall y)"
      by auto
   then show ?case by simp
 next
 case (prod z zs)
    have "codomain_wall zs = domain_wall y"
          using prod.hyps prod.prems
          by (metis compose_Nil compose_leftassociativity is_tangle_right_compose)
    moreover have "codomain_wall zs = codomain_wall (z*zs)"
          using domain_wall_compose by auto
    ultimately show ?case by metis
 qed
(*
lemma assumes "(well_defined_tangle x)"
          and "(well_defined_tangle y)"
          and "(domain_wall y) = (codomain_wall x)"
      shows   "well_defined_tangle (x \<circ> y)"
proof-
 have "(list_sum (domain_codomain_list (x \<circ> y))) =
                     (list_sum (domain_codomain_list x))
                    + ((abs ((domain_wall y) - (codomain_wall x))))
                    + (list_sum (domain_codomain_list y))"
   unfolding  domain_codomain_list_sum_compose by auto
 moreover have "((abs ((domain_wall y) - (codomain_wall x))))  = 0"
          using assms abs_def by auto
 moreover have "list_sum (domain_codomain_list x) = 0"
              using well_defined_tangle_def assms(1) by auto
 moreover have  "list_sum (domain_codomain_list y) = 0"
              using well_defined_tangle_def assms(2) by auto
 ultimately have "(list_sum (domain_codomain_list (x \<circ> y))) = 0" by auto
 then show ?thesis using well_defined_tangle_def by auto
qed
*)
(*defining compose for diagrams*)
definition compose_Tangle::"Tangle_Diagram \<Rightarrow> Tangle_Diagram \<Rightarrow> Tangle_Diagram" (infixl "\<circ>" 65)
 where
"compose_Tangle x y = Abs_Tangle_Diagram ((Rep_Tangle_Diagram x) \<circ> (Rep_Tangle_Diagram y))"

theorem well_defined_compose:
 assumes "is_tangle_diagram x"
     and "is_tangle_diagram y"
     and "domain_wall x = codomain_wall y"
 shows "(Abs_Tangle_Diagram x) \<circ> (Abs_Tangle_Diagram y)
                          = (Abs_Tangle_Diagram (x \<circ> y))"
     using  Abs_Tangle_Diagram_inverse assms(1) assms(2) compose_Tangle_def mem_Collect_eq
     by auto

(*defining domain and co-domain of tangles*)
definition domain_Tangle::"Tangle_Diagram \<Rightarrow> int"
where
"domain_Tangle x = domain_wall(Rep_Tangle_Diagram x)"

definition codomain_Tangle::"Tangle_Diagram \<Rightarrow> int"
where
"codomain_Tangle x = codomain_wall(Rep_Tangle_Diagram x)"

end


(* Author: Dmitry Traytel *)

theory List_More
imports Main "List-Index.List_Index" "HOL-Library.Multiset"
begin

subsection \<open>Library Functions\<close>

abbreviation "bool_product_lists n \<equiv> product_lists (replicate n [True, False])"

lemma in_set_bool_product_lists[simp]:
  "bs \<in> set (bool_product_lists n) \<longleftrightarrow> length bs = n"
proof (induct n arbitrary: bs)
  case (Suc n) thus ?case by (cases bs) auto
qed simp

text \<open>More on sort and remdups\<close>

lemma insort_min[simp]: "\<forall>y \<in> set xs. x < y \<Longrightarrow> insort x xs = x # xs"
  by (induct xs) auto

lemma insort_max[simp]: "\<forall>y \<in> set xs. x > y \<Longrightarrow> insort x xs = xs @ [x]"
  by (induct xs) auto

lemma insort_snoc[simp]: "\<forall>z \<in> set xs. y > z \<Longrightarrow>
  insort x (xs @ [y]) = (if x < y then insort x xs @ [y] else xs @ [y, x])"
  by (induct xs) auto

declare set_insort_key[simp]

lemma insort_remdups[simp]: "\<lbrakk>sorted xs; a \<notin> set xs\<rbrakk> \<Longrightarrow> insort a (remdups xs) = remdups (insort a xs)"
proof (induct xs)
  case (Cons x xs) thus ?case by (cases xs) (auto)
qed simp

lemma remdups_insort[simp]: "a \<in> set xs \<Longrightarrow> remdups (insort a xs) = remdups xs"
  by (induct xs) auto

lemma sort_remdups[simp]: "sort (remdups xs) = remdups (sort xs)"
  by (induct xs) auto

lemma sort_map_insort[simp]: "sorted xs \<Longrightarrow> sort (map f (insort a xs)) = insort (f a) (sort (map f xs))"
  by (induct xs) (auto simp: insort_left_comm)

lemma sort_map_sort[simp]: "sort (map f (sort xs)) = sort (map f xs)"
  by (induct xs) auto

lemma remdups_append: "remdups (xs @ ys) = remdups (filter (\<lambda>x. x \<notin> set ys) xs) @ remdups ys"
  by (induct xs) auto

lemma remdups_concat_map_remdups:
  "remdups (concat (map f (remdups xs))) = remdups (concat (map f xs))"
  by (induct xs) (auto simp: remdups_append filter_empty_conv)

(*remdups'*)

primrec remdups' where
  "remdups' f [] = []"
| "remdups' f (x # xs) =
    (case List.find (\<lambda>y. f x = f y) xs of None \<Rightarrow> x # remdups' f xs | _ \<Rightarrow> remdups' f xs)"

lemma map_remdups'[simp]: "map f (remdups' f xs) = remdups (map f xs)"
  by (induct xs) (auto split: option.splits simp add: find_Some_iff find_None_iff)

lemma remdups'_map[simp]: "remdups' f (map g xs) = map g (remdups' (f o g) xs)"
  by (induct xs) (auto split: option.splits simp add: find_None_iff,
                auto simp: find_Some_iff elim: imageI[OF nth_mem])

lemma map_apfst_remdups':
  "map (f o fst) (remdups' snd xs) = map fst (remdups' snd (map (apfst f) xs))"
  by (auto simp: comp_def)

lemma set_remdups'[simp]: "f ` set (remdups' f xs) = f ` set xs"
  by (induct xs) (auto split: option.splits simp add: find_Some_iff)

lemma subset_remdups': "set (remdups' f xs) \<subseteq> set xs"
  by (induct xs) (auto split: option.splits)

lemma find_append[simp]:
  "List.find P (xs @ ys) = None = (List.find P xs = None \<and> List.find P ys = None)"
  by (induct xs) auto

lemma subset_remdups'_append: "set (remdups' f (xs @ ys)) \<subseteq> set (remdups' f xs) \<union> set (remdups' f ys)"
  by (induct xs arbitrary: ys) (auto split: option.splits)

lemmas mp_remdups' = subsetD[OF subset_remdups']
lemmas mp_remdups'_append = subsetD[OF subset_remdups'_append]

lemma inj_on_set_remdups'[simp]: "inj_on f (set (remdups' f xs))"
  by (induct xs) (auto split: option.splits simp add: find_None_iff dest!: mp_remdups')

lemma distinct_remdups'[simp]: "distinct (map f (remdups' f xs))"
  by (induct xs) (auto split: option.splits simp: find_None_iff)

lemma distinct_remdups'_strong: "(\<forall>x\<in>set xs. \<forall>y\<in>set xs. g x = g y \<longrightarrow> f x = f y) \<Longrightarrow>
  distinct (map g (remdups' f xs))"
proof (induct xs)
  case (Cons x xs) thus ?case
    by (auto split: option.splits) (fastforce simp: find_None_iff dest!: mp_remdups')
qed simp

lemma set_remdups'_strong:
  "f ` set (remdups' g xs) = f ` set xs" if "\<forall>x\<in>set xs. \<forall>y\<in>set xs. g x = g y \<longrightarrow> f x = f y"
using that proof (induction xs)
  case Nil
  then show ?case
    by simp
next
  case (Cons x xs)
  then have "\<forall>x\<in>set xs. \<forall>y\<in>set xs. g x = g y \<longrightarrow> f x = f y"
    by (auto simp only: set_simps)
  then have "f ` set (remdups' g xs) = f ` set xs"
    by (rule Cons.IH)
  then show ?case
    by (auto simp add: find_Some_iff split: option.splits)
      (metis Cons.prems image_eqI list.set_intros(1) list.set_intros(2) nth_mem)
qed

(*multisets only needed below*)
lemma multiset_concat_gen: "M + mset (concat xs) = fold (\<lambda>x M. M + mset x) xs M"
  by (induct xs arbitrary: M) (auto, metis union_assoc)

corollary multiset_concat: "mset (concat xs) = fold (\<lambda>x M. M + mset x) xs {#}"
  using multiset_concat_gen[of "{#}" xs] by simp

lemma fold_mset_insort[simp]: "fold (\<lambda>x M. M + mset (f x)) (insort x xs) M =
  fold (\<lambda>x M. M + mset (f x)) xs (mset (f x) + M)"
  by (induct xs arbitrary: M) (auto simp: ac_simps)

lemma fold_mset_sort[simp]:
  "fold (\<lambda>x M. M + mset (f x)) (sort xs) M = fold (\<lambda>x M. M + mset (f x)) xs M"
  by (induct xs arbitrary: M) (auto simp: ac_simps)

lemma multiset_concat_map_sort[simp]:
  "mset (concat (map f (sort xs))) = mset (concat (map f xs))"
  by (auto simp: multiset_concat fold_map o_def)

lemma sort_concat_map_sort[simp]: "sort (concat (map f (sort xs))) = sort (concat (map f xs))"
  by (auto intro: properties_for_sort)

end


theory T58
imports Main
begin
lemma "(
(\<forall> x::nat. \<forall> y::nat. meet(x, y) = meet(y, x)) &
(\<forall> x::nat. \<forall> y::nat. join(x, y) = join(y, x)) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. meet(x, meet(y, z)) = meet(meet(x, y), z)) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. join(x, join(y, z)) = join(join(x, y), z)) &
(\<forall> x::nat. \<forall> y::nat. meet(x, join(x, y)) = x) &
(\<forall> x::nat. \<forall> y::nat. join(x, meet(x, y)) = x) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. mult(x, join(y, z)) = join(mult(x, y), mult(x, z))) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. mult(join(x, y), z) = join(mult(x, z), mult(y, z))) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. meet(x, over(join(mult(x, y), z), y)) = x) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. meet(y, undr(x, join(mult(x, y), z))) = y) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. join(mult(over(x, y), y), x) = x) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. join(mult(y, undr(y, x)), x) = x) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. mult(x, meet(y, z)) = meet(mult(x, y), mult(x, z))) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. undr(x, join(y, z)) = join(undr(x, y), undr(x, z))) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. over(x, meet(y, z)) = join(over(x, y), over(x, z))) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. undr(meet(x, y), z) = join(undr(x, z), undr(y, z))) &
(\<forall> x::nat. \<forall> y::nat. invo(join(x, y)) = meet(invo(x), invo(y))) &
(\<forall> x::nat. \<forall> y::nat. invo(meet(x, y)) = join(invo(x), invo(y))) &
(\<forall> x::nat. invo(invo(x)) = x)
) \<longrightarrow>
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. mult(meet(x, y), z) = meet(mult(x, z), mult(y, z)))
"
nitpick[card nat=4,timeout=86400]
oops
end


theory FreeLogic imports Main

begin
 consts fExistence:: "'a\<Rightarrow>bool" ("E") (*Existence/definedness predicate in free logic*)

 abbreviation fForall ("\<^bold>\<forall>") (*Free universal quantification*)
   where "\<^bold>\<forall>\<Phi> \<equiv> \<forall>x. E x \<longrightarrow> \<Phi> x"
 abbreviation fForallBinder (binder "\<^bold>\<forall>" [8] 9) (*Binder notation*)
   where "\<^bold>\<forall>x. \<phi> x \<equiv> \<^bold>\<forall>\<phi>"

 abbreviation fExists ("\<^bold>\<exists>")
   where "\<^bold>\<exists>\<Phi> \<equiv> \<not>(\<^bold>\<forall>(\<lambda>y. \<not>(\<Phi> y)))"
 abbreviation fExistsBinder (binder "\<^bold>\<exists>" [8]9)
   where "\<^bold>\<exists>x. \<phi> x \<equiv> \<^bold>\<exists>\<phi>"
 abbreviation fExistsUnique ("\<^bold>\<exists>!")
  where "\<^bold>\<exists>!\<phi> \<equiv> \<^bold>\<exists>x. (\<phi> x \<and> (\<^bold>\<forall>y. \<phi> y \<longrightarrow> y = x))"
 abbreviation fExistsUniqueBinder (binder "\<^bold>\<exists>!" [8]9)
  where "\<^bold>\<exists>!x. \<phi> x \<equiv> \<^bold>\<exists>!\<phi>"

abbreviation KlEq (infixr "\<cong>" 56) (* Kleene equality *)
   where "x \<cong> y \<equiv> (E x \<or> E y) \<longrightarrow> x = y"
abbreviation ExId (infixr "\<simeq>" 56) (* Existing identity *)
   where "x \<simeq> y \<equiv> E x \<and> E y \<and> x = y"

lemma fallI [intro]: "\<^bold>\<forall>x. \<phi> x" if "\<And>x. E x \<longrightarrow> \<phi> x" using that by simp
lemma fexI [intro]: "E x \<and> \<phi> x \<Longrightarrow> \<^bold>\<exists>x::'a. \<phi> x" by auto
lemma fexE [elim]: "(\<And>x. (E x \<and> \<phi> x) \<Longrightarrow> C) \<Longrightarrow> C" if "\<^bold>\<exists>x. \<phi> x" using that by auto

lemma fall3I: "(\<And>x y z. E x \<and> E y \<and> E z \<Longrightarrow> \<phi> x y z) \<Longrightarrow> (\<^bold>\<forall>x y z. \<phi> x y z)" for \<phi>::"'a \<Rightarrow> 'a \<Rightarrow> 'a \<Rightarrow> bool"
  by simp

lemma equE: assumes "A \<Longrightarrow> B" and "B \<Longrightarrow> A" shows "A \<longleftrightarrow> B"
  using assms(1) assms(2) by blast
lemma contraposition: assumes "\<not>B \<longrightarrow> \<not>A" shows "A \<longrightarrow> B"
  using assms by blast

end


(* This Isabelle theory is produced using the TIP tool offered at the following website:
     https://github.com/tip-org/tools
   This file was originally provided as part of TIP benchmark at the following website:
     https://github.com/tip-org/benchmarks
   Yutaka Nagashima at CIIRC, CTU changed the TIP output theory file slightly
   to make it compatible with Isabelle2017.
\:w
   Some proofs were added by Yutaka Nagashima.*)
  theory TIP_tree_Flatten2
imports "../../Test_Base"
begin

datatype 'a list = nil2 | cons2 "'a" "'a list"

datatype 'a Tree = Node "'a Tree" "'a" "'a Tree" | Nil

fun x :: "'a list => 'a list => 'a list" where
"x (nil2) z = z"
| "x (cons2 z2 xs) z = cons2 z2 (x xs z)"

fun flatten2 :: "'a Tree => 'a list => 'a list" where
"flatten2 (Node p z2 q) z = flatten2 p (cons2 z2 (flatten2 q z))"
| "flatten2 (Nil) z = z"

fun flatten0 :: "'a Tree => 'a list" where
"flatten0 (Node p z q) =
   x (flatten0 p) (x (cons2 z (nil2)) (flatten0 q))"
| "flatten0 (Nil) = nil2"

theorem property0 :
  "((flatten2 p (nil2)) = (flatten0 p))"
  oops

end


theory ex_3_4
  imports Main ex_3_3
begin
inductive iter::"('a \<Rightarrow> 'a \<Rightarrow> bool) \<Rightarrow> nat \<Rightarrow> 'a \<Rightarrow> 'a \<Rightarrow> bool" for r where
refl: "iter r 0 x x" |
step: "\<lbrakk>r x y; iter r n y z\<rbrakk> \<Longrightarrow> iter r (Suc n) x z"

theorem star_iter:"star r x y \<Longrightarrow> (\<exists>n. iter r n x y)"
  apply (induction rule: star.induct)
   apply (metis refl)
  by (auto dest:star.step step)
end


section \<open> Function Toolkit \<close>

theory Function_Toolkit
  imports Relation_Toolkit
begin

subsection \<open> Partial Functions \<close>

lemma partial_functions: "X \<rightarrow>\<^sub>p Y = {f \<in> X \<leftrightarrow> Y. \<forall> p \<in> f. \<forall> q \<in> f. p.1 = q.1 \<longrightarrow> p.2 = q.2}"
  by (auto simp add: rel_pfun_def single_valued_def)

notation size ("#_" [999] 999)

instantiation set :: (type) size
begin
definition [simp]: "size A = card A"
instance ..
end

instantiation pfun :: (type, type) size
begin

definition size_pfun :: "('a \<Zpfun> 'b) \<Rightarrow> nat" where
"size_pfun f = card (pfun_graph f)"

instance ..

end

lemma size_finite_pfun: "finite (pdom f) \<Longrightarrow> #f = #(dom f)"
  by (simp add: card_pfun_graph size_pfun_def)

lemma card_pfun_empty [simp]: "#{}\<^sub>p = 0"
  by (simp add: size_pfun_def pfun_graph_zero)

lemma card_pfun_update [simp]: "finite (dom f) \<Longrightarrow> #(f(k \<mapsto> v)\<^sub>p) = (if (k \<in> dom f) then #f else #f + 1)"
  by (auto simp add: size_pfun_def pfun_graph_update Dom_pfun_graph rel_domres_compl_disj)
     (metis card_pfun_graph insert_absorb pdom_upd pfun_graph_update)

subsection \<open> Total Functions \<close>

text \<open> One issue that emerges in this encoding is the treatment of total functions. In Z, a total
  function is a particular kind of partial function whose domain covers the type universe. In HOL,
  a total function is one of the basic types. Typically, one wishes to apply total functions,
  partial functions, and finite functions to values using the notation @{term "f x"}. In order
  to implement this, we need to coerce the given function @{term f} to a total function, since
  this is fundamental to HOL's application construct. However, that means that we can't also
  coerce a total function to a partial function, as expected by Z, since this would lead to
  a cycle. Consequently, we actually need to create a new ``total function'' type, different
  to the HOL one, to break the cycle. We therefore consider the HOL total function type
  to be meta-logical with respect to Z.  \<close>

declare [[coercion pfun_of_tfun]]

subsection \<open> Disjointness \<close>

consts
  disjoint :: "'f \<Rightarrow> bool"

adhoc_overloading
  disjoint rel_disjoint and
  disjoint pfun_disjoint and
  disjoint list_disjoint

subsection \<open> Partitions \<close>

consts partitions :: "'f \<Rightarrow> 'a set \<Rightarrow> bool" (infix "partitions" 65)

adhoc_overloading
  partitions rel_partitions and
  partitions pfun_partitions and
  partitions list_partitions

end


(*  Title:       POSIX Lexing with Derivatives of Regular Expressions
    Authors:     Fahad Ausaf <fahad.ausaf at icloud.com>, 2016
                 Roy Dyckhoff <roy.dyckhoff at st-andrews.ac.uk>, 2016
                 Christian Urban <christian.urban at kcl.ac.uk>, 2016
    Maintainer:  Christian Urban <christian.urban at kcl.ac.uk>
*)

theory Lexer
  imports "Regular-Sets.Derivatives"
begin

section \<open>Values\<close>

datatype 'a val =
  Void
| Atm 'a
| Seq "'a val" "'a val"
| Right "'a val"
| Left "'a val"
| Stars "('a val) list"

section \<open>The string behind a value\<close>

fun
  flat :: "'a val \<Rightarrow> 'a list"
where
  "flat (Void) = []"
| "flat (Atm c) = [c]"
| "flat (Left v) = flat v"
| "flat (Right v) = flat v"
| "flat (Seq v1 v2) = (flat v1) @ (flat v2)"
| "flat (Stars []) = []"
| "flat (Stars (v#vs)) = (flat v) @ (flat (Stars vs))"

abbreviation
  "flats vs \<equiv> concat (map flat vs)"

lemma flat_Stars [simp]:
 "flat (Stars vs) = concat (map flat vs)"
by (induct vs) (auto)

section \<open>Relation between values and regular expressions\<close>

inductive
  Prf :: "'a val \<Rightarrow> 'a rexp \<Rightarrow> bool" ("\<turnstile> _ : _" [100, 100] 100)
where
 "\<lbrakk>\<turnstile> v1 : r1; \<turnstile> v2 : r2\<rbrakk> \<Longrightarrow> \<turnstile> Seq v1 v2 : Times r1 r2"
| "\<turnstile> v1 : r1 \<Longrightarrow> \<turnstile> Left v1 : Plus r1 r2"
| "\<turnstile> v2 : r2 \<Longrightarrow> \<turnstile> Right v2 : Plus r1 r2"
| "\<turnstile> Void : One"
| "\<turnstile> Atm c : Atom c"
| "\<lbrakk>\<forall>v \<in> set vs. \<turnstile> v : r \<and> flat v \<noteq> []\<rbrakk> \<Longrightarrow> \<turnstile> Stars vs : Star r"

inductive_cases Prf_elims:
  "\<turnstile> v : Zero"
  "\<turnstile> v : Times r1 r2"
  "\<turnstile> v : Plus r1 r2"
  "\<turnstile> v : One"
  "\<turnstile> v : Atom c"
  "\<turnstile> vs : Star r"

lemma Prf_flat_lang:
  assumes "\<turnstile> v : r" shows "flat v \<in> lang r"
using assms
  by (induct v r rule: Prf.induct)
     (auto simp add: concat_in_star subset_eq)

lemma Star_string:
  assumes "s \<in> star A"
  shows "\<exists>ss. concat ss = s \<and> (\<forall>s \<in> set ss. s \<in> A)"
using assms
by (metis in_star_iff_concat subsetD)

lemma Star_val:
  assumes "\<forall>s\<in>set ss. \<exists>v. s = flat v \<and> \<turnstile> v : r"
  shows "\<exists>vs. flats vs = concat ss \<and> (\<forall>v\<in>set vs. \<turnstile> v : r \<and> flat v \<noteq> [])"
using assms
apply(induct ss)
apply(auto)
apply (metis empty_iff list.set(1))
by (metis append.simps(1) flat.simps(7) flat_Stars set_ConsD)

lemma L_flat_Prf1:
  assumes "\<turnstile> v : r" shows "flat v \<in> lang r"
using assms
  apply (induct)
  apply(auto)
  by (metis Prf.intros(6) Prf_flat_lang flat_Stars lang.simps(6))

lemma L_flat_Prf2:
  assumes "s \<in> lang r" shows "\<exists>v. \<turnstile> v : r \<and> flat v = s"
using assms
apply(induct r arbitrary: s)
apply(auto intro: Prf.intros)
using Prf.intros(2) flat.simps(3) apply blast
using Prf.intros(3) flat.simps(4) apply blast
apply (metis Prf.intros(1) concE flat.simps(5))
apply(subgoal_tac "\<exists>vs::('a val) list. concat (map flat vs) = s \<and> (\<forall>v \<in> set vs. \<turnstile> v : r \<and> flat v \<noteq> [])")
apply(auto)[1]
apply(rule_tac x="Stars vs" in exI)
apply(simp)
apply(drule Star_string)
apply(auto)
using Prf.intros(6) apply blast
by (smt (verit) Star_val in_star_iff_concat subset_iff)

lemma L_flat_Prf:
  "lang r = {flat v | v. \<turnstile> v : r}"
using L_flat_Prf1 L_flat_Prf2 by blast

section \<open>Sulzmann and Lu functions\<close>

fun
  mkeps :: "'a rexp \<Rightarrow> 'a val"
where
  "mkeps(One) = Void"
| "mkeps(Times r1 r2) = Seq (mkeps r1) (mkeps r2)"
| "mkeps(Plus r1 r2) = (if nullable(r1) then Left (mkeps r1) else Right (mkeps r2))"
| "mkeps(Star r) = Stars []"

fun injval :: "'a rexp \<Rightarrow> 'a \<Rightarrow> 'a val \<Rightarrow> 'a val"
where
  "injval (Atom d) c Void = Atm c"
| "injval (Plus r1 r2) c (Left v1) = Left(injval r1 c v1)"
| "injval (Plus r1 r2) c (Right v2) = Right(injval r2 c v2)"
| "injval (Times r1 r2) c (Seq v1 v2) = Seq (injval r1 c v1) v2"
| "injval (Times r1 r2) c (Left (Seq v1 v2)) = Seq (injval r1 c v1) v2"
| "injval (Times r1 r2) c (Right v2) = Seq (mkeps r1) (injval r2 c v2)"
| "injval (Star r) c (Seq v (Stars vs)) = Stars ((injval r c v) # vs)"

section \<open>Mkeps, injval\<close>

lemma mkeps_nullable:
  assumes "nullable r"
  shows "\<turnstile> mkeps r : r"
using assms
by (induct r)
   (auto intro: Prf.intros)

lemma mkeps_flat:
  assumes "nullable r"
  shows "flat (mkeps r) = []"
using assms
by (induct r) (auto)

lemma Prf_injval_flat:
  assumes "\<turnstile> v : deriv c r"
  shows "flat (injval r c v) = c # (flat v)"
using assms
apply(induct c r arbitrary: v rule: deriv.induct)
apply(auto elim!: Prf_elims intro: mkeps_flat split: if_splits)
done

lemma Prf_injval:
  assumes "\<turnstile> v : deriv c r"
  shows "\<turnstile> (injval r c v) : r"
using assms
apply(induct r arbitrary: c v rule: rexp.induct)
apply(auto intro!: Prf.intros mkeps_nullable elim!: Prf_elims split: if_splits)
(* Star *)
by (simp add: Prf_injval_flat)

section \<open>Our Alternative Posix definition\<close>

inductive
  Posix :: "'a list \<Rightarrow> 'a rexp \<Rightarrow> 'a val \<Rightarrow> bool" ("_ \<in> _ \<rightarrow> _" [100, 100, 100] 100)
where
  Posix_One: "[] \<in> One \<rightarrow> Void"
| Posix_Atom: "[c] \<in> (Atom c) \<rightarrow> (Atm c)"
| Posix_Plus1: "s \<in> r1 \<rightarrow> v \<Longrightarrow> s \<in> (Plus r1 r2) \<rightarrow> (Left v)"
| Posix_Plus2: "\<lbrakk>s \<in> r2 \<rightarrow> v; s \<notin> lang r1\<rbrakk> \<Longrightarrow> s \<in> (Plus r1 r2) \<rightarrow> (Right v)"
| Posix_Times: "\<lbrakk>s1 \<in> r1 \<rightarrow> v1; s2 \<in> r2 \<rightarrow> v2;
    \<not>(\<exists>s\<^sub>3 s\<^sub>4. s\<^sub>3 \<noteq> [] \<and> s\<^sub>3 @ s\<^sub>4 = s2 \<and> (s1 @ s\<^sub>3) \<in> lang r1 \<and> s\<^sub>4 \<in> lang r2)\<rbrakk> \<Longrightarrow>
    (s1 @ s2) \<in> (Times r1 r2) \<rightarrow> (Seq v1 v2)"
| Posix_Star1: "\<lbrakk>s1 \<in> r \<rightarrow> v; s2 \<in> Star r \<rightarrow> Stars vs; flat v \<noteq> [];
    \<not>(\<exists>s\<^sub>3 s\<^sub>4. s\<^sub>3 \<noteq> [] \<and> s\<^sub>3 @ s\<^sub>4 = s2 \<and> (s1 @ s\<^sub>3) \<in> lang r \<and> s\<^sub>4 \<in> lang (Star r))\<rbrakk>
    \<Longrightarrow> (s1 @ s2) \<in> Star r \<rightarrow> Stars (v # vs)"
| Posix_Star2: "[] \<in> Star r \<rightarrow> Stars []"

inductive_cases Posix_elims:
  "s \<in> Zero \<rightarrow> v"
  "s \<in> One \<rightarrow> v"
  "s \<in> Atom c \<rightarrow> v"
  "s \<in> Plus r1 r2 \<rightarrow> v"
  "s \<in> Times r1 r2 \<rightarrow> v"
  "s \<in> Star r \<rightarrow> v"

lemma Posix1:
  assumes "s \<in> r \<rightarrow> v"
  shows "s \<in> lang r" "flat v = s"
using assms
by (induct s r v rule: Posix.induct) (auto)

lemma Posix1a:
  assumes "s \<in> r \<rightarrow> v"
  shows "\<turnstile> v : r"
using assms
  apply(induct s r v rule: Posix.induct)
  apply(auto intro: Prf.intros)
  by (metis Prf.intros(6) Prf_elims(6) set_ConsD val.inject(5))

lemma Posix_mkeps:
  assumes "nullable r"
  shows "[] \<in> r \<rightarrow> mkeps r"
using assms
apply(induct r)
apply(auto intro: Posix.intros simp add: nullable_iff)
apply(subst append.simps(1)[symmetric])
apply(rule Posix.intros)
apply(auto)
done

lemma Posix_determ:
  assumes "s \<in> r \<rightarrow> v1" "s \<in> r \<rightarrow> v2"
  shows "v1 = v2"
using assms
proof (induct s r v1 arbitrary: v2 rule: Posix.induct)
  case (Posix_One v2)
  have "[] \<in> One \<rightarrow> v2" by fact
  then show "Void = v2" by cases auto
next
  case (Posix_Atom c v2)
  have "[c] \<in> Atom c \<rightarrow> v2" by fact
  then show "Atm c = v2" by cases auto
next
  case (Posix_Plus1 s r1 v r2 v2)
  have "s \<in> Plus r1 r2 \<rightarrow> v2" by fact
  moreover
  have "s \<in> r1 \<rightarrow> v" by fact
  then have "s \<in> lang r1" by (simp add: Posix1)
  ultimately obtain v' where eq: "v2 = Left v'" "s \<in> r1 \<rightarrow> v'" by cases auto
  moreover
  have IH: "\<And>v2. s \<in> r1 \<rightarrow> v2 \<Longrightarrow> v = v2" by fact
  ultimately have "v = v'" by simp
  then show "Left v = v2" using eq by simp
next
  case (Posix_Plus2 s r2 v r1 v2)
  have "s \<in> Plus r1 r2 \<rightarrow> v2" by fact
  moreover
  have "s \<notin> lang r1" by fact
  ultimately obtain v' where eq: "v2 = Right v'" "s \<in> r2 \<rightarrow> v'"
    by cases (auto simp add: Posix1)
  moreover
  have IH: "\<And>v2. s \<in> r2 \<rightarrow> v2 \<Longrightarrow> v = v2" by fact
  ultimately have "v = v'" by simp
  then show "Right v = v2" using eq by simp
next
  case (Posix_Times s1 r1 v1 s2 r2 v2 v')
  have "(s1 @ s2) \<in> Times r1 r2 \<rightarrow> v'"
       "s1 \<in> r1 \<rightarrow> v1" "s2 \<in> r2 \<rightarrow> v2"
       "\<not> (\<exists>s\<^sub>3 s\<^sub>4. s\<^sub>3 \<noteq> [] \<and> s\<^sub>3 @ s\<^sub>4 = s2 \<and> s1 @ s\<^sub>3 \<in> lang r1 \<and> s\<^sub>4 \<in> lang r2)" by fact+
  then obtain v1' v2' where "v' = Seq v1' v2'" "s1 \<in> r1 \<rightarrow> v1'" "s2 \<in> r2 \<rightarrow> v2'"
  apply(cases) apply (auto simp add: append_eq_append_conv2)
  using Posix1(1) by fastforce+
  moreover
  have IHs: "\<And>v1'. s1 \<in> r1 \<rightarrow> v1' \<Longrightarrow> v1 = v1'"
            "\<And>v2'. s2 \<in> r2 \<rightarrow> v2' \<Longrightarrow> v2 = v2'" by fact+
  ultimately show "Seq v1 v2 = v'" by simp
next
  case (Posix_Star1 s1 r v s2 vs v2)
  have "(s1 @ s2) \<in> Star r \<rightarrow> v2"
       "s1 \<in> r \<rightarrow> v" "s2 \<in> Star r \<rightarrow> Stars vs" "flat v \<noteq> []"
       "\<not> (\<exists>s\<^sub>3 s\<^sub>4. s\<^sub>3 \<noteq> [] \<and> s\<^sub>3 @ s\<^sub>4 = s2 \<and> s1 @ s\<^sub>3 \<in> lang r \<and> s\<^sub>4 \<in> lang (Star r))" by fact+
  then obtain v' vs' where "v2 = Stars (v' # vs')" "s1 \<in> r \<rightarrow> v'" "s2 \<in> (Star r) \<rightarrow> (Stars vs')"
  apply(cases) apply (auto simp add: append_eq_append_conv2)
  using Posix1(1) apply fastforce
  apply (metis Posix1(1) Posix_Star1.hyps(6) append_Nil append_Nil2)
  using Posix1(2) by blast
  moreover
  have IHs: "\<And>v2. s1 \<in> r \<rightarrow> v2 \<Longrightarrow> v = v2"
            "\<And>v2. s2 \<in> Star r \<rightarrow> v2 \<Longrightarrow> Stars vs = v2" by fact+
  ultimately show "Stars (v # vs) = v2" by auto
next
  case (Posix_Star2 r v2)
  have "[] \<in> Star r \<rightarrow> v2" by fact
  then show "Stars [] = v2" by cases (auto simp add: Posix1)
qed

lemma Posix_injval:
  assumes "s \<in> (deriv c r) \<rightarrow> v"
  shows "(c # s) \<in> r \<rightarrow> (injval r c v)"
using assms
proof(induct r arbitrary: s v rule: rexp.induct)
  case Zero
  have "s \<in> deriv c Zero \<rightarrow> v" by fact
  then have "s \<in> Zero \<rightarrow> v" by simp
  then have "False" by cases
  then show "(c # s) \<in> Zero \<rightarrow> (injval Zero c v)" by simp
next
  case One
  have "s \<in> deriv c One \<rightarrow> v" by fact
  then have "s \<in> Zero \<rightarrow> v" by simp
  then have "False" by cases
  then show "(c # s) \<in> One \<rightarrow> (injval One c v)" by simp
next
  case (Atom d)
  consider (eq) "c = d" | (ineq) "c \<noteq> d" by blast
  then show "(c # s) \<in> (Atom d) \<rightarrow> (injval (Atom d) c v)"
  proof (cases)
    case eq
    have "s \<in> deriv c (Atom d) \<rightarrow> v" by fact
    then have "s \<in> One \<rightarrow> v" using eq by simp
    then have eqs: "s = [] \<and> v = Void" by cases simp
    show "(c # s) \<in> Atom d \<rightarrow> injval (Atom d) c v" using eq eqs
    by (auto intro: Posix.intros)
  next
    case ineq
    have "s \<in> deriv c (Atom d) \<rightarrow> v" by fact
    then have "s \<in> Zero \<rightarrow> v" using ineq by simp
    then have "False" by cases
    then show "(c # s) \<in> Atom d \<rightarrow> injval (Atom d) c v" by simp
  qed
next
  case (Plus r1 r2)
  have IH1: "\<And>s v. s \<in> deriv c r1 \<rightarrow> v \<Longrightarrow> (c # s) \<in> r1 \<rightarrow> injval r1 c v" by fact
  have IH2: "\<And>s v. s \<in> deriv c r2 \<rightarrow> v \<Longrightarrow> (c # s) \<in> r2 \<rightarrow> injval r2 c v" by fact
  have "s \<in> deriv c (Plus r1 r2) \<rightarrow> v" by fact
  then have "s \<in> Plus (deriv c r1) (deriv c r2) \<rightarrow> v" by simp
  then consider (left) v' where "v = Left v'" "s \<in> deriv c r1 \<rightarrow> v'"
              | (right) v' where "v = Right v'" "s \<notin> lang (deriv c r1)" "s \<in> deriv c r2 \<rightarrow> v'"
              by cases auto
  then show "(c # s) \<in> Plus r1 r2 \<rightarrow> injval (Plus r1 r2) c v"
  proof (cases)
    case left
    have "s \<in> deriv c r1 \<rightarrow> v'" by fact
    then have "(c # s) \<in> r1 \<rightarrow> injval r1 c v'" using IH1 by simp
    then have "(c # s) \<in> Plus r1 r2 \<rightarrow> injval (Plus r1 r2) c (Left v')" by (auto intro: Posix.intros)
    then show "(c # s) \<in> Plus r1 r2 \<rightarrow> injval (Plus r1 r2) c v" using left by simp
  next
    case right
    have "s \<notin> lang (deriv c r1)" by fact
    then have "c # s \<notin> lang r1" by (simp add: lang_deriv Deriv_def)
    moreover
    have "s \<in> deriv c r2 \<rightarrow> v'" by fact
    then have "(c # s) \<in> r2 \<rightarrow> injval r2 c v'" using IH2 by simp
    ultimately have "(c # s) \<in> Plus r1 r2 \<rightarrow> injval (Plus r1 r2) c (Right v')"
      by (auto intro: Posix.intros)
    then show "(c # s) \<in> Plus r1 r2 \<rightarrow> injval (Plus r1 r2) c v" using right by simp
  qed
next
  case (Times r1 r2)
  have IH1: "\<And>s v. s \<in> deriv c r1 \<rightarrow> v \<Longrightarrow> (c # s) \<in> r1 \<rightarrow> injval r1 c v" by fact
  have IH2: "\<And>s v. s \<in> deriv c r2 \<rightarrow> v \<Longrightarrow> (c # s) \<in> r2 \<rightarrow> injval r2 c v" by fact
  have "s \<in> deriv c (Times r1 r2) \<rightarrow> v" by fact
  then consider
        (left_nullable) v1 v2 s1 s2 where
        "v = Left (Seq v1 v2)"  "s = s1 @ s2"
        "s1 \<in> deriv c r1 \<rightarrow> v1" "s2 \<in> r2 \<rightarrow> v2" "nullable r1"
        "\<not> (\<exists>s\<^sub>3 s\<^sub>4. s\<^sub>3 \<noteq> [] \<and> s\<^sub>3 @ s\<^sub>4 = s2 \<and> s1 @ s\<^sub>3 \<in> lang (deriv c r1) \<and> s\<^sub>4 \<in> lang r2)"
      | (right_nullable) v1 s1 s2 where
        "v = Right v1" "s = s1 @ s2"
        "s \<in> deriv c r2 \<rightarrow> v1" "nullable r1" "s1 @ s2 \<notin> lang (Times (deriv c r1) r2)"
      | (not_nullable) v1 v2 s1 s2 where
        "v = Seq v1 v2" "s = s1 @ s2"
        "s1 \<in> deriv c r1 \<rightarrow> v1" "s2 \<in> r2 \<rightarrow> v2" "\<not>nullable r1"
        "\<not> (\<exists>s\<^sub>3 s\<^sub>4. s\<^sub>3 \<noteq> [] \<and> s\<^sub>3 @ s\<^sub>4 = s2 \<and> s1 @ s\<^sub>3 \<in> lang (deriv c r1) \<and> s\<^sub>4 \<in> lang r2)"
        by (force split: if_splits elim!: Posix_elims simp add: lang_deriv Deriv_def)
  then show "(c # s) \<in> Times r1 r2 \<rightarrow> injval (Times r1 r2) c v"
    proof (cases)
      case left_nullable
      have "s1 \<in> deriv c r1 \<rightarrow> v1" by fact
      then have "(c # s1) \<in> r1 \<rightarrow> injval r1 c v1" using IH1 by simp
      moreover
      have "\<not> (\<exists>s\<^sub>3 s\<^sub>4. s\<^sub>3 \<noteq> [] \<and> s\<^sub>3 @ s\<^sub>4 = s2 \<and> s1 @ s\<^sub>3 \<in> lang (deriv c r1) \<and> s\<^sub>4 \<in> lang r2)" by fact
      then have "\<not> (\<exists>s\<^sub>3 s\<^sub>4. s\<^sub>3 \<noteq> [] \<and> s\<^sub>3 @ s\<^sub>4 = s2 \<and> (c # s1) @ s\<^sub>3 \<in> lang r1 \<and> s\<^sub>4 \<in> lang r2)"
         by (simp add: lang_deriv Deriv_def)
      ultimately have "((c # s1) @ s2) \<in> Times r1 r2 \<rightarrow> Seq (injval r1 c v1) v2" using left_nullable by (rule_tac Posix.intros)
      then show "(c # s) \<in> Times r1 r2 \<rightarrow> injval (Times r1 r2) c v" using left_nullable by simp
    next
      case right_nullable
      have "nullable r1" by fact
      then have "[] \<in> r1 \<rightarrow> (mkeps r1)" by (rule Posix_mkeps)
      moreover
      have "s \<in> deriv c r2 \<rightarrow> v1" by fact
      then have "(c # s) \<in> r2 \<rightarrow> (injval r2 c v1)" using IH2 by simp
      moreover
      have "s1 @ s2 \<notin> lang (Times (deriv c r1) r2)" by fact
      then have "\<not> (\<exists>s\<^sub>3 s\<^sub>4. s\<^sub>3 \<noteq> [] \<and> s\<^sub>3 @ s\<^sub>4 = c # s \<and> [] @ s\<^sub>3 \<in> lang r1 \<and> s\<^sub>4 \<in> lang r2)"
        using right_nullable
        apply (auto simp add: lang_deriv Deriv_def append_eq_Cons_conv)
        by (metis concI mem_Collect_eq)
      ultimately have "([] @ (c # s)) \<in> Times r1 r2 \<rightarrow> Seq (mkeps r1) (injval r2 c v1)"
      by(rule Posix.intros)
      then show "(c # s) \<in> Times r1 r2 \<rightarrow> injval (Times r1 r2) c v" using right_nullable by simp
    next
      case not_nullable
      have "s1 \<in> deriv c r1 \<rightarrow> v1" by fact
      then have "(c # s1) \<in> r1 \<rightarrow> injval r1 c v1" using IH1 by simp
      moreover
      have "\<not> (\<exists>s\<^sub>3 s\<^sub>4. s\<^sub>3 \<noteq> [] \<and> s\<^sub>3 @ s\<^sub>4 = s2 \<and> s1 @ s\<^sub>3 \<in> lang (deriv c r1) \<and> s\<^sub>4 \<in> lang r2)" by fact
      then have "\<not> (\<exists>s\<^sub>3 s\<^sub>4. s\<^sub>3 \<noteq> [] \<and> s\<^sub>3 @ s\<^sub>4 = s2 \<and> (c # s1) @ s\<^sub>3 \<in> lang r1 \<and> s\<^sub>4 \<in> lang r2)" by (simp add: lang_deriv Deriv_def)
      ultimately have "((c # s1) @ s2) \<in> Times r1 r2 \<rightarrow> Seq (injval r1 c v1) v2" using not_nullable
        by (rule_tac Posix.intros) (simp_all)
      then show "(c # s) \<in> Times r1 r2 \<rightarrow> injval (Times r1 r2) c v" using not_nullable by simp
    qed
next
  case (Star r)
  have IH: "\<And>s v. s \<in> deriv c r \<rightarrow> v \<Longrightarrow> (c # s) \<in> r \<rightarrow> injval r c v" by fact
  have "s \<in> deriv c (Star r) \<rightarrow> v" by fact
  then consider
      (cons) v1 vs s1 s2 where
        "v = Seq v1 (Stars vs)" "s = s1 @ s2"
        "s1 \<in> deriv c r \<rightarrow> v1" "s2 \<in> (Star r) \<rightarrow> (Stars vs)"
        "\<not> (\<exists>s\<^sub>3 s\<^sub>4. s\<^sub>3 \<noteq> [] \<and> s\<^sub>3 @ s\<^sub>4 = s2 \<and> s1 @ s\<^sub>3 \<in> lang (deriv c r) \<and> s\<^sub>4 \<in> lang (Star r))"
        apply(auto elim!: Posix_elims(1-5) simp add: lang_deriv Deriv_def intro: Posix.intros)
        apply(rotate_tac 3)
        apply(erule_tac Posix_elims(6))
        apply (simp add: Posix.intros(6))
        using Posix.intros(7) by blast
    then show "(c # s) \<in> Star r \<rightarrow> injval (Star r) c v"
    proof (cases)
      case cons
          have "s1 \<in> deriv c r \<rightarrow> v1" by fact
          then have "(c # s1) \<in> r \<rightarrow> injval r c v1" using IH by simp
        moreover
          have "s2 \<in> Star r \<rightarrow> Stars vs" by fact
        moreover
          have "(c # s1) \<in> r \<rightarrow> injval r c v1" by fact
          then have "flat (injval r c v1) = (c # s1)" by (rule Posix1)
          then have "flat (injval r c v1) \<noteq> []" by simp
        moreover
          have "\<not> (\<exists>s\<^sub>3 s\<^sub>4. s\<^sub>3 \<noteq> [] \<and> s\<^sub>3 @ s\<^sub>4 = s2 \<and> s1 @ s\<^sub>3 \<in> lang (deriv c r) \<and> s\<^sub>4 \<in> lang (Star r))" by fact
          then have "\<not> (\<exists>s\<^sub>3 s\<^sub>4. s\<^sub>3 \<noteq> [] \<and> s\<^sub>3 @ s\<^sub>4 = s2 \<and> (c # s1) @ s\<^sub>3 \<in> lang r \<and> s\<^sub>4 \<in> lang (Star r))"
            by (simp add: lang_deriv Deriv_def)
        ultimately
        have "((c # s1) @ s2) \<in> Star r \<rightarrow> Stars (injval r c v1 # vs)" by (rule Posix.intros)
        then show "(c # s) \<in> Star r \<rightarrow> injval (Star r) c v" using cons by(simp)
    qed
qed

section \<open>The Lexer by Sulzmann and Lu\<close>

fun
  lexer :: "'a rexp \<Rightarrow> 'a list \<Rightarrow> ('a val) option"
where
  "lexer r [] = (if nullable r then Some(mkeps r) else None)"
| "lexer r (c#s) = (case (lexer (deriv c r) s) of
                    None \<Rightarrow> None
                  | Some(v) \<Rightarrow> Some(injval r c v))"

lemma lexer_correct_None:
  shows "s \<notin> lang r \<longleftrightarrow> lexer r s = None"
apply(induct s arbitrary: r)
apply(simp add: nullable_iff)
apply(drule_tac x="deriv a r" in meta_spec)
apply(auto simp add: lang_deriv Deriv_def)
done

lemma lexer_correct_Some:
  shows "s \<in> lang r \<longleftrightarrow> (\<exists>v. lexer r s = Some(v) \<and> s \<in> r \<rightarrow> v)"
apply(induct s arbitrary: r)
apply(auto simp add: Posix_mkeps nullable_iff)[1]
apply(drule_tac x="deriv a r" in meta_spec)
apply(simp add: lang_deriv Deriv_def)
apply(rule iffI)
apply(auto intro: Posix_injval simp add: Posix1(1))
done

lemma lexer_correctness:
  shows "(lexer r s = Some v) \<longleftrightarrow> s \<in> r \<rightarrow> v"
  and   "(lexer r s = None) \<longleftrightarrow> \<not>(\<exists>v. s \<in> r \<rightarrow> v)"
apply(auto)
using lexer_correct_None lexer_correct_Some apply fastforce
using Posix1(1) Posix_determ lexer_correct_Some apply blast
using Posix1(1) lexer_correct_None apply blast
using lexer_correct_None lexer_correct_Some by blast

end


(* Property from Productive Use of Failure in Inductive Proof,
   Andrew Ireland and Alan Bundy, JAR 1996.
   This Isabelle theory is produced using the TIP tool offered at the following website:
     https://github.com/tip-org/tools
   This file was originally provided as part of TIP benchmark at the following website:
     https://github.com/tip-org/benchmarks
   Yutaka Nagashima at CIIRC, CTU changed the TIP output theory file slightly
   to make it compatible with Isabelle2017.*)
  theory TIP_prop_22
  imports "../../Test_Base"
begin

datatype 'a list = nil2 | cons2 "'a" "'a list"

datatype Nat = Z | S "Nat"

fun x :: "'a list => 'a list => 'a list" where
  "x (nil2) z = z"
| "x (cons2 z2 xs) z = cons2 z2 (x xs z)"

fun length :: "'a list => Nat" where
  "length (nil2) = Z"
| "length (cons2 z xs) = S (length xs)"

fun even :: "Nat => bool" where
  "even (Z) = True"
| "even (S (Z)) = False"
| "even (S (S z2)) = even z2"

theorem property0 :
  "((even (length (x y z))) = (even (length (x z y))))"
  oops

end