theory Verification
  imports Language
begin

record store =
  s_f\<^sub>A :: nat
  s_f\<^sub>B :: nat
  s_i\<^sub>A :: nat
  s_i\<^sub>B :: nat
  s_fmax :: nat
  s_A :: "nat list"

type_synonym program = "(store \<times> store) llist set"

datatype var = f\<^sub>A | f\<^sub>B | i\<^sub>A | i\<^sub>B | fmax

primrec deref :: "var \<Rightarrow> store \<Rightarrow> nat" where
  "deref f\<^sub>A s = s_f\<^sub>A s"
| "deref f\<^sub>B s = s_f\<^sub>B s"
| "deref i\<^sub>A s = s_i\<^sub>A s"
| "deref i\<^sub>B s = s_i\<^sub>B s"
| "deref fmax s = s_fmax s"

datatype expr = Const nat
              | Var var
              | ALen
              | Lookup expr
              | BinOp "nat \<Rightarrow> nat \<Rightarrow> nat" expr expr
              | Fun "nat \<Rightarrow> nat" expr

primrec eval_expr :: "expr \<Rightarrow> store \<Rightarrow> nat" where
  "eval_expr (Const c) s = c"
| "eval_expr (Var v) s = deref v s"
| "eval_expr ALen s = length (s_A s)"
| "eval_expr (Lookup x) s = s_A s ! eval_expr x s"
| "eval_expr (BinOp f x y) s = f (eval_expr x s) (eval_expr y s)"
| "eval_expr (Fun f x) s = f (eval_expr x s)"

datatype bool_expr = BTrue ("\<one>")
                   | BFalse ("\<zero>")
                   | BDisj bool_expr bool_expr (infixl "\<oplus>" 65)
                   | BConj bool_expr bool_expr (infixl "\<otimes>" 70)
                   | BImpl bool_expr bool_expr (infixl "\<rightharpoonup>" 60)
                   | BIff bool_expr bool_expr
                   | BNot bool_expr
                   | BExpr1 "nat \<Rightarrow> bool" expr
                   | BExpr2 "nat \<Rightarrow> nat \<Rightarrow> bool" expr expr
                   | BArray "nat \<Rightarrow> nat list \<Rightarrow> bool" expr

primrec eval_bool_expr :: "bool_expr \<Rightarrow> store \<Rightarrow> bool" where
  "eval_bool_expr BTrue s = True"
| "eval_bool_expr BFalse s = False"
| "eval_bool_expr (BDisj x y) s = (eval_bool_expr x s \<or> eval_bool_expr y s)"
| "eval_bool_expr (BConj x y) s = (eval_bool_expr x s \<and> eval_bool_expr y s)"
| "eval_bool_expr (BImpl x y) s = (eval_bool_expr x s \<longrightarrow> eval_bool_expr y s)"
| "eval_bool_expr (BIff x y) s = (eval_bool_expr x s \<longleftrightarrow> eval_bool_expr y s)"
| "eval_bool_expr (BNot x) s = (\<not> eval_bool_expr x s)"
| "eval_bool_expr (BExpr1 f x) s = f (eval_expr x s)"
| "eval_bool_expr (BExpr2 f x y) s = f (eval_expr x s) (eval_expr y s)"
| "eval_bool_expr (BArray p x) s = p (eval_expr x s) (s_A s)"

(* no_notation residual_l (infixl "\<leftarrow>" 60) *)

primrec assign :: "var \<Rightarrow> expr \<Rightarrow> store \<Rightarrow> store" (infix "\<leftarrow>" 67) where
  "(f\<^sub>A \<leftarrow> e) s = store.make (eval_expr e s) (s_f\<^sub>B s) (s_i\<^sub>A s) (s_i\<^sub>B s) (s_fmax s) (s_A s)"
| "(f\<^sub>B \<leftarrow> e) s = store.make (s_f\<^sub>A s) (eval_expr e s) (s_i\<^sub>A s) (s_i\<^sub>B s) (s_fmax s) (s_A s)"
| "(i\<^sub>A \<leftarrow> e) s = store.make (s_f\<^sub>A s) (s_f\<^sub>B s) (eval_expr e s) (s_i\<^sub>B s) (s_fmax s) (s_A s)"
| "(i\<^sub>B \<leftarrow> e) s = store.make (s_f\<^sub>A s) (s_f\<^sub>B s) (s_i\<^sub>A s) (eval_expr e s) (s_fmax s) (s_A s)"
| "(fmax \<leftarrow> e) s = store.make (s_f\<^sub>A s) (s_f\<^sub>B s) (s_i\<^sub>A s) (s_i\<^sub>B s) (eval_expr e s) (s_A s)"

primrec e_subst :: "expr \<Rightarrow> expr \<Rightarrow> var \<Rightarrow> expr" where
  "e_subst (Const c) e v = Const c"
| "e_subst (Var v') e v = (if v = v' then e else Var v')"
| "e_subst ALen e v = ALen"
| "e_subst (Lookup x) e v = Lookup (e_subst x e v)"
| "e_subst (BinOp f x y) e v = BinOp f (e_subst x e v) (e_subst y e v)"
| "e_subst (Fun f x) e v = Fun f (e_subst x e v)"

primrec be_subst :: "bool_expr \<Rightarrow> expr \<Rightarrow> var \<Rightarrow> bool_expr" ("_[_\<bar>_]") where
  "be_subst BTrue e v = BTrue"
| "be_subst BFalse e v = BFalse"
| "be_subst (BDisj x y) e v = BDisj (x[e\<bar>v]) (y[e\<bar>v])"
| "be_subst (BConj x y) e v = BConj (x[e\<bar>v]) (y[e\<bar>v])"
| "be_subst (BImpl x y) e v = BImpl (x[e\<bar>v]) (y[e\<bar>v])"
| "be_subst (BIff x y) e v = BIff (x[e\<bar>v]) (y[e\<bar>v])"
| "be_subst (BNot x) e v = BNot (x[e\<bar>v])"
| "be_subst (BExpr1 f x) e v = BExpr1 f (e_subst x e v)"
| "be_subst (BExpr2 f x y) e v = BExpr2 f (e_subst x e v) (e_subst y e v)"
| "be_subst (BArray p x) e v = BArray p (e_subst x e v)"

lemma [simp]: "eval_expr e ((x\<^sub>v \<leftarrow> E) s) = eval_expr (e_subst e E x\<^sub>v) s"
proof (induct e)
  case (Const c)
  show ?case by simp
next
  case (Var v)
  show ?case
    apply (cases x\<^sub>v)
    apply (simp_all add: store.defs)
    apply (cases v, simp_all)
    apply (cases v, simp_all)
    apply (cases v, simp_all)
    apply (cases v, simp_all)
    by (cases v, simp_all)
next
  case ALen
  thus ?case
    by simp
next
  case (Lookup x)
  thus ?case
    by simp
next
  case (BinOp f x y)
  thus ?case
    by simp
next
  case (Fun f x)
  thus ?case
    by simp
qed

lemma assign_eval_bool: "eval_bool_expr (Q[E\<bar>x\<^sub>v]) s \<longleftrightarrow> eval_bool_expr Q ((x\<^sub>v \<leftarrow> E) s)"
proof (induct Q)
  case BTrue
  thus ?case
    by simp
next
  case BFalse
  thus ?case
    by simp
next
  case (BDisj Q1 Q2)
  thus ?case
    by auto
next
  case (BConj Q1 Q2)
  thus ?case
    by simp
next
  case (BImpl Q1 Q2)
  thus ?case
    by simp
next
  case (BIff Q1 Q2)
  thus ?case
    by simp
next
  case (BNot Q)
  thus ?case
    by simp
next
  case (BExpr1 f x)
  thus ?case
    by simp
next
  case (BExpr2 f x y)
  thus ?case
    by simp
next
  case (BArray p x)
  thus ?case
    by auto
qed

definition test :: "bool_expr \<Rightarrow> program" where
  "test P \<equiv> Language.test (eval_bool_expr P)"

definition sequential_composition :: "program \<Rightarrow> program \<Rightarrow> program" (infixr ";" 52) where
  "X; Y \<equiv> X\<cdot>Y"

definition parallel_composition :: "program \<Rightarrow> program \<Rightarrow> program"
  ("parallel { _ } meanwhile { _ }" [51,51] 55) where
  "parallel { X } meanwhile { Y } \<equiv> X \<parallel> Y"

definition while_loop :: "bool_expr \<Rightarrow> program \<Rightarrow> program" ("while _ { _ }" [51] 55) where
  "while B { P } \<equiv> (test B ; P)\<^sup>\<star>; test (BNot B)"

definition quintuple :: "store rel \<Rightarrow> store rel \<Rightarrow> bool_expr \<Rightarrow> program \<Rightarrow> bool_expr \<Rightarrow> bool"
  ("_, //_ //\<turnstile> \<lbrace>_\<rbrace>// _// \<lbrace>_\<rbrace>" [20,20,20,20,20] 1000) where
  "R, G \<turnstile> \<lbrace>P\<rbrace> X \<lbrace>Q\<rbrace> \<equiv> (X \<subseteq> test P \<rightharpoondown> (R \<rhd> FIN \<cdot> test Q \<inter> guar G))"

definition preserve :: "bool_expr \<Rightarrow> store rel" where
  "preserve P = {(\<sigma>, \<sigma>'). eval_bool_expr P \<sigma>  \<longrightarrow> eval_bool_expr P \<sigma>'}"

lemma relcomp_elem: "(\<sigma>,\<tau>) \<in> R O S \<longleftrightarrow> (\<exists>\<gamma>. (\<sigma>,\<gamma>) \<in> R \<and> (\<gamma>,\<tau>) \<in> S)"
  by auto

lemma preservation': "eval_bool_expr P \<sigma> \<Longrightarrow> (\<sigma>, \<tau>) \<in> {(\<sigma>, \<sigma>'). eval_bool_expr P \<sigma> \<longrightarrow> eval_bool_expr P \<sigma>'} ^^ n \<Longrightarrow> eval_bool_expr P \<tau>"
proof (induct n arbitrary: \<tau>)
  case 0 thus ?case by simp
next
  case (Suc n)
  from Suc(2) and Suc(3) show ?case
    apply (simp add: relcomp_elem)
    apply (erule exE)
    apply (erule conjE)
    by (metis Suc.hyps)
qed

