theory topo_frontier_algebra
  imports topo_operators_basic
begin
nitpick_params[assms=true, user_axioms=true, show_all, expect=genuine, format=3] (*default Nitpick settings*)

section \<open>Frontier Algebra\<close>

text\<open>\noindent{The closure of a set A (@{text "\<C>(A)"}) can be seen as the set A augmented by (i) its boundary points,
or (ii) its accumulation/limit points. In this section we explore the first variant by drawing on the notion
of a frontier algebra, defined in an analogous fashion as the well-known closure and interior algebras.}\<close>

text\<open>\noindent{Declares a primitive (unconstrained) frontier (aka. boundary) operation and defines others from it.}\<close>
consts \<F>::"\<sigma>\<Rightarrow>\<sigma>"
abbreviation "\<I> \<equiv> \<I>\<^sub>F \<F>" \<comment>\<open> interior \<close>
abbreviation "\<C> \<equiv> \<C>\<^sub>F \<F>" \<comment>\<open> closure \<close>
abbreviation "\<B> \<equiv> \<B>\<^sub>F \<F>" \<comment>\<open> border \<close>

subsection \<open>Basic properties\<close>

text\<open>\noindent{Verifies minimal conditions under which operators resulting from conversion functions coincide.}\<close>
lemma ICdual: "Fr_2 \<F> \<Longrightarrow> \<I> \<^bold>\<equiv> \<C>\<^sup>d" by (simp add: Cl_fr_def Fr_2_def Int_fr_def dual_def equal_op_def conn)
lemma ICdual': "Fr_2 \<F> \<Longrightarrow> \<C> \<^bold>\<equiv> \<I>\<^sup>d" by (simp add: Cl_fr_def Fr_2_def Int_fr_def dual_def equal_op_def conn)

text\<open>\noindent{Fixed-point and other operators are interestingly related.}\<close>
lemma fp1: "\<I>\<^sup>f\<^sup>p \<^bold>\<equiv> \<B>\<^sup>c" using Br_fr_def Int_fr_def unfolding equal_op_def conn by auto
lemma fp2: "\<B>\<^sup>f\<^sup>p \<^bold>\<equiv> \<I>\<^sup>c" using Br_fr_def Int_fr_def unfolding equal_op_def conn by auto
lemma fp3: "Fr_2 \<F> \<Longrightarrow> \<C>\<^sup>f\<^sup>p \<^bold>\<equiv> \<B>\<^sup>d" using Br_fr_def Cl_fr_def Fr_2_def dual_def equal_op_def conn by fastforce
lemma fp4: "Fr_2 \<F> \<Longrightarrow> (\<B>\<^sup>d)\<^sup>f\<^sup>p \<^bold>\<equiv> \<C>" by (smt dimp_def equal_op_def fp3)
lemma fp5: "\<F>\<^sup>f\<^sup>p \<^bold>\<equiv> \<B> \<^bold>\<squnion> (\<C>\<^sup>c)" using Br_fr_def Cl_fr_def unfolding equal_op_def conn by auto

text\<open>\noindent{Different inter-relations (some redundant ones are kept to help the provers).}\<close>
lemma monI: "Fr_1b \<F> \<Longrightarrow> MONO(\<I>)" by (simp add: IF1a MONO_MULTa)
lemma monC: "Fr_6 \<F> \<Longrightarrow> MONO(\<C>)" by (simp add: Cl_fr_def Fr_6_def MONO_def conn)
lemma pB1: "\<forall>A. \<B> A \<^bold>\<approx> A \<^bold>\<leftharpoonup> \<I> A" using Br_fr_def fp1 unfolding conn equal_op_def by metis
lemma pB2: "\<forall>A. \<B> A \<^bold>\<approx> A \<^bold>\<and> \<F> A" by (simp add: Br_fr_def)
lemma pB3: "Fr_2 \<F> \<Longrightarrow> \<forall>A. \<B>(\<^bold>\<midarrow>A) \<^bold>\<approx> \<^bold>\<midarrow>A \<^bold>\<and> \<F> A" by (simp add: Fr_2_def pB2 conn)
lemma pB4: "Fr_2 \<F> \<Longrightarrow> \<forall>A. \<B>(\<^bold>\<midarrow>A) \<^bold>\<approx> \<^bold>\<midarrow>A \<^bold>\<and> \<C> A" using CB_rel Cl_br_def pB3 unfolding conn equal_op_def by metis
lemma pB5: "Fr_1b \<F> \<Longrightarrow> Fr_2 \<F> \<Longrightarrow> \<forall>A. \<B>(\<C> A) \<^bold>\<preceq> (\<B> A) \<^bold>\<or> \<B>(\<^bold>\<midarrow>A)"  by (smt BC_rel Br_cl_def Cl_fr_def Fr_6_def PF6 equal_op_def conn)
lemma pF1: "\<forall>A. \<F> A \<^bold>\<approx> \<C> A \<^bold>\<leftharpoonup> \<I> A"  using Cl_fr_def Int_fr_def conn by auto
lemma pF2: "Fr_2 \<F> \<Longrightarrow> \<forall>A. \<F> A \<^bold>\<approx> \<C> A \<^bold>\<and> \<C>(\<^bold>\<midarrow>A)" using Cl_fr_def Fr_2_def conn by auto
lemma pF3: "Fr_2 \<F> \<Longrightarrow> \<forall>A. \<F> A \<^bold>\<approx> \<B> A \<^bold>\<or> \<B>(\<^bold>\<midarrow>A)" using Br_fr_def Fr_2_def conn by auto
lemma pF4: "Fr_1 \<F> \<Longrightarrow> Fr_2 \<F> \<Longrightarrow> Fr_4(\<F>) \<Longrightarrow> \<forall>A. \<F>(\<I> A) \<^bold>\<preceq> \<F> A" by (smt IDEMa_def IF2 IF4 Int_fr_def MONO_def PF1 PF6 PI4 diff_def monC pF1)
lemma pF5: "Fr_1 \<F> \<Longrightarrow> Fr_2 \<F> \<Longrightarrow> Fr_4 \<F> \<Longrightarrow> \<forall>A. \<F>(\<C> A) \<^bold>\<preceq> \<F> A" by (metis Br_fr_def CF4 Cl_fr_def IDEM_def PF1 join_def meet_def pB5 pF3)
lemma pA1: "\<forall>A. A \<^bold>\<approx> \<I> A \<^bold>\<or> \<B> A" using Br_fr_def Int_fr_def unfolding conn by auto
lemma pA2: "Fr_2 \<F> \<Longrightarrow> \<forall>A. A \<^bold>\<approx> \<C> A \<^bold>\<leftharpoonup> \<B>(\<^bold>\<midarrow>A)" using pB1 dual_def fp3 unfolding equal_op_def conn by smt
lemma pC1: "Fr_2 \<F> \<Longrightarrow> \<forall>A. \<C> A \<^bold>\<approx> A \<^bold>\<or> \<B>(\<^bold>\<midarrow>A)" using Cl_fr_def pB4 conn by auto
lemma pC2: "\<forall>A. \<C> A \<^bold>\<approx> A \<^bold>\<or> \<F> A" using Cl_fr_def by auto
lemma pI1: "\<forall>A. \<I> A \<^bold>\<approx> A \<^bold>\<leftharpoonup> \<B> A" using pA1 pB1 conn by auto
lemma pI2: "\<forall>A. \<I> A \<^bold>\<approx> A \<^bold>\<leftharpoonup> \<F> A" by (simp add: Int_fr_def)

lemma IC_imp: "Fr_1 \<F> \<Longrightarrow> Fr_2 \<F> \<Longrightarrow> Fr_3 \<F> \<Longrightarrow> \<forall>A B. \<I>(A \<^bold>\<rightarrow> B) \<^bold>\<preceq> \<C> A \<^bold>\<rightarrow> \<C> B" proof -
  assume fr1: "Fr_1 \<F>" and fr2: "Fr_2 \<F>" and fr3: "Fr_3 \<F>"
  { fix a b
    have "(a \<^bold>\<rightarrow> b) \<^bold>\<and> \<^bold>\<midarrow>b \<^bold>\<rightarrow> \<^bold>\<midarrow>a = \<^bold>\<top>" unfolding conn by auto
    hence "\<I>((a \<^bold>\<rightarrow> b) \<^bold>\<and> \<^bold>\<midarrow>b \<^bold>\<rightarrow> \<^bold>\<midarrow>a) \<^bold>\<approx> \<I>(\<^bold>\<top>)" by simp
    hence "\<I>((a \<^bold>\<rightarrow> b) \<^bold>\<and> \<^bold>\<midarrow>b \<^bold>\<rightarrow> \<^bold>\<midarrow>a) \<^bold>\<approx> \<^bold>\<top>" using fr3 IF3 dNOR_def fr2 by auto
    moreover have "let A=(a \<^bold>\<rightarrow> b) \<^bold>\<and> \<^bold>\<midarrow>b; B=\<^bold>\<midarrow>a in \<I>(A \<^bold>\<rightarrow> B) \<^bold>\<preceq> \<I>(A) \<^bold>\<rightarrow> \<I>(B)" using fr1 IF1 PI7 Int_7_def by metis
    ultimately have "\<I>((a \<^bold>\<rightarrow> b) \<^bold>\<and> \<^bold>\<midarrow>b) \<^bold>\<rightarrow> \<I>(\<^bold>\<midarrow>a) \<^bold>\<approx> \<^bold>\<top>" unfolding conn by simp
    moreover have "let A=a \<^bold>\<rightarrow> b; B=\<^bold>\<midarrow>b in \<I>(A \<^bold>\<and> B) \<^bold>\<approx> \<I>(A) \<^bold>\<and> \<I>(B)" using fr1 IF1 MULT_def by simp
    ultimately have "\<I>(a \<^bold>\<rightarrow> b) \<^bold>\<and> \<I>(\<^bold>\<midarrow>b) \<^bold>\<rightarrow> \<I>(\<^bold>\<midarrow>a) \<^bold>\<approx> \<^bold>\<top>" unfolding conn by simp
    moreover have "\<forall>A. \<I>(\<^bold>\<midarrow>A) \<^bold>\<approx> \<^bold>\<midarrow>\<C>(A)" using Cl_fr_def Fr_2_def Int_fr_def fr2  unfolding conn by auto
    ultimately have "\<I>(a \<^bold>\<rightarrow> b) \<^bold>\<and> \<^bold>\<midarrow>\<C>(b) \<^bold>\<rightarrow> \<^bold>\<midarrow>\<C>(a) \<^bold>\<approx> \<^bold>\<top>" unfolding conn by simp
    hence "\<I>(a \<^bold>\<rightarrow> b) \<^bold>\<and> \<^bold>\<midarrow>\<C>(b) \<^bold>\<preceq> \<^bold>\<midarrow>\<C>(a)" unfolding conn by simp
    hence "\<I>(a \<^bold>\<rightarrow> b) \<^bold>\<and> \<C> a \<^bold>\<preceq> \<C> b" unfolding conn by metis
  } thus ?thesis unfolding conn by simp
qed

text\<open>\noindent{Defines some fixed-point predicates and prove some properties.}\<close>
abbreviation openset ("Op") where "Op A \<equiv> fp \<I> A"
abbreviation closedset ("Cl") where "Cl A \<equiv> fp \<C> A"
abbreviation borderset ("Br") where "Br A \<equiv> fp \<B> A"
abbreviation frontierset ("Fr") where "Fr A \<equiv> fp \<F> A"

lemma Int_Open: "Fr_1a \<F> \<Longrightarrow> Fr_2 \<F> \<Longrightarrow> Fr_4 \<F> \<Longrightarrow> \<forall>A. Op(\<I> A)" using IF4 IDEM_def by blast
lemma Cl_Closed: "Fr_1a \<F> \<Longrightarrow> Fr_2 \<F> \<Longrightarrow> Fr_4 \<F> \<Longrightarrow> \<forall>A. Cl(\<C> A)" using CF4 IDEM_def by blast
lemma Br_Border: "Fr_1b \<F> \<Longrightarrow> \<forall>A. Br(\<B> A)" using Br_fr_def Fr_1b_def conn by auto
text\<open>\noindent{In contrast, there is no analogous fixed-point result for frontier:}\<close>
lemma "\<FF> \<F> \<Longrightarrow> \<forall>A. Fr(\<F> A)" nitpick oops (*counterexample even if assuming all frontier conditions*)

lemma OpCldual: "Fr_2 \<F> \<Longrightarrow> \<forall>A. Cl A \<longleftrightarrow> Op(\<^bold>\<midarrow>A)" using Cl_fr_def Fr_2_def Int_fr_def conn by auto
lemma ClOpdual: "Fr_2 \<F> \<Longrightarrow> \<forall>A. Op A \<longleftrightarrow> Cl(\<^bold>\<midarrow>A)" using ICdual dual_def unfolding equal_op_def conn by auto
lemma Fr_ClBr: "\<forall>A. Fr(A) = (Cl(A) \<and> Br(A))" using Br_fr_def Cl_fr_def join_def meet_def by auto
lemma Cl_F: "Fr_4 \<F> \<Longrightarrow> \<forall>A. Cl(\<F> A)" using Cl_fr_def Fr_4_def conn by auto

subsection \<open>Further properties\<close>

text\<open>\noindent{The definitions and theorems below are well known in the literature (e.g. \<^cite>\<open>Kuratowski2\<close>).
Here we uncover the minimal conditions under which they hold (taking frontier operation as primitive).}\<close>
lemma Cl_Bzero: "Fr_2 \<F> \<Longrightarrow> \<forall>A. Cl A \<longleftrightarrow> \<B>(\<^bold>\<midarrow>A) \<^bold>\<approx> \<^bold>\<bottom>" using pA2 pC1 unfolding conn by metis
lemma Op_Bzero: "\<forall>A. Op A \<longleftrightarrow> (\<B> A) \<^bold>\<approx> \<^bold>\<bottom>" using pB1 pI1 unfolding conn by metis
lemma Br_boundary: "Fr_2 \<F> \<Longrightarrow> \<forall>A. Br(A) \<longleftrightarrow> \<I> A \<^bold>\<approx> \<^bold>\<bottom>" by (metis Br_fr_def Int_fr_def bottom_def diff_def meet_def)
lemma Fr_nowhereDense: "Fr_2 \<F> \<Longrightarrow> \<forall>A. Fr(A) \<longrightarrow> \<I>(\<C> A) \<^bold>\<approx> \<^bold>\<bottom>" using Fr_ClBr Br_boundary eq_ext by metis
lemma Cl_FB: "\<forall>A. Cl A \<longleftrightarrow> \<F> A \<^bold>\<approx> \<B> A" using Br_fr_def Cl_fr_def unfolding conn by auto
lemma Op_FB: "Fr_2 \<F> \<Longrightarrow> \<forall>A. Op A \<longleftrightarrow> \<F> A \<^bold>\<approx> \<B>(\<^bold>\<midarrow>A)" using Br_fr_def Fr_2_def Int_fr_def unfolding conn by auto
lemma Clopen_Fzero: "\<forall>A. Cl A \<and> Op A \<longleftrightarrow> \<F> A \<^bold>\<approx> \<^bold>\<bottom>" using Cl_fr_def Int_fr_def unfolding conn by auto

lemma Int_sup_closed: "Fr_1b \<F> \<Longrightarrow> supremum_closed (\<lambda>A. Op A)" by (smt IF1a Int_fr_def MONO_def MONO_MULTa sup_char conn)

text\<open>\noindent{Introduces a predicate for indicating that two sets are disjoint and proves some properties.}\<close>
abbreviation "Disj A B \<equiv> A \<^bold>\<and> B \<^bold>\<approx> \<^bold>\<bottom>"