lemma preservation: "eval_bool_expr P \<sigma> \<Longrightarrow> (\<sigma>, \<tau>) \<in> (preserve P)\<^sup>* \<Longrightarrow> eval_bool_expr P \<tau>"
  apply (simp add: preserve_def)
  apply (drule rtrancl_imp_relpow)
  apply (erule exE)+
  apply (rule preservation')
  by simp_all

lemma test_guar: "test P \<subseteq> guar G"
  by (metis test_def test_in_guar)

lemma preimp_mono: "G \<subseteq> R \<Longrightarrow> X \<subseteq> Y \<Longrightarrow> R \<rightharpoondown> X \<subseteq> G \<rightharpoondown> Y"
  by (metis order_trans preimp_antitone preimp_iso)

lemma Rely_antitone: "G\<^sup>* \<subseteq> R\<^sup>* \<Longrightarrow> R \<rhd> X \<subseteq> G \<rhd> X"
  apply (auto simp add: Rely_def)
  apply (rename_tac x y)
  apply (rule_tac x = y in bexI)
  apply simp_all
  by (metis rely_antitone)

lemma Rely_mono: "G\<^sup>* \<subseteq> R\<^sup>* \<Longrightarrow> X \<subseteq> Y \<Longrightarrow> R \<rhd> X \<subseteq> G \<rhd> Y"
  apply (rule order_trans[where y = "G \<rhd> X"])
  apply (rule Rely_antitone)
  apply simp
  apply (rule prog_rely_iso)
  by auto

lemma l_prod_mono: "X \<subseteq> Y \<Longrightarrow> Z \<subseteq> W \<Longrightarrow> X \<cdot> Z \<subseteq> Y \<cdot> W"
  by (metis seq.mult_isol_var)

lemma guar_mono: "G\<^sup>* \<subseteq> G'\<^sup>* \<Longrightarrow> guar G \<subseteq> guar G'"
  by (auto simp add: guar_def) (metis contra_subsetD)

lemma evaluate_tests [simp]: "test P \<subseteq> test Q \<longleftrightarrow> (\<forall>s. eval_bool_expr P s \<longrightarrow> eval_bool_expr Q s)"
  by (auto simp add: test_def Language.test_def)

lemma preimp_zero [simp]: "({} \<rightharpoondown> x) = UNIV"
  by (simp add: preimp_def)

lemma preimp_zero_right: "X \<noteq> {} \<Longrightarrow> X \<rightharpoondown> {} = {}"
  by (auto simp add: preimp_def l_prod_def)

abbreviation "\<T> \<equiv> test"

abbreviation "\<P> \<equiv> preserve"

abbreviation "\<F> \<equiv> FIN"

(* ------------------------------------------------------------------------
   Assignment
   ------------------------------------------------------------------------ *)

definition assign_prog :: "var \<Rightarrow> expr \<Rightarrow> (store \<times> store) llist set" (infix ":=" 67) where
  "v := E \<equiv> {(\<sigma>,\<sigma>') # sng (\<sigma>',\<sigma>') |\<sigma> \<sigma>'. \<sigma>' = (v \<leftarrow> E) \<sigma>}"

lemma FIN_test1: "xs \<in> FIN \<cdot> t \<Longrightarrow> x # xs \<in> FIN \<cdot> t"
  by (auto simp add: FIN_def l_prod_def) (metis lappend_code(2) lfinite_LCons)

lemma FIN_test2: "x # xs \<in> t \<Longrightarrow> x # xs \<in> FIN \<cdot> t"
  by (auto simp add: FIN_def l_prod_def) (metis lappend_code(1) lfinite_code(1))

lemma rely_elem1: "env (R\<^sup>*) x \<and> x \<in> X \<Longrightarrow> x \<in> R \<rhd> X"
  by (auto simp add: Rely_def rely_def)

lemma refine_assignment:
  "v := E \<subseteq> \<T> (Q[E\<bar>v]) \<rightharpoondown> (\<P> (Q[E\<bar>v]) \<rhd> \<F> \<cdot> \<T> Q \<inter> guar {(\<sigma>, (v \<leftarrow> E) \<sigma>)|\<sigma>. eval_bool_expr (Q[E\<bar>v]) \<sigma>})"
proof (simp only: subset_iff, clarify)
  let ?G = "{(\<sigma>, (v \<leftarrow> E) \<sigma>)|\<sigma>. eval_bool_expr (Q[E\<bar>v]) \<sigma>}"

  fix w
  assume "w \<in> v := E"

  then obtain \<sigma> \<sigma>'
  where w_def: "w = (\<sigma>, \<sigma>') # sng (\<sigma>', \<sigma>')" and \<sigma>'_assign: "\<sigma>' = (v \<leftarrow> E) \<sigma>"
    by (auto simp add: assign_prog_def)

  have "{(\<tau>, \<tau>) # (\<sigma>, \<sigma>') # sng (\<sigma>', \<sigma>') |\<tau>. eval_bool_expr (Q[E\<bar>v]) \<tau>} \<subseteq> preserve (Q[E\<bar>v]) \<rhd> FIN \<cdot> test Q \<inter> guar ?G"
  proof (simp only: subset_iff, clarify)
    fix \<tau> assume "eval_bool_expr (Q[E\<bar>v]) \<tau>"

    have "test Q \<noteq> {}"
      by (auto simp add: test_def Language.test_def) (metis `eval_bool_expr (Q[E\<bar>v]) \<tau>` assign_eval_bool)
    then obtain Q_inhab where "Q_inhab \<in> test Q"
      by (metis all_not_in_conv)

    show "(\<tau>, \<tau>) # (\<sigma>, \<sigma>') # sng (\<sigma>', \<sigma>') \<in> preserve (Q[E\<bar>v]) \<rhd> FIN \<cdot> test Q \<inter> guar ?G"
    proof (cases "(\<tau>, \<sigma>) \<in> (preserve (Q[E\<bar>v]))\<^sup>*")
      assume [simp]: "(\<tau>, \<sigma>) \<in> (preserve (Q[E\<bar>v]))\<^sup>*"
      hence "eval_bool_expr (Q[E\<bar>v]) \<sigma>"
        by (metis `eval_bool_expr (Q[E\<bar>v]) \<tau>` preservation)

      show "(\<tau>, \<tau>) # (\<sigma>, \<sigma>') # sng (\<sigma>', \<sigma>') \<in> preserve (Q[E\<bar>v]) \<rhd> FIN \<cdot> test Q \<inter> guar ?G"
        apply (rule rely_elem1)
        apply auto
        apply (rule FIN_test1)
        apply (rule FIN_test1)
        apply (rule FIN_test2)
        apply (simp add: test_def Language.test_def)
        apply (metis \<sigma>'_assign `eval_bool_expr (Q[E\<bar>v]) \<sigma>` assign_eval_bool)
        apply (rule r_into_rtrancl )
        by (simp add: \<sigma>'_assign `eval_bool_expr (Q[E\<bar>v]) \<sigma>`)
    next
      assume \<tau>\<sigma>: "(\<tau>, \<sigma>) \<notin> (preserve (Q[E\<bar>v]))\<^sup>*"

      show "(\<tau>, \<tau>) # (\<sigma>, \<sigma>') # sng (\<sigma>', \<sigma>') \<in> preserve (Q[E\<bar>v]) \<rhd> FIN \<cdot> test Q \<inter> guar ?G"
        apply (auto simp add: Rely_def)
        apply (rule_tac x = "(\<tau>, \<tau>) # (\<sigma>, \<sigma>) # (\<sigma>', \<sigma>') # Q_inhab" in bexI)
        apply (simp add: rely_def)
        apply (rule disjI1)
        apply (rule_tac x = "LNil" in exI)
        apply (rule_tac x = \<tau> in exI)
        apply (rule_tac x = \<tau> in exI)
        apply (rule_tac x = \<sigma> in exI)
        apply (simp_all add: \<tau>\<sigma>)
        apply auto
        apply (metis FIN_def FIN_test1 LCons_in_l_prod `Q_inhab \<in> test Q` lfinite_LCons lfinite_code(1) mem_Collect_eq)
        apply (rule subsetD[of "test Q"])
        by (simp_all add: test_guar `Q_inhab \<in> test Q`)
    qed
  qed
  hence "{sng (\<sigma>, \<sigma>) |\<sigma>. eval_bool_expr (Q[E\<bar>v]) \<sigma>} \<cdot> {w} \<subseteq> preserve (Q[E\<bar>v]) \<rhd> FIN \<cdot> test Q \<inter> guar ?G"
    apply (simp add: w_def)
    apply (subst fin_l_prod)
    by (auto simp add: fin_l_prod FIN_def)
  thus "w \<in> test (Q[E\<bar>v]) \<rightharpoondown> (preserve (Q[E\<bar>v]) \<rhd> FIN \<cdot> test Q \<inter> guar ?G)"
    by (simp only: preimp_elem_var test_def Language.test_def)
qed

lemma assignment_rule:
  assumes "R\<^sup>* \<subseteq> (\<P> (Q[E\<bar>v]))\<^sup>*"
  and "{(\<sigma>, (v \<leftarrow> E) \<sigma>)|\<sigma>. eval_bool_expr (Q[E\<bar>v]) \<sigma>}\<^sup>* \<subseteq> G\<^sup>*"
  and "test P \<subseteq> test (Q[E\<bar>v])"
  shows "R, G \<turnstile> \<lbrace>P\<rbrace> v := E \<lbrace>Q\<rbrace>"
  apply (simp add: quintuple_def)
  apply (rule subset_trans[OF refine_assignment[where Q = Q]])
  apply (rule preimp_mono[OF assms(3)])
  apply (rule Rely_mono[OF assms(1)])
  apply (rule Int_mono[OF order_refl])
  by (rule guar_mono[OF assms(2)])

(* ------------------------------------------------------------------------
   Sequential Composition
   ------------------------------------------------------------------------ *)

lemma tests_finite: "test P \<subseteq> \<F>"
  by (simp add: test_def tests_finite)

lemma test_preimp: "test P \<cdot> (test P \<rightharpoondown> X) \<subseteq> X"
  by (metis preimp_galois_3 tests_finite)

lemma test_inter_guar [simp]: "test P \<inter> guar G = test P"
  by (simp add: test_def)

lemma refine_sequential: "(test P \<rightharpoondown> (R \<rhd> FIN \<cdot> test S \<inter> guar G)) \<cdot> (test S \<rightharpoondown> (R \<rhd> FIN \<cdot> test Q \<inter> guar G)) \<le> (test P \<rightharpoondown> (R \<rhd> FIN \<cdot> test Q \<inter> guar G))"
  apply (subst preimp_galois_2[symmetric, OF tests_finite])
  apply (simp only: l_prod_assoc[symmetric])
  apply (rule subset_trans[OF l_prod_isol[OF test_preimp]])
  apply (simp only: guar_lprod test_inter_guar)
  apply (rule subset_trans[OF rely_l_prod_var])
  defer
  apply (simp only: l_prod_assoc)
  apply (rule subset_trans[OF prog_rely_iso[OF l_prod_isor[OF test_preimp]]])
  apply (rule subset_trans[OF prog_rely_iso[OF rely_l_prod_var2]])
  defer
  apply (rule subset_trans[OF rely_idem])
  apply (simp only: l_prod_assoc[symmetric] guar_lprod[symmetric])
  apply (rule subset_trans[OF prog_rely_iso[OF l_prod_isol[OF inter_isol[OF FIN_FIN]]]])
  by (rule order_refl)

lemma sequential_rule: "R, G \<turnstile> \<lbrace>P\<rbrace> x \<lbrace>S\<rbrace> \<Longrightarrow> R, G \<turnstile> \<lbrace>S\<rbrace> y \<lbrace>Q\<rbrace> \<Longrightarrow> R, G \<turnstile> \<lbrace>P\<rbrace> x \<cdot> y \<lbrace>Q\<rbrace>"
  apply (simp add: quintuple_def)
  apply (subst subset_trans[where B = "(test P \<rightharpoondown> (R \<rhd> FIN \<cdot> test S \<inter> guar G)) \<cdot> (test S \<rightharpoondown> (R \<rhd> FIN \<cdot> test Q \<inter> guar G))"])
  apply (rule l_prod_mono)
  apply simp_all
  by (rule refine_sequential)

(* ------------------------------------------------------------------------
   If Statement
   ------------------------------------------------------------------------ *)

lemma one_test_pre: "test P \<cdot> X = {(\<sigma>,\<sigma>) # x |\<sigma> x. eval_bool_expr P \<sigma> \<and> x \<in> X}"
  apply (subst fin_l_prod)
  apply (metis tests_finite)
  apply (simp add: test_def)
  apply (auto simp add: Language.test_def)
  by (metis lappend_code(1) lappend_code(2))

lemma two_tests_pre: "test P \<cdot> test S \<cdot> X = {(\<sigma>,\<sigma>) # (\<sigma>',\<sigma>') # x |\<sigma> \<sigma>' x. eval_bool_expr P \<sigma> \<and> eval_bool_expr S \<sigma>' \<and> x \<in> X}"
  apply (subst fin_l_prod)
  apply (metis tests_finite)
  apply (subst fin_l_prod)
  apply (simp add: test_def Language.test_def FIN_def)
  apply (metis lfinite_LCons lfinite_code(1) lfinite_lappend)
  apply (auto simp add: test_def Language.test_def)
  by (metis lappend_code(1) lappend_code(2))

lemma rely_cons_eq: "rely R (x # xs) (y # ys) \<Longrightarrow> x = y"
  apply (auto simp add: rely_def)
  by (metis (erased, hide_lams) lappend_code(1) lappend_code(2) lhd_LCons llist.exhaust)

lemma rely_cons_lem: "rely R ((\<gamma>', \<gamma>') # x) ((\<gamma>', \<gamma>') # y) \<Longrightarrow> rely R ((\<gamma>, \<gamma>) # (\<gamma>', \<gamma>') # x) ((\<gamma>, \<gamma>) # (\<gamma>', \<gamma>') # y)"
  apply (cases "(\<gamma>, \<gamma>') \<in> R\<^sup>*")
  apply (auto simp add: rely_def)
  apply (rule_tac x = "(\<gamma>, \<gamma>) # z" in exI)
  apply (rule_tac x = \<sigma> in exI)
  apply (rule_tac x = \<sigma>' in exI)
  apply (rule_tac x = \<tau> in exI)
  apply (intro conjI)
  apply simp_all
  apply metis
  apply metis
  apply (metis env_lem1 prod.sel(1) prod.sel(2))
  apply (rule_tac x = LNil in exI)
  apply (rule_tac x = \<gamma> in exI)
  apply (rule_tac x = \<gamma> in exI)
  apply (rule_tac x = \<gamma>' in exI)
  apply simp_all
  apply (intro conjI)
  apply metis
  by metis

lemma stutter_1: "x \<in> FIN \<cdot> test Q \<inter> guar G \<Longrightarrow> rely R x ((\<sigma>', \<sigma>') # t') \<Longrightarrow> rely R ((\<sigma>, \<sigma>) # x) ((\<sigma>, \<sigma>) # (\<sigma>', \<sigma>') # t')"
  apply (cases x)
  apply simp
  defer
  apply simp
  apply (frule rely_cons_eq)
  apply simp
  apply (metis rely_cons_lem)
proof -
  assume "rely R LNil ((\<sigma>', \<sigma>') # t')"
  hence False by (simp add: LNil_eq_lappend_iff rely_def)
  thus "rely R (sng (\<sigma>, \<sigma>)) ((\<sigma>, \<sigma>) # (\<sigma>', \<sigma>') # t')" by meson
qed

lemma double_test1:
  assumes "\<And>t. t \<in> test P \<cdot> x \<Longrightarrow> t \<in> R \<rhd> FIN \<cdot> test Q \<inter> guar G"
  and "t \<in> test S \<cdot> test P \<cdot> x"
  shows "t \<in> R \<rhd> FIN \<cdot> test Q \<inter> guar G"
proof -
  from assms(2)
  obtain \<sigma> \<sigma>' t'
  where "t = (\<sigma>,\<sigma>) # (\<sigma>',\<sigma>') # t'" and "t' \<in> x" and "eval_bool_expr S \<sigma>" and "eval_bool_expr P \<sigma>'"
    by (simp add: two_tests_pre) metis

  hence "(\<sigma>',\<sigma>') # t' \<in> test P \<cdot> x"
    by (simp add: one_test_pre)

  hence "(\<sigma>',\<sigma>') # t' \<in> R \<rhd> FIN \<cdot> test Q \<inter> guar G"
    by (metis assms(1))

  hence "(\<sigma>,\<sigma>) # (\<sigma>',\<sigma>') # t' \<in> R \<rhd> FIN \<cdot> test Q \<inter> guar G"
    apply (simp add: Rely_def)
    apply (erule bexE)
    apply (rule_tac x = "(\<sigma>,\<sigma>) # x" in bexI)
    apply (rule stutter_1)
    apply simp_all
    by (metis FIN_test1)

  thus ?thesis
    by (metis `t = (\<sigma>, \<sigma>) # (\<sigma>', \<sigma>') # t'`)
qed

lemma double_test2: "test P \<rightharpoondown> (R \<rhd> FIN \<cdot> test Q \<inter> guar G) \<le> test S \<cdot> test P \<rightharpoondown> (R \<rhd> FIN \<cdot> test Q \<inter> guar G)"
  apply (auto simp add: subset_iff preimp_def)
  apply (rule_tac x = x in exI)
  apply auto
  by (metis double_test1)

lemma mumble_lem1': "(\<sigma>',\<sigma>) \<in> R\<^sup>* \<Longrightarrow> rely R ((\<sigma>', \<sigma>') # x) ((\<sigma>', \<sigma>') # (\<sigma>, \<sigma>) # y) \<Longrightarrow> rely R x ((\<sigma>, \<sigma>) # y)"
  apply (simp add: rely_def)
  apply auto
  apply (subgoal_tac "\<exists>z'. z = (\<sigma>', \<sigma>') # z'")
  apply (erule exE)+
  apply simp
  apply (rule_tac x = z' in exI)
  apply (rule_tac x = \<sigma>'' in exI)
  apply (rule_tac x = \<sigma>''' in exI)
  apply (rule_tac x = \<tau> in exI)
  apply (intro conjI)
  apply metis
  apply metis
  apply simp
  apply simp
  apply (metis env_tl)
  apply (subgoal_tac "z = LNil \<or> (\<exists>\<gamma> \<gamma>' z''. z = (\<gamma>, \<gamma>') # z'')")
  apply (erule disjE)
  apply simp
  apply (erule exE)+
  apply simp
  by (metis llist.exhaust prod.collapse)

lemma mumble_lem1: "(\<sigma>',\<sigma>) \<in> R\<^sup>*  \<Longrightarrow> x \<in> FIN \<cdot> test Q \<inter> guar G \<Longrightarrow> rely R x ((\<sigma>', \<sigma>') # (\<sigma>, \<sigma>) # t') \<Longrightarrow> rely R (ltl x) ((\<sigma>, \<sigma>) # t')"
  apply (cases x)
  apply simp
  defer
  apply simp
  apply (frule rely_cons_eq)
  apply simp
  apply (metis mumble_lem1')
  by (smt LNil_eq_lappend_iff llist.distinct(1) rely_def)

lemma double_tests: "test P \<cdot> test Q = {(\<sigma>, \<sigma>) # (\<sigma>', \<sigma>') # LNil |\<sigma> \<sigma>'. eval_bool_expr P \<sigma> \<and> eval_bool_expr Q \<sigma>'}"
  apply (auto simp add: test_def Language.test_def l_prod_def)
  apply (metis lappend_code(1) lappend_code(2) lfinite_LCons lfinite_code(1))
  by (metis lappend_code(1) lappend_code(2) lfinite_LCons lfinite_code(1))

lemma triple_tests: "test P \<cdot> test Q \<cdot> test S = {(\<sigma>, \<sigma>) # (\<sigma>', \<sigma>') # (\<sigma>'', \<sigma>'') # LNil |\<sigma> \<sigma>' \<sigma>''. eval_bool_expr P \<sigma> \<and> eval_bool_expr Q \<sigma>' \<and> eval_bool_expr S \<sigma>''}"
  apply (auto simp add: test_def Language.test_def l_prod_def)
  by (metis lappend_code(1) lappend_code(2) lfinite_LCons lfinite_code(1))+

lemma preimp_2_l_prod: "Z \<subseteq> FIN \<Longrightarrow> Y \<subseteq> FIN \<Longrightarrow> X \<le> Y \<rightharpoondown> Z \<rightharpoondown> W \<longleftrightarrow> X \<le> Z \<cdot> Y \<rightharpoondown> W"
proof -
  assume a1: "Y \<subseteq> FIN"
  assume a2: "Z \<subseteq> FIN"
  hence "\<And>x\<^sub>1. FIN \<rightharpoondown> x\<^sub>1 \<subseteq> Z \<rightharpoondown> x\<^sub>1" by (simp add: preimp_antitone)
  hence "Z \<cdot> Y \<subseteq> FIN" using a1 a2 by (metis (no_types) FIN_FIN order_refl order_trans preimp_galois_2)
  thus "(X \<subseteq> Y \<rightharpoondown> Z \<rightharpoondown> W) = (X \<subseteq> Z \<cdot> Y \<rightharpoondown> W)" using a1 a2 by (metis (no_types) l_prod_assoc preimp_galois_2)
qed

lemma test2_conj':
  assumes "\<And>t. t \<in> test (P \<otimes> B) \<cdot> X \<Longrightarrow> t \<in> R \<rhd> FIN \<cdot> test Q \<inter> guar G"
  and "t \<in> test P \<cdot> test B \<cdot> X"
  and "R\<^sup>* \<subseteq> (preserve P)\<^sup>*"
  and "test Q \<noteq> {}"
  shows "t \<in> R \<rhd> FIN \<cdot> test Q \<inter> guar G"
proof -
  from `t \<in> test P \<cdot> test B \<cdot> X`
  obtain \<sigma> \<sigma>' t'
  where t_def: "t = (\<sigma>, \<sigma>) # (\<sigma>', \<sigma>') # t'" and "eval_bool_expr P \<sigma>" and "eval_bool_expr B \<sigma>'" and "t' \<in> X"
    by (simp add: two_tests_pre) metis

  from `test Q \<noteq> {}`
  obtain \<sigma>''
  where "eval_bool_expr Q \<sigma>''"
    by (auto simp add: test_def Language.test_def)
  hence "sng (\<sigma>'', \<sigma>'') \<in> test Q"
    by (auto simp add: test_def Language.test_def)

  {
    assume "(\<sigma>, \<sigma>') \<notin> (preserve P)\<^sup>*"

    hence "(\<sigma>, \<sigma>) # (\<sigma>', \<sigma>') # t' \<in> R \<rhd> FIN \<cdot> test Q \<inter> guar G"
      apply (auto simp add: Rely_def)
      apply (rule_tac x = "(\<sigma>, \<sigma>) # (\<sigma>', \<sigma>') # sng (\<sigma>'', \<sigma>'')" in bexI)
      apply (rule rely_antitone[OF `R\<^sup>* \<subseteq> (preserve P)\<^sup>*`])
      apply (simp add: rely_def)
      apply (rule disjI1)
      apply (rule_tac x = LNil in exI)
      apply (rule_tac x = \<sigma> in exI) apply (rule_tac x = \<sigma> in exI)
      apply (rule_tac x = \<sigma>' in exI)
      apply simp
      by (metis FIN_test1 FIN_test2 Int_iff `sng (\<sigma>'', \<sigma>'') \<in> test Q` guar_LCons_eq guar_singleton rtrancl.rtrancl_refl)

    hence "t \<in> R \<rhd> FIN \<cdot> test Q \<inter> guar G"
      by (metis t_def)
  }
  moreover
  {
    assume "(\<sigma>, \<sigma>') \<in> (preserve P)\<^sup>*"

    from preservation[OF `eval_bool_expr P \<sigma>` this] and `eval_bool_expr B \<sigma>'`
    have "sng (\<sigma>', \<sigma>') \<in> test (P \<otimes> B)"
      by (simp add: test_def Language.test_def)

    hence "(\<sigma>', \<sigma>') # t' \<in> test (P \<otimes> B) \<cdot> X"
      by (metis LCons_in_l_prod `t' \<in> X`)

    hence "(\<sigma>', \<sigma>') # t' \<in> R \<rhd> FIN \<cdot> test Q \<inter> guar G"
      by (metis assms(1))

    hence "(\<sigma>, \<sigma>) # (\<sigma>', \<sigma>') # t' \<in> R \<rhd> FIN \<cdot> test Q \<inter> guar G"
      apply (simp add: Rely_def)
      apply (erule bexE)
      apply (rule_tac x = "(\<sigma>, \<sigma>) # x" in bexI)
      apply (metis stutter_1)
      apply auto
      by (metis FIN_test1)

    hence "t \<in> R \<rhd> FIN \<cdot> test Q \<inter> guar G"
      by (metis t_def)
  }
  ultimately show ?thesis by blast
qed

lemma llength_ge_1: "llength x > 1 \<Longrightarrow> \<exists>x1 x2 x3. x = x1 # x2 # x3"
  by (metis eSuc_enat iless_Suc_eq less_imp_le llength_LCons llength_eq_0 llist.collapse(2) neq_iff one_eSuc zero_enat_def)

lemma post_ltl: "llength x > 1 \<Longrightarrow> x \<in> \<F> \<cdot> \<T> Q \<Longrightarrow> ltl x \<in> \<F> \<cdot> \<T> Q"
  apply (drule llength_ge_1)
  apply (erule exE)+
  apply simp
  apply (auto simp add: FIN_def l_prod_def test_def Language.test_def)
  by (metis lappend_code(1) lfinite.simps llist.distinct(1) llist.sel(3) ltl_lappend)

lemma [simp]: "xa = x21 # x22 \<frown> ((\<sigma>', \<sigma>'') # (\<tau>, \<tau>') # x') \<Longrightarrow> z = x21 # x22 \<Longrightarrow> llength x22 + eSuc (eSuc (llength x')) \<noteq> 0"
  apply (cases x22)
  apply simp_all
  by (simp add: plus_enat_eq_0_conv)

lemma eSuc_0_llength_lem: "xa = z \<frown> ((\<sigma>', \<sigma>'') # (\<tau>, \<tau>') # x') \<Longrightarrow> eSuc 0 < llength xa"
  apply (cases z)
  by simp_all

lemma guar_ltl: "x \<in> guar G \<Longrightarrow> ltl x \<in> guar G"
  by (cases x) simp_all

lemma test2_conj'_opp_lem:
  "(\<sigma>, \<sigma>) # (\<sigma>, \<sigma>) # x \<in> R \<rhd> FIN \<cdot> test Q \<inter> guar G \<Longrightarrow> (\<sigma>, \<sigma>) # x \<in> R \<rhd> FIN \<cdot> test Q \<inter> guar G"
  apply (auto simp add: Rely_def)
  apply (rule_tac x = "ltl xa" in bexI)
  apply (meson Int_iff mumble_lem1 rtrancl.rtrancl_refl)
  apply auto
  apply (rule post_ltl)
  apply simp_all
  apply (simp add: rely_def)
  apply (erule disjE)
  prefer 2
  apply (simp_all add: one_eSuc)
  apply (erule exE)+
  apply (erule conjE)+
  apply (erule exE)+
  apply (meson eSuc_0_llength_lem)
  by (metis guar_ltl)

lemma test2_conj'_opp:
  assumes "\<And>t. t \<in> test P \<cdot> test B \<cdot> X \<Longrightarrow> t \<in> R \<rhd> FIN \<cdot> test Q \<inter> guar G"
  and "t \<in> test (P \<otimes> B) \<cdot> X"
  and "R\<^sup>* \<subseteq> (preserve P)\<^sup>*"
  and "test Q \<noteq> {}"
  shows "t \<in> R \<rhd> FIN \<cdot> test Q \<inter> guar G"
proof -
  from `t \<in> test (P \<otimes> B) \<cdot> X`
  obtain \<sigma> t'
  where t_def: "t = (\<sigma>, \<sigma>) # t'" and "eval_bool_expr P \<sigma>" and "eval_bool_expr B \<sigma>" and "t' \<in> X"
    by (auto simp add: test_def Language.test_def l_prod_def)

  from `test Q \<noteq> {}`
  obtain \<sigma>'
  where "eval_bool_expr Q \<sigma>'"
    by (auto simp add: test_def Language.test_def)
  hence "sng (\<sigma>', \<sigma>') \<in> test Q"
    by (auto simp add: test_def Language.test_def)

  from `eval_bool_expr P \<sigma>` and `eval_bool_expr B \<sigma>` and `t' \<in> X`
  have "(\<sigma>, \<sigma>) # (\<sigma>, \<sigma>) # t' \<in> test P \<cdot> test B \<cdot> X"
    apply (simp only: l_prod_assoc)
    apply (rule LCons_in_l_prod)
    apply (simp add: test_def Language.test_def)
    apply (rule LCons_in_l_prod)
    apply (simp add: test_def Language.test_def)
    by simp

  hence "(\<sigma>, \<sigma>) # (\<sigma>, \<sigma>) # t' \<in> R \<rhd> FIN \<cdot> test Q \<inter> guar G"
    using assms(1) by blast

  hence "(\<sigma>, \<sigma>) # t' \<in> R \<rhd> FIN \<cdot> test Q \<inter> guar G"
    using test2_conj'_opp_lem by blast

  then show ?thesis
    using t_def by blast
qed

lemma [simp]: "\<F> \<cdot> {} = {}"
  by (auto simp add: l_prod_def FIN_def)

lemma [simp]: "\<T> P \<cdot> {} = {}"
  by (auto simp add: l_prod_def test_def Language.test_def)

lemma [simp]: "R \<rhd> {} = {}"
  by (auto simp add: Rely_def)

lemma test2_conj_var:
  assumes "R\<^sup>* \<subseteq> (preserve P)\<^sup>*"
  and "test (P \<otimes> B) \<noteq> {}"
  shows "test (P \<otimes> B) \<rightharpoondown> (R \<rhd> FIN \<cdot> test Q \<inter> guar G) \<subseteq> test P \<cdot> test B \<rightharpoondown> (R \<rhd> FIN \<cdot> test Q \<inter> guar G)"
  apply (cases "test Q = {}")
  apply simp
  apply (cases "test P = {}")
  apply simp
  apply (cases "test B = {}")
  apply simp
  apply (subst preimp_zero_right)
  apply (rule assms(2))
  apply (subst preimp_zero_right)
  apply (metis FIN_l_prod empty_subsetI preimp_galois_2 preimp_zero_right subset_antisym)
  apply simp
  apply (simp add: preimp_def subset_iff)
  apply (intro allI impI)
  apply (erule exE)+
  apply (rule_tac x = x in exI)
  apply auto
  by (metis (mono_tags, hide_lams) all_not_in_conv assms(1) test2_conj')

lemma test2_conj:
  assumes "R\<^sup>* \<subseteq> (preserve P)\<^sup>*"
  and "test Q \<noteq> {}"
  shows "test (P \<otimes> B) \<rightharpoondown> (R \<rhd> FIN \<cdot> test Q \<inter> guar G) \<subseteq> test P \<cdot> test B \<rightharpoondown> (R \<rhd> FIN \<cdot> test Q \<inter> guar G)"
  apply (simp add: preimp_def subset_iff)
  apply (intro allI impI)
  apply (erule exE)+
  apply (rule_tac x = x in exI)
  apply auto
  apply (rule test2_conj')
  apply auto
  apply (metis assms(1) contra_subsetD)
  by (metis assms(2))

lemma test2_conj_opp:
  assumes "R\<^sup>* \<subseteq> (preserve P)\<^sup>*"
  and "test Q \<noteq> {}"
  shows "test P \<cdot> test B \<rightharpoondown> (R \<rhd> FIN \<cdot> test Q \<inter> guar G) \<subseteq> test (P \<otimes> B) \<rightharpoondown> (R \<rhd> FIN \<cdot> test Q \<inter> guar G)"
  apply (simp add: preimp_def subset_iff)
  apply (intro allI impI)
  apply (erule exE)+
  apply (rule_tac x = x in exI)
  apply auto
  apply (rule test2_conj'_opp)
  apply auto
  apply (metis assms(1) contra_subsetD)
  by (metis assms(2))

lemma test2_conj_eq:
  assumes "R\<^sup>* \<subseteq> (preserve P)\<^sup>*"
  and "test Q \<noteq> {}"
  shows "test P \<cdot> test B \<rightharpoondown> (R \<rhd> FIN \<cdot> test Q \<inter> guar G) = test (P \<otimes> B) \<rightharpoondown> (R \<rhd> FIN \<cdot> test Q \<inter> guar G)"
  by (simp add: assms(1) assms(2) subset_antisym test2_conj test2_conj_opp)

lemma empty_test_pair:
  assumes "test (P \<otimes> B) = {}"
  and "test Q \<noteq> {}"
  and "R\<^sup>* \<subseteq> (preserve P)\<^sup>*"
  shows "test P \<cdot> test B \<cdot> X \<subseteq> R \<rhd> FIN \<cdot> test Q \<inter> guar G"
proof (auto simp add: subset_iff)
  fix t
  assume "t \<in> test P \<cdot> test B \<cdot> X"

  then obtain \<sigma> \<sigma>' t'
  where "t = (\<sigma>, \<sigma>) # (\<sigma>', \<sigma>') # t'" and "eval_bool_expr P \<sigma>" and "eval_bool_expr B \<sigma>'" and "t' \<in> X"
    by (simp add: two_tests_pre) metis

  from `eval_bool_expr B \<sigma>'` and assms(1) have "\<not> eval_bool_expr P \<sigma>'"
    by (auto simp add: Language.test_def test_def)

  from `test Q \<noteq> {}`
  obtain \<sigma>''
  where "eval_bool_expr Q \<sigma>''"
    by (auto simp add: Language.test_def test_def)
  hence "sng (\<sigma>'', \<sigma>'') \<in> test Q"
    by (auto simp add: Language.test_def test_def)

  hence "(\<sigma>, \<sigma>) # (\<sigma>', \<sigma>') # t' \<in> R \<rhd> FIN \<cdot> test Q \<inter> guar G"
    apply (auto simp add: Rely_def)
    apply (rule_tac x = "(\<sigma>, \<sigma>) # (\<sigma>', \<sigma>') # sng (\<sigma>'', \<sigma>'')" in bexI)
    apply (rule rely_antitone[OF assms(3)])
    apply (auto simp add: rely_def)
    apply (rule_tac x = LNil in exI)
    apply (rule_tac x = \<sigma> in exI) apply (rule_tac x = \<sigma> in exI)
    apply (rule_tac x = \<sigma>' in exI)
    apply (intro conjI)
    apply simp_all
    apply (metis `\<not> eval_bool_expr P \<sigma>'` `eval_bool_expr P \<sigma>` preservation)
    by (metis FIN_test1 FIN_test2)

  thus "t \<in> R \<rhd> FIN \<cdot> test Q \<inter> guar G"
    by (metis `t = (\<sigma>, \<sigma>) # (\<sigma>', \<sigma>') # t'`)
qed

lemma "test P = {} \<Longrightarrow> R, G \<turnstile> \<lbrace>P\<rbrace> X \<lbrace>Q\<rbrace>"
  by (auto simp add: quintuple_def)

lemma zero_rule: "R, G \<turnstile> \<lbrace>P\<rbrace> {} \<lbrace>Q\<rbrace>"
  by (simp add: quintuple_def)

lemma conj_empty: "test (P \<otimes> B) = {} \<Longrightarrow> test (P \<otimes> (BNot B)) = test P"
  by (auto simp add: test_def Language.test_def)

lemma conj_empty2: "test (P \<otimes> BNot B) = {} \<Longrightarrow> test (P \<otimes> B) = test P"
  by (auto simp add: test_def Language.test_def)

lemma test_to_precondition_var: "test (P \<otimes> B) \<noteq> {} \<Longrightarrow> R\<^sup>* \<subseteq> (preserve P)\<^sup>* \<Longrightarrow> R, G \<turnstile> \<lbrace>P \<otimes> B\<rbrace> X \<lbrace>Q\<rbrace> \<Longrightarrow> R, G \<turnstile> \<lbrace>P\<rbrace> test B \<cdot> X \<lbrace>Q\<rbrace>"
  apply (simp add: quintuple_def)
  apply (subst preimp_galois_2[symmetric])
  apply (simp add: tests_finite)
  apply (simp only: l_prod_assoc[symmetric])
  apply (subst preimp_galois_2)
  apply (simp add: tests_finite)
  apply (rule subset_trans[OF _ test2_conj_var])
  by simp_all

lemma test_to_precondition: "test Q \<noteq> {} \<Longrightarrow> R\<^sup>* \<subseteq> (preserve P)\<^sup>* \<Longrightarrow> R, G \<turnstile> \<lbrace>P \<otimes> B\<rbrace> X \<lbrace>Q\<rbrace> \<Longrightarrow> R, G \<turnstile> \<lbrace>P\<rbrace> test B \<cdot> X \<lbrace>Q\<rbrace>"
  apply (simp add: quintuple_def)
  apply (subst preimp_galois_2[symmetric])
  apply (simp add: tests_finite)
  apply (simp only: l_prod_assoc[symmetric])
  apply (subst preimp_galois_2)
  apply (simp add: tests_finite)
  apply (rule subset_trans[OF _ test2_conj])
  by simp_all

lemma FIN_l_prod_ex: "z \<in> FIN \<cdot> X \<Longrightarrow> \<exists>z'. z' \<in> X"
  by (auto simp add: FIN_def l_prod_def)

lemma test_conj_leq1: "test (P \<otimes> B) \<subseteq> test P"
  by (auto simp add: test_def Language.test_def)

lemma test_conj_leq2: "test (B \<otimes> P) \<subseteq> test P"
  by (auto simp add: test_def Language.test_def)

lemma test_conj_2:
  assumes "\<And>t. t \<in> test P \<cdot> X \<Longrightarrow> t \<in> R \<rhd> FIN \<cdot> test Q \<inter> guar G"
  and "t \<in> test P \<cdot> test B \<cdot> X"
  and "R\<^sup>* \<subseteq> (preserve P)\<^sup>*"
  shows "t \<in> R \<rhd> FIN \<cdot> test Q \<inter> guar G"
proof -
  from assms(2)
  obtain \<sigma> \<sigma>' t'
  where t_def: "t = (\<sigma>, \<sigma>) # (\<sigma>', \<sigma>') # t'" and "eval_bool_expr P \<sigma>" and "eval_bool_expr B \<sigma>'" and "t' \<in> X"
    by (simp add: two_tests_pre) metis

  hence "(\<sigma>, \<sigma>) # t' \<in> test P \<cdot> X"
    apply -
    apply (rule LCons_in_l_prod)
    by (auto simp add: test_def Language.test_def)

  hence "(\<sigma>, \<sigma>) # t' \<in> R \<rhd> FIN \<cdot> test Q \<inter> guar G"
    by (metis assms(1))

  then obtain \<sigma>'' where "sng (\<sigma>'', \<sigma>'')  \<in> test Q"
    apply (auto simp add: Rely_def)
    apply (drule FIN_l_prod_ex)
    by (auto simp add: Language.test_def test_def)

  {
    assume "(\<sigma>, \<sigma>') \<notin> (preserve P)\<^sup>*"

    hence "(\<sigma>, \<sigma>) # (\<sigma>', \<sigma>') # t' \<in> R \<rhd> FIN \<cdot> test Q \<inter> guar G"
      apply (auto simp add: Rely_def)
      apply (rule_tac x = "(\<sigma>, \<sigma>) # (\<sigma>', \<sigma>') # sng (\<sigma>'', \<sigma>'')" in bexI)
      apply (rule rely_antitone[OF `R\<^sup>* \<subseteq> (preserve P)\<^sup>*`])
      apply (simp add: rely_def)
      apply (rule disjI1)
      apply (rule_tac x = LNil in exI)
      apply (rule_tac x = \<sigma> in exI) apply (rule_tac x = \<sigma> in exI)
      apply (rule_tac x = \<sigma>' in exI)
      apply simp
      by (metis FIN_test1 FIN_test2 Int_iff `sng (\<sigma>'', \<sigma>'') \<in> test Q` guar_LCons_eq guar_singleton rtrancl.rtrancl_refl)

    hence "t \<in> R \<rhd> FIN \<cdot> test Q \<inter> guar G"
      by (metis t_def)
  }
  moreover
  {
    assume "(\<sigma>, \<sigma>') \<in> (preserve P)\<^sup>*"

    from preservation[OF `eval_bool_expr P \<sigma>` this] and `eval_bool_expr B \<sigma>'`
    have "sng (\<sigma>', \<sigma>') \<in> test (P \<otimes> B)"
      by (simp add: test_def Language.test_def)

    hence "(\<sigma>', \<sigma>') # t' \<in> test (P \<otimes> B) \<cdot> X"
      by (metis LCons_in_l_prod `t' \<in> X`)

    also have "... \<subseteq> test P \<cdot> X"
      by (metis l_prod_isol test_conj_leq1)

    finally have "(\<sigma>', \<sigma>') # t' \<in> test P \<cdot> X" .

    hence "(\<sigma>', \<sigma>') # t' \<in> R \<rhd> FIN \<cdot> test Q \<inter> guar G"
      by (metis assms(1))

    hence "(\<sigma>, \<sigma>) # (\<sigma>', \<sigma>') # t' \<in> R \<rhd> FIN \<cdot> test Q \<inter> guar G"
      apply (simp add: Rely_def)
      apply (erule bexE)
      apply (rule_tac x = "(\<sigma>, \<sigma>) # x" in bexI)
      apply (metis stutter_1)
      apply auto
      by (metis FIN_test1)

    hence "t \<in> R \<rhd> FIN \<cdot> test Q \<inter> guar G"
      by (metis t_def)
  }
  ultimately show ?thesis by blast
qed

lemma test_conj_3:
  assumes "R\<^sup>* \<subseteq> (preserve P)\<^sup>*"
  shows "test P \<rightharpoondown> (R \<rhd> FIN \<cdot> test Q \<inter> guar G) \<subseteq> test P \<cdot> test B \<rightharpoondown> (R \<rhd> FIN \<cdot> test Q \<inter> guar G)"
  apply (simp add: subset_iff)
  apply (simp add: preimp_def)
  apply auto
  apply (rule_tac x = x in exI)
  apply (simp add: subset_iff)
  apply (intro allI impI)
  apply (rule test_conj_2)
  apply auto
  by (metis assms contra_subsetD)

lemma choice_rule:
  assumes "R, G \<turnstile> \<lbrace>P\<rbrace> X \<lbrace>Q\<rbrace>"
  and "R, G \<turnstile> \<lbrace>P\<rbrace> Y \<lbrace>Q\<rbrace>"
  shows "R, G \<turnstile> \<lbrace>P\<rbrace> X \<union> Y \<lbrace>Q\<rbrace>"
  using assms
  by (simp add: quintuple_def)

lemma if_rule:
  assumes "R\<^sup>* \<subseteq> (preserve P)\<^sup>*"
  and "test Q \<noteq> {}"
  and "R, G \<turnstile> \<lbrace>P \<otimes> B\<rbrace> X \<lbrace>Q\<rbrace>"
  and "R, G \<turnstile> \<lbrace>P \<otimes> (BNot B)\<rbrace> Y \<lbrace>Q\<rbrace>"
  shows "R, G \<turnstile> \<lbrace>P\<rbrace> test B \<cdot> X \<union> test (BNot B) \<cdot> Y \<lbrace>Q\<rbrace>"
  apply (rule choice_rule)
  apply (rule test_to_precondition)
  apply (simp_all add: assms)
  apply (rule test_to_precondition)
  by (simp_all add: assms)

lemma if_rule_var:
  assumes "R\<^sup>* \<subseteq> (preserve P)\<^sup>*"
  and "test (P \<otimes> B) \<noteq> {}"
  and "test (P \<otimes> BNot B) \<noteq> {}"
  and "R, G \<turnstile> \<lbrace>P \<otimes> B\<rbrace> X \<lbrace>Q\<rbrace>"
  and "R, G \<turnstile> \<lbrace>P \<otimes> (BNot B)\<rbrace> Y \<lbrace>Q\<rbrace>"
  shows "R, G \<turnstile> \<lbrace>P\<rbrace> test B \<cdot> X \<union> test (BNot B) \<cdot> Y \<lbrace>Q\<rbrace>"
  apply (rule choice_rule)
  apply (rule test_to_precondition_var)
  apply (simp_all add: assms)
  apply (rule test_to_precondition_var)
  by (simp_all add: assms)

definition "skip \<equiv> {LNil}"

lemma remove_Rely: "X \<subseteq> Y \<Longrightarrow> X \<subseteq> R \<rhd> Y"
  by (metis Rely_ext Un_subset_iff sup.absorb1)

lemma skip_rule: "R, G \<turnstile> \<lbrace>P\<rbrace> skip \<lbrace>P\<rbrace>"
  apply (simp add: quintuple_def)
  apply (subst preimp_galois_2[symmetric])
  apply (simp add: tests_finite)
  apply (rule remove_Rely)
  apply (simp add: skip_def)
  apply auto
  apply (metis (erased, hide_lams) FIN_def contra_subsetD empty_subsetI insert_subset l_prod_isol lfinite_LNil mem_Collect_eq seq.mult.left_neutral)
  by (metis contra_subsetD test_def test_in_guar)

lemma star_inductl_one_skip: "skip \<union> x \<cdot> y \<subseteq> y \<Longrightarrow> x\<^sup>\<star> \<subseteq> y"
  apply (rule seq.star_inductl_one[rule_format])
  by (simp add: skip_def)

lemma refine_skip [simp]: "skip \<subseteq> test P \<rightharpoondown> (R \<rhd> FIN \<cdot> test P \<inter> guar G)"
  using skip_rule
  by (simp add: quintuple_def)

lemma star_rule:
  assumes "R, G \<turnstile> \<lbrace>P\<rbrace> X \<lbrace>P\<rbrace>"
  shows "R, G \<turnstile> \<lbrace>P\<rbrace> X\<^sup>\<star> \<lbrace>P\<rbrace>"
  using assms
proof (simp add: quintuple_def)
  assume "X \<subseteq> test P \<rightharpoondown> (R \<rhd> FIN \<cdot> test P \<inter> guar G)"

  moreover have "(test P \<rightharpoondown> (R \<rhd> FIN \<cdot> test P \<inter> guar G))\<^sup>\<star> \<subseteq> test P \<rightharpoondown> (R \<rhd> FIN \<cdot> test P \<inter> guar G)"
    by (rule star_inductl_one_skip[rule_format]) (simp add: refine_sequential)

  ultimately show "X\<^sup>\<star> \<subseteq> test P \<rightharpoondown> (R \<rhd> FIN \<cdot> test P \<inter> guar G)"
    by (metis (erased, hide_lams) inf.absorb2 inf_commute seq.star_ext seq.star_iso)
qed

lemma while_lem1:
  assumes "R\<^sup>* \<subseteq> (preserve I)\<^sup>*"
  and "test (BNot P \<otimes> I) \<noteq> {}"
  shows "test I \<cdot> test (BNot P) \<subseteq> R \<rhd> FIN \<cdot> test (BNot P \<otimes> I) \<inter> guar G"
proof -
  from assms(2) obtain \<sigma>''
  where "sng (\<sigma>'', \<sigma>'') \<in> test (BNot P \<otimes> I)"
    by (smt Collect_empty_eq mem_Collect_eq test_def Language.test_def)

  {
    fix t
    assume "t \<in> test I \<cdot> test (BNot P)"

    then obtain \<sigma> \<sigma>'
    where t_def: "t = (\<sigma>, \<sigma>) # sng (\<sigma>', \<sigma>')" and "eval_bool_expr I \<sigma>" and "eval_bool_expr (BNot P) \<sigma>'"
      by (simp add: double_tests) blast

    {
      assume "(\<sigma>, \<sigma>') \<in> (preserve I)\<^sup>*"

      hence "eval_bool_expr I \<sigma>'"
        by (metis `eval_bool_expr I \<sigma>` preservation)

      hence "eval_bool_expr (BNot P \<otimes> I) \<sigma>'"
        by (metis `eval_bool_expr (BNot P) \<sigma>'` eval_bool_expr.simps(4))

      hence "sng (\<sigma>', \<sigma>') \<in> test (BNot P \<otimes> I)"
        by (simp add: test_def Language.test_def)

      hence "(\<sigma>, \<sigma>) # sng (\<sigma>', \<sigma>') \<in> R \<rhd> FIN \<cdot> test (BNot P \<otimes> I) \<inter> guar G"
        apply (auto simp add: Rely_def)
        apply (rule_tac x = "(\<sigma>, \<sigma>) # sng (\<sigma>', \<sigma>')" in bexI)
        apply (rule rely_refl)
        apply auto
        by (metis FIN_test1 FIN_test2)

      hence "t \<in> R \<rhd> FIN \<cdot> test (BNot P \<otimes> I) \<inter> guar G"
        by (simp add: t_def)
    }
    moreover
    {
      assume "(\<sigma>, \<sigma>') \<notin> (preserve I)\<^sup>*"

      hence "(\<sigma>, \<sigma>) # sng (\<sigma>', \<sigma>') \<in> R \<rhd> FIN \<cdot> test (BNot P \<otimes> I) \<inter> guar G"
        apply (auto simp add: Rely_def)
        apply (rule_tac x = "(\<sigma>, \<sigma>) # (\<sigma>', \<sigma>') # sng (\<sigma>'',\<sigma>'')" in bexI)
        apply (simp add: rely_def)
        apply (rule_tac x = LNil in exI)
        apply (rule_tac x = \<sigma> in exI) apply (rule_tac x = \<sigma> in exI)
        apply (rule_tac x = \<sigma>' in exI)
        apply simp_all
        apply (metis assms(1) contra_subsetD)
        by (metis FIN_test1 FIN_test2 `sng (\<sigma>'', \<sigma>'') \<in> test (BNot P \<otimes> I)`)

      hence "t \<in> R \<rhd> FIN \<cdot> test (BNot P \<otimes> I) \<inter> guar G"
        by (simp add: t_def)
    }
    ultimately have "t \<in> R \<rhd> FIN \<cdot> test (BNot P \<otimes> I) \<inter> guar G" by blast
  }
  thus ?thesis
    by blast
qed

lemma "test P \<noteq> {} \<longleftrightarrow> (\<exists>\<sigma>. eval_bool_expr P \<sigma>)"
  by (auto simp add: test_def Language.test_def)

lemma while_rule:
  assumes "R\<^sup>* \<subseteq> (preserve I)\<^sup>*"
  and "test (BNot P \<otimes> I) \<noteq> {}"
  and "test (I \<otimes> P) \<noteq> {}"
  and "R, G \<turnstile> \<lbrace>I \<otimes> P\<rbrace> X \<lbrace>I\<rbrace>"
  shows "R, G \<turnstile> \<lbrace>I\<rbrace> (test P \<cdot> X)\<^sup>\<star> \<cdot> test (BNot P) \<lbrace>(BNot P) \<otimes> I\<rbrace>"
  apply (simp add: quintuple_def)
  apply (rule seq.star_inductl[rule_format])
  apply simp
  apply (intro conjI)
  apply (subst preimp_galois_2[symmetric])
  apply (simp add: tests_finite)
  apply (rule while_lem1[OF assms(1) assms(2)])
  using assms(4)
  apply (simp add: quintuple_def)
  apply (subst preimp_galois_2[symmetric])
  apply (simp add: tests_finite)
  apply (subst l_prod_assoc)
  apply (subst l_prod_assoc[symmetric])
  apply (subst preimp_galois_2)
  apply (simp add: tests_finite)
  apply (rule subset_trans[OF _ test2_conj_var[OF assms(1) assms(3)]])
  apply (rule subset_trans)
  prefer 2
  apply (rule refine_sequential[where S = "I"])
  by (metis l_prod_isol)

(* ------------------------------------------------------------------------
   Parallel Rule
   ------------------------------------------------------------------------ *)

lemma weakening:
  assumes "test P' \<subseteq> test P"
  and "test Q \<subseteq> test Q'"
  and "R'\<^sup>* \<subseteq> R\<^sup>*"
  and "G\<^sup>* \<subseteq> G'\<^sup>*"
  and "R, G \<turnstile> \<lbrace>P\<rbrace> X \<lbrace>Q\<rbrace>"
  shows "R', G' \<turnstile> \<lbrace>P'\<rbrace> X \<lbrace>Q'\<rbrace>"
  using assms
  apply (simp only: quintuple_def)
  apply (erule_tac subset_trans)
  apply (rule preimp_mono)
  apply simp
  apply (rule Rely_mono)
  apply simp
  by (metis guar_mono inf_mono l_prod_isor)

(* ------------------------------------------------------------------------
   Parallel Rule
   ------------------------------------------------------------------------ *)

lemma parallel_rule:
  assumes "(R \<union> G\<^sub>1)\<^sup>* \<subseteq> (R\<^sub>2)\<^sup>*"
  and "(R \<union> G\<^sub>2)\<^sup>* \<subseteq> R\<^sub>1\<^sup>*"
  and "(G\<^sub>1 \<union> G\<^sub>2)\<^sup>* \<subseteq> G\<^sup>*"
  and "R\<^sub>1, G\<^sub>1 \<turnstile> \<lbrace>P\<^sub>1\<rbrace> X \<lbrace>Q\<^sub>1\<rbrace>"
  and "R\<^sub>2, G\<^sub>2 \<turnstile> \<lbrace>P\<^sub>2\<rbrace> Y \<lbrace>Q\<^sub>2\<rbrace>"
  shows "R, G \<turnstile> \<lbrace>P\<^sub>1 \<otimes> P\<^sub>2\<rbrace> X \<parallel> Y \<lbrace>Q\<^sub>1 \<otimes> Q\<^sub>2\<rbrace>"
  sorry

lemma parallel_statement_rule:
  assumes "(R \<union> G\<^sub>1)\<^sup>* \<subseteq> (R\<^sub>2)\<^sup>*"
  and "(R \<union> G\<^sub>2)\<^sup>* \<subseteq> R\<^sub>1\<^sup>*"
  and "(G\<^sub>1 \<union> G\<^sub>2)\<^sup>* \<subseteq> G\<^sup>*"
  and "test P \<subseteq> test (P\<^sub>1 \<otimes> P\<^sub>2)"
  and "test (Q\<^sub>1 \<otimes> Q\<^sub>2) \<subseteq> test Q"
  and "R\<^sub>1, G\<^sub>1 \<turnstile> \<lbrace>P\<^sub>1\<rbrace> X \<lbrace>Q\<^sub>1\<rbrace>"
  and "R\<^sub>2, G\<^sub>2 \<turnstile> \<lbrace>P\<^sub>2\<rbrace> Y \<lbrace>Q\<^sub>2\<rbrace>"
  shows "R, G \<turnstile> \<lbrace>P\<rbrace> parallel { X } meanwhile { Y } \<lbrace>Q\<rbrace>"
  sorry

lemma preimp_dist: "(X \<union> Y) \<rightharpoondown> Z \<le> (X \<rightharpoondown> Z) \<union> (Y \<rightharpoondown> Z)"
  by (auto simp add: preimp_def)

lemma preimp_dist_var: "(X \<rightharpoondown> Z) \<inter> (Y \<rightharpoondown> Z) \<le> (X \<union> Y) \<rightharpoondown> Z"
 apply (auto simp add: preimp_def)
 apply (rule_tac x = "Xa \<inter> Xaa" in exI)
  by (meson Int_iff dual_order.trans inf_le1 inf_le2 l_prod_isor)

lemma skip_preimp [simp]: "{LNil} \<rightharpoondown> X = X"
  by (auto simp add: preimp_def)

lemma preimp_star1: "X\<^sup>\<star> \<rightharpoondown> Y \<subseteq> X \<rightharpoondown> Y"
  by (rule preimp_mono) (auto simp add: seq.star_ext)

lemma preimp_star2: "X \<subseteq> \<F> \<Longrightarrow> X \<cdot> (X\<^sup>\<star> \<rightharpoondown> Y) \<subseteq> Y"
  by (simp add: preimp_galois_2 preimp_star1)

lemma Rely_preimp: "R \<rhd> (P \<rightharpoondown> Q) \<le> P \<rightharpoondown> (R \<rhd> Q)"
  apply (auto simp add: preimp_def Rely_continuous)
  apply (rule_tac x = "R \<rhd> Xa" in exI)
  apply auto
  by (meson prog_rely_iso rely_l_prod_var2 subsetCE)

end


(*
Title: Preliminary Lemmas for Number Theoretic Transform
Author: Thomas Ammer
*)

theory Preliminary_Lemmas
 imports Berlekamp_Zassenhaus.Finite_Field
         "HOL-Number_Theory.Number_Theory"
begin

section \<open>Preliminary Lemmas\<close>

subsection \<open>A little bit of Modular Arithmetic\<close>

text \<open>An obvious lemma. Just for simplification.\<close>

lemma two_powrs_div:
  assumes "j < (i::nat) "
  shows "((2^i) div ((2::nat)^(Suc j)))*2 =  ((2^i) div (2^j))"
proof-
  have "((2::nat)^i) div (2^(Suc j)) = 2^(i -1) div(2^ j)" using assms
    by (smt (z3) One_nat_def add_le_cancel_left diff_Suc_Suc div_by_Suc_0 div_if less_nat_zero_code plus_1_eq_Suc power_diff_power_eq zero_neq_numeral)
  thus ?thesis
    by (metis Suc_diff_Suc Suc_leI assms less_imp_le_nat mult.commute power_Suc power_diff_power_eq zero_neq_numeral)
qed

lemma two_powr_div:
  assumes "j < (i::nat) "
  shows "((2^i) div ((2::nat)^j)) =  2^(i-j)"
  by (simp add: assms less_or_eq_imp_le power_diff)

text \<open>
  The order of an element is the same whether we consider it as an integer or as a natural number.
\<close>
(* TODO: Move *)
lemma ord_int: "ord (int p) (int x) = ord p x"
proof (cases "coprime p x")
  case False
  thus ?thesis
    by (auto simp: ord_def)
next
  case True
  have "(LEAST d. 0 < d \<and> [int x ^ d = 1] (mod int p)) = ord p x"
  proof (intro Least_equality conjI)
    show "[int x ^ ord p x = 1] (mod int p)"
      using True by (metis cong_int_iff of_nat_1 of_nat_power ord_works)
    show "ord p x \<le> y" if "0 < y \<and> [int x ^ y = 1] (mod int p)" for y
      using that by (metis cong_int_iff int_ops(2) linorder_not_less of_nat_power ord_minimal)
  qed (use True in auto)
  thus ?thesis
    by (auto simp: ord_def)
qed

lemma not_residue_primroot_1:
  assumes "n > 2"
  shows   "\<not>residue_primroot n 1"
  using assms totient_gt_1[of n] by (auto simp: residue_primroot_def)

lemma residue_primroot_not_cong_1:
  assumes "residue_primroot n g" "n > 2"
  shows   "[g \<noteq> 1] (mod n)"
  using residue_primroot_cong not_residue_primroot_1 assms by metis

text \<open>
We want to show the existence of a generating element of $\mathbb{Z}_p$ where $p$ is prime.
\label{primroot1} \<close>

text \<open>Non-trivial order of an element $g$ modulo $p$ in a ring  implies $g\neq1$.
Although this lemma applies to all rings, it's only intended to be used in connection with $nat$s or $int$s
\<close>

lemma prime_not_2_order_not_1:
  assumes "prime p"
          "p > 2 "
          "ord p g > 2"
  shows   "g \<noteq> 1"
proof
  assume "g = 1"
  hence "ord p g = 1" unfolding ord_def
    by (simp add: Least_equality)
  then show False using assms by auto
qed

text \<open>The same for modular arithmetic.\<close>

lemma prime_not_2_order_not_1_mod:
 assumes "prime p "
         "p > 2 "
         "ord p g > 2"
 shows   "[g \<noteq> 1] (mod p)"
proof
  assume "[g = 1] (mod p)"
  hence "ord p g = 1" unfolding ord_def
    by(split if_split, metis assms(1) assms(2) assms(3) ord_cong prime_not_2_order_not_1)
  then show False using assms by auto
qed

text \<open>
Now we formulate our lemma about generating elements in residue classes:
There is an element $g \in \mathbb{Z}_p$ such that for any $x \in \mathbb{Z}_p$
there is a natural $i$ such that $g^i \equiv x \; (\mod p)$.\<close>

lemma generator_exists:
  assumes "prime (p::nat)" "p > 2"
  shows "\<exists> g. [g \<noteq> 1] (mod p) \<and> (\<forall> x. (0<x \<and> x < p )\<longrightarrow> (\<exists> i. [g^i = x] (mod p)))"
proof-
  obtain g where g_prim_root:"residue_primroot p g"
    using assms prime_gt_1_nat prime_primitive_root_exists
    by (metis One_nat_def)
  have g_not_1: "[g \<noteq> 1] (mod p)"
    using residue_primroot_not_cong_1 assms g_prim_root by blast

  have "\<exists>i. [g ^ i = x] (mod p)" if x_bounds: "x > 0" "x < p" for x
  proof -
    have 1:"coprime p x"
      using assms prime_nat_iff'' x_bounds by blast
    have 2:"ord p g = p-1"
      by (metis assms(1) g_prim_root residue_primroot_def totient_prime)
    hence bij: "bij_betw (\<lambda>i. g ^ i mod p) {..<totient p} (totatives p)"
      using residue_primroot_is_generator[of p g] totatives_def[of p]
          1 totient_def[of p] assms g_prim_root prime_gt_1_nat by blast
    have 3:"x mod p \<in> totatives p"
      by (simp add: "1" coprime_commute in_totatives_iff order_le_less x_bounds)
    have " {..<totient p} \<noteq> {}"
      by (metis assms(1) lessThan_empty_iff prime_nat_iff'' totient_0_iff)
   then obtain i where "g^i mod p = x mod p"
      using bij_betw_inv[of "(\<lambda>i. g ^ i mod p)" "{..<totient p}" "(totatives p)"]
      3 bij
      by (metis (no_types, lifting) bij_betw_iff_bijections)
   then show ?thesis
     using cong_def by blast
  qed
  thus ?thesis
    using g_prim_root g_not_1 by auto
qed

subsection \<open>General Lemmas in a Finite Field\<close>

text \<open>
\label{primroot2}
We make certain assumptions:
From now on, we will calculate in a finite field which is the ring of integers modulo a prime $p$.
Let $n$ be the length of vectors to be transformed.
By Dirichlet's theorem on arithmetic progressions we can
 assume that there is a natural number $k$ and a prime $p$ with $p = k\cdot n + 1$.
In order to avoid some special cases and even contradictions,
we additionally assume that $p \geq 3$ and $n \geq 2$.
\<close>

text \<open>\label{prelim}\<close>
locale preliminary =
  fixes
       a_type::"('a::prime_card) itself"
   and p::nat
   and n::nat
   and k::nat
 assumes
       p_def: "p= CARD('a)" and p_lst3: "p > 2"  and p_fact: "p = k*n +1"
   and n_lst2: "n \<ge> 2"
begin

lemma exp_rule: "((c::('a) mod_ring) * d )^e= (c^e) * (d^e)"
  by (simp add: power_mult_distrib)

lemma "\<exists> y. x \<noteq> 0 \<longrightarrow> (x::(('a) mod_ring)) *  y = 1"
  by (metis dvd_field_iff unit_dvdE)

lemma test: "prime p"
  by (simp add: p_def prime_card)

lemma k_bound: "k > 0"
  using p_fact prime_nat_iff'' test by force

text \<open>We show some homomorphisms.\<close>

lemma homomorphism_add: "(of_int_mod_ring x)+(of_int_mod_ring y) =
              ((of_int_mod_ring  (x+y)) ::(('a::prime_card) mod_ring))"
  by (metis of_int_hom.hom_add of_int_of_int_mod_ring)

lemma homomorphism_mul_on_ring: "(of_int_mod_ring x)*(of_int_mod_ring y) =
              ((of_int_mod_ring  (x*y)) ::(('a::prime_card) mod_ring))"
  by (metis of_int_mult of_int_of_int_mod_ring)

lemma exp_homo:"(of_int_mod_ring (x^i)) = ((of_int_mod_ring x)^i ::(('a::prime_card) mod_ring))"
  by (induction i) (metis of_int_of_int_mod_ring of_int_power)+

lemma mod_homo: "((of_int_mod_ring x)::(('a::prime_card) mod_ring)) = of_int_mod_ring (x mod p)"
  using p_def unfolding of_int_mod_ring_def by simp

lemma int_exp_hom: "int x ^i = int (x^i)"
  by simp

lemma coprime_nat_int: "coprime (int p) (to_int_mod_ring pr) \<longleftrightarrow> coprime p (nat(to_int_mod_ring pr))"
  unfolding coprime_def to_int_mod_ring_def
  by (smt (z3) Rep_mod_ring atLeastLessThan_iff dvd_trans int_dvd_int_iff int_nat_eq int_ops(2) prime_divisor_exists prime_nat_int_transfer primes_dvd_imp_eq test to_int_mod_ring.rep_eq to_int_mod_ring_def)

lemma nat_int_mod:"[nat (to_int_mod_ring pr) ^ d = 1] (mod p) =
                           [ (to_int_mod_ring pr) ^ d = 1] (mod (int p)) "
  unfolding to_int_mod_ring_def
  by (metis Rep_mod_ring atLeastLessThan_iff cong_int_iff int_exp_hom int_nat_eq int_ops(2) to_int_mod_ring.rep_eq to_int_mod_ring_def)

text \<open>Order of $p$ doesn't change when interpreting it as an integer.\<close>

lemma ord_lift: "ord (int p) (to_int_mod_ring pr) = ord p (nat (to_int_mod_ring pr))"
proof -
  have "to_int_mod_ring pr = int (nat (to_int_mod_ring pr))"
    by (metis Rep_mod_ring atLeastLessThan_iff int_nat_eq to_int_mod_ring.rep_eq)
  thus ?thesis
    using ord_int by metis
qed

text \<open>A primitive root has order $p-1$.\<close>

lemma primroot_ord: "residue_primroot p g \<Longrightarrow> ord p g = p -1"
  by (simp add: residue_primroot_def test totient_prime)

text \<open>If $x^l = 1$ in $\mathbb{Z}_p$, then $l$ is an upper bound for the order of $x$ in $\mathbb{Z}_ p$.\<close>

lemma ord_max:
  assumes "l \<noteq> 0" "(x :: (('a::prime_card) mod_ring))^l = 1"
  shows " ord p (to_int_mod_ring x) \<le> l"
proof-
  have "[(to_int_mod_ring x)^l = 1] (mod p)"
    by (metis assms(2) cong_def exp_homo of_int_mod_ring.rep_eq of_int_mod_ring_to_int_mod_ring one_mod_card_int one_mod_ring.rep_eq p_def)
  thus ?thesis unfolding ord_def using assms
    by (smt (z3) Least_le less_imp_le_nat not_gr0)
qed

subsection \<open>Existence of $n$-th Roots of Unity in the Finite Field\<close>

text \<open>
\label{primroot3}
We obtain an element in the finite field such that
its reinterpretation as a $nat$ will be a primitive root in the residue class modulo $p$.
The difference between residue classes, their representatives in the Integers and elements
of the finite field is notable. When conducting informal proofs, this distinction
 is usually blurred, but Isabelle enforces the explicit conversion between those structures.
\<close>

lemma primroot_ex:
  obtains primroot::"('a::prime_card) mod_ring" where
    "primroot^(p-1) = 1"
    "primroot \<noteq> 1"
    "residue_primroot p (nat (to_int_mod_ring primroot))"
proof-
  obtain g where g_Def: "residue_primroot p g \<and> g \<noteq> 1"
    using prime_nat_iff' prime_primitive_root_exists test
    by (metis bigger_prime euler_theorem ord_1_right power_one_right prime_nat_iff'' residue_primroot.cases residue_primroot_cong)
  hence "[g \<noteq> 1] (mod p)" using prime_not_2_order_not_1_mod[of p g]
    by (metis One_nat_def p_lst3 less_numeral_extra(4) ord_eq_Suc_0_iff residue_primroot.cases totient_gt_1)
  hence "[g^(p-1) = 1] (mod p)" using g_Def
    by (metis coprime_commute euler_theorem residue_primroot_def test totient_prime)
  moreover hence "int (g ^ (p - 1)) mod int p = (1::int)"
    by (metis cong_def int_ops(2) mod_less of_nat_mod prime_gt_1_nat test)
  moreover hence "of_int_mod_ring (int (g ^ (p - 1)) mod int p) =
                      ((of_int_mod_ring 1) ::(('a::prime_card) mod_ring))" by simp
  ultimately have "(of_int_mod_ring (g^(p-1))) = (1 ::(('a::prime_card) mod_ring))"
    using mod_homo[of "g^(p-1)"]  by (metis exp_homo power_0)
  hence "((of_int_mod_ring g)^(p-1) ::(('a::prime_card) mod_ring)) = 1"
    using exp_homo[of "int g" "p-1"] by simp
  moreover
  have "((of_int_mod_ring g) ::(('a::prime_card) mod_ring)) \<noteq> 1"
  proof
    assume "((of_int_mod_ring g) ::(('a::prime_card) mod_ring)) = 1"
    hence "[int g = 1] (mod p)" using p_def unfolding of_int_mod_ring_def
      by (metis \<open>of_int_mod_ring (int g) = 1\<close> cong_def of_int_mod_ring.rep_eq one_mod_card_int one_mod_ring.rep_eq)
    hence "[g=1] (mod p)"
      by (metis cong_int_iff int_ops(2))
    thus False
      using \<open>[g \<noteq> 1] (mod p)\<close> by auto
  qed
  moreover have \<open>residue_primroot p (g mod p)\<close>
    using g_Def by simp
  then have \<open>residue_primroot p (nat (to_int_mod_ring (of_int_mod_ring (int g) :: 'a mod_ring)))\<close>
    by (transfer fixing: p) (simp add: p_def nat_mod_distrib)
  ultimately show thesis ..
qed

text \<open>From this, we obtain an $n$-th root of unity $\omega$ in the finite
field of characteristic $p$.
 Note that in this step we will use the assumption $p = k \cdot n +1$
from locale $preliminary$: The $k$-th power of a primitive
root $pr$ modulo $p$ will have the property $(pr^k)^n \equiv 1 \mod p$.
\<close>

lemma omega_properties_ex:
  obtains \<omega> ::"(('a::prime_card) mod_ring)"
  where  "\<omega>^n = 1"
         "\<omega> \<noteq> 1"
         "\<forall> m. \<omega>^m = 1 \<and> m\<noteq>0 \<longrightarrow> m \<ge> n"
proof-
  obtain pr::"(('a::prime_card) mod_ring)" where a: "pr^(p-1) = 1 " and b: "pr \<noteq> 1"
              and c: "residue_primroot p (nat( to_int_mod_ring pr))"
    using primroot_ex by blast
  moreover hence "(pr^k)^n =1"
    by (simp add: p_fact power_mult)
  moreover have "pr^k \<noteq> 1"
  proof
    assume " pr ^ k = 1"
    hence "(to_int_mod_ring pr)^k mod p = 1"
      by (metis exp_homo of_int_mod_ring.rep_eq of_int_mod_ring_to_int_mod_ring one_mod_ring.rep_eq p_def)
    hence "ord p (to_int_mod_ring pr) \<le> k"
      by (simp add: \<open>pr ^ k = 1\<close> k_bound ord_max)
    hence "ord p (nat (to_int_mod_ring pr)) \<le> k"
      by (metis ord_lift)
    also have "ord p (nat (to_int_mod_ring pr)) = p - 1"
      using c primroot_ord[of "(nat (to_int_mod_ring pr))"] by blast
    also have "\<dots> = k * n"
      using p_fact by simp
    finally have "n \<le> 1"
      using k_bound by simp
    thus False
      using n_lst2 by linarith
  qed
  moreover have "\<forall> m. (pr^k)^m = 1 \<and> m\<noteq>0 \<longrightarrow> m \<ge> n"
  proof(rule ccontr)
    assume  "\<not> (\<forall>m. (pr ^ k) ^ m = 1 \<and> m\<noteq>0 \<longrightarrow> n \<le> m) "
    then obtain m where "(pr^k)^m = 1  \<and> m\<noteq>0 \<and> m < n" by force
    hence "ord p (to_int_mod_ring pr) \<le> k * m" using ord_max[of "k*m" pr]
      by (metis calculation(5) mult_is_0 power_mult)
    moreover have "ord p (nat (to_int_mod_ring pr)) = p-1" using c primroot_ord ord_lift by simp
    ultimately show False
      by (metis \<open>(pr ^ k) ^ m = 1 \<and> m \<noteq> 0 \<and> m < n\<close> add_diff_cancel_right' nat_0_less_mult_iff nat_mult_le_cancel_disj not_less ord_lift p_def p_fact prime_card prime_gt_1_nat zero_less_diff)
  qed
    ultimately show ?thesis
    using that by simp
qed

text \<open>We define an $n$-th root of unity $\omega$ for $NTT$.\<close>
theorem omega_exists: "\<exists> \<omega> ::(('a::prime_card) mod_ring) .
                              \<omega>^n = 1 \<and> \<omega> \<noteq> 1 \<and> (\<forall> m. \<omega>^m = 1 \<and> m\<noteq>0 \<longrightarrow> m \<ge> n)"
  using omega_properties_ex by metis

definition "(omega::(('a::prime_card) mod_ring)) =
       (SOME \<omega> . (\<omega>^n = 1 \<and> \<omega> \<noteq> 1\<and> (\<forall> m. \<omega>^m = 1 \<and> m\<noteq>0 \<longrightarrow> m \<ge> n)))"

lemma omega_properties: "omega^n = 1" "omega \<noteq> 1"
  "(\<forall> m. omega^m = 1 \<and> m\<noteq>0 \<longrightarrow> m \<ge> n)"
  unfolding omega_def using omega_exists
  by (smt (verit, best) verit_sko_ex')+

text \<open>We define the multiplicative inverse $\mu$ of $\omega$.\<close>

definition "mu = omega ^ (n - 1)"

lemma mu_properties: "mu * omega = 1" "mu \<noteq> 1"
proof -
  have "omega ^ (n - 1) * omega = omega ^ Suc (n - 1)"
    by simp
  also have "Suc (n - 1) = n"
    using n_lst2 by simp
  also have "omega ^ n = 1"
    using omega_properties(1) by auto
  finally show "mu * omega = 1"
    by (simp add: mu_def)
next
  show "mu \<noteq> 1"
    using omega_properties n_lst2 by (auto simp: mu_def)
qed

subsection \<open>Some Lemmas on Sums\<close>
text \<open>\label{sums}\<close>

text \<open>The following lemmas concern sums over a finite field.
 Most of the propositions are intuitive.\<close>

lemma sum_in: "(\<Sum>i=0..<(x::nat). f i * (y ::('a mod_ring))) = (\<Sum>i=0..<x. f i )* (y) "
  by(induction x) (auto simp add: algebra_simps)

lemma sum_eq: "(\<And> i. i < x \<Longrightarrow> f i = g i)
                    \<Longrightarrow> (\<Sum>i=0..<(x::nat). f i) = (\<Sum>i=0..<x. g i) "
  by(induction x) (auto simp add: algebra_simps)

lemma sum_diff_in: "(\<Sum>i=0..<(x::nat). (f i)::('a mod_ring)) - (\<Sum>i=0..<x. g i) =
                    (\<Sum>i=0..<x. f i - g i)"
 by(induction x) (auto simp add: algebra_simps)

lemma sum_swap: "(\<Sum>i=0..<(x::nat). \<Sum>j=0..<(y::nat). f i j) =
                 (\<Sum>j=0..<(y::nat). \<Sum>i=0..<(x::nat). f i j ) "
  using Groups_Big.comm_monoid_add_class.sum.swap by fast

lemma sum_const: "(\<Sum>i=0..<(x::nat). (c::('a::prime_card) mod_ring)) = (of_int_mod_ring x) * c"
  by(induction x, simp add: algebra_simps,  simp add: algebra_simps)
    (metis distrib_left mult.right_neutral of_int_of_int_mod_ring of_int_of_nat_eq of_nat_Suc)

lemma sum_split: "(r1::nat) < r2 \<Longrightarrow> (\<Sum>l = 0..<r1. ((f l)::(('a::prime_card) mod_ring)))
                                         +(\<Sum>l = r1..<r2. f l) = (\<Sum>l = 0..<r2. f l)"
  by (meson less_or_eq_imp_le sum.atLeastLessThan_concat zero_le)

lemma sum_index_shift: "(\<Sum>l = (a::nat)..< b. f(l+c)) = (\<Sum>l = (a+c)..< (b+c). f l )"
  by(induction a arbitrary: b c) (metis sum.shift_bounds_nat_ivl)+

text \<open>One may sum over even and odd indices independently.
The lemma statement was taken from a formalization of FFT~\parencite{FFT-AFP}.
We give an alternative proof adapted to the finite field $\mathbb{Z}_p$.
\<close>

lemma sum_splice:
  "(\<Sum>i::nat = 0..<2*nn. f i) = (\<Sum>i = 0..<nn. f (2*i)) + (\<Sum>i = 0..<nn. f (2*i+1))"
proof(induction nn)
  case (Suc n)
  have "(\<Sum>i::nat = 0..<2*(n+1). f i)  = (\<Sum>i::nat = 0..<(2*n). f i) + f(2*n+1) + f (2*n)"
    by( simp add: algebra_simps)
  also have "\<dots> = (\<Sum>i::nat = 0..<n. f (2*i)) + (\<Sum>i::nat = 0..<n. f (2*i+1)) + f(2*n+1) + f (2*n)"
    using Suc by simp
  also have "\<dots> = (\<Sum>i::nat = 0..<(Suc n). f (2*i)) + (\<Sum>i::nat = 0..<(Suc n). f (2*i+1))"
   by( simp add: algebra_simps)
  finally show ?case by simp
qed simp

lemma sum_even_odd_split: "even (a::nat) \<Longrightarrow> (\<Sum>j=0..<(a div 2). f (2*j))+ (\<Sum>j=0..<(a div 2). f (2*j+1)) =  (\<Sum>j=0..<a. f j)"
  by (induction a, simp)(metis even_two_times_div_two sum_splice)

lemma sum_splice_other_way_round: " (\<Sum>j=(0::nat)..<i. f (2*j)) + (\<Sum>j=0..<i. f (2*j+1)) =
        (\<Sum>j=(0::nat)..<2*i. f j )"
by (metis sum_splice)

lemma sum_neg_in: "- (\<Sum>j = 0..<l. (f j)::('a mod_ring)) =  (\<Sum>j = 0..<l. - f j) "
  by (simp add: sum_negf)

subsection \<open>Geometric Sums\<close>

text \<open>\label{geosum}\<close>

text \<open>This lemma will be important for proving properties on $\mathsf{NTT}$. At first, an informal proof sketch:
\begin{align*}
(1-x) \cdot \sum \limits _{l = 0} ^ {r-1} x^l
&= \sum \limits _{l = 0} ^ {r-1} x^l  - x \cdot \sum \limits _{l = 0} ^{r-1} x^l \\
&= \sum \limits _{l = 0} ^ {r-1} x^l  - \sum \limits _{l = 1} ^{r} x^l \\
& = 1 - x^r
\end{align*}

The same lemma for integers can be found in~\parencite{Dirichlet_Series-AFP}.
 Our version is adapted to finite fields.
\<close>

lemma geo_sum:
  assumes "x \<noteq> 1"
  shows "(1-x)*(\<Sum>l = 0..<r. (x::('a mod_ring))^l) = (1-x^r)"
proof-
  have 0:"x * (\<Sum>l = 0..<r. x^l) = (\<Sum>l = 0..<r. x^(Suc l))" using sum_in[of "\<lambda> l. x^l" x r]
    by(simp add: algebra_simps)
  have 1:"(\<Sum>l = 0..<r. x^l) - (\<Sum>l = 0..<r. x^(Suc l)) = (\<Sum>l = 0..<r. x^l - x^(Suc l))"
    by(rule sum_diff_in)
  have 2: "(\<Sum>l = 0..<r. x^l - x^(Suc l)) = 1 - x^r"
    by(induction r) simp+
  thus ?thesis
    by (simp add: lessThan_atLeast0 one_diff_power_eq)
qed

lemmas sum_rules = sum_in sum_eq sum_diff_in sum_swap sum_const sum_split sum_index_shift

end
end


(*<*) theory merge_sort imports Main begin (*>*)

fun le :: "nat \<Rightarrow> nat list \<Rightarrow> bool" where
  "le a []     = True"
| "le a (x#xs) = (a <= x \<and> le a xs)"

fun sorted2 :: "nat list \<Rightarrow> bool" where
"sorted2 [] = True "
| "sorted2 (x#[]) = True "
| "sorted2 (x#(y#r)) = ( x\<le>y \<and> sorted2 (y#r) )"

value "sorted [2::nat,1,3]"

primrec sorted :: "nat list \<Rightarrow> bool" where
  "sorted []     = True"
| "sorted (x#xs) = (le x xs \<and> sorted xs)"

lemma lemma_new2 :"(sorted2(x#y) \<Longrightarrow> le x y) \<Longrightarrow> ( sorted2 (x#a#y) \<Longrightarrow> le x (a#y) )"
proof -
  assume new3:"(sorted2(x#y) \<Longrightarrow> le x y)"
  assume new4:" sorted2 (x#a#y)"
  then have new5:"x\<le>a" by simp
  from new4 have "sorted2 (a#y)" by simp
  (* have  "a\<le>x \<Longrightarrow> le x y  \<Longrightarrow>  le a (x#y) "  using test1 by simp  *)  (* not in scope*)
  have "x\<le>a  \<Longrightarrow> sorted2 (a#y) \<Longrightarrow> sorted2 (x#y)"
  proof (induct y)
    case Nil
    then show ?case by auto
    next
    case (Cons a y)
      then show ?case by simp
  qed
  from this new5 new4 have "sorted2 (x#y)" by simp
  then have "le x y" using new3 by simp
  from this new5 show "le x (a#y)" by simp
qed

lemma lemma1_2:"sorted2(x#y) \<Longrightarrow> le x y"
proof -
  have 1:"sorted2(x#[]) \<Longrightarrow> le x []" by simp
  (*
  have 2:"(sorted2(x#y) \<Longrightarrow> le x y) \<Longrightarrow> ( sorted2 (a#x#y) \<Longrightarrow> le a (x#y) ) "  (*useless, failed attempt*)
  proof -
    assume 3:"(sorted2(x#y) \<Longrightarrow> le x y)"
    assume 4:" sorted2 (a#x#y)"
    then have 5:"a\<le>x " by simp
    from 4 have 6:"sorted2(x#y)" by simp
    from this 3 have 7:"le x y" by simp
    have test1:  "a\<le>x \<Longrightarrow> le x y  \<Longrightarrow>  le a (x#y) "
    proof -
      have " a\<le> x \<Longrightarrow> le x y \<Longrightarrow> le a y"
      proof (induct y)
        case Nil
        then show ?case by simp
      next
        case (Cons a y)
        then show ?case by simp
      qed
      then show  "a\<le>x \<Longrightarrow> le x y  \<Longrightarrow>  le a (x#y) "  by simp
    qed
    from this  5 7 show  "le a (x#y)" by simp
  qed *)
  (*have new2 :"(sorted2(x#y) \<Longrightarrow> le x y) \<Longrightarrow> ( sorted2 (x#a#y) \<Longrightarrow> le x (a#y) )"  (*doest work ,have to move it out*)
  proof -
    assume new3:"(sorted2(x#y) \<Longrightarrow> le x y)"
    assume new4:" sorted2 (x#a#y)"
    then have new5:"x\<le>a" by simp
    from new4 have "sorted2 (a#y)" by simp
    (* have  "a\<le>x \<Longrightarrow> le x y  \<Longrightarrow>  le a (x#y) "  using test1 by simp  *)  (* not in scope*)
    have "x\<le>a  \<Longrightarrow> sorted2 (a#y) \<Longrightarrow> sorted2 (x#y)"
    proof (induct y)
      case Nil
      then show ?case by auto
      next
      case (Cons a y)
        then show ?case by simp
    qed
    from this new5 new4 have "sorted2 (x#y)" by simp
    then have "le x y" using new3 by simp
    from this new5 show "le x (a#y)" by simp
  qed*)
  (*from new2 have "\<And> a x y. (sorted2(x#y) \<Longrightarrow> le x y) \<Longrightarrow> ( sorted2 (x#a#y) \<Longrightarrow> le x (a#y) )" by auto*)
  show "sorted2(x#y) \<Longrightarrow> le x y"
  proof (induct y)
    case Nil
    then show ?case by simp
  next
    case (Cons a y)
    from lemma_new2 show "\<And>a y. (sorted2 (x # y) \<Longrightarrow> le x y) \<Longrightarrow> sorted2 (x # a # y) \<Longrightarrow> le x (a # y)"
      by auto
  qed
qed

lemma lemma1: "(sorted (x#y) \<Longrightarrow> sorted2 (x#y) ) \<Longrightarrow> (sorted (a#x#y) \<Longrightarrow> sorted2 (a#x#y))" by simp

lemma lemma2: "(sorted (x#y) \<longrightarrow> sorted2 (x#y) ) \<Longrightarrow> (sorted (a#x#y) \<longrightarrow> sorted2 (a#x#y)) " by simp

lemma induct1: "\<And> P.  (P::nat list \<Rightarrow>bool) [] \<Longrightarrow> ( \<And> x. P (x#[])) \<Longrightarrow> ( \<And> a x y.( P (x#y) \<Longrightarrow> P (a#x#y) )) \<Longrightarrow> (\<And> l. P l) "  using sorted_wrt_induct by blast

(* same as induct1 *)
lemma induct1_2 : "  (P::nat list \<Rightarrow>bool) [] \<Longrightarrow> ( \<And> x. P (x#[])) \<Longrightarrow> ( \<And> a x y.( P (x#y) \<Longrightarrow> P (a#x#y) )) \<Longrightarrow> (\<And> l. P l) "  using sorted_wrt_induct by blast

definition PP :: "nat list \<Rightarrow>bool" where "(PP x) \<equiv>  (sorted x \<longrightarrow> sorted2 x)"

lemma lemma3: " \<And> a x y. PP(x#y) \<Longrightarrow> PP(a#x#y)" by (simp add: lemma2 PP_def)

lemma lemma4: "PP []" by (simp add: PP_def)

lemma lemma5: " \<And> x. PP (x#[])" by (simp add: PP_def)

(*
lemma lemma6: " sorted ll \<Longrightarrow> sorted2 ll"
proof -
  (* from lemma4 lemma5 lemma3 induct1 have 1: "\<And> l . PP(l)" by blast *)
  from induct1 lemma4 have " ( \<And> x. PP (x#[])) \<Longrightarrow> ( \<And> a x y.( PP (x#y) \<Longrightarrow> PP (a#x#y) )) \<Longrightarrow> (\<And> l. PP l)" by blast
  from this lemma5 have " ( \<And> a x y.( PP (x#y) \<Longrightarrow> PP (a#x#y) )) \<Longrightarrow> (\<And> l. PP l) " by simp
  from this lemma3 have " (\<And> l. PP l )" by simp
  then have "\<And> ll. sorted ll \<longrightarrow> sorted2 ll" by (simp add: PP_def)
  then show " sorted ll \<Longrightarrow> sorted2 ll" by simp
   (* then show ?thesis by simp *)  (* doesnt work *)
qed
*)

lemma lemma6_new_prex3:" le b (a#ll) \<longrightarrow> sorted2 (a#ll) \<longrightarrow> sorted2 (b # a#ll)"
  by simp

lemma lemma6_new_prex2:"le b ll \<longrightarrow> sorted2 ll \<longrightarrow> sorted2 (b #ll)"
proof (cases ll)
  case Nil
  then show ?thesis by simp
next
  case (Cons a list)
  from this lemma6_new_prex3 show ?thesis by simp
qed

lemma lemma6_new_pre: "(sorted ll \<Longrightarrow> sorted2 ll) \<Longrightarrow> sorted (a # ll) \<Longrightarrow> sorted2 (a # ll)"
proof -
  assume 1:"sorted ll \<Longrightarrow> sorted2 ll"
  assume 2:"sorted (a # ll)"
  from 2 have "sorted (ll)" by simp
  from this 1 have 4:"sorted2 ll" by simp
  from 2 have 3:"le a ll" by simp
  from 3 4 lemma6_new_prex2 show "sorted2 (a # ll) "by simp
qed

lemma lemma6_new: " sorted ll \<longrightarrow> sorted2 ll"
proof (induction ll)
  case Nil
  then show ?case by auto
next
  case (Cons a ll)
  from this lemma6_new_pre show ?case by simp
qed

lemma lemma7_pre: "(sorted2 ll \<Longrightarrow> sorted ll) \<Longrightarrow> sorted2 (a # ll) \<Longrightarrow> sorted (a # ll)"
proof -
  assume 1:"(sorted2 ll \<Longrightarrow> sorted ll)"
  assume 2:"sorted2 (a # ll)"
  from 2 have 3:"(sorted2 ll)"
    by (metis sorted2.elims(3) sorted2.simps(3))
  from 1 3 have 4: "sorted ll" by simp
  from 2 lemma1_2 have "le a ll" by simp
  from this 4 show "sorted (a#ll)" by simp
qed

lemma lemma7: " sorted2 ll \<longrightarrow> sorted ll"
proof (induct ll)
case Nil
  then show ?case by simp
next
  case (Cons a ll)
  from this lemma7_pre show ?case by auto
qed

lemma lemma7_again: " sorted2 ll \<longrightarrow> sorted ll"
proof (rule list.induct)
  show "sorted2 [] \<longrightarrow> sorted []" by auto
next
  from lemma7_pre show "\<And>x1 x2. sorted2 x2 \<longrightarrow> sorted x2 \<Longrightarrow> sorted2 (x1 # x2) \<longrightarrow> sorted (x1 # x2)"
    by auto
qed

lemma sort_eq: "sorted2 = sorted"
proof -
  from lemma7_again lemma6_new show  "sorted2 = sorted" by auto
qed

primrec count :: "nat list => nat => nat" where
  "count []     y = 0"
| "count (x#xs) y = (if x=y then Suc(count xs y) else count xs y)"

fun
 merge :: "nat list \<Rightarrow> nat list \<Rightarrow> nat list"
where
 "merge [] ys = ys" |
 "merge xs [] = xs" |
 "merge (x # xs) (y # ys) = (
   if x \<le> y
     then x # merge xs (y # ys)
     else y # merge (x # xs) ys
 )"

fun
 msort :: "nat list \<Rightarrow> nat list"
where
 "msort [] = []" |
 "msort [x] = [x]" |
 "msort xs = (
   let half = length xs div 2 in
   merge (msort (take half xs)) (msort (drop half xs))
 )"

lemma le_lemma: " le a x\<Longrightarrow> le a y \<Longrightarrow> le a (merge x y) "
proof (induct x y rule:merge.induct)
  show " \<And>ys. le a [] \<Longrightarrow> le a ys \<Longrightarrow> le a (merge [] ys)" by auto
next
  show " \<And>v va. le a (v # va) \<Longrightarrow> le a [] \<Longrightarrow> le a (merge (v # va) [])" by auto
next
  show "\<And>x xs y ys.
       (x \<le> y \<Longrightarrow> le a xs \<Longrightarrow> le a (y # ys) \<Longrightarrow> le a (merge xs (y # ys))) \<Longrightarrow>
       (\<not> x \<le> y \<Longrightarrow> le a (x # xs) \<Longrightarrow> le a ys \<Longrightarrow> le a (merge (x # xs) ys)) \<Longrightarrow>
       le a (x # xs) \<Longrightarrow> le a (y # ys) \<Longrightarrow> le a (merge (x # xs) (y # ys))" by auto
qed

(* interesting but not needed
lemma le_lemma_inv: " le a (merge x y) \<Longrightarrow> le a x" sorry

lemma le_lemma_inv2:  " le a (merge x y) \<Longrightarrow> le a y" sorry
*)

lemma  le_lemma2: "a\<le> x \<Longrightarrow> le x y \<Longrightarrow> le a y"
proof (induct y)
  case Nil
  then show ?case by simp
next
  case (Cons a y)
  then show ?case by auto
qed

lemma sort_merge_pre: " (x \<le> y \<Longrightarrow> sorted2 xs \<longrightarrow> sorted2 (y # ys) \<longrightarrow> sorted2 (merge xs (y # ys))) \<Longrightarrow>
       (\<not> x \<le> y \<Longrightarrow> sorted2 (x # xs) \<longrightarrow> sorted2 ys \<longrightarrow> sorted2 (merge (x # xs) ys)) \<Longrightarrow>
       sorted2 (x # xs) \<Longrightarrow> sorted2 (y # ys) \<Longrightarrow> sorted2 (merge (x # xs) (y # ys))"
proof -
  assume  1:"(x \<le> y \<Longrightarrow> sorted2 xs \<longrightarrow> sorted2 (y # ys) \<longrightarrow> sorted2 (merge xs (y # ys)))"
  from this sort_eq have new1: "(x \<le> y \<Longrightarrow> sorted xs \<longrightarrow> sorted (y # ys) \<longrightarrow> sorted (merge xs (y # ys)))" by simp
  assume  2:" (\<not> x \<le> y \<Longrightarrow> sorted2 (x # xs) \<longrightarrow> sorted2 ys \<longrightarrow> sorted2 (merge (x # xs) ys))"
  from this sort_eq have new2: " (\<not> x \<le> y \<Longrightarrow> sorted (x # xs) \<longrightarrow> sorted ys \<longrightarrow> sorted (merge (x # xs) ys))" by simp
  assume  3:"sorted2 (x # xs) "
  from this sort_eq have new3: "sorted (x#xs)" by simp
  assume  4:"sorted2 (y # ys) "
  from this sort_eq have new4: "sorted (y#ys)" by simp
  from new3 have new5:"le x xs" by auto
  from new4 have new6:"le y ys" by auto
  from new3 have new3_2:"sorted xs" by simp
  from new4 have new4_2:"sorted ys" by simp
  have new_goal: "sorted (merge (x # xs) (y # ys))"
  proof (cases)
    assume 5:"x\<le>y"
    from this new1  have " sorted xs \<longrightarrow> sorted (y # ys) \<longrightarrow> sorted (merge xs (y # ys))" by simp
    from this new3_2 new4 have key:"sorted (merge xs (y # ys))" by simp
    from this have "sorted ( x #(merge xs (y # ys)) )"
    proof -
      have "le x ys" using 5 new6 le_lemma2 by simp
      from this have "le x (y#ys)" using 5 by simp
      from this new5 le_lemma have "le x (merge xs (y # ys))" by simp
      from this key show "sorted ( x #(merge xs (y # ys)) )" by simp
    qed
    from this 5 show  "sorted (merge (x # xs) (y # ys))" by simp
    next
    assume 5:"\<not> x\<le>y "
    from this new2 have " sorted (x # xs) \<longrightarrow> sorted ys \<longrightarrow> sorted(merge (x # xs) ys)" by simp
    from this new3 new4_2 have key:" sorted(merge (x # xs) ys) " by simp
    from 5 have 55:"y \<le> x" by simp
    have "sorted ( y # merge (x # xs) ys )"
    proof -
      have "le y xs" using 55 new5 le_lemma2 by simp
      from this have "le y (x#xs)" using 55 by simp
      from this new6 le_lemma have "le y (merge (x # xs) ys) " by simp
      from this key show "sorted ( y # merge (x # xs) ys )" by simp
    qed
    from this 5 show  "sorted (merge (x # xs) (y # ys))" by simp
  qed
  from this sort_eq show    "sorted2 (merge (x # xs) (y # ys))"  by simp
  (*  failed
  proof (cases)
    assume 5:"x\<le>y"
    from 5 1 have 6:"(sorted2 xs \<longrightarrow> sorted2 (y # ys) \<longrightarrow> sorted2 (merge xs (y # ys)))" by simp
    from 5 have "merge (x # xs) (y # ys )  = x # merge xs (y # ys) " by simp
    from 3 sorted2_lemma have "sorted2 (xs)" by simp
    from this 4 6 have 7: " sorted2 (merge xs (y # ys)) " by simp
    from this have "sorted2 ( x # merge xs (y # ys) )"
    proof (cases xs)
      case Nil
      from this 7 show "sorted2 ( x # merge xs (y # ys) )"  sorry
    next
      case (Cons a list)
      show "sorted2 ( x # merge xs (y # ys) )"
      proof
        case "a< y"
        short
    qed
    from 5 this show "sorted2 (merge (x # xs) (y # ys))" by simp
    next
    assume "\<not> x\<le>y "
    show  "sorted2 (merge (x # xs) (y # ys))" sorry
  qed
  *)
qed

lemma lemma_final_pre:" sorted2 a \<longrightarrow> sorted2 b \<longrightarrow> sorted2 (merge a b )"
proof (induction a b rule: merge.induct)
  show "\<And>ys. sorted2 [] \<longrightarrow> sorted2 ys \<longrightarrow> sorted2 (merge [] ys)" by auto
next
  show "\<And>v va. sorted2 (v # va) \<longrightarrow> sorted2 [] \<longrightarrow> sorted2 (merge (v # va) [])" by auto
next
  show "\<And>x xs y ys.
       (x \<le> y \<Longrightarrow> sorted2 xs \<longrightarrow> sorted2 (y # ys) \<longrightarrow> sorted2 (merge xs (y # ys))) \<Longrightarrow>
       (\<not> x \<le> y \<Longrightarrow> sorted2 (x # xs) \<longrightarrow> sorted2 ys \<longrightarrow> sorted2 (merge (x # xs) ys)) \<Longrightarrow>
       sorted2 (x # xs) \<longrightarrow> sorted2 (y # ys) \<longrightarrow> sorted2 (merge (x # xs) (y # ys))"
    using sort_merge_pre by simp
qed

(*
theorem lemma_final2:"sorted2 (msort ll)"  (is ?test_is)
proof (induct ll rule: msort.induct)
  show "sorted2 (msort [])" by simp
next
  show "\<And>x. sorted2 (msort [x])" by simp
next
  show "\<And>v vb vc.
       (\<And>x. x = length (v # vb # vc) div 2 \<Longrightarrow> sorted2 (msort (take x (v # vb # vc)))) \<Longrightarrow>
       (\<And>x. x = length (v # vb # vc) div 2 \<Longrightarrow> sorted2 (msort (drop x (v # vb # vc)))) \<Longrightarrow>
       sorted2 (msort (v # vb # vc))" using lemma_final_pre by simp
qed
*)

lemma lemma_final2_again:"sorted2 (msort ll)"  (is ?test_is)   (*manually ,by metis *)
proof (induct ll rule: msort.induct)
  show "sorted2 (msort [])" by simp
next
  show "\<And>x. sorted2 (msort [x])" by simp
next
  show "\<And>v vb vc.
       (\<And>x. x = length (v # vb # vc) div 2 \<Longrightarrow> sorted2 (msort (take x (v # vb # vc)))) \<Longrightarrow>
       (\<And>x. x = length (v # vb # vc) div 2 \<Longrightarrow> sorted2 (msort (drop x (v # vb # vc)))) \<Longrightarrow>
       sorted2 (msort (v # vb # vc))"
  proof -
    fix v vb vc
    show  "(\<And>x. x = length (v # vb # vc) div 2 \<Longrightarrow> sorted2 (msort (take x (v # vb # vc)))) \<Longrightarrow>
       (\<And>y. y = length (v # vb # vc) div 2 \<Longrightarrow> sorted2 (msort (drop y (v # vb # vc)))) \<Longrightarrow>
       sorted2 (msort (v # vb # vc))"
    proof -
    assume 1:" (\<And>x. x = length (v # vb # vc) div 2 \<Longrightarrow> sorted2 (msort (take x (v # vb # vc))))"
    assume 2:"(\<And>y. y = length (v # vb # vc) div 2 \<Longrightarrow> sorted2 (msort (drop y (v # vb # vc))))"
    obtain z where z:"z =  length (v # vb # vc) div 2 " by simp
    from z 1 have 3:"sorted2 (msort (take z (v # vb # vc)))" by simp
    from z 2 have 4:"sorted2 (msort (drop z (v # vb # vc)))" by simp
    from z have "msort (v # vb # vc)  = merge (msort (take z (v#vb#vc))) (msort (drop z (v#vb#vc)))" by simp
    from this 3 4 lemma_final_pre show "sorted2 (msort (v # vb # vc))" by metis
  qed
qed
qed

(* failed attemp bc of didnt use "induct ll"
lemma lemma_final:"sorted2 (msort ll)"
proof (induct rule: msort.induct)
  show "sorted2 []" by simp
next
  show "\<And>x. sorted2 [x]" by simp
next

  show "\<And>v vb vc.
       (\<And>x. x = length (v # vb # vc) div 2 \<Longrightarrow> sorted2 (take x (v # vb # vc))) \<Longrightarrow>
       (\<And>y. y = length (v # vb # vc) div 2 \<Longrightarrow> sorted2 (drop y (v # vb # vc))) \<Longrightarrow> sorted2 (v # vb # vc)"
  proof -
    fix v vb vc
    show  "
       (\<And> x. x = length (v # vb # vc) div 2 \<Longrightarrow> sorted2 (take x (v # vb # vc))) \<Longrightarrow>
       (\<And> y. y = length (v # vb # vc) div 2 \<Longrightarrow> sorted2 (drop y (v # vb # vc))) \<Longrightarrow> sorted2 (v # vb # vc)"
    proof -
      assume  1:"(\<And> x. x = length (v # vb # vc) div 2 \<Longrightarrow> sorted2 (take x (v # vb # vc)))"
      then have 2:"  sorted2 (take ( length (v # vb # vc) div 2) (v # vb # vc))" by simp
      assume  3:"\<And> y. y = length (v # vb # vc) div 2 \<Longrightarrow> sorted2 (drop y (v # vb # vc))"
      then have 4:" sorted2 (drop ( length (v # vb # vc) div 2) (v # vb # vc)) " by simp
      obtain z where z:"z =  length (v # vb # vc) div 2 " by simp
      from 1 2 z have 5:"sorted2 (take z (v # vb # vc))" by simp
      from 3 4 z have 6:"sorted2 (drop z (v # vb # vc))" by simp
      from z 5 6 have "sorted2 (v # vb # vc) " sorry
      from this show " sorted2 (v # vb # vc)" by simp
  qed
qed
*)
lemma count_lemma0:"count (merge xs ys) x = (count xs x) + (count ys x)"
proof (induct xs ys rule:merge.induct)
  show "\<And>ys. count (merge [] ys) x = count [] x + count ys x" by auto
next
  show "\<And>v va. count (merge (v # va) []) x = count (v # va) x + count [] x" by auto
next
  show "\<And>xa xs y ys.
       (xa \<le> y \<Longrightarrow> count (merge xs (y # ys)) x = count xs x + count (y # ys) x) \<Longrightarrow>
       (\<not> xa \<le> y \<Longrightarrow> count (merge (xa # xs) ys) x = count (xa # xs) x + count ys x) \<Longrightarrow>
       count (merge (xa # xs) (y # ys)) x = count (xa # xs) x + count (y # ys) x " by auto
qed

(*
lemma count_lemma1: "count xs x = (count (take n xs) x)  + (count (drop n xs) x)"
proof (induct xs)
  show " count [] x = count (take n []) x + count (drop n []) x" by auto
next
  show "\<And>a xs. count xs x = count (take n xs) x + count (drop n xs) x \<Longrightarrow>
            count (a # xs) x = count (take n (a # xs)) x + count (drop n (a # xs)) x "
    sorry
qed
*)

lemma count_lemma_cat: "count (xs @ ys) x = (count xs x)  + (count ys x)"
proof (induct xs)
  show "count ([] @ ys) x = count [] x + count ys x" by auto
next
  show "\<And>a xs. count (xs @ ys) x = count xs x + count ys x \<Longrightarrow>
            count ((a # xs) @ ys) x = count (a # xs) x + count ys x" by auto
qed

lemma cat_lemma: " xs = (take n xs) @ (drop n xs)"
proof (induct xs)
  show "[] = take n [] @ drop n []" by auto
next
  show "\<And>a xs. xs = take n xs @ drop n xs \<Longrightarrow> a # xs = take n (a # xs) @ drop n (a # xs) "
    by auto
qed

lemma count_lemma11:  "count xs x = (count (take n xs) x)  + (count (drop n xs) x)" (is "?P" )
proof -
  show "?P" using count_lemma_cat cat_lemma by metis
qed

theorem "sorted (msort ll)"
proof -
  show "sorted (msort ll)" using lemma_final2_again sort_eq by simp
qed

theorem "sorted2 (msort ll)"
proof -
  show "sorted2 (msort ll)" using lemma_final2_again by simp
qed

theorem "count (msort xs) x = count xs x" (is "?P" )
proof (induct xs rule:msort.induct)
  show "count (msort []) x = count [] x" by auto
next
  show "\<And>xa. count (msort [xa]) x = count [xa] x" by auto
next
  show "\<And>v vb vc.
       (\<And>xa. xa = length (v # vb # vc) div 2 \<Longrightarrow>
              count (msort (take xa (v # vb # vc))) x = count (take xa (v # vb # vc)) x) \<Longrightarrow>
       (\<And>xa. xa = length (v # vb # vc) div 2 \<Longrightarrow>
              count (msort (drop xa (v # vb # vc))) x = count (drop xa (v # vb # vc)) x) \<Longrightarrow>
       count (msort (v # vb # vc)) x = count (v # vb # vc) x "
    using count_lemma11 count_lemma0 by simp
qed


(*
Author: Alexander Katovsky
*)

header "Universe"

theory Universe
imports "~~/src/HOL/ZF/MainZF"
begin

locale Universe =
  fixes U :: ZF (structure)
  assumes Uempty  : "Elem Empty U"
  and     Usubset : "Elem u U \<Longrightarrow> subset u U"
  and     Usingle : "Elem u U \<Longrightarrow> Elem (Singleton u) U"
  and     Upow    : "Elem u U \<Longrightarrow> Elem (Power u) U"
  and     Uim     : "\<lbrakk>Elem I U ; Elem u (Fun I U) \<rbrakk> \<Longrightarrow> Elem (Sum (Range u)) U"
  and     Unat    : "Elem Nat U"
(*
axiomatization where
  Grothendieck: "\<forall> x . \<exists> uni . (Universe uni) \<and> Elem x uni"
*)
lemma ElemLambdaFun : "(\<And> x .Elem x u \<Longrightarrow> Elem (f x) U) \<Longrightarrow> Elem (Lambda u f) (Fun u U)"
apply (subst Elem_Lambda_Fun)
apply simp
done

lemma RangeRepl: "Range (Lambda A f) = Repl A f"
apply (subst Ext)
apply (subst Range)
apply (simp add: Repl Opair Lambda_def)
done

lemma (in Universe) Utrans: "\<lbrakk>Elem a U ; Elem b a\<rbrakk> \<Longrightarrow> Elem b U"
apply (drule Usubset)
apply (insert HOLZF.subset_def [of a U])
apply (auto simp add: Usubset)
done

lemma ReplId: "Repl A id = A"
by (subst Ext, simp add: Repl)

lemma (in Universe) UniverseSum : "Elem u U \<Longrightarrow> Elem (Sum u) U"
apply (frule_tac u = "Lambda u id" in Uim)
apply (subst Elem_Lambda_Fun)
apply (frule Usubset)
apply (simp add: subset_def)
apply (simp only: RangeRepl ReplId)
done

lemma (in Universe) UniverseUnion:
  assumes "Elem u U" and "Elem v U"
  shows "Elem (union u v) U"
proof-
  let ?f = "(% x. if x = Empty then u else v)"
    and ?S = "(Power (Power Empty))"
  have 1: "(Upair u v) = Range (Lambda ?S ?f)"
    by (subst RangeRepl, simp add: Upair_def)
  have 2: "\<lbrakk>Elem u U; Elem v U\<rbrakk> \<Longrightarrow> Elem (Lambda ?S ?f) (Fun ?S U)"
    by (rule ElemLambdaFun, simp)
  show ?thesis using assms
    apply (subst HOLZF.union_def)
    apply (subst 1)
    apply (rule_tac I="?S" in Uim)
    apply (rule Upow)+
    apply (rule Uempty)
    apply (rule 2)
    apply simp+
    done
qed

lemma UPairSingleton: "Upair u v = union (Singleton u) (Singleton v)"
apply (subst Ext)
apply (subst Upair)
apply (subst union)
apply (subst Singleton)+
apply (simp)
done

lemma (in Universe) UniverseUPair: "\<lbrakk>Elem u U ; Elem v U\<rbrakk> \<Longrightarrow> Elem (Upair u v) U"
apply (subst UPairSingleton)
apply (rule UniverseUnion)
apply (rule Usingle, simp)+
done

lemma (in Universe) UniversePair: "\<lbrakk>Elem u U ; Elem v U\<rbrakk> \<Longrightarrow> Elem (Opair u v) U"
apply (subst Opair_def)
apply ((rule UniverseUPair)+, simp+)+
done

lemma (in Universe) "\<lbrakk>Elem u U ; Elem v U\<rbrakk> \<Longrightarrow> Elem (Sum (Repl u (%x . Singleton (Opair x v)))) U"
apply (rule RangeRepl [THEN subst])
apply (rule Uim [of u], simp)
apply (rule ElemLambdaFun)
apply (rule Usingle)
apply (rule UniversePair)
apply (rule Utrans)
apply simp+
done

lemma SumRepl: "Sum (Repl A (Singleton o f)) = Repl A f"
proof-
  show ?thesis
    apply (subst Ext)
    apply (subst Sum)
    apply (subst Repl)+
    apply (auto simp add: Singleton)
    proof-
      fix a
      show "Elem a A \<Longrightarrow> \<exists>y. Elem (f a) y \<and> (\<exists>a. Elem a A \<and> y = Singleton (f a))"
        apply (rule exI [of _ "Singleton (f a)"])
        apply (subst Singleton, simp+)
        apply (rule exI [of _ "a"], simp+)
        done
      qed
    qed

lemma (in Universe) UniverseProd:
  assumes "Elem u U" and "Elem v U"
  shows   "Elem (CartProd u v) U"
proof-
  show ?thesis using assms
    apply (subst CartProd_def)
    apply (rule RangeRepl [of u "% x . (Repl v (Opair x))", THEN subst])
    apply (rule Uim [of u], simp)
    apply (rule ElemLambdaFun)
    proof-
      fix x
      show "\<lbrakk>Elem u U; Elem v U; Elem x u\<rbrakk> \<Longrightarrow> Elem (Repl v (Opair x)) U"
        apply (drule Utrans [of u x], simp)
        apply (rule SumRepl [THEN subst])
        apply (rule RangeRepl [THEN subst])
        apply (rule Uim [of v], simp)
        apply (rule ElemLambdaFun,simp)
        apply (rule Usingle)
        apply (rule UniversePair)
        apply (drule Usubset, simp)
        proof-
          fix xa
          show "\<lbrakk>Elem v U; Elem x u; Elem x U; Elem xa v\<rbrakk> \<Longrightarrow> Elem xa U"
            by (rule Utrans, simp+)
        qed
      qed
    qed

lemma (in Universe) UniverseSubset: "\<lbrakk>subset u v ; Elem v U\<rbrakk> \<Longrightarrow> Elem u U"
  apply (drule_tac HOLZF.Power [of u v, THEN ssubst])
  apply (drule Upow)
  apply (rule Utrans, simp+)
  done

definition
  Product :: "ZF \<Rightarrow> ZF" where
  "Product U = Sep (Fun U (Sum U)) (%f . (\<forall> u . Elem u U \<longrightarrow> Elem (app f u) u))"

lemma SepSubset: "subset (Sep A p) A"
apply (subst subset_def)
apply (subst Sep, simp)
done

lemma SubsetSmall:
  assumes "subset A' A" and "subset A B" shows "subset A' B"
  proof-
    have "(subset A' A \<and> subset A B) \<longrightarrow> subset A' B"
      by ((subst subset_def)+, simp+)
    thus ?thesis using assms by simp
  qed

lemma SubsetTrans:
  assumes "(subset a b)" and "(subset b c)"
  shows "(subset a c)"
proof-
  have "(subset a b) \<and> (subset b c) \<longrightarrow> (subset a c)"
    by ((subst subset_def)+, simp)
  thus ?thesis using assms by simp
qed

lemma SubsetSepTrans: "subset A B \<Longrightarrow> subset (Sep A p) B"
apply (rule SubsetSmall [of "Sep A p" A B])
apply (rule SepSubset)
by simp

lemma ProductSubset: "subset (Product u) (Power (CartProd u (Sum u)))"
apply (subst Product_def)
apply (subst Fun_def)
apply (subst PFun_def)
apply (rule SubsetSepTrans)+
apply (subst subset_def)
by simp

lemma (in Universe) UniverseProduct: "Elem u U \<Longrightarrow> Elem (Product u) U"
apply (rule_tac u="(Product u)" and v="Power (CartProd u (Sum u))" in UniverseSubset)
apply (rule ProductSubset)
apply (rule Upow)
apply (rule UniverseProd, simp)
apply (rule UniverseSum,simp)
done

lemma ZFImageRangeExplode: "x \<in> range explode \<Longrightarrow> f ` x \<in> range explode"
proof-
  assume "x \<in> range explode"
  from this obtain y where "x = explode y" using range_ex1_eq by auto
  hence "f ` x = explode (Repl y f)" using explode_Repl_eq by simp
  thus "f ` x \<in> range explode" by auto
qed

definition "subsetFn X Y \<equiv> \<lambda> x . (if x \<in> Y then x else SOME y . y \<in> Y)"

lemma subsetFn: "\<lbrakk>Y \<noteq> {} ; Y \<subseteq> X \<rbrakk> \<Longrightarrow> (subsetFn X Y) ` X = Y"
proof(auto simp add: subsetFn_def)
  fix x assume "x \<in> Y"
  thus "(SOME y. y \<in> Y) \<in> Y" using someI_ex[of "\<lambda> x . x \<in> Y"] by auto
qed

lemma ZFSubsetRangeExplode: "\<lbrakk>X \<in> range explode ; Y \<subseteq> X\<rbrakk> \<Longrightarrow> Y \<in> range explode"
proof(cases "Y = {}", simp)
  have "explode Empty = {}" using explode_Empty by simp
  thus "{} \<in> range explode" by (auto simp add: explode_def)
  assume "Y \<noteq> {}" and "Y \<subseteq> X" and "X \<in> range explode" thus "Y \<in> range explode"
    using ZFImageRangeExplode[of X "subsetFn X Y"] subsetFn[of Y X] by simp
qed

lemma ZFUnionRangeExplode:
  assumes "\<And> x . x \<in> A \<Longrightarrow> f x \<in> range explode" and "A \<in> range explode"
  shows "(\<Union> x \<in> A . f x) \<in> range explode"
proof-
  let ?S = "Sep (Sum (Repl (implode A) (implode o f))) (\<lambda> y . \<exists> x  . (Elem x (implode A)) \<and> (Elem y (implode (f x))))"
  have "explode ?S = (\<Union> x \<in> A . f x)"
  proof(auto simp add: UNION_eq explode_def Sep Sum Repl assms Elem_implode)
    fix x y assume a: "y \<in> A" and b: "x \<in> f y"
    show "\<exists>z. Elem x z \<and> (\<exists>a. a \<in> A \<and> z = implode (f a))"
      apply(rule exI[where ?x = "implode (f y)"])
      apply(auto simp add: explode_def Sep Sum Repl assms Elem_implode a b)
      by(rule exI[where ?x = y], simp add: a)
  qed
  thus ?thesis by auto
qed

lemma ZFUnionNatInRangeExplode: "(\<And> (n :: nat) . f n \<in> range explode) \<Longrightarrow> (\<Union> n . f n) \<in> range explode"
proof-
  assume a: "(\<And> (n :: nat) . f n \<in> range explode)"
  have "explode Nat \<in> range explode" by simp
  moreover have "\<And> n . n \<in> (explode Nat) \<Longrightarrow> (f o Nat2nat) n \<in> range explode" using a
    by(auto simp add: explode_def)
  moreover have "(\<Union> n . f n) = (\<Union> n \<in> (explode Nat) . (f o Nat2nat) n)"
  proof(auto simp add: Nat2nat_def)
    fix x n assume aa: "x \<in> f n" show "\<exists> n \<in> (explode Nat) . x \<in> f (inv nat2Nat n)"
      apply(rule bexI[where ?x = "nat2Nat n"])
      by(auto simp add: aa inj_nat2Nat explode_Elem)
  qed
  ultimately show "(\<Union> n . f n) \<in> range explode" using ZFUnionRangeExplode by simp
qed

lemma ZFProdFnInRangeExplode: "\<lbrakk>A \<in> range explode ; B \<in> range explode\<rbrakk> \<Longrightarrow> f ` (A \<times> B) \<in> range explode"
proof-
  assume a: "A \<in> range explode" and b: "B \<in> range explode"
  let ?X = "(explode (CartProd (implode A) (implode B)))"
  have "f ` (A \<times> B) = (f  o (\<lambda> z . (Fst z, Snd z))) ` ?X"
  proof(auto simp add: explode_def CartProd image_def Fst Snd)
    {
      fix z y assume z: "z \<in> A" and y: "y \<in> B" show "\<exists>x. (\<exists>a. Elem a (implode A) \<and>
        (\<exists>b. Elem b (implode B) \<and> x = Opair a b)) \<and> f (z, y) = f (Fst x, Snd x)"
        apply(insert z y a b)
        apply(rule exI[where ?x = "Opair z y"])
        apply(auto simp add: Opair explode_Elem Fst Snd)
        done
    }
    {
      fix a b assume aa: "Elem a (implode A)" and bb: "Elem b (implode B)"
      show "\<exists> x \<in> A . \<exists> y \<in> B . f (a,b) = f (x,y)"
        by(rule bexI[where ?x = a], rule bexI[where ?x = b], simp, insert a b aa bb, auto simp add: explode_Elem)
    }
  qed
  moreover have "?X \<in> range explode" by simp
  ultimately show "f ` (A \<times> B) \<in> range explode" using ZFImageRangeExplode by simp
qed

lemma ZFUnionInRangeExplode: "\<lbrakk>A \<in> range explode ; B \<in> range explode\<rbrakk> \<Longrightarrow> A \<union> B \<in> range explode"
proof-
  assume "A \<in> range explode" and "B \<in> range explode"
  from this obtain A' B' where A': "A = explode A'" and B': "B = explode B'" by auto
  have "A \<union> B = explode (union (implode A) (implode B))"
    by(auto simp add: explode_union  union explode_Elem A' B')
  thus "A \<union> B \<in> range explode" by auto
qed

lemma SingletonInRangeExplode: "{x} \<in> range explode"
proof-
  have "explode (Singleton x) = {x}" by(auto simp add: explode_def Singleton)
  thus ?thesis by auto
qed

definition ZFTriple :: "[ZF,ZF,ZF] \<Rightarrow> ZF" where
  "ZFTriple a b c = Opair (Opair a b) c"
definition "ZFTFst = Fst o Fst"
definition "ZFTSnd = Snd o Fst"
definition "ZFTThd = Snd"

lemma ZFTFst: "ZFTFst (ZFTriple a b c) = a"
  by(auto simp add: ZFTriple_def ZFTFst_def Fst)
lemma ZFTSnd: "ZFTSnd (ZFTriple a b c) = b"
  by(auto simp add: ZFTriple_def ZFTSnd_def Snd Fst)
lemma ZFTThd: "ZFTThd (ZFTriple a b c) = c"
  by(auto simp add: ZFTriple_def ZFTThd_def Snd Fst)

lemma ZFTriple: "ZFTriple a b c = ZFTriple a' b' c' \<Longrightarrow> (a = a' \<and> b = b' \<and> c = c')"
by(auto simp add: ZFTriple_def Opair)

lemma ZFSucZero: "Nat2nat (SucNat Empty) = 1"
proof-
  have "nat2Nat 0 = Empty" by auto
  hence "(SucNat Empty) = nat2Nat (Suc 0)" by auto
  hence "Nat2nat (SucNat Empty) = Nat2nat (nat2Nat (Suc 0))" by simp
  also have "... = Suc 0" using Nat2nat_nat2Nat[of "Suc 0"] by simp
  finally show ?thesis by simp
qed

lemma ZFZero: "Nat2nat Empty = 0"
proof-
  have "nat2Nat 0 = Empty" by auto
  hence "Nat2nat Empty = Nat2nat (nat2Nat 0)" by simp
  thus ?thesis using Nat2nat_nat2Nat[of "0"] by simp
qed

lemma ZFSucNeq0: "Elem x Nat \<Longrightarrow> Nat2nat (SucNat x) \<noteq> 0"
by(auto simp add: Nat2nat_SucNat)

end