lemma Disj_comm: "\<forall>A B. Disj A B \<longrightarrow> Disj B A" unfolding conn by fastforce
lemma Disj_IF: "\<forall>A. Disj (\<I> A) (\<F> A)" by (simp add: Int_fr_def conn)
lemma Disj_B: "\<forall>A. Disj (\<B> A) (\<B>(\<^bold>\<midarrow>A))" using Br_fr_def unfolding conn by auto
lemma Disj_I: "\<forall>A. Disj (\<I> A) (\<^bold>\<midarrow>A)" by (simp add: Int_fr_def conn)
lemma Disj_BCI: "Fr_2 \<F> \<Longrightarrow> \<forall>A. Disj (\<B>(\<C> A)) (\<I>(\<^bold>\<midarrow>A))" using Br_fr_def Cl_fr_def Fr_2_def Int_fr_def conn by metis
lemma Disj_CBI: "Fr_6 \<F> \<Longrightarrow> Fr_4 \<F> \<Longrightarrow> \<forall>A. Disj (\<C>(\<B>(\<^bold>\<midarrow>A))) (\<I>(\<^bold>\<midarrow>A))" by (metis Br_fr_def Cl_F IB_rel Int_br_def MONO_MULTa MULT_a_def eq_ext' monC conn)

text\<open>\noindent{Introduces a predicate for indicating that two sets are separated and proves some properties.}\<close>
definition "Sep A B \<equiv> Disj (\<C> A) B \<and> Disj (\<C> B) A"

lemma Sep_comm: "\<forall>A B. Sep A B \<longrightarrow> Sep B A" by (simp add: Sep_def)
lemma Sep_disj: "\<forall>A B. Sep A B \<longrightarrow> Disj A B" using Cl_fr_def Sep_def conn by fastforce
lemma Sep_I: "Fr_1(\<F>) \<Longrightarrow> Fr_2(\<F>) \<Longrightarrow> Fr_4(\<F>) \<Longrightarrow> \<forall>A. Sep (\<I> A) (\<I> (\<^bold>\<midarrow>A))" using Cl_fr_def pF4 Fr_2_def Int_fr_def unfolding Sep_def conn by metis
lemma Sep_sub: "Fr_6 \<F>  \<Longrightarrow> \<forall>A B C D. Sep A B \<and> C \<^bold>\<preceq> A \<and> D \<^bold>\<preceq> B \<longrightarrow> Sep C D" using MONO_def monC unfolding Sep_def conn by smt
lemma Sep_Cl_diff: "Fr_6 \<F> \<Longrightarrow> \<forall>A B. Cl(A) \<and> Cl(B) \<longrightarrow> Sep (A \<^bold>\<leftharpoonup> B) (B \<^bold>\<leftharpoonup> A)" using Fr_6_def pC2 unfolding Sep_def conn by smt
lemma Sep_Op_diff: "Fr_1b \<F> \<Longrightarrow> Fr_2 \<F> \<Longrightarrow> \<forall>A B. Op(A) \<and> Op(B) \<longrightarrow> Sep (A \<^bold>\<leftharpoonup> B) (B \<^bold>\<leftharpoonup> A)" proof -
  assume fr1b:"Fr_1b \<F>" and fr2:"Fr_2 \<F>"
  { fix A B
    from fr1b fr2 have aux: "let M=\<^bold>\<midarrow>A ; N=\<^bold>\<midarrow>B in (Cl(M) \<and> Cl(N) \<longrightarrow> Sep (M \<^bold>\<leftharpoonup> N) (N \<^bold>\<leftharpoonup> M))" using PF6 Sep_Cl_diff by simp
    { assume "Op(A) \<and> Op(B)"
      hence "Cl(\<^bold>\<midarrow>A) \<and> Cl(\<^bold>\<midarrow>B)" using fr2 ClOpdual by simp
      hence "Sep (\<^bold>\<midarrow>A \<^bold>\<leftharpoonup> \<^bold>\<midarrow>B) (\<^bold>\<midarrow>B \<^bold>\<leftharpoonup> \<^bold>\<midarrow>A)" using fr1b fr2 aux unfolding conn by simp
      moreover have "(\<^bold>\<midarrow>A \<^bold>\<leftharpoonup> \<^bold>\<midarrow>B) \<^bold>\<approx> (B \<^bold>\<leftharpoonup> A)" unfolding conn by auto
      moreover have "(\<^bold>\<midarrow>B \<^bold>\<leftharpoonup> \<^bold>\<midarrow>A) \<^bold>\<approx> (A \<^bold>\<leftharpoonup> B)" unfolding conn by auto
      ultimately have "Sep (B \<^bold>\<leftharpoonup> A) (A \<^bold>\<leftharpoonup> B)" unfolding conn by simp
      hence "Sep (A \<^bold>\<leftharpoonup> B) (B \<^bold>\<leftharpoonup> A)" using Sep_comm by simp
    } hence "Op(A) \<and> Op(B) \<longrightarrow> Sep (A \<^bold>\<leftharpoonup> B) (B \<^bold>\<leftharpoonup> A)" by (rule impI)
  } thus ?thesis by simp
qed
lemma Sep_Cl: "\<forall>A B. Cl(A) \<and> Cl(B) \<and> Disj A B \<longrightarrow> Sep A B" unfolding Sep_def conn by blast
lemma Sep_Op: "Fr_1b \<F> \<Longrightarrow> Fr_2 \<F>  \<Longrightarrow> \<forall>A B. Op(A) \<and> Op(B) \<and> Disj A B \<longrightarrow> Sep A B" proof -
  assume fr1b:"Fr_1b \<F>" and fr2:"Fr_2 \<F>"
  { fix A B
    from fr1b fr2 have aux: "Op(A) \<and> Op(B) \<longrightarrow> Sep (A \<^bold>\<leftharpoonup> B) (B \<^bold>\<leftharpoonup> A)" using Sep_Op_diff by simp
    { assume op: "Op(A) \<and> Op(B)" and disj: "Disj A B"
      hence "(A \<^bold>\<leftharpoonup> B) \<^bold>\<approx> A \<and> (B \<^bold>\<leftharpoonup> A) \<^bold>\<approx> B" unfolding conn by blast
      hence "Sep A B" using op aux unfolding conn by simp
    } hence "Op(A) \<and> Op(B) \<and> Disj A B \<longrightarrow> Sep A B" by simp
  } thus ?thesis by simp
qed
lemma "Fr_1a \<F> \<Longrightarrow> Fr_2 \<F> \<Longrightarrow> \<forall>A B C. Sep A B \<and> Sep A C \<longrightarrow> Sep A (B \<^bold>\<or> C)" using CF1a ADDI_a_def unfolding Sep_def conn by metis

text\<open>\noindent{Verifies a neighborhood-based definition of closure.}\<close>
definition "nbhd A p \<equiv> \<exists>E. E \<^bold>\<preceq> A \<and> Op(E) \<and> (E p)"
lemma nbhd_def2: "Fr_1 \<F> \<Longrightarrow> Fr_2 \<F> \<Longrightarrow> Fr_4 \<F> \<Longrightarrow> \<forall>A p. (nbhd A p) = (\<I> A p)" using pF4 MONO_def PF1 monI pI2 unfolding nbhd_def conn by smt

lemma C_def_lr: "Fr_1b \<F> \<Longrightarrow> Fr_2 \<F> \<Longrightarrow> Fr_4 \<F> \<Longrightarrow> \<forall>A p. (\<C> A p) \<longrightarrow> (\<forall>E. (nbhd E p) \<longrightarrow> \<not>(Disj E A))" using Cl_fr_def Fr_2_def Fr_6_def PF6 pF1 unfolding nbhd_def conn by smt
lemma C_def_rl: "Fr_1 \<F> \<Longrightarrow> Fr_2 \<F> \<Longrightarrow> Fr_4 \<F> \<Longrightarrow> \<forall>A p. (\<C> A p) \<longleftarrow> (\<forall>E. (nbhd E p) \<longrightarrow> \<not>(Disj E A))" using Cl_fr_def pF5 pA1 pB4 unfolding nbhd_def conn by smt
lemma C_def: "Fr_1 \<F> \<Longrightarrow> Fr_2 \<F> \<Longrightarrow> Fr_4 \<F> \<Longrightarrow> \<forall>A p. (\<C> A p) \<longleftrightarrow> (\<forall>E. (nbhd E p) \<longrightarrow> \<not>(Disj E A))" using C_def_lr C_def_rl PF1 by blast

text\<open>\noindent{Explore the Barcan and converse Barcan formulas.}\<close>
lemma Barcan_I: "Fr_inf \<F> \<Longrightarrow> \<forall>P. (\<^bold>\<forall>x. \<I>(P x)) \<^bold>\<preceq> \<I>(\<^bold>\<forall>x. P x)" using IF_inf Barcan1 by auto
lemma Barcan_C: "Fr_2 \<F> \<Longrightarrow> Fr_inf \<F> \<Longrightarrow> \<forall>P. \<C>(\<^bold>\<exists>x. P x) \<^bold>\<preceq> (\<^bold>\<exists>x. \<C>(P x))" using Fr_2_def CF_inf Barcan2 by metis
lemma CBarcan_I: "Fr_1b \<F> \<Longrightarrow> \<forall>P. \<I>(\<^bold>\<forall>x. P x)  \<^bold>\<preceq> (\<^bold>\<forall>x. \<I>(P x))" by (metis (mono_tags, lifting) MONO_def monI)
lemma CBarcan_C: "Fr_6 \<F> \<Longrightarrow> \<forall>P. (\<^bold>\<exists>x. \<C>(P x)) \<^bold>\<preceq> \<C>(\<^bold>\<exists>x. P x)"  by (metis (mono_tags, lifting) MONO_def monC)

end


(*    Title:              SATSolverVerification/Trail.thy
      Author:             Filip Maric
      Maintainer:         Filip Maric <filip at matf.bg.ac.yu>
*)

header{*  Trail datatype definition and its properties *}

theory Trail
imports MoreList
begin

text{*   Trail is a list in which some elements can be marked. *}
type_synonym 'a Trail = "('a*bool) list"

abbreviation
  element :: "('a*bool) \<Rightarrow> 'a"
  where "element x == fst x"

abbreviation
  marked :: "('a*bool) \<Rightarrow> bool"
  where "marked  x == snd x"

(*--------------------------------------------------------------------------------*)
subsection{* Trail elements *}

text{* Elements of the trail with marks removed *}
primrec
elements              :: "'a Trail \<Rightarrow> 'a list"
where
  "elements [] = []"
| "elements (h#t) = (element h) # (elements t)"

lemma
"elements t = map fst t"
by (induct t) auto

lemma eitherMarkedOrNotMarkedElement:
  shows "a = (element a, True) \<or> a = (element a, False)"
by (cases a) auto

lemma eitherMarkedOrNotMarked:
  assumes "e \<in> set (elements M)"
  shows "(e, True) \<in> set M \<or> (e, False) \<in> set M"
using assms
proof (induct M)
  case (Cons m M')
  thus ?case
    proof (cases "e = element m")
      case True
      thus ?thesis
        using eitherMarkedOrNotMarkedElement [of "m"]
        by auto
    next
      case False
      with Cons
      show ?thesis
        by auto
    qed
qed simp

lemma elementMemElements [simp]:
  assumes "x \<in> set M"
  shows "element x \<in> set (elements M)"
using assms
by (induct M) (auto split: split_if_asm)

lemma elementsAppend [simp]:
  shows "elements (a @ b) = elements a @ elements b"
by (induct a) auto

lemma elementsEmptyIffTrailEmpty [simp]:
  shows "(elements list = []) = (list = [])"
by (induct list) auto

lemma elementsButlastTrailIsButlastElementsTrail [simp]:
  shows "elements (butlast M) = butlast (elements M)"
by (induct M) auto

lemma elementLastTrailIsLastElementsTrail [simp]:
  assumes "M \<noteq> []"
  shows "element (last M) = last (elements M)"
using assms
by (induct M) auto

lemma isPrefixElements:
  assumes "isPrefix a b"
  shows "isPrefix (elements a) (elements b)"
using assms
unfolding isPrefix_def
by auto

lemma prefixElementsAreTrailElements:
  assumes
  "isPrefix p M"
  shows
  "set (elements p) \<subseteq> set (elements M)"
using assms
unfolding isPrefix_def
by auto

lemma uniqElementsTrailImpliesUniqElementsPrefix:
  assumes
  "isPrefix p M" and "uniq (elements M)"
  shows
  "uniq (elements p)"
proof-
  from `isPrefix p M`
  obtain s
    where "M = p @ s"
    unfolding isPrefix_def
    by auto
  with `uniq (elements M)`
  show ?thesis
    using uniqAppend[of "elements p" "elements s"]
    by simp
qed

lemma uniqImpliesExclusiveTrueOrFalse:
  assumes
  "(e, d) \<in> set M" and "uniq (elements M)"
  shows
  "\<not> (e, \<not> d) \<in> set M"
using assms
proof (induct M)
  case (Cons m M')
  {
    assume "(e, d) = m"
    hence "(e, \<not> d) \<noteq> m"
      by auto
    from `(e, d) = m` `uniq (elements (m # M'))`
    have "\<not> (e, d) \<in> set M'"
      by (auto simp add: uniqAppendIff)
    with Cons
    have ?case
      by (auto split: split_if_asm)
  }
  moreover
  {
    assume "(e, \<not> d) = m"
    hence "(e, d) \<noteq> m"
      by auto
    from `(e, \<not> d) = m` `uniq (elements (m # M'))`
    have "\<not> (e, \<not> d) \<in> set M'"
      by (auto simp add: uniqAppendIff)
    with Cons
    have ?case
      by (auto split: split_if_asm)
  }
  moreover
  {
    assume "(e, d) \<noteq> m" "(e, \<not> d) \<noteq> m"
    from `(e, d) \<noteq> m` `(e, d) \<in> set (m # M')` have
      "(e, d) \<in> set M'"
      by simp
    with `uniq (elements (m # M'))` Cons(1)
    have "\<not> (e, \<not> d) \<in> set M'"
      by simp
    with `(e, \<not> d) \<noteq> m`
    have ?case
      by simp
  }
  moreover
  {
    have "(e, d) = m \<or> (e, \<not> d) = m \<or> (e, d) \<noteq> m \<and> (e, \<not> d) \<noteq> m"
      by auto
  }
  ultimately
  show ?case
    by auto
qed simp

(*--------------------------------------------------------------------------------*)
subsection{* Marked trail elements *}

primrec
markedElements        :: "'a Trail \<Rightarrow> 'a list"
where
  "markedElements [] = []"
| "markedElements (h#t) =  (if (marked h) then (element h) # (markedElements t) else (markedElements t))"

lemma
"markedElements t = (elements (filter snd t))"
by (induct t) auto

lemma markedElementIsMarkedTrue:
  shows "(m \<in> set (markedElements M)) = ((m, True) \<in> set M)"
using assms
by (induct M) (auto split: split_if_asm)

lemma markedElementsAppend:
  shows "markedElements (M1 @ M2) = markedElements M1 @ markedElements M2"
by (induct M1) auto

lemma markedElementsAreElements:
  assumes "m \<in> set (markedElements M)"
  shows   "m \<in> set (elements M)"
using assms markedElementIsMarkedTrue[of "m" "M"]
by auto

lemma markedAndMemberImpliesIsMarkedElement:
  assumes "marked m" "m \<in> set M"
  shows "(element m) \<in> set (markedElements M)"
proof-
  have "m = (element m, marked m)"
    by auto
  with `marked m`
  have "m = (element m, True)"
    by simp
  with `m \<in> set M` have
    "(element m, True) \<in> set M"
    by simp
  thus ?thesis
    using markedElementIsMarkedTrue [of "element m" "M"]
    by simp
qed

lemma markedElementsPrefixAreMarkedElementsTrail:
  assumes "isPrefix p M" "m \<in> set (markedElements p)"
  shows "m \<in> set (markedElements M)"
proof-
  from `m \<in> set (markedElements p)`
  have "(m, True) \<in> set p"
    by (simp add: markedElementIsMarkedTrue)
  with `isPrefix p M`
  have "(m, True) \<in> set M"
    using prefixIsSubset[of "p" "M"]
    by auto
  thus ?thesis
    by (simp add: markedElementIsMarkedTrue)
qed

lemma markedElementsTrailMemPrefixAreMarkedElementsPrefix:
  assumes
  "uniq (elements M)" and
  "isPrefix p M" and
  "m \<in> set (elements p)" and
  "m \<in> set (markedElements M)"
  shows
  "m \<in> set (markedElements p)"
proof-
  from `m \<in> set (markedElements M)` have "(m, True) \<in> set M"
    by (simp add: markedElementIsMarkedTrue)
  with `uniq (elements M)` `m \<in> set (elements p)`
  have "(m, True) \<in> set p"
  proof-
    {
      assume "(m, False) \<in> set p"
      with `isPrefix p M`
      have "(m, False) \<in> set M"
        using prefixIsSubset[of "p" "M"]
        by auto
      with `(m, True) \<in> set M` `uniq (elements M)`
      have False
        using uniqImpliesExclusiveTrueOrFalse[of "m" "True" "M"]
        by simp
    }
    with `m \<in> set (elements p)`
    show ?thesis
      using eitherMarkedOrNotMarked[of "m" "p"]
      by auto
  qed
  thus ?thesis
    using markedElementIsMarkedTrue[of "m" "p"]
    by simp
qed

(*--------------------------------------------------------------------------------*)
subsection{* Prefix before/upto a trail element *}

text{* Elements of the trail before the first occurence of a given element - not incuding it *}
primrec
prefixBeforeElement  :: "'a \<Rightarrow> 'a Trail \<Rightarrow> 'a Trail"
where
  "prefixBeforeElement e [] = []"
| "prefixBeforeElement e (h#t) =
 (if (element h) = e then
     []
  else
     (h # (prefixBeforeElement e t))
 )"

lemma "prefixBeforeElement e t = takeWhile (\<lambda> e'. element e' \<noteq> e) t"
by (induct t) auto

lemma "prefixBeforeElement e t = take (firstPos e (elements t)) t"
by (induct t) auto

text{* Elements of the trail before the first occurence of a given element - incuding it *}
primrec
prefixToElement  :: "'a \<Rightarrow> 'a Trail \<Rightarrow> 'a Trail"
where
  "prefixToElement e [] = []"
| "prefixToElement e (h#t) =
   (if (element h) = e then
      [h]
    else
      (h # (prefixToElement e t))
   )"

lemma "prefixToElement e t = take ((firstPos e (elements t)) + 1) t"
by (induct t) auto

lemma isPrefixPrefixToElement:
  shows "isPrefix (prefixToElement e t) t"
unfolding isPrefix_def
by (induct t) auto

lemma isPrefixPrefixBeforeElement:
  shows "isPrefix (prefixBeforeElement e t) t"
unfolding isPrefix_def
by (induct t) auto

lemma prefixToElementContainsTrailElement:
  assumes "e \<in> set (elements M)"
  shows "e \<in> set (elements (prefixToElement e M))"
using assms
by (induct M) auto

lemma prefixBeforeElementDoesNotContainTrailElement:
  assumes "e \<in> set (elements M)"
  shows "e \<notin> set (elements (prefixBeforeElement e M))"
using assms
by (induct M) auto

lemma prefixToElementAppend:
  shows "prefixToElement e (M1 @ M2) =
            (if e \<in> set (elements M1) then
                prefixToElement e M1
             else
                M1 @ prefixToElement e M2
             )"
by (induct M1) auto

lemma prefixToElementToPrefixElement:
  assumes
  "isPrefix p M" and "e \<in> set (elements p)"
  shows
  "prefixToElement e M = prefixToElement e p"
using assms
unfolding isPrefix_def
proof (induct p arbitrary: M)
  case (Cons a p')
  then obtain s
    where "(a # p') @ s = M"
    by auto
  show ?case
  proof (cases "(element a) = e")
    case True
    from True `(a # p') @ s = M` have "prefixToElement e M = [a]"
      by auto
    moreover
    from True have "prefixToElement e (a # p') = [a]"
      by auto
    ultimately
    show ?thesis
      by simp
  next
    case False
    from False `(a # p') @ s = M` have "prefixToElement e M = a # prefixToElement e (p' @ s)"
      by auto
    moreover
    from False have "prefixToElement e (a # p') = a # prefixToElement e p'"
      by simp
    moreover
    from False `e \<in> set (elements (a # p'))` have "e \<in> set (elements p')"
      by simp
    have "? s . (p' @ s = p' @ s)"
      by simp
    from `e \<in> set (elements p')`  `? s. (p' @ s = p' @ s)`
      have "prefixToElement e (p' @ s) = prefixToElement e p'"
      using Cons(1) [of "p' @ s"]
      by simp
    ultimately show ?thesis
      by simp
  qed
qed simp

(*--------------------------------------------------------------------------------*)
subsection{* Marked elements upto a given trail element *}

text{* Marked elements of the trail upto the given element (which is also included if it is marked) *}
definition
markedElementsTo :: "'a \<Rightarrow> 'a Trail \<Rightarrow> 'a list"
where
"markedElementsTo e t = markedElements (prefixToElement e t)"

lemma markedElementsToArePrefixOfMarkedElements:
  shows "isPrefix (markedElementsTo e M) (markedElements M)"
unfolding isPrefix_def
unfolding markedElementsTo_def
by (induct M) auto

lemma markedElementsToAreMarkedElements:
  assumes "m \<in> set (markedElementsTo e M)"
  shows "m \<in> set (markedElements M)"
using assms
using markedElementsToArePrefixOfMarkedElements[of "e" "M"]
using prefixIsSubset
by auto

lemma markedElementsToNonMemberAreAllMarkedElements:
  assumes "e \<notin> set (elements M)"
  shows "markedElementsTo e M = markedElements M"
using assms
unfolding markedElementsTo_def
by (induct M) auto

lemma markedElementsToAppend:
  shows "markedElementsTo e (M1 @ M2) =
          (if e \<in> set (elements M1) then
                 markedElementsTo e M1
           else
                 markedElements M1 @ markedElementsTo e M2
          )"
unfolding markedElementsTo_def
by (auto simp add: prefixToElementAppend markedElementsAppend)

lemma markedElementsEmptyImpliesMarkedElementsToEmpty:
  assumes "markedElements M = []"
  shows "markedElementsTo e M = []"
using assms
using markedElementsToArePrefixOfMarkedElements [of "e" "M"]
unfolding isPrefix_def
by auto

lemma markedElementIsMemberOfItsMarkedElementsTo:
  assumes
  "uniq (elements M)" and "marked e" and "e \<in> set M"
  shows
  "element e \<in> set (markedElementsTo (element e) M)"
using assms
unfolding markedElementsTo_def
by (induct M) (auto split: split_if_asm)

lemma markedElementsToPrefixElement:
  assumes "isPrefix p M" and "e \<in> set (elements p)"
  shows "markedElementsTo e M = markedElementsTo e p"
unfolding markedElementsTo_def
using assms
by (simp add: prefixToElementToPrefixElement)

(*--------------------------------------------------------------------------------*)
subsection{* Last marked element in a trail *}

definition
lastMarked :: "'a Trail \<Rightarrow> 'a"
where
"lastMarked t = last (markedElements t)"

lemma lastMarkedIsMarkedElement:
  assumes "markedElements M \<noteq> []"
  shows "lastMarked M \<in> set (markedElements M)"
using assms
unfolding lastMarked_def
by simp

lemma removeLastMarkedFromMarkedElementsToLastMarkedAreAllMarkedElementsInPrefixLastMarked:
  assumes
  "markedElements M \<noteq> []"
  shows
  "removeAll (lastMarked M) (markedElementsTo (lastMarked M) M) = markedElements (prefixBeforeElement (lastMarked M) M)"
using assms
unfolding lastMarked_def
unfolding markedElementsTo_def
by (induct M) auto

lemma markedElementsToLastMarkedAreAllMarkedElements:
  assumes
  "uniq (elements M)" and "markedElements M \<noteq> []"
  shows
  "markedElementsTo (lastMarked M) M = markedElements M"
using assms
unfolding lastMarked_def
unfolding markedElementsTo_def
by (induct M) (auto simp add: markedElementsAreElements)

lemma lastTrailElementMarkedImpliesMarkedElementsToLastElementAreAllMarkedElements:
  assumes
  "marked (last M)" and "last (elements M) \<notin> set (butlast (elements M))"
  shows
  "markedElementsTo (last (elements M)) M = markedElements M"
using assms
unfolding markedElementsTo_def
by (induct M) auto

lemma lastMarkedIsMemberOfItsMarkedElementsTo:
  assumes
  "uniq (elements M)" and "markedElements M \<noteq> []"
  shows
  "lastMarked M \<in> set (markedElementsTo (lastMarked M) M)"
using assms
using markedElementsToLastMarkedAreAllMarkedElements [of "M"]
using lastMarkedIsMarkedElement [of "M"]
by auto

lemma lastTrailElementNotMarkedImpliesMarkedElementsToLAreMarkedElementsToLInButlastTrail:
  assumes "\<not> marked (last M)"
  shows "markedElementsTo e M = markedElementsTo e (butlast M)"
using assms
unfolding markedElementsTo_def
by (induct M) auto

(*--------------------------------------------------------------------------------*)
subsection{* Level of a trail element *}

text{* Level of an element is the number of marked elements that precede it *}

definition
elementLevel :: "'a \<Rightarrow> 'a Trail \<Rightarrow> nat"
where
"elementLevel e t = length (markedElementsTo e t)"

lemma elementLevelMarkedGeq1:
  assumes
  "uniq (elements M)" and "e \<in> set (markedElements M)"
  shows
  "elementLevel e M >= 1"
proof-
  from `e \<in> set (markedElements M)` have "(e, True) \<in> set M"
    by (simp add: markedElementIsMarkedTrue)
  with `uniq (elements M)`  have "e \<in> set (markedElementsTo e M)"
    using markedElementIsMemberOfItsMarkedElementsTo[of "M" "(e, True)"]
    by simp
  hence "markedElementsTo e M \<noteq> []"
    by auto
  thus ?thesis
    unfolding elementLevel_def
    using length_greater_0_conv[of "markedElementsTo e M"]
    by arith
qed

lemma elementLevelAppend:
  assumes "a \<in> set (elements M)"
  shows "elementLevel a M = elementLevel a (M @ M')"
using assms
unfolding elementLevel_def
by (simp add: markedElementsToAppend)

lemma elementLevelPrecedesLeq:
  assumes
  "precedes a b (elements M)"
  shows
  "elementLevel a M \<le> elementLevel b M"
using assms
proof (induct M)
  case (Cons m M')
  {
    assume "a = element m"
    hence ?case
      unfolding elementLevel_def
      unfolding markedElementsTo_def
      by simp
  }
  moreover
  {
    assume "b = element m"
    {
      assume "a \<noteq> b"
      hence "\<not> precedes a b (b # (elements M'))"
        by (rule noElementsPrecedesFirstElement)
      with `b = element m` `precedes a b (elements (m # M'))`
      have False
        by simp
    }
    hence "a = b"
      by auto
    hence ?case
      by simp
  }
  moreover
  {
    assume "a \<noteq> element m" "b \<noteq> element m"
    moreover
    from `precedes a b (elements (m # M'))`
    have "a \<in> set (elements (m # M'))" "b \<in> set (elements (m # M'))"
      unfolding precedes_def
      by (auto split: split_if_asm)
    from `a \<noteq> element m` `a \<in> set (elements (m # M'))`
    have "a \<in> set (elements M')"
      by simp
    moreover
    from `b \<noteq> element m` `b \<in> set (elements (m # M'))`
    have "b \<in> set (elements M')"
      by simp
    ultimately
    have "elementLevel a M' \<le> elementLevel b M'"
      using Cons
      unfolding precedes_def
      by auto
    hence ?case
      using `a \<noteq> element m` `b \<noteq> element m`
      unfolding elementLevel_def
      unfolding markedElementsTo_def
      by auto
  }
  ultimately
  show ?case
    by auto
next
  case Nil
  thus ?case
    unfolding precedes_def
    by simp
qed

lemma elementLevelPrecedesMarkedElementLt:
  assumes
  "uniq (elements M)" and
  "e \<noteq> d" and
  "d \<in> set (markedElements M)" and
  "precedes e d (elements M)"
  shows
  "elementLevel e M < elementLevel d M"
using assms
proof (induct M)
  case (Cons m M')
  {
    assume "e = element m"
    moreover
    with `e \<noteq> d` have "d \<noteq> element m"
      by simp
    moreover
    from `uniq (elements (m # M'))` `d \<in> set (markedElements (m # M'))`
    have "1 \<le> elementLevel d (m # M')"
      using elementLevelMarkedGeq1[of "m # M'" "d"]
      by auto
    moreover
    from `d \<noteq> element m` `d \<in> set (markedElements (m # M'))`
    have "d \<in> set (markedElements M')"
      by (simp split: split_if_asm)
    from `uniq (elements (m # M'))` `d \<in> set (markedElements M')`
    have "1 \<le> elementLevel d M'"
      using elementLevelMarkedGeq1[of "M'" "d"]
      by auto
    ultimately
    have ?case
      unfolding elementLevel_def
      unfolding markedElementsTo_def
      by (auto split: split_if_asm)
  }
  moreover
  {
    assume "d = element m"
    from `e \<noteq> d` have "\<not> precedes e d (d # (elements M'))"
      using noElementsPrecedesFirstElement[of "e" "d" "elements M'"]
      by simp
    with `d = element m` `precedes e d (elements (m # M'))`
    have False
      by simp
    hence ?case
      by simp
  }
  moreover
  {
    assume "e \<noteq> element m" "d \<noteq> element m"
    moreover
    from `precedes e d (elements (m # M'))`
    have "e \<in> set (elements (m # M'))" "d \<in> set (elements (m # M'))"
      unfolding precedes_def
      by (auto split: split_if_asm)
    from `e \<noteq> element m` `e \<in> set (elements (m # M'))`
    have "e \<in> set (elements M')"
      by simp
    moreover
    from `d \<noteq> element m` `d \<in> set (elements (m # M'))`
    have "d \<in> set (elements M')"
      by simp
    moreover
    from `d \<noteq> element m` `d \<in> set (markedElements (m # M'))`
    have "d \<in> set (markedElements M')"
      by (simp split: split_if_asm)
    ultimately
    have "elementLevel e M' < elementLevel d M'"
      using `uniq (elements (m # M'))` Cons
      unfolding precedes_def
      by auto
    hence ?case
      using `e \<noteq> element m` `d \<noteq> element m`
      unfolding elementLevel_def
      unfolding markedElementsTo_def
      by auto
  }
  ultimately
  show ?case
    by auto
qed simp

lemma differentMarkedElementsHaveDifferentLevels:
  assumes
  "uniq (elements M)" and
  "a \<in> set (markedElements M)" and
  "b \<in> set (markedElements M)" and
  "a \<noteq> b"
  shows "elementLevel a M \<noteq> elementLevel b M"
proof-
  from `a \<in> set (markedElements M)`
  have "a \<in> set (elements M)"
    by (simp add: markedElementsAreElements)
  moreover
  from `b \<in> set (markedElements M)`
  have "b \<in> set (elements M)"
    by (simp add: markedElementsAreElements)
  ultimately
  have "precedes a b (elements M) \<or> precedes b a (elements M)"
    using `a \<noteq> b`
    using precedesTotalOrder[of "a" "elements M" "b"]
    by simp
  moreover
  {
    assume "precedes a b (elements M)"
    with assms
    have ?thesis
      using elementLevelPrecedesMarkedElementLt[of "M" "a" "b"]
      by auto
  }
  moreover
  {
    assume "precedes b a (elements M)"
    with assms
    have ?thesis
      using elementLevelPrecedesMarkedElementLt[of "M" "b" "a"]
      by auto
  }
  ultimately
  show ?thesis
    by auto
qed

(* ------------------------------------------------------------------------- *)
subsection{* Current trail level *}

text{* Current level is the number of marked elements in the trail *}

definition
currentLevel :: "'a Trail \<Rightarrow> nat"
where
"currentLevel t = length (markedElements t)"

lemma currentLevelNonMarked:
  shows "currentLevel M = currentLevel (M @ [(l, False)])"
by (auto simp add:currentLevel_def markedElementsAppend)

lemma currentLevelPrefix:
  assumes "isPrefix a b"
  shows "currentLevel a <= currentLevel b"
using assms
unfolding isPrefix_def
unfolding currentLevel_def
by (auto simp add: markedElementsAppend)

lemma elementOnCurrentLevel:
  assumes "a \<notin> set (elements M)"
  shows "elementLevel a (M @ [(a, d)]) = currentLevel  (M @ [(a, d)])"
using assms
unfolding currentLevel_def
unfolding elementLevel_def
unfolding markedElementsTo_def
by (auto simp add: prefixToElementAppend)

(*--------------------------------------------------------------------------------*)
subsection{* Prefix to a given trail level *}

text{* Prefix is made or elements of the trail up to a given element level *}

primrec
prefixToLevel_aux :: "'a Trail \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> 'a Trail"
where
  "(prefixToLevel_aux [] l cl) = []"
| "(prefixToLevel_aux (h#t) l cl) =
  (if (marked h) then
    (if (cl >= l) then [] else (h # (prefixToLevel_aux t l (cl+1))))
  else
    (h # (prefixToLevel_aux t l cl))
  )"

definition
prefixToLevel :: "nat \<Rightarrow> 'a Trail \<Rightarrow> 'a Trail"
where
prefixToLevel_def: "(prefixToLevel l t) == (prefixToLevel_aux t l 0)"

lemma isPrefixPrefixToLevel_aux:
  shows "\<exists> s. prefixToLevel_aux t l i @ s = t"
by (induct t arbitrary: i) auto

lemma isPrefixPrefixToLevel:
  shows "(isPrefix (prefixToLevel l t) t)"
using isPrefixPrefixToLevel_aux[of "t" "l"]
unfolding isPrefix_def
unfolding prefixToLevel_def
by simp

lemma currentLevelPrefixToLevel_aux:
  assumes "l \<ge> i"
  shows "currentLevel (prefixToLevel_aux M l i) <= l - i"
using assms
proof (induct M arbitrary: i)
  case (Cons m M')
  {
    assume "marked m" "i = l"
    hence ?case
      unfolding currentLevel_def
      by simp
  }
  moreover
  {
    assume "marked m" "i < l"
    hence ?case
      using Cons(1) [of "i+1"]
      unfolding currentLevel_def
      by simp
  }
  moreover
  {
    assume "\<not> marked m"
    hence ?case
      using Cons
      unfolding currentLevel_def
      by simp
  }
  ultimately
  show ?case
    using `i <= l`
    by auto
next
  case Nil
  thus ?case
    unfolding currentLevel_def
    by simp
qed

lemma currentLevelPrefixToLevel:
  shows "currentLevel (prefixToLevel level M) \<le> level"
using currentLevelPrefixToLevel_aux[of "0" "level" "M"]
unfolding prefixToLevel_def
by simp

lemma currentLevelPrefixToLevelEq_aux:
  assumes "l \<ge> i" "currentLevel M >= l - i"
  shows "currentLevel (prefixToLevel_aux M l i) = l - i"
using assms
proof (induct M arbitrary: i)
  case (Cons m M')
  {
    assume "marked m" "i = l"
    hence ?case
      unfolding currentLevel_def
      by simp
  }
  moreover
  {
    assume "marked m" "i < l"
    hence ?case
      using Cons(1) [of "i+1"]
      using Cons(3)
      unfolding currentLevel_def
      by simp
  }
  moreover
  {
    assume "\<not> marked m"
    hence ?case
      using Cons
      unfolding currentLevel_def
      by simp
  }
  ultimately
  show ?case
    using `i <= l`
    by auto
next
  case Nil
  thus ?case
    unfolding currentLevel_def
    by simp
qed

lemma currentLevelPrefixToLevelEq:
assumes
  "level \<le> currentLevel M"
shows
  "currentLevel (prefixToLevel level M) = level"
using assms
unfolding prefixToLevel_def
using currentLevelPrefixToLevelEq_aux[of "0" "level" "M"]
by simp

lemma prefixToLevel_auxIncreaseAuxilaryCounter:
  assumes "k \<ge> i"
  shows "prefixToLevel_aux M l i = prefixToLevel_aux M (l + (k - i)) k"
using assms
proof (induct M arbitrary: i k)
  case (Cons m M')
  {
    assume "\<not> marked m"
    hence ?case
      using Cons(1)[of "i" "k"] Cons(2)
      by simp
  }
  moreover
  {
    assume "i \<ge> l" "marked m"
    hence ?case
      using `k \<ge> i`
      by simp
  }
  moreover
  {
    assume "i < l" "marked m"
    hence ?case
      using Cons(1)[of "i+1" "k+1"] Cons(2)
      by simp
  }
  ultimately
  show ?case
    by (auto split: split_if_asm)
qed simp

lemma isPrefixPrefixToLevel_auxLowerLevel:
  assumes "i \<le> j"
  shows "isPrefix (prefixToLevel_aux M i k) (prefixToLevel_aux M j k)"
using assms
by (induct M arbitrary: k) (auto simp add:isPrefix_def)

lemma isPrefixPrefixToLevelLowerLevel:
assumes "level < level'"
shows "isPrefix (prefixToLevel level M) (prefixToLevel level' M)"
using assms
unfolding prefixToLevel_def
using isPrefixPrefixToLevel_auxLowerLevel[of "level" "level'" "M" "0"]
by simp

lemma prefixToLevel_auxPrefixToLevel_auxHigherLevel:
  assumes "i \<le> j"
  shows "prefixToLevel_aux a i k = prefixToLevel_aux (prefixToLevel_aux a j k) i k"
using assms
by (induct a arbitrary: k) auto

lemma prefixToLevelPrefixToLevelHigherLevel:
  assumes "level \<le> level'"
  shows "prefixToLevel level M = prefixToLevel level (prefixToLevel level' M)"
using assms
unfolding prefixToLevel_def
using prefixToLevel_auxPrefixToLevel_auxHigherLevel[of "level" "level'" "M" "0"]
by simp

lemma prefixToLevelAppend_aux1:
  assumes
  "l \<ge> i" and "l - i < currentLevel a"
  shows
  "prefixToLevel_aux (a @ b) l i = prefixToLevel_aux a l i"
using assms
proof (induct a arbitrary: i)
  case (Cons a a')
  {
    assume "\<not> marked a"
    hence ?case
      using Cons(1)[of "i"] `i \<le> l` `l - i < currentLevel (a # a')`
      unfolding currentLevel_def
      by simp
  }
  moreover
  {
    assume "marked a" "l = i"
    hence ?case
      by simp
  }
  moreover
  {
    assume "marked a" "l > i"
    hence ?case
      using Cons(1)[of "i + 1"] `i \<le> l` `l - i < currentLevel (a # a')`
      unfolding currentLevel_def
      by simp
  }
  ultimately
  show ?case
    using `i \<le> l`
    by auto
next
  case Nil
  thus ?case
    unfolding currentLevel_def
    by simp
qed

lemma prefixToLevelAppend_aux2:
  assumes
  "i \<le> l" and "currentLevel a + i \<le> l"
  shows "prefixToLevel_aux (a @ b) l i = a @ prefixToLevel_aux b l (i + (currentLevel a))"
using assms
proof (induct a arbitrary: i)
  case (Cons a a')
  {
    assume "\<not> marked a"
    hence ?case
      using Cons
      unfolding currentLevel_def
      by simp
  }
  moreover
  {
    assume "marked a" "l = i"
    hence ?case
      using `(currentLevel (a # a')) + i \<le> l`
      unfolding currentLevel_def
      by simp
  }
  moreover
  {
    assume "marked a" "l > i"
    hence "prefixToLevel_aux (a' @ b) l (i + 1) = a' @ prefixToLevel_aux b l (i + 1 + currentLevel a')"
      using Cons(1) [of "i + 1"] `(currentLevel (a # a')) + i \<le> l`
      unfolding currentLevel_def
      by simp
    moreover
    have "i + 1 + length (markedElements a') = i + (1 + length (markedElements a'))"
      by simp
    ultimately
    have ?case
      using `marked a` `l > i`
      unfolding currentLevel_def
      by simp
  }
  ultimately
  show ?case
    using `l \<ge> i`
    by auto
next
  case Nil
  thus ?case
    unfolding currentLevel_def
    by simp
qed

lemma prefixToLevelAppend:
  shows "prefixToLevel level (a @ b) =
  (if level < currentLevel a then
      prefixToLevel level a
  else
      a @ prefixToLevel_aux b level (currentLevel a)
  )"
proof (cases "level < currentLevel a")
  case True
  thus ?thesis
    unfolding prefixToLevel_def
    using prefixToLevelAppend_aux1[of "0" "level" "a"]
    by simp
next
  case False
  thus ?thesis
    unfolding prefixToLevel_def
    using prefixToLevelAppend_aux2[of "0" "level" "a"]
    by simp
qed

lemma isProperPrefixPrefixToLevel:
  assumes "level < currentLevel t"
  shows "\<exists> s. (prefixToLevel level t) @ s = t \<and> s \<noteq> [] \<and> (marked (hd s))"
proof-
  have "isPrefix (prefixToLevel level t) t"
    by (simp add:isPrefixPrefixToLevel)
  then obtain s::"'a Trail"
    where "(prefixToLevel level t) @ s = t"
    unfolding isPrefix_def
    by auto
  moreover
  have "s \<noteq> []"
  proof-
    {
      assume "s = []"
      with `(prefixToLevel level t) @ s = t`
      have "prefixToLevel level t = t"
        by simp
      hence "currentLevel (prefixToLevel level t) \<le> level"
        using currentLevelPrefixToLevel[of "level" "t"]
        by simp
      with `prefixToLevel level t = t` have "currentLevel t \<le> level"
        by simp
      with `level < currentLevel t` have False
        by simp
    }
    thus ?thesis
      by auto
  qed
  moreover
  have "marked (hd s)"
  proof-
    {
      assume "\<not> marked (hd s)"
      have "currentLevel (prefixToLevel level t) \<le> level"
        by (simp add:currentLevelPrefixToLevel)
      from `s \<noteq> []` have "s = [hd s] @ (tl s)"
        by simp
      with `(prefixToLevel level t) @ s = t` have
        "t = (prefixToLevel level t) @ [hd s] @ (tl s)"
        by simp
      hence "(prefixToLevel level t) = (prefixToLevel level ((prefixToLevel level t) @ [hd s] @ (tl s)))"
        by simp
      also
      with `currentLevel (prefixToLevel level t) \<le> level`
      have "\<dots> = ((prefixToLevel level t) @ (prefixToLevel_aux ([hd s] @ (tl s)) level (currentLevel (prefixToLevel level t))))"
        by (auto simp add: prefixToLevelAppend)
      also
      have "\<dots> =
        ((prefixToLevel level t) @ (hd s) # prefixToLevel_aux (tl s) level (currentLevel (prefixToLevel level t)))"
      proof-
        from `currentLevel (prefixToLevel level t) <= level` `\<not> marked (hd s)`
        have "prefixToLevel_aux ([hd s] @ (tl s)) level (currentLevel (prefixToLevel level t)) =
          (hd s) # prefixToLevel_aux (tl s) level (currentLevel (prefixToLevel level t))"
          by simp
        thus ?thesis
          by simp
      qed
      ultimately
      have "(prefixToLevel level t) = (prefixToLevel level t) @ (hd s) # prefixToLevel_aux (tl s) level (currentLevel (prefixToLevel level t))"
        by simp
      hence "False"
        by auto
    }
    thus ?thesis
      by auto
  qed
  ultimately
  show ?thesis
    by auto
qed

lemma prefixToLevelElementsElementLevel:
  assumes
  "e  \<in> set (elements (prefixToLevel level M))"
  shows
  "elementLevel e M \<le> level"
proof -
  have "elementLevel e (prefixToLevel level M) \<le> currentLevel (prefixToLevel  level M)"
    by (simp add: elementLevelLeqCurrentLevel)
  moreover
  hence "currentLevel (prefixToLevel level M) \<le> level"
    using currentLevelPrefixToLevel[of "level" "M"]
    by simp
  ultimately have "elementLevel e (prefixToLevel level M) \<le> level"
    by simp
  moreover
  have "isPrefix (prefixToLevel level M) M"
    by (simp add:isPrefixPrefixToLevel)
  then obtain s
    where "(prefixToLevel level M) @ s = M"
    unfolding isPrefix_def
    by auto
  with `e  \<in> set (elements (prefixToLevel level M))`
  have "elementLevel e (prefixToLevel level M) = elementLevel e M"
    using elementLevelAppend [of "e" "prefixToLevel level M" "s"]
    by simp
  ultimately
  show ?thesis
    by simp
qed

lemma elementLevelLtLevelImpliesMemberPrefixToLevel_aux:
  assumes
  "e  \<in> set(elements M)" and
  "elementLevel e M + i \<le> level" and
  "i \<le> level"
  shows
  "e  \<in> set (elements (prefixToLevel_aux M level i))"
using assms
proof (induct M arbitrary: i)
  case (Cons m M')
  thus ?case
  proof (cases "e = element m")
    case True
    thus ?thesis
      using `elementLevel e (m # M') + i \<le> level`
      unfolding prefixToLevel_def
      unfolding elementLevel_def
      unfolding markedElementsTo_def
      by (simp split: split_if_asm)
  next
    case False
    with `e \<in> set (elements (m # M'))`
    have "e \<in> set (elements M')"
      by simp

    show ?thesis
    proof (cases "marked m")
      case True
      with Cons `e \<noteq> element m`
      have "(elementLevel e M') + i + 1 \<le> level"
        unfolding elementLevel_def
        unfolding markedElementsTo_def
        by (simp split: split_if_asm)
      moreover
      have "elementLevel e M' \<ge> 0"
        by auto
      ultimately
      have "i + 1 \<le> level"
        by simp
      with `e \<in> set (elements M')` `(elementLevel e M') + i + 1 \<le> level` Cons(1)[of "i+1"]
      have "e \<in> set (elements (prefixToLevel_aux M' level (i + 1)))"
        by simp
      with `e \<noteq> element m` `i + 1 \<le> level` True
      show ?thesis
        by simp
    next
      case False
      with `e \<noteq> element m` `elementLevel e (m # M') + i \<le> level` have "elementLevel e M' + i \<le> level"
        unfolding elementLevel_def
        unfolding markedElementsTo_def
        by (simp split: split_if_asm)
      with `e \<in> set (elements M')` have "e \<in> set (elements (prefixToLevel_aux M' level i))"
        using Cons
        by (auto split: split_if_asm)
      with `e \<noteq> element m` False show ?thesis
        by simp
    qed
  qed
qed simp

lemma elementLevelLtLevelImpliesMemberPrefixToLevel:
  assumes
  "e \<in> set (elements M)" and
  "elementLevel e M \<le> level"
  shows
  "e \<in> set (elements (prefixToLevel level M))"
using assms
using elementLevelLtLevelImpliesMemberPrefixToLevel_aux[of "e" "M" "0" "level"]
unfolding prefixToLevel_def
by simp

lemma literalNotInEarlierLevelsThanItsLevel:
  assumes
  "level < elementLevel e M"
  shows
  "e \<notin> set (elements (prefixToLevel level M))"
proof-
  {
    assume "\<not> ?thesis"
    hence "level \<ge> elementLevel e M"
      by (simp add: prefixToLevelElementsElementLevel)
    with `level < elementLevel e M`
    have False
      by simp
  }
  thus ?thesis
    by auto
qed

lemma elementLevelPrefixElement:
  assumes "e \<in> set (elements (prefixToLevel level M))"
  shows "elementLevel e (prefixToLevel level M) = elementLevel e M"
using assms
proof-
  have "isPrefix (prefixToLevel level M) M"
    by (simp add: isPrefixPrefixToLevel)
  then obtain s where "(prefixToLevel level M) @ s = M"
    unfolding isPrefix_def
    by auto
  with assms show ?thesis
    using elementLevelAppend[of "e" "prefixToLevel level M" "s"]
    by auto
qed

lemma currentLevelZeroTrailEqualsItsPrefixToLevelZero:
  assumes "currentLevel M = 0"
  shows "M = prefixToLevel 0 M"
using assms
proof (induct M)
  case (Cons a M')
  show ?case
  proof-
    from Cons
    have "currentLevel M' = 0" and "markedElements M' = []" and "\<not> marked a"
      unfolding currentLevel_def
      by (auto split: split_if_asm)
    thus ?thesis
      using Cons
      unfolding prefixToLevel_def
      by auto
  qed
next
  case Nil
  thus ?case
    unfolding currentLevel_def
    unfolding prefixToLevel_def
    by simp
qed

(*--------------------------------------------------------------------------------*)
subsection{* Number of literals of every trail level *}

primrec
levelsCounter_aux :: "'a Trail \<Rightarrow> nat list \<Rightarrow> nat list"
where
  "levelsCounter_aux [] l = l"
| "levelsCounter_aux (h # t) l =
    (if (marked h) then
        levelsCounter_aux t (l @ [1])
     else
        levelsCounter_aux t (butlast l @ [Suc (last l)])
    )"

definition
levelsCounter :: "'a Trail \<Rightarrow> nat list"
where
"levelsCounter t = levelsCounter_aux t [0]"

lemma levelsCounter_aux_startIrellevant:
  "\<forall> y. y \<noteq> [] \<longrightarrow> levelsCounter_aux a (x @ y) = (x @ levelsCounter_aux a y)"
by (induct a) (auto simp add: butlastAppend)

lemma levelsCounter_auxSuffixContinues: "\<forall> l. levelsCounter_aux (a @ b) l = levelsCounter_aux b (levelsCounter_aux a l)"
by (induct a) auto

lemma levelsCounter_auxNotEmpty: "\<forall> l. l \<noteq> [] \<longrightarrow> levelsCounter_aux a l \<noteq> []"
by (induct a) auto

lemma levelsCounter_auxIncreasesFirst:
"\<forall> m n l1 l2. levelsCounter_aux a (m # l1) = n # l2 \<longrightarrow> m <= n"
proof (induct "a")
  case Nil
  {
    fix m::nat and n::nat and l1::"nat list" and l2::"nat list"
    assume "levelsCounter_aux [] (m # l1) = n # l2"
    hence "m = n"
      by simp
  }
  thus ?case
    by simp
next
  case (Cons a list)
  {
    fix m::nat and n::nat and l1::"nat list" and l2::"nat list"
    assume "levelsCounter_aux (a # list) (m # l1) = n # l2"
    have "m <= n"
    proof (cases "marked a")
      case True
      with `levelsCounter_aux (a # list) (m # l1) = n # l2`
      have "levelsCounter_aux list (m # l1 @ [Suc 0]) = n # l2"
        by simp
      with Cons
      show ?thesis
        by auto
    next
      case False
      show ?thesis
      proof (cases "l1 = []")
        case True
        with `\<not> marked a` `levelsCounter_aux (a # list) (m # l1) = n # l2`
        have "levelsCounter_aux list [Suc m] = n # l2"
          by simp
        with Cons
        have "Suc m <= n"
          by auto
        thus ?thesis
          by simp
      next
        case False
        with `\<not> marked a` `levelsCounter_aux (a # list) (m # l1) = n # l2`
        have "levelsCounter_aux list (m # butlast l1 @ [Suc (last l1)]) = n # l2"
          by simp
        with Cons
        show ?thesis
          by auto
      qed
    qed
  }
  thus ?case
    by simp
qed

lemma levelsCounterPrefix:
  assumes "(isPrefix p a)"
  shows "? rest. rest \<noteq> [] \<and> levelsCounter a = butlast (levelsCounter p) @ rest \<and> last (levelsCounter p) \<le> hd rest"
proof-
  from assms
  obtain s :: "'a Trail" where "p @ s = a"
    unfolding isPrefix_def
    by auto
  from `p @ s = a` have "levelsCounter a = levelsCounter (p @ s)"
    by simp
  show ?thesis
  proof (cases "s = []")
    case True
    have "(levelsCounter a) = (butlast (levelsCounter p)) @ [last (levelsCounter p)] \<and>
      (last (levelsCounter p)) <= hd [last (levelsCounter p)]"
      using `p @ s = a` `s = []`
      unfolding levelsCounter_def
      using levelsCounter_auxNotEmpty[of "p"]
      by auto
    thus ?thesis
      by auto
  next
    case False
    show ?thesis
    proof (cases "marked (hd s)")
      case True
      from `p @ s = a` have "levelsCounter a = levelsCounter (p @ s)"
        by simp
      also
      have "\<dots> = levelsCounter_aux s (levelsCounter_aux p [0])"
        unfolding levelsCounter_def
        by (simp add: levelsCounter_auxSuffixContinues)
      also
      have "\<dots> = levelsCounter_aux (tl s) ((levelsCounter_aux p [0]) @ [1])"
      proof-
        from `s \<noteq> []` have "s = hd s # tl s"
          by simp
        then have "levelsCounter_aux s (levelsCounter_aux p [0]) = levelsCounter_aux (hd s # tl s) (levelsCounter_aux p [0])"
          by simp
        with `marked (hd s)` show ?thesis
          by simp
      qed
      also
      have "\<dots> = levelsCounter_aux p [0] @ (levelsCounter_aux (tl s) [1])"
        by (simp add: levelsCounter_aux_startIrellevant)
      finally
      have "levelsCounter a = levelsCounter p @ (levelsCounter_aux (tl s) [1])"
        unfolding levelsCounter_def
        by simp
      hence "(levelsCounter a) = (butlast (levelsCounter p)) @ ([last (levelsCounter p)] @ (levelsCounter_aux (tl s) [1])) \<and>
        (last (levelsCounter p)) <= hd ([last (levelsCounter p)] @ (levelsCounter_aux (tl s) [1]))"
        unfolding levelsCounter_def
        using levelsCounter_auxNotEmpty[of "p"]
        by auto
      thus ?thesis
        by auto
    next
      case False
      from `p @ s = a` have "levelsCounter a = levelsCounter (p @ s)"
        by simp
      also
      have "\<dots> = levelsCounter_aux s (levelsCounter_aux p [0])"
        unfolding levelsCounter_def
        by (simp add: levelsCounter_auxSuffixContinues)
      also
      have "\<dots> = levelsCounter_aux (tl s) ((butlast (levelsCounter_aux p [0])) @ [Suc (last (levelsCounter_aux p [0]))])"
      proof-
        from `s \<noteq> []` have "s = hd s # tl s"
          by simp
        then have "levelsCounter_aux s (levelsCounter_aux p [0]) = levelsCounter_aux (hd s # tl s) (levelsCounter_aux p [0])"
          by simp
        with `~marked (hd s)` show ?thesis
          by simp
      qed
      also
      have "\<dots> = butlast (levelsCounter_aux p [0]) @ (levelsCounter_aux (tl s) [Suc (last (levelsCounter_aux p [0]))])"
        by (simp add: levelsCounter_aux_startIrellevant)
      finally
      have "levelsCounter a = butlast (levelsCounter_aux p [0]) @ (levelsCounter_aux (tl s) [Suc (last (levelsCounter_aux p [0]))])"
        unfolding levelsCounter_def
        by simp
      moreover
      have "hd (levelsCounter_aux (tl s) [Suc (last (levelsCounter_aux p [0]))]) >= Suc (last (levelsCounter_aux p [0]))"
      proof-
        have "(levelsCounter_aux (tl s) [Suc (last (levelsCounter_aux p [0]))]) \<noteq> []"
          using levelsCounter_auxNotEmpty[of "tl s"]
          by simp
        then obtain h t where "(levelsCounter_aux (tl s) [Suc (last (levelsCounter_aux p [0]))]) = h # t"
          using neq_Nil_conv[of "(levelsCounter_aux (tl s) [Suc (last (levelsCounter_aux p [0]))])"]
          by auto
        hence "h \<ge> Suc (last (levelsCounter_aux p [0]))"
          using levelsCounter_auxIncreasesFirst[of "tl s"]
          by auto
        with `(levelsCounter_aux (tl s) [Suc (last (levelsCounter_aux p [0]))]) = h # t`
        show ?thesis
          by simp
      qed
      ultimately
      have "levelsCounter a = butlast (levelsCounter p) @ (levelsCounter_aux (tl s) [Suc (last (levelsCounter_aux p [0]))]) \<and>
        last (levelsCounter p) \<le> hd (levelsCounter_aux (tl s) [Suc (last (levelsCounter_aux p [0]))])"
        unfolding levelsCounter_def
        by simp
      thus ?thesis
        using levelsCounter_auxNotEmpty[of "tl s"]
        by auto
    qed
  qed
qed

lemma levelsCounterPrefixToLevel:
  assumes "p = prefixToLevel level a" "level \<ge> 0" "level < currentLevel a"
  shows "? rest . rest \<noteq> [] \<and> (levelsCounter a) = (levelsCounter p) @ rest"
proof-
  from assms
  obtain s :: "'a Trail" where "p @ s = a" "s \<noteq> []" "marked (hd s)"
    using isProperPrefixPrefixToLevel[of "level" "a"]
    by auto
  from `p @ s = a` have "levelsCounter a = levelsCounter (p @ s)"
    by simp
  also
  have "\<dots> = levelsCounter_aux s (levelsCounter_aux p [0])"
    unfolding levelsCounter_def
    by (simp add: levelsCounter_auxSuffixContinues)
  also
  have "\<dots> = levelsCounter_aux (tl s) ((levelsCounter_aux p [0]) @ [1])"
  proof-
    from `s \<noteq> []` have "s = hd s # tl s"
      by simp
    then have "levelsCounter_aux s (levelsCounter_aux p [0]) = levelsCounter_aux (hd s # tl s) (levelsCounter_aux p [0])"
      by simp
    with `marked (hd s)` show ?thesis
      by simp
  qed
  also
  have "\<dots> = levelsCounter_aux p [0] @ (levelsCounter_aux (tl s) [1])"
    by (simp add: levelsCounter_aux_startIrellevant)
  finally
  have "levelsCounter a = levelsCounter p @ (levelsCounter_aux (tl s) [1])"
    unfolding levelsCounter_def
    by simp
  moreover
  have "levelsCounter_aux (tl s) [1] \<noteq> []"
    by (simp add: levelsCounter_auxNotEmpty)
  ultimately
  show ?thesis
    by simp
qed

(*--------------------------------------------------------------------------------*)
subsection{* Prefix before last marked element *}

primrec
prefixBeforeLastMarked  :: "'a Trail \<Rightarrow> 'a Trail"
where
  "prefixBeforeLastMarked [] = []"
| "prefixBeforeLastMarked (h#t) =  (if (marked h) \<and> (markedElements t) = [] then [] else (h#(prefixBeforeLastMarked t)))"

lemma prefixBeforeLastMarkedIsPrefixBeforeLastLevel:
  assumes "markedElements M \<noteq> []"
  shows "prefixBeforeLastMarked M = prefixToLevel ((currentLevel M) - 1) M"
using assms
proof (induct M)
  case Nil
  thus ?case
    by simp
next
  case (Cons a M')
  thus ?case
  proof (cases "marked a")
    case True
    hence "currentLevel (a # M') \<ge> 1"
      unfolding currentLevel_def
      by simp
    with True Cons show ?thesis
      using prefixToLevel_auxIncreaseAuxilaryCounter[of "0" "1" "M'" "currentLevel M' - 1"]
      unfolding prefixToLevel_def
      unfolding currentLevel_def
      by auto
  next
    case False
    with Cons show ?thesis
      unfolding prefixToLevel_def
      unfolding currentLevel_def
      by auto
  qed
qed

lemma isPrefixPrefixBeforeLastMarked:
  shows "isPrefix (prefixBeforeLastMarked M) M"
unfolding isPrefix_def
by (induct M) auto

lemma lastMarkedNotInPrefixBeforeLastMarked:
  assumes "uniq (elements M)" and "markedElements M \<noteq> []"
  shows "\<not> (lastMarked M) \<in> set (elements (prefixBeforeLastMarked M))"
using assms
unfolding lastMarked_def
by (induct M) (auto split: split_if_asm simp add: markedElementsAreElements)

lemma uniqImpliesPrefixBeforeLastMarkedIsPrefixBeforeLastMarked:
  assumes "markedElements M \<noteq> []" and "(lastMarked M) \<notin> set (elements M)"
  shows "prefixBeforeLastMarked M = prefixBeforeElement (lastMarked M) M"
using assms
unfolding lastMarked_def
proof (induct M)
  case Nil
  thus ?case
    by auto
next
  case (Cons a M')
  show ?case
  proof (cases "marked a \<and> (markedElements M') = []")
    case True
    thus ?thesis
      unfolding lastMarked_def
      by auto
  next
    case False
    hence "last (markedElements (a # M')) = last (markedElements M')"
      by auto
    thus ?thesis
      using Cons
      by (auto split: split_if_asm simp add: markedElementsAreElements)
  qed
qed

lemma markedElementsAreElementsBeforeLastDecisionAndLastDecision:
  assumes "markedElements M \<noteq> []"
  shows "(markedElements M) = (markedElements (prefixBeforeLastMarked M)) @ [lastMarked M]"
using assms
unfolding lastMarked_def
by (induct M) (auto split: split_if_asm)

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.*)
  theory TIP_weird_nat_mul3_spec
  imports "../../Test_Base"
begin

datatype Nat = Z | S "Nat"

fun plus :: "Nat => Nat => Nat" where
  "plus (Z) y = y"
| "plus (S z) y = S (plus z y)"

fun times :: "Nat => Nat => Nat" where
  "times (Z) y = Z"
| "times (S z) y = plus y (times z y)"

fun add3 :: "Nat => Nat => Nat => Nat" where
  "add3 (Z) (Z) z = z"
| "add3 (Z) (S x3) z = plus (S Z) (add3 Z x3 z)"
| "add3 (S x2) y z = plus (S Z) (add3 x2 y z)"

fun mul3 :: "Nat => Nat => Nat => Nat" where
  "mul3 (Z) y z = Z"
| "mul3 (S x2) (Z) z = Z"
| "mul3 (S x2) (S x3) (Z) = Z"
| "mul3 (S x2) (S x3) (S x4) =
     (let fail :: Nat =
       plus
         (S Z)
         (add3
            (mul3 x2 x3 x4)
            (add3 (mul3 (S Z) x3 x4) (mul3 x2 (S Z) x4) (mul3 x2 x3 (S Z)))
            (add3 x2 x3 x4))
     in (if (x2 = Z) then
           (if (x3 = Z) then (if (x4 = Z) then S Z else fail) else fail)
           else
           fail))"

theorem property0 :
  "((mul3 x y z) = (times (times x y) z))"
  oops

end


(*  Title:      TwoSquares.thy
    Authors:    Roelof Oosterhuis, 2007  Rijksuniversiteit Groningen
                Jaime Mendizabal Roche, 2016
*)

theory TwoSquares
imports
  "HOL-Number_Theory.Number_Theory"
begin

context

  fixes sum2sq_nat :: "nat \<Rightarrow> nat \<Rightarrow> nat"
  defines "sum2sq_nat a b \<equiv> a^2+b^2"

  fixes is_sum2sq_nat :: "nat \<Rightarrow> bool"
  defines "is_sum2sq_nat n \<equiv> (\<exists> a b. n = sum2sq_nat a b)"

begin

(* TODO: move this lemma to the distribution (?). (It is used also in QuadForm and FourSquares) *)
private lemma best_division_abs: "(n::int) > 0 \<Longrightarrow> \<exists> k. 2 * \<bar>a - k*n\<bar> \<le> n"
proof -
  assume a: "n > 0"
  define k where "k = a div n"
  hence h: "a - k * n = a mod n" by (simp add: mod_div_mult_eq algebra_simps)
  thus ?thesis
  proof (cases "2 * (a mod n) \<le> n")
    case True
    hence "2 * \<bar>a - k*n\<bar> \<le> n" using h pos_mod_sign a by auto
    thus ?thesis by blast
  next
    case False
    hence "2 * (n - a mod n) \<le> n" by auto
    have "a - (k+1)*n = a mod n - n" using h by (simp add: algebra_simps)
    hence "2 * \<bar>a - (k+1)*n\<bar> \<le> n" using h pos_mod_bound[of n a] a False by fastforce
    thus ?thesis by blast
  qed
qed

private definition
  sum2sq_int :: "int \<times> int \<Rightarrow> int" where
  "sum2sq_int = (\<lambda>(a,b). a^2+b^2)"

private definition
  is_sum2sq_int :: "int \<Rightarrow> bool" where
  "is_sum2sq_int n \<longleftrightarrow> (\<exists> a b. n = sum2sq_int(a,b))"

private lemma sum2sq_int_nat_eq: "sum2sq_nat a b = sum2sq_int (a, b)"
  unfolding sum2sq_nat_def sum2sq_int_def by simp

private lemma is_sum2sq_int_nat_eq: "is_sum2sq_nat n = is_sum2sq_int (int n)"
  unfolding is_sum2sq_nat_def is_sum2sq_int_def
proof
  assume "\<exists>a b. n = sum2sq_nat a b"
  thus "\<exists>a b. int n = sum2sq_int (a, b)" using sum2sq_int_nat_eq by force
next
  assume "\<exists>a b. int n = sum2sq_int (a, b)"
  then obtain a b where "int n = sum2sq_int (a, b)" by blast
  hence "int n = sum2sq_int (int (nat \<bar>a\<bar>), int (nat \<bar>b\<bar>))" unfolding sum2sq_int_def by simp
  hence "int n = int (sum2sq_nat (nat \<bar>a\<bar>) (nat \<bar>b\<bar>))" using sum2sq_int_nat_eq by presburger
  thus "\<exists>a b. n = sum2sq_nat a b" by auto
qed

private lemma product_two_squares_aux: "sum2sq_int(a, b) * sum2sq_int(c, d) = sum2sq_int(a*c - b*d, a*d + b*c)"
  unfolding power2_eq_square sum2sq_int_def by (simp add: algebra_simps)

private lemma product_two_squares_int: "is_sum2sq_int m \<Longrightarrow> is_sum2sq_int n \<Longrightarrow> is_sum2sq_int (m*n)"
  by (unfold is_sum2sq_int_def, auto simp only: product_two_squares_aux, blast)

private lemma product_two_squares_nat: "is_sum2sq_nat m \<Longrightarrow> is_sum2sq_nat n \<Longrightarrow> is_sum2sq_nat (m*n)"
  using product_two_squares_int is_sum2sq_int_nat_eq by simp

private lemma sots1_aux:
  assumes "prime (4*k+3)"
  assumes "odd (multiplicity (4*k+3) n)"
  shows "\<not> is_sum2sq_nat n"
proof
  assume "is_sum2sq_nat n"
  then obtain a b where h1: "n = a^2 + b^2"  unfolding is_sum2sq_nat_def sum2sq_nat_def by blast
  have ab_nz: "a \<noteq> 0 \<or> b \<noteq> 0" by (rule ccontr) (insert assms, auto simp: h1)
  let ?p = "4*k+3"
  let ?g = "gcd a b"
  have h2: "?g \<noteq> 0" using assms(2) h1 odd_pos by fastforce
  then obtain a' b' where h3: "a = a' * ?g" "b = b' * ?g" "coprime a' b'"
    using gcd_coprime_exists by blast
  have "?g^2 dvd n" using dvd_add h1 by auto
  then obtain m where h4: "m * ?g^2 = n" using dvd_div_mult_self by blast
  also have "\<dots> = (a' * ?g)^2 + (b' * ?g)^2" unfolding h1 using h3 by presburger
  also have "\<dots> = ?g^2 * a'^2 + ?g^2 * b'^2" unfolding power2_eq_square by simp
  finally have "?g^2 * m = ?g^2 * (a'^2 + b'^2)" by (simp add: distrib_left mult.commute)
  hence h5: "m = a'^2 + b'^2" using h2 by auto
  let ?mul = "multiplicity ?p ?g"
  have "multiplicity ?p (?g^2) = ?mul + ?mul"
    unfolding power2_eq_square using h2 assms
    by (subst prime_elem_multiplicity_mult_distrib) simp_all
  hence "even (multiplicity ?p (?g^2))" by simp
  moreover have "m \<noteq> 0" using assms(2) h4 odd_pos by fastforce
  ultimately have "odd (multiplicity ?p m)"
    using assms ab_nz by (simp_all add: h4 [symmetric] prime_elem_multiplicity_mult_distrib)
  hence "?p dvd m" using not_dvd_imp_multiplicity_0 by force
  hence h6: "?p dvd a'^2+b'^2" using h5 by auto
  {
    assume "?p dvd a'^2"
    moreover hence "?p dvd b'^2" using h6 dvd_add_right_iff by blast
    ultimately have "?p dvd a'" "?p dvd b'" using assms(1) prime_dvd_power_nat by blast+
    hence "False"
      using assms(1) h3(3) coprime_common_divisor_nat[of a' b' ?p] not_prime_1 by linarith
  }
  hence "\<not> (?p dvd a'^2)" ..
  hence h7: "\<not> (?p dvd a')" using assms(1)
    by (simp add: power2_eq_square prime_dvd_mult_iff)
  hence "coprime ?p a'"
    using assms(1) by (simp add: prime_imp_coprime)
  thm prime_imp_coprime_nat
  moreover have "a' \<noteq> 0" using h7 dvd_0_right[of ?p] by meson
  ultimately obtain ainv aux where "a' * ainv = ?p * aux + 1"
    using bezout_nat[of "a'" ?p]
    by (auto simp: ac_simps)
  hence "[a' * ainv = 1] (mod ?p)" using cong_to_1'_nat by auto
  from cong_mult [OF this this] have h11: "[1 = ainv^2 * a'^2] (mod ?p)"
    unfolding power2_eq_square by (simp add: algebra_simps cong_sym)
  let ?bdiva = "ainv * b'"
  have "[ainv^2 * (a'^2 + b'^2) = 0] (mod ?p)"
    using h6 cong_dvd_modulus_nat cong_mult_self_right by blast
  from cong_add [OF h11 this] have "[1 + ainv^2 * b'^2 = 0] (mod ?p)"
    unfolding add_mult_distrib2 using cong_add_lcancel_nat[of "ainv^2 * a'^2"]
    by fastforce
  hence h8: "[?bdiva^2 + 1 = 0] (mod ?p)" by (simp add: power_mult_distrib)
  {
    assume "?p dvd ?bdiva"
    hence "?p dvd (?bdiva^2)" by (simp add: assms(1) prime_dvd_power_nat_iff)
    hence "[?bdiva^2 = 0] (mod ?p)" using cong_altdef_nat by auto
    hence "[?bdiva^2 +1 = 1] (mod ?p)" using cong_add_rcancel_0_nat by blast
    from this h8 have "[0 = 1] (mod ?p)" using cong_sym cong_trans by blast
    hence "?p dvd 1" using cong_0_1_nat by auto
    hence "False" using assms(1) by simp
  }
  hence "\<not> (?p dvd ?bdiva)" ..
  hence h9: "[?bdiva^(?p-1) = 1] (mod ?p)"
    using assms(1) fermat_theorem [of ?p ?bdiva] by simp
  have h10: "?p\<ge>3" by simp
  have h11: "[?bdiva^(4*k+2) = 1] (mod ?p)" using h9 by auto
  have "[(?bdiva^2 + 1)^2 = 0] (mod ?p)" using h8 cong_pow [of "?bdiva^2 + 1" 0 ?p 2] by auto
  moreover have "?bdiva ^ 4 = (?bdiva ^ 2) ^ 2" by auto
  hence "(?bdiva^2 + 1)^2 = ?bdiva^4 + ?bdiva^2 + ?bdiva^2 + 1"
    by (auto simp: algebra_simps power2_eq_square)
  ultimately have "[?bdiva^4 + ?bdiva^2 + ?bdiva^2 + 1 = 0] (mod ?p)" by simp
  moreover have "[?bdiva^4 + ?bdiva^2 + (?bdiva^2 + 1) = ?bdiva^4 + ?bdiva^2 + 0] (mod ?p)"
    using h8 cong_add_lcancel_nat by blast
  ultimately have "[?bdiva^4 + ?bdiva^2 = 0] (mod ?p)" by (simp add: cong_def)
  hence "[?bdiva^4 + ?bdiva^2 + 1 = 0 + 1] (mod ?p)" using cong_add_rcancel_nat by blast
  moreover have "[?bdiva^4 + (?bdiva^2 + 1) = ?bdiva^4 + 0] (mod ?p)"
    using h8 cong_add_lcancel_nat by blast
  ultimately have "[?bdiva^4 = 1] (mod ?p)" by (simp add: cong_def)
  hence "[(?bdiva^4)^k = 1^k] (mod ?p)" using cong_pow by blast
  hence h12: "[?bdiva^(4*k) = 1] (mod ?p)" by (simp add: power_mult)
  hence h13: "[?bdiva^(4*k)*(?bdiva^2 + 1) = 1*(?bdiva^2 + 1)] (mod ?p)"
    using cong_scalar_right by blast
  have "?bdiva^(4*k)*(?bdiva^2 + 1) = ?bdiva^(4*k+2)+?bdiva^(4*k)"
    unfolding add_mult_distrib2 power_add by simp
  hence "[?bdiva^(4*k+2)+?bdiva^(4*k) = ?bdiva^2 + 1] (mod ?p)"
    using h13 unfolding nat_mult_1 by presburger
  moreover have "[?bdiva^(4*k+2) + ?bdiva^(4*k) = 1 + 1] (mod ?p)"
    using h11 h12 cong_add by blast
  ultimately have "[?bdiva^2 + 1 = 2] (mod ?p)"
    by (auto simp add: cong_def)
  hence "[0 = 2] (mod ?p)" using h8 by (simp add: cong_def)
  then have "?p dvd 2" by (auto dest: cong_dvd_iff)
  then show False
    by (auto dest: dvd_imp_le)
qed

private lemma sots1: assumes "is_sum2sq_nat n"
  shows "\<And> k. prime (4*k+3) \<longrightarrow> even (multiplicity (4*k+3) n)"
using sots1_aux assms by blast

private lemma aux_lemma: assumes "[(a::nat) = b] (mod c)" "b < c"
  shows "\<exists> k. a = c*k + b"
proof -
  have "a mod c = b" using assms by (simp add: cong_def mod_if)
  hence "b \<le> a" using assms by auto
  thus ?thesis using cong_le_nat assms(1) by auto
qed

private lemma Legendre_1mod4: "prime (4*k+1::nat) \<Longrightarrow> (Legendre (-1) (4*k+1)) = 1"
proof -
  let ?p = "4*k+1"
  let ?L = "Legendre (-1) ?p"
  assume p: "prime ?p"
  from p have "k \<noteq> 0" by (intro notI) simp_all
  hence p2: "?p > 2" by simp
  with p have "[?L = (-1)^((?p - 1) div 2)] (mod ?p)"
    by (rule euler_criterion)
  hence "[?L = (-1)^(2 * nat k)] (mod ?p)" by auto
  hence "[?L = 1] (mod ?p)" unfolding power_mult by simp
  hence "?p dvd 1-?L"
    using cong_iff_dvd_diff dvd_minus_iff[of ?p "?L-1"] by auto
  moreover have "?L=1 \<or> ?L=0 \<or> ?L=-1" by (simp add: Legendre_def)
  ultimately have "?L = 1 \<or> ?p dvd 1 \<or> ?p dvd (2::int)" by auto
  moreover
  { assume "?p dvd 1 \<or> ?p dvd (2::int)"
    with p2 have False by (auto simp add: zdvd_not_zless) }
  ultimately show ?thesis by auto
qed

private lemma qf1_prime_exists: "prime (4*k+1) \<Longrightarrow> is_sum2sq_nat (4*k+1)"
proof -
  let ?p = "4*k+1"
  assume p: "prime ?p"
  hence "Legendre (-1) ?p = 1" by (rule Legendre_1mod4)
  moreover
  { assume "\<not> QuadRes ?p (-1)"
    hence "Legendre (-1) ?p \<noteq> 1" by (unfold Legendre_def, auto) }
  ultimately have "QuadRes ?p (-1)" by auto
  then obtain s1 where s1: "[s1^2 = -1] (mod ?p)" by (auto simp add: QuadRes_def)
  hence s1': "[s1^2 + 1 = 0] (mod ?p)" by (simp add: cong_iff_dvd_diff)
  define s2 where "s2 = nat \<bar>s1\<bar>"
  hence "int (s2^2 + 1) = s1^2 + 1" by auto
  with s1' have "[int (s2^2 + 1) = 0] (mod ?p)" by presburger
  hence s2: "[s2^2 + 1 = 0] (mod ?p)"
    using cong_int_iff by fastforce
  from p have p0: "?p > 0" by simp
  then obtain s where s0p: "0 \<le> s \<and> s < ?p \<and> [s2 = s] (mod ?p)"
    using cong_less_unique_nat[of ?p] by fastforce
  then have "[s^2 = s2^2] (mod ?p)"
    by (simp add: cong_sym cong_pow)
  with s2 have s: "[s^2 + 1 = 0] (mod ?p)"
    using cong_trans cong_add_rcancel_nat by blast
  hence "?p dvd s^2 + 1" using cong_altdef_nat by auto
  then obtain t where t: "s^2 + 1 = ?p*t" by (auto simp add: dvd_def)
  hence "?p*t = sum2sq_nat s 1" by (simp add: sum2sq_nat_def)
  hence qf1pt: "is_sum2sq_nat (?p*t)" by (auto simp add: is_sum2sq_nat_def)
  have t_l_p: "t < ?p"
  proof (rule ccontr)
    assume "\<not> t < ?p"
    hence "t > ?p - 1" by simp
    with p0 have "?p*(?p - 1) < ?p*t" by (simp only: mult_less_mono2)
    also with t have "\<dots> = s^2 + 1" by simp
    also have "\<dots> \<le> ?p*(?p - 1) - ?p + 2"
    proof -
      from s0p have "s \<le> ?p - 1" by (auto simp add: less_le)
      with s0p have "s^2 \<le> (?p - 1)^2" by (simp only: power_mono)
      also have "\<dots> = ?p*(?p - 1) - 1*(?p - 1)" by (simp only: power2_eq_square diff_mult_distrib)
      finally show ?thesis by auto
    qed
    finally have "?p < 2" by simp
    with p show False by (unfold prime_def, auto)
  qed
  have tpos: "t \<ge> 1"
  proof (rule ccontr)
    assume "\<not> t \<ge> 1"
    hence "t < 1" by auto
    moreover
    { assume "t = 0" with t have "s^2 + 1 = 0" by simp }
     moreover
    { assume "t < 0"
      with p0 have "?p*t < ?p*0" by (simp only: zmult_zless_mono2)
      with t have "s^2 + 1 < 0" by auto }
    moreover have "s^2 \<ge> 0" by (simp only: zero_le_power2)
    ultimately show False by (auto simp add: less_le)
  qed
  moreover
  { assume t1: "t > 0"
    then obtain tn where tn: "tn = t - 1" by auto
    have "is_sum2sq_nat (?p*(1+ 0))" (is "?Q 0")
      \<comment> \<open>So, $Q~n =$ there exist $x,y$ such that $x^2+y^2 =(p*(1+ int(n)))$\<close>
    proof (rule ccontr)
      assume nQ1: "\<not> ?Q 0"
      have "(1 + tn) < ?p \<Longrightarrow> \<not> ?Q tn"
      proof (induct tn rule: infinite_descent0)
        case 0
        from nQ1 show "1+ 0 < ?p \<Longrightarrow> \<not> ?Q 0" by simp
      next
        case (smaller n)
        hence n0: "n > 0" and IH: "1+ n < ?p \<and> ?Q n" by auto
        then obtain x y where "x^2 + y^2 = int (?p*(1+ n))"
          using is_sum2sq_int_nat_eq by (unfold is_sum2sq_int_def sum2sq_int_def, auto)
        hence xy: "x^2 + y^2 = (int ?p)*(int (1+ n))" unfolding of_nat_mult by presburger
        let ?n1 = "int (1 + n)"
        from n0 have n1pos: "?n1 > 0" by simp
        then obtain r v where rv: "v = x-r*?n1 \<and> 2*\<bar>v\<bar> \<le> ?n1"
          by (frule_tac n="?n1" in best_division_abs, auto)
        from n1pos obtain s w where sw: "w = y-s*?n1 \<and> 2*\<bar>w\<bar> \<le> ?n1"
          by (frule_tac n="?n1" in best_division_abs, auto)
        let ?C = "v^2 + w^2"
        have "?n1 dvd ?C"
        proof
          from rv sw have "?C = (x-r*?n1)^2 + (y-s*?n1)^2" by simp
          also have "\<dots> = x^2 + y^2 - 2*x*(r*?n1) - 2*y*(s*?n1) + (r*?n1)^2 + (s*?n1)^2"
            unfolding power2_eq_square by (simp add: algebra_simps)
          also with xy have "\<dots> = ?n1*?p - ?n1*(2*x*r) - ?n1*(2*y*s) + ?n1^2*r^2 + ?n1^2*s^2"
            by (simp only: ac_simps power_mult_distrib)
          finally show "?C = ?n1*(?p - 2*x*r - 2*y*s + ?n1*(r^2 + s^2))"
            by (simp only: power_mult_distrib distrib_left ac_simps
              left_diff_distrib right_diff_distrib power2_eq_square)
        qed
        then obtain m1 where m1: "?C = ?n1*m1" by (auto simp add: dvd_def)
        have mn: "m1 < ?n1"
        proof (rule ccontr)
          assume "\<not> m1 < ?n1" hence "?n1-m1 \<le> 0" by simp
          hence "4*?n1 - 4*m1 \<le> 0" by simp
          with n1pos have "2*?n1 - 4*m1 < 0" by simp
          with n1pos have "?n1*(2*?n1 - 4*m1) < ?n1*0" by (simp only: zmult_zless_mono2)
          hence contr: "?n1*(2*?n1- 4*m1) < 0" by simp
          have hlp: "2*\<bar>v\<bar> \<ge> 0 \<and> 2*\<bar>w\<bar> \<ge> 0" by simp
          from m1 have "4*?n1*m1 = 4*v^2 + 4*w^2" by arith
          also have "\<dots> = (2*\<bar>v\<bar>)^2 + (2*\<bar>w\<bar>)^2"
            by (auto simp add: power_mult_distrib)
          also from rv hlp have "\<dots> \<le> ?n1^2 + (2*\<bar>w\<bar>)^2"
            using power_mono [of "2*\<bar>b\<bar>" "1 + int n" 2 for b] by auto
          also from sw hlp have "\<dots> \<le> ?n1^2 + ?n1^2"
            using power_mono [of "2*\<bar>b\<bar>" "1 + int n" 2 for b] by auto
          finally have "?n1*m1*4 \<le> ?n1*?n1*2" by (simp add: power2_eq_square ac_simps)
          hence "?n1*(2*?n1- 4*m1) \<ge> 0" by (simp only: right_diff_distrib ac_simps)
          with contr show False by auto
        qed
        have "?p*m1 = (r*v + s*w + m1)^2 + (r*w - s*v)^2"
        proof -
          from m1 xy have "(?p*?n1)*?C = (x^2+y^2)*(v^2+w^2)" by simp
          also have "\<dots> = (x*v + y*w)^2 + (x*w - y*v)^2"
            by (simp add: eval_nat_numeral field_simps)
          also with rv sw have "\<dots> = ((r*?n1+v)*v + (s*?n1+w)*w)^2 + ((r*?n1+v)*w - (s*?n1+w)*v)^2"
            by simp
          also have "\<dots> = (?n1*(r*v) + ?n1*(s*w) + (v^2+w^2))^2 + (?n1*(r*w) - ?n1*(s*v))^2"
            by (simp add: eval_nat_numeral field_simps)
          also from m1 have "\<dots> = (?n1*(r*v) + ?n1*(s*w) + ?n1*m1)^2 + (?n1*(r*w) - ?n1*(s*v))^2"
            by simp
          finally have "(?p*?n1)*?C = ?n1^2*(r*v + s*w + m1)^2 + ?n1^2*(r*w - s*v)^2"
            by (simp add: eval_nat_numeral field_simps)
          with m1 have "?n1^2*(?p*m1) = ?n1^2*((r*v + s*w + m1)^2 + (r*w - s*v)^2)"
            by (simp only: ac_simps power2_eq_square, simp add: distrib_left)
          hence "?n1^2*(?p*m1 - (r*v+s*w+m1)^2 - (r*w-s*v)^2) = 0"
            by (auto simp add: distrib_left right_diff_distrib)
          moreover from n1pos have "?n1^2 \<noteq> 0" by (simp add: power2_eq_square)
          ultimately show ?thesis by simp
        qed
        hence qf1pm1: "is_sum2sq_int ((int ?p)*m1)"
          by (unfold is_sum2sq_int_def sum2sq_int_def, auto)
        have m1pos: "m1 > 0"
        proof -
          { assume "v^2 + w^2 = 0"
            hence "v = 0 \<and> w = 0" using sum_power2_eq_zero_iff by blast
            with rv sw have "?n1 dvd x \<and> ?n1 dvd y" by (unfold dvd_def, auto)
            hence "?n1^2 dvd x^2 \<and> ?n1^2 dvd y^2" by simp
            hence "?n1^2 dvd x^2 + y^2" by (simp only: dvd_add)
            with xy have "?n1*?n1 dvd ?n1*?p" by (simp only: power2_eq_square ac_simps)
            moreover from n1pos have "?n1 \<noteq> 0" by simp
            ultimately have "?n1 dvd ?p" by (rule zdvd_mult_cancel)
            with n1pos have "?n1 \<ge> 0 \<and> ?n1 dvd ?p" by simp
            with p have "?n1 = 1 \<or> ?n1 = ?p" unfolding prime_nat_iff by presburger
            with IH have "?Q 0" by auto
            with nQ1 have False by simp }
          moreover
          { assume "v^2 + 1*w^2 \<noteq> 0"
            moreover have "v^2 + w^2 \<ge> 0" by simp
            ultimately have vwpos: "v^2 + w^2 > 0" by arith
            with m1 have "m1 \<noteq> 0" by auto
            moreover have "m1 \<ge> 0"
            proof (rule ccontr)
              assume "\<not> m1 \<ge> 0"
              hence "m1 < 0" by simp
              with n1pos have "?n1*m1 < ?n1*0" by (simp only: zmult_zless_mono2)
              with m1 vwpos show False by simp
            qed
            ultimately have ?thesis by auto }
          ultimately show ?thesis by auto
        qed
        hence "1 + int((nat m1) - 1) = m1" by arith
        with qf1pm1 have Qm1: "?Q ((nat m1) - 1)"
          using is_sum2sq_int_nat_eq by (simp add: algebra_simps)
        then obtain mm where tmp: "mm = (nat m1) - 1 \<and> ?Q mm" by auto
        moreover have "mm<n" using tmp mn m1pos by arith
        moreover with IH have "1 + int mm < ?p" by auto
        ultimately show ?case by auto
      qed
      hence "\<not> is_sum2sq_nat (?p*t)" using tn tpos t_l_p by auto
      with qf1pt show False by simp
    qed
    hence ?thesis by auto }
  ultimately show ?thesis by (auto simp add: less_le)
qed

private lemma fermat_two_squares: assumes "prime p" "(\<not> [p = 3] (mod 4))"
  shows "is_sum2sq_nat p"
proof (cases "p=2")
case True
  have "(2::nat)=1^2+1^2" using power2_eq_square by simp
  thus ?thesis unfolding is_sum2sq_nat_def sum2sq_nat_def using True by fast
next
case False
  hence "p > 2" using assms(1) unfolding prime_nat_iff by auto
  hence h1: "odd p" using assms(1) prime_odd_nat by simp
  hence h2: "\<not> [p = 0] (mod 4)" unfolding cong_def by fastforce
  have h3: "\<not> [p = 2] (mod 4)" using h1 cong_dvd_iff [of p 2 2] cong_dvd_modulus_nat by auto
  obtain x where h4: "[p = x] (mod 4) \<and> x<4" by (meson cong_less_unique_nat zero_less_numeral)
  from h1 h2 h3 h4 assms have "x\<noteq>0 \<and> x\<noteq>2 \<and> x\<noteq>3 \<and> x<4" by meson
  hence "x=1" by linarith
  from this h4 have "[p = 1] (mod 4)" by simp
  then obtain k where "p = 4*k+1" using aux_lemma by fastforce
  thus ?thesis using qf1_prime_exists assms by blast
qed

private lemma sots2: assumes "\<And> k. prime (4*k+3) \<longrightarrow> even (multiplicity (4*k+3) n)"
  shows "is_sum2sq_nat n" using assms
proof (induction n rule: nat_less_induct)
case (1 n)
  thus ?case
  proof (cases "n>1")
  case f: False
    thus ?thesis
    proof (cases "n=1")
    case True
      have "(1::nat)=0^2+1^2" by (simp add: power2_eq_square)
      thus ?thesis using True unfolding is_sum2sq_nat_def sum2sq_nat_def by blast
    next
    case False
      hence "n=0" using f by simp
      moreover have "(0::nat)=0^2+0^2" by (simp add: power2_eq_square)
      ultimately show ?thesis unfolding is_sum2sq_nat_def sum2sq_nat_def by blast
    qed
  next
  case True
  then obtain p m where h1: "prime p \<and> n = p * m" using prime_divisor_exists[of n]
    by (auto elim: dvdE)
  with True have m_nz: "m \<noteq> 0" by (intro notI) auto
  from h1 have h2: "m<n" using n_less_m_mult_n[of m p] prime_gt_Suc_0_nat[of p] True by linarith
    {
      assume a1: "[p = 3] (mod 4)"
      then obtain kp where "p = 4*kp+3" using aux_lemma by fastforce
      hence "even (multiplicity p n)" using "1.prems" h1 by auto
      moreover have "multiplicity p n \<noteq> 0" using h1 True m_nz
        by (subst multiplicity_eq_zero_iff) (auto simp: prime_gt_0_nat)
      ultimately have h3: "multiplicity p n \<ge> 2" by presburger
      have "p dvd m"
      proof (rule ccontr)
        assume a2: "\<not> p dvd m"
        hence "multiplicity p m = 0" by (rule not_dvd_imp_multiplicity_0)
        moreover from h1 have "multiplicity p p = 1" by (intro multiplicity_prime) auto
        moreover have "m > 0" using h1 True by (cases "m = 0") simp_all
        ultimately have "multiplicity p n = 1" using h1
          using prime_elem_multiplicity_mult_distrib [of p p m] m_nz prime_gt_0_nat
          by auto
        thus "False" using h3 by simp
      qed
      then obtain m' where h4: "m = p * m'" using dvdE by blast
      with h1 have h5: "n = p^2 * m'" by (simp add: power2_eq_square)
      have h6: "m'<n"
        using dual_order.strict_trans h1 h2 h4 nat_mult_less_cancel1 prime_gt_0_nat[of p] by blast
      have "\<And> kq. prime (4*kq + 3) \<Longrightarrow> even (multiplicity (4*kq + 3) m')"
      proof -
        fix kq::nat
        let ?q = "4*kq + 3"
        assume a2: "prime ?q"
        {
          assume p: "p=?q"
          hence h7: "multiplicity ?q (p^2) = 2" using h1
            by (auto intro!: multiplicity_prime_power)
          have "even (multiplicity ?q n)" using 1(2)[of kq] a2 by blast
          also note h5
          also from p h1 h4 m_nz
            have "multiplicity (4 * kq + 3) (p^2 * m') =
                    Suc (Suc (multiplicity (4 * kq + 3) m'))"
            by (subst prime_elem_multiplicity_mult_distrib) auto
          finally have "even (multiplicity ?q m')" by simp
        }
        moreover {
          assume "p\<noteq>?q"
          from a2 h4 m_nz have "multiplicity ?q n =
                                  multiplicity (4 * kq + 3) (p\<^sup>2) + multiplicity (4 * kq + 3) m'"
            unfolding h5 by (subst prime_elem_multiplicity_mult_distrib) simp_all
          also from \<open>p \<noteq> ?q\<close> a2 h1 have "multiplicity ?q (p^2) = 0"
            by (intro multiplicity_distinct_prime_power) simp_all
          finally have "multiplicity ?q n = multiplicity ?q m'" by simp
          moreover have "even (multiplicity ?q n)" using 1(2)[of kq] a2 by blast
          ultimately have "even (multiplicity ?q m')" by simp
        }
        ultimately show "even (multiplicity ?q m')" by blast
      qed
      hence "is_sum2sq_nat m'" by (simp add: 1 h6)
      moreover have "p^2 = p^2 + 0^2" by simp
      hence "is_sum2sq_nat (p^2)" unfolding is_sum2sq_nat_def sum2sq_nat_def by blast
      ultimately have ?thesis using product_two_squares_nat h5 by blast
    } moreover
    {
      assume a1: "\<not> [p = 3] (mod 4)"
      have "\<And> kq. prime (4*kq+3) \<Longrightarrow> even (multiplicity (4*kq+3) m)"
      proof -
        fix kq
        let ?q = "4*(kq::nat) + 3"
        assume a2: "prime ?q"
        { assume "p = ?q"
          then have False using a1 cong_add_rcancel_0_nat [of "4 * kq" 3 4]
            by (auto simp add: cong_def)
        }
        hence "p\<noteq>?q" ..

        have "n = p * m" using h1 by simp
        also from h1 a2 m_nz have "multiplicity ?q \<dots> =
                                  multiplicity (4 * kq + 3) p + multiplicity (4 * kq + 3) m"
          by (subst prime_elem_multiplicity_mult_distrib) (simp_all add: prime_gt_0_nat)
        also from \<open>p \<noteq> ?q\<close> a2 h1 have "multiplicity ?q p = 0"
          by (intro prime_multiplicity_other) simp_all
        finally have "multiplicity ?q n = multiplicity ?q m" by simp
        moreover have "even (multiplicity ?q n)" using 1(2)[of kq] a2 by blast
        ultimately show "even (multiplicity ?q m)" by simp
      qed
      hence "is_sum2sq_nat m" by (simp add: 1 h2)
      moreover have "is_sum2sq_nat p" using fermat_two_squares a1 h1 by blast
      ultimately have ?thesis using product_two_squares_nat h1 by blast
    } ultimately
    show ?thesis by blast
  qed
qed

theorem sum_of_two_squares:
    "is_sum2sq_nat n \<longleftrightarrow> (\<forall> k. prime (4*k+3) \<longrightarrow> even (multiplicity (4*k+3) n))"
  using sots1[of n] sots2[of n] by blast

private lemma k_mod_eq: "(\<forall>p::nat. prime p \<and> [p = 3] (mod 4) \<longrightarrow> P p) = (\<forall>k. prime (4*k+3) \<longrightarrow> P (4*k+3))"
proof
  assume a1: "\<forall>p. prime p \<and> [p = 3] (mod 4) \<longrightarrow> P p"
  {
    fix k :: nat
    assume "prime (4 * k + 3)"
    moreover hence "[4*k+3 = 3] (mod 4)"
      by (simp add: cong_add_rcancel_0_nat cong_mult_self_left)
    ultimately have "P (4 * k + 3)" using a1 by blast
  }
  thus "\<forall>k. prime (4 * k + 3) \<longrightarrow> P (4 * k + 3)" by blast
next
  assume a1: "\<forall>k. prime (4 * k + 3) \<longrightarrow> P (4 * k + 3)"
  {
    fix p :: nat
    assume "prime p" "[p = 3] (mod 4)"
    moreover with aux_lemma obtain k where "p = 4*k+3" by fastforce
    ultimately have "P p" using a1 by blast
  }
  thus "\<forall>p. prime p \<and> [p = 3] (mod 4) \<longrightarrow> P p" by blast
qed

theorem sum_of_two_squares':
    "is_sum2sq_nat n \<longleftrightarrow> (\<forall> p. prime p \<and> [p = 3] (mod 4) \<longrightarrow> even (multiplicity p n))"
  using sum_of_two_squares k_mod_eq by presburger

theorem sum_of_two_squares_prime: assumes "prime p"
  shows "is_sum2sq_nat p = [p\<noteq>3] (mod 4)"
proof (cases "[p=3] (mod 4)")
case True
  have "odd (multiplicity p p)" using assms by simp
  hence "\<not> (is_sum2sq_nat p)" using assms True sum_of_two_squares' by blast
  with True show ?thesis by simp
qed (simp add: fermat_two_squares assms)

end

end


\<^marker>\<open>creator "Kevin Kappelmann"\<close>
subsection \<open>Transport using Bijections\<close>
theory Transport_Bijections
  imports
    HOL_Basics.Functions_Bijection
    Transport_Base
begin

paragraph \<open>Summary\<close>
text \<open>Setup for Transport using bijective transport functions.\<close>

locale transport_bijection =
  fixes L :: "'a \<Rightarrow> 'a \<Rightarrow> bool"
  and R :: "'b \<Rightarrow> 'b \<Rightarrow> bool"
  and l :: "'a \<Rightarrow> 'b"
  and r :: "'b \<Rightarrow> 'a"
  assumes mono_wrt_rel_left: "(L \<Rrightarrow>\<^sub>m R) l"
  and mono_wrt_rel_right: "(R \<Rrightarrow>\<^sub>m L) r"
  and inverse_left_right: "inverse_on (in_field L) l r"
  and inverse_right_left: "inverse_on (in_field R) r l"
begin

interpretation transport L R l r .

lemma bijection_on_in_field: "bijection_on (in_field (\<le>\<^bsub>L\<^esub>)) (in_field (\<le>\<^bsub>R\<^esub>)) l r"
  using mono_wrt_rel_left mono_wrt_rel_right inverse_left_right inverse_right_left
  by (intro bijection_onI in_field_if_in_field_if_mono_wrt_rel)
  auto

lemma half_galois_prop_left: "((\<le>\<^bsub>L\<^esub>) \<^sub>h\<unlhd> (\<le>\<^bsub>R\<^esub>)) l r"
  using mono_wrt_rel_left inverse_right_left
  by (intro half_galois_prop_leftI)
  (auto dest!: in_field_if_in_codom inverse_onD)

lemma half_galois_prop_right: "((\<le>\<^bsub>L\<^esub>) \<unlhd>\<^sub>h (\<le>\<^bsub>R\<^esub>)) l r"
  using mono_wrt_rel_right inverse_left_right
  by (intro half_galois_prop_rightI)
  (auto dest!: in_field_if_in_dom inverse_onD)

lemma galois_prop: "((\<le>\<^bsub>L\<^esub>) \<unlhd> (\<le>\<^bsub>R\<^esub>)) l r"
  using half_galois_prop_left half_galois_prop_right
  by (intro galois_propI)

lemma galois_connection: "((\<le>\<^bsub>L\<^esub>) \<stileturn> (\<le>\<^bsub>R\<^esub>)) l r"
  using mono_wrt_rel_left mono_wrt_rel_right galois_prop
  by (intro galois_connectionI)

lemma rel_equivalence_on_unitI:
  assumes "reflexive_on (in_field (\<le>\<^bsub>L\<^esub>)) (\<le>\<^bsub>L\<^esub>)"
  shows "rel_equivalence_on (in_field (\<le>\<^bsub>L\<^esub>)) (\<le>\<^bsub>L\<^esub>) \<eta>"
  using assms inverse_left_right
  by (subst rel_equivalence_on_unit_iff_reflexive_on_if_inverse_on)

interpretation flip : transport_bijection R L r l
  rewrites "order_functors.unit r l \<equiv> \<epsilon>"
  using mono_wrt_rel_left mono_wrt_rel_right inverse_left_right inverse_right_left
  by unfold_locales (simp_all only: flip_unit_eq_counit)

lemma galois_equivalence: "((\<le>\<^bsub>L\<^esub>) \<equiv>\<^sub>G (\<le>\<^bsub>R\<^esub>)) l r"
  using galois_connection flip.galois_prop by (intro galois_equivalenceI)

lemmas rel_equivalence_on_counitI = flip.rel_equivalence_on_unitI

lemma order_equivalenceI:
  assumes "reflexive_on (in_field (\<le>\<^bsub>L\<^esub>)) (\<le>\<^bsub>L\<^esub>)"
  and "reflexive_on (in_field (\<le>\<^bsub>R\<^esub>)) (\<le>\<^bsub>R\<^esub>)"
  shows "((\<le>\<^bsub>L\<^esub>) \<equiv>\<^sub>o (\<le>\<^bsub>R\<^esub>)) l r"
  using assms mono_wrt_rel_left mono_wrt_rel_right rel_equivalence_on_unitI
    rel_equivalence_on_counitI
  by (intro order_equivalenceI)

lemma preorder_equivalenceI:
  assumes "preorder_on (in_field (\<le>\<^bsub>L\<^esub>)) (\<le>\<^bsub>L\<^esub>)"
  and "preorder_on (in_field (\<le>\<^bsub>R\<^esub>)) (\<le>\<^bsub>R\<^esub>)"
  shows "((\<le>\<^bsub>L\<^esub>) \<equiv>\<^bsub>pre\<^esub> (\<le>\<^bsub>R\<^esub>)) l r"
  using assms by (intro preorder_equivalence_if_galois_equivalenceI
    galois_equivalence)
  simp_all

lemma partial_equivalence_rel_equivalenceI:
  assumes "partial_equivalence_rel (\<le>\<^bsub>L\<^esub>)"
  and "partial_equivalence_rel (\<le>\<^bsub>R\<^esub>)"
  shows "((\<le>\<^bsub>L\<^esub>) \<equiv>\<^bsub>PER\<^esub> (\<le>\<^bsub>R\<^esub>)) l r"
  using assms by (intro partial_equivalence_rel_equivalence_if_galois_equivalenceI
    galois_equivalence)
  simp_all

end

locale transport_reflexive_on_in_field_bijection =
  fixes L :: "'a \<Rightarrow> 'a \<Rightarrow> bool"
  and R :: "'b \<Rightarrow> 'b \<Rightarrow> bool"
  and l :: "'a \<Rightarrow> 'b"
  and r :: "'b \<Rightarrow> 'a"
  assumes reflexive_on_in_field_left: "reflexive_on (in_field L) L"
  and reflexive_on_in_field_right: "reflexive_on (in_field R) R"
  and transport_bijection: "transport_bijection L R l r"
begin

sublocale tbij? : transport_bijection L R l r
  rewrites "reflexive_on (in_field L) L \<equiv> True"
  and "reflexive_on (in_field R) R \<equiv> True"
  and "\<And>P. (True \<Longrightarrow> P) \<equiv> Trueprop P"
  using transport_bijection reflexive_on_in_field_left reflexive_on_in_field_right
  by auto

lemmas rel_equivalence_on_unit = rel_equivalence_on_unitI
lemmas rel_equivalence_on_counit = rel_equivalence_on_counitI
lemmas order_equivalence = order_equivalenceI

end

locale transport_preorder_on_in_field_bijection =
  fixes L :: "'a \<Rightarrow> 'a \<Rightarrow> bool"
  and R :: "'b \<Rightarrow> 'b \<Rightarrow> bool"
  and l :: "'a \<Rightarrow> 'b"
  and r :: "'b \<Rightarrow> 'a"
  assumes preorder_on_in_field_left: "preorder_on (in_field L) L"
  and preorder_on_in_field_right: "preorder_on (in_field R) R"
  and transport_bijection: "transport_bijection L R l r"
begin

sublocale trefl_bij? : transport_reflexive_on_in_field_bijection L R l r
  rewrites "preorder_on (in_field L) L \<equiv> True"
  and "preorder_on (in_field R) R \<equiv> True"
  and "\<And>P. (True \<Longrightarrow> P) \<equiv> Trueprop P"
  using transport_bijection
  by (intro transport_reflexive_on_in_field_bijection.intro)
  (insert preorder_on_in_field_left preorder_on_in_field_right, auto)

lemmas preorder_equivalence = preorder_equivalenceI

end

locale transport_partial_equivalence_rel_bijection =
  fixes L :: "'a \<Rightarrow> 'a \<Rightarrow> bool"
  and R :: "'b \<Rightarrow> 'b \<Rightarrow> bool"
  and l :: "'a \<Rightarrow> 'b"
  and r :: "'b \<Rightarrow> 'a"
  assumes partial_equivalence_rel_left: "partial_equivalence_rel L"
  and partial_equivalence_rel_right: "partial_equivalence_rel R"
  and transport_bijection: "transport_bijection L R l r"
begin

sublocale tpre_bij? : transport_preorder_on_in_field_bijection L R l r
  rewrites "partial_equivalence_rel L \<equiv> True"
  and "partial_equivalence_rel R \<equiv> True"
  and "\<And>P. (True \<Longrightarrow> P) \<equiv> Trueprop P"
  using transport_bijection
  by (intro transport_preorder_on_in_field_bijection.intro)
  (insert partial_equivalence_rel_left partial_equivalence_rel_right, auto)

lemmas partial_equivalence_rel_equivalence = partial_equivalence_rel_equivalenceI

end

locale transport_eq_restrict_bijection =
  fixes P :: "'a \<Rightarrow> bool"
  and Q :: "'b \<Rightarrow> bool"
  and l :: "'a \<Rightarrow> 'b"
  and r :: "'b \<Rightarrow> 'a"
  assumes bijection_on_in_field:
    "bijection_on (in_field ((=\<^bsub>P\<^esub>) :: 'a \<Rightarrow> _)) (in_field ((=\<^bsub>Q\<^esub>) :: 'b \<Rightarrow> _)) l r"
begin

interpretation transport "(=\<^bsub>P\<^esub>)" "(=\<^bsub>Q\<^esub>)" l r .

sublocale tper_bij? : transport_partial_equivalence_rel_bijection "(=\<^bsub>P\<^esub>)" "(=\<^bsub>Q\<^esub>)" l r
  using bijection_on_in_field partial_equivalence_rel_eq_restrict
    eq_restrict_le_eq
  by unfold_locales
  (auto elim: bijection_onE intro!:
    mono_wrt_rel_left_if_reflexive_on_if_le_eq_if_mono_wrt_in_field
      [of "in_field (=\<^bsub>Q\<^esub>)"]
    flip_of.mono_wrt_rel_left_if_reflexive_on_if_le_eq_if_mono_wrt_in_field
      [of "in_field (=\<^bsub>P\<^esub>)"])

lemma Galois_eq_Galois_eq_eq_restrict: "(\<^bsub>L\<^esub>\<lessapprox>) = (galois_rel.Galois (=) (=) r)\<restriction>\<^bsub>P\<^esub>\<upharpoonleft>\<^bsub>Q\<^esub>"
  by (subst galois_rel.Galois_restrict_left_eq_Galois_left_restrict_left
    galois_rel.Galois_restrict_right_eq_Galois_right_restrict_right
    restrict_right_eq rel_inv_eq_self_if_symmetric)+
  (auto simp: eq_restrict_eq_eq_restrict_left)

end

locale transport_eq_bijection =
  fixes l :: "'a \<Rightarrow> 'b"
  and r :: "'b \<Rightarrow> 'a"
  assumes bijection_on_in_field:
    "bijection_on (in_field ((=) :: 'a \<Rightarrow> _)) (in_field ((=) :: 'b \<Rightarrow> _)) l r"
begin

sublocale teq_restr_bij? : transport_eq_restrict_bijection \<top> \<top> l r
  rewrites "(=\<^bsub>\<top> :: 'a \<Rightarrow> bool\<^esub>) = ((=) :: 'a \<Rightarrow> _)"
  and "(=\<^bsub>\<top> :: 'b \<Rightarrow> bool\<^esub>) = ((=) :: 'b \<Rightarrow> _)"
  using bijection_on_in_field by unfold_locales simp_all

end

end