section \<open>Order and equivalence on lenses\<close>

theory Lens_Order
imports Lens_Algebra
begin

text \<open>A lens $X$ is a sub-lens of $Y$ if there is a well-behaved lens $Z$ such that $X = Z \lcomp Y$,
  or in other words if $X$ can be expressed purely in terms of $Y$.\<close>

definition sublens :: "('a \<Longrightarrow> 'c) \<Rightarrow> ('b \<Longrightarrow> 'c) \<Rightarrow> bool" (infix "\<subseteq>\<^sub>L" 55) where
[lens_defs]: "sublens X Y = (\<exists> Z :: ('a, 'b) lens. vwb_lens Z \<and> X = Z ;\<^sub>L Y)"

lemma sublens_pres_mwb:
  "\<lbrakk> mwb_lens Y; X \<subseteq>\<^sub>L Y \<rbrakk> \<Longrightarrow> mwb_lens X"
  by (unfold_locales, auto simp add: sublens_def lens_comp_def)

lemma sublens_pres_wb:
  "\<lbrakk> wb_lens Y; X \<subseteq>\<^sub>L Y \<rbrakk> \<Longrightarrow> wb_lens X"
  by (unfold_locales, auto simp add: sublens_def lens_comp_def)

lemma sublens_pres_vwb:
  "\<lbrakk> vwb_lens Y; X \<subseteq>\<^sub>L Y \<rbrakk> \<Longrightarrow> vwb_lens X"
  by (unfold_locales, auto simp add: sublens_def lens_comp_def)

lemma sublens_refl:
  "X \<subseteq>\<^sub>L X"
  using id_vwb_lens sublens_def by force

lemma sublens_trans:
  "\<lbrakk> X \<subseteq>\<^sub>L Y; Y \<subseteq>\<^sub>L Z \<rbrakk> \<Longrightarrow> X \<subseteq>\<^sub>L Z"
  apply (auto simp add: sublens_def lens_comp_assoc)
  apply (rename_tac Z\<^sub>1 Z\<^sub>2)
  apply (rule_tac x="Z\<^sub>1 ;\<^sub>L Z\<^sub>2" in exI)
  apply (simp add: lens_comp_assoc)
  using comp_vwb_lens apply blast
done

lemma sublens_least: "wb_lens X \<Longrightarrow> 0\<^sub>L \<subseteq>\<^sub>L X"
  using sublens_def unit_vwb_lens by fastforce

lemma sublens_greatest: "vwb_lens X \<Longrightarrow> X \<subseteq>\<^sub>L 1\<^sub>L"
  by (simp add: sublens_def)

lemma sublens_obs_get:
  "\<lbrakk> mwb_lens X; Y \<subseteq>\<^sub>L X \<rbrakk> \<Longrightarrow>  get\<^bsub>Y\<^esub> (put\<^bsub>X\<^esub> \<sigma> v) = get\<^bsub>Y\<^esub> (put\<^bsub>X\<^esub> \<rho> v)"
  by (auto simp add: sublens_def lens_comp_def)

definition lens_equiv :: "('a \<Longrightarrow> 'c) \<Rightarrow> ('b \<Longrightarrow> 'c) \<Rightarrow> bool" (infix "\<approx>\<^sub>L" 51) where
[lens_defs]: "lens_equiv X Y = (X \<subseteq>\<^sub>L Y \<and> Y \<subseteq>\<^sub>L X)"

lemma lens_equivI [intro]:
  "\<lbrakk> X \<subseteq>\<^sub>L Y; Y \<subseteq>\<^sub>L X \<rbrakk> \<Longrightarrow> X \<approx>\<^sub>L Y"
  by (simp add: lens_equiv_def)

lemma lens_equiv_refl:
  "X \<approx>\<^sub>L X"
  by (simp add: lens_equiv_def sublens_refl)

lemma lens_equiv_sym:
  "X \<approx>\<^sub>L Y \<Longrightarrow> Y \<approx>\<^sub>L X"
  by (simp add: lens_equiv_def)

lemma lens_equiv_trans:
  "\<lbrakk> X \<approx>\<^sub>L Y; Y \<approx>\<^sub>L Z \<rbrakk> \<Longrightarrow> X \<approx>\<^sub>L Z"
  by (auto intro: sublens_trans simp add: lens_equiv_def)

lemma sublens_pres_indep:
  "\<lbrakk> X \<subseteq>\<^sub>L Y; Y \<bowtie> Z \<rbrakk> \<Longrightarrow> X \<bowtie> Z"
  apply (auto intro!:lens_indepI simp add: sublens_def lens_comp_def lens_indep_comm)
  apply (simp add: lens_indep_sym)
done

lemma lens_quotient_mwb:
  "\<lbrakk> mwb_lens Y; X \<subseteq>\<^sub>L Y \<rbrakk> \<Longrightarrow> mwb_lens (X /\<^sub>L Y)"
  by (unfold_locales, auto simp add: lens_quotient_def lens_create_def sublens_def lens_comp_def comp_def)

subsection \<open>Lens algebraic laws\<close>

lemma plus_lens_distr: "mwb_lens Z \<Longrightarrow> (X +\<^sub>L Y) ;\<^sub>L Z = (X ;\<^sub>L Z) +\<^sub>L (Y ;\<^sub>L Z)"
  by (auto simp add: lens_comp_def lens_plus_def comp_def)

text \<open>This law explains the behaviour of lens quotient.\<close>

lemma lens_quotient_comp:
  "\<lbrakk> weak_lens Y; X \<subseteq>\<^sub>L Y \<rbrakk> \<Longrightarrow> (X /\<^sub>L Y) ;\<^sub>L Y = X"
  by (auto simp add: lens_quotient_def lens_comp_def comp_def sublens_def)

lemma lens_comp_quotient:
  "weak_lens Y \<Longrightarrow> (X ;\<^sub>L Y) /\<^sub>L Y = X"
  by (simp add: lens_quotient_def lens_comp_def)

lemma lens_quotient_id: "weak_lens X \<Longrightarrow> (X /\<^sub>L X) = 1\<^sub>L"
  by (force simp add: lens_quotient_def id_lens_def)

lemma lens_quotient_id_denom: "X /\<^sub>L 1\<^sub>L = X"
  by (simp add: lens_quotient_def id_lens_def lens_create_def)

lemma lens_quotient_unit: "weak_lens X \<Longrightarrow> (0\<^sub>L /\<^sub>L X) = 0\<^sub>L"
  by (simp add: lens_quotient_def zero_lens_def)

lemma lens_quotient_plus:
  "\<lbrakk> mwb_lens Z; X \<subseteq>\<^sub>L Z; Y \<subseteq>\<^sub>L Z \<rbrakk> \<Longrightarrow> (X +\<^sub>L Y) /\<^sub>L Z = (X /\<^sub>L Z) +\<^sub>L (Y /\<^sub>L Z)"
  apply (auto simp add: lens_quotient_def lens_plus_def sublens_def lens_comp_def comp_def)
  apply (rule ext)
  apply (rule ext)
  apply (simp add: prod.case_eq_if)
done

lemma plus_pred_sublens: "\<lbrakk> mwb_lens Z; X \<subseteq>\<^sub>L Z; Y \<subseteq>\<^sub>L Z; X \<bowtie> Y \<rbrakk> \<Longrightarrow> (X +\<^sub>L Y) \<subseteq>\<^sub>L Z"
  apply (auto simp add: sublens_def)
  apply (rename_tac Z\<^sub>1 Z\<^sub>2)
  apply (rule_tac x="Z\<^sub>1 +\<^sub>L Z\<^sub>2" in exI)
  apply (auto intro!: plus_wb_lens)
  apply (simp add: lens_comp_indep_cong_left plus_vwb_lens)
  apply (simp add: plus_lens_distr)
done

lemma lens_plus_sub_assoc_1:
  "X +\<^sub>L Y +\<^sub>L Z \<subseteq>\<^sub>L (X +\<^sub>L Y) +\<^sub>L Z"
  apply (simp add: sublens_def)
  apply (rule_tac x="(fst\<^sub>L ;\<^sub>L fst\<^sub>L) +\<^sub>L (snd\<^sub>L ;\<^sub>L fst\<^sub>L) +\<^sub>L snd\<^sub>L" in exI)
  apply (auto)
  apply (rule plus_vwb_lens)
  apply (simp add: comp_vwb_lens fst_vwb_lens)
  apply (rule plus_vwb_lens)
  apply (simp add: comp_vwb_lens fst_vwb_lens snd_vwb_lens)
  apply (simp add: snd_vwb_lens)
  apply (simp add: fst_snd_lens_indep lens_indep_left_ext)
  apply (rule lens_indep_sym)
  apply (rule plus_pres_lens_indep)
  using fst_snd_lens_indep fst_vwb_lens lens_indep_left_comp lens_indep_sym vwb_lens_mwb apply blast
  using fst_snd_lens_indep lens_indep_left_ext lens_indep_sym apply blast
  apply (auto simp add: lens_plus_def lens_comp_def fst_lens_def snd_lens_def prod.case_eq_if split_beta')[1]
done

lemma lens_plus_sub_assoc_2:
  "(X +\<^sub>L Y) +\<^sub>L Z \<subseteq>\<^sub>L X +\<^sub>L Y +\<^sub>L Z"
  apply (simp add: sublens_def)
  apply (rule_tac x="(fst\<^sub>L +\<^sub>L (fst\<^sub>L ;\<^sub>L snd\<^sub>L)) +\<^sub>L (snd\<^sub>L ;\<^sub>L snd\<^sub>L)" in exI)
  apply (auto)
  apply (rule plus_vwb_lens)
  apply (rule plus_vwb_lens)
  apply (simp add: fst_vwb_lens)
  apply (simp add: comp_vwb_lens fst_vwb_lens snd_vwb_lens)
  apply (rule lens_indep_sym)
  apply (rule lens_indep_left_ext)
  using fst_snd_lens_indep lens_indep_sym apply blast
  apply (auto intro: comp_vwb_lens simp add: snd_vwb_lens)
  apply (rule plus_pres_lens_indep)
  apply (simp add: fst_snd_lens_indep lens_indep_left_ext lens_indep_sym)
  apply (simp add: fst_snd_lens_indep lens_indep_left_comp snd_vwb_lens)
  apply (auto simp add: lens_plus_def lens_comp_def fst_lens_def snd_lens_def prod.case_eq_if split_beta')[1]
done

lemma lens_plus_assoc:
  "(X +\<^sub>L Y) +\<^sub>L Z \<approx>\<^sub>L X +\<^sub>L Y +\<^sub>L Z"
  by (simp add: lens_equivI lens_plus_sub_assoc_1 lens_plus_sub_assoc_2)

lemma lens_plus_sub_comm: "X \<bowtie> Y \<Longrightarrow> X +\<^sub>L Y \<subseteq>\<^sub>L Y +\<^sub>L X"
  apply (simp add: sublens_def)
  apply (rule_tac x="snd\<^sub>L +\<^sub>L fst\<^sub>L" in exI)
  apply (auto)
  apply (simp add: fst_snd_lens_indep fst_vwb_lens lens_indep_sym plus_vwb_lens snd_vwb_lens)
  apply (simp add: lens_indep_sym lens_plus_swap)
done

lemma lens_plus_comm: "X \<bowtie> Y \<Longrightarrow> X +\<^sub>L Y \<approx>\<^sub>L Y +\<^sub>L X"
  by (simp add: lens_equivI lens_indep_sym lens_plus_sub_comm)

lemma lens_plus_ub: "wb_lens Y \<Longrightarrow> X \<subseteq>\<^sub>L X +\<^sub>L Y"
  by (metis fst_lens_plus fst_vwb_lens sublens_def)

lemma lens_plus_right_sublens:
  "\<lbrakk> vwb_lens Y; Y \<bowtie> Z; X \<subseteq>\<^sub>L Z \<rbrakk> \<Longrightarrow> X \<subseteq>\<^sub>L Y +\<^sub>L Z"
  apply (auto simp add: sublens_def)
  apply (rename_tac Z')
  apply (rule_tac x="Z' ;\<^sub>L snd\<^sub>L" in exI)
  apply (auto)
  using comp_vwb_lens snd_vwb_lens apply blast
  apply (simp add: lens_comp_assoc snd_lens_plus)
done

lemma lens_comp_lb [simp]: "vwb_lens X \<Longrightarrow> X ;\<^sub>L Y \<subseteq>\<^sub>L Y"
  by (auto simp add: sublens_def)

lemma lens_unit_plus_sublens_1: "X \<subseteq>\<^sub>L 0\<^sub>L +\<^sub>L X"
  by (metis lens_comp_lb snd_lens_plus snd_vwb_lens zero_lens_indep unit_wb_lens)

lemma lens_unit_prod_sublens_2: "0\<^sub>L +\<^sub>L X \<subseteq>\<^sub>L X"
  apply (auto simp add: sublens_def)
  apply (rule_tac x="0\<^sub>L +\<^sub>L 1\<^sub>L" in exI)
  apply (auto)
  apply (rule plus_vwb_lens)
  apply (simp add: unit_vwb_lens)
  apply (simp add: id_vwb_lens)
  apply (simp add: zero_lens_indep)
  apply (auto simp add: lens_plus_def zero_lens_def lens_comp_def id_lens_def prod.case_eq_if comp_def)
  apply (rule ext)
  apply (rule ext)
  apply (auto)
done

lemma lens_plus_left_unit: "0\<^sub>L +\<^sub>L X \<approx>\<^sub>L X"
  by (simp add: lens_equivI lens_unit_plus_sublens_1 lens_unit_prod_sublens_2)

lemma lens_plus_right_unit: "X +\<^sub>L 0\<^sub>L \<approx>\<^sub>L X"
  using lens_equiv_trans lens_indep_sym lens_plus_comm lens_plus_left_unit zero_lens_indep by blast

lemma lens_plus_mono_left:
  "\<lbrakk> Y \<bowtie> Z; X \<subseteq>\<^sub>L Y \<rbrakk> \<Longrightarrow> X +\<^sub>L Z \<subseteq>\<^sub>L Y +\<^sub>L Z"
  apply (auto simp add: sublens_def)
  apply (rename_tac Z')
  apply (rule_tac x="Z' \<times>\<^sub>L 1\<^sub>L" in exI)
  apply (subst prod_lens_comp_plus)
  apply (simp_all)
  using id_vwb_lens prod_vwb_lens apply blast
done

lemma lens_plus_mono_right:
  "\<lbrakk> X \<bowtie> Z; Y \<subseteq>\<^sub>L Z \<rbrakk> \<Longrightarrow> X +\<^sub>L Y \<subseteq>\<^sub>L X +\<^sub>L Z"
  by (metis prod_lens_comp_plus prod_vwb_lens sublens_def sublens_refl)

lemma lens_plus_subcong: "\<lbrakk> Y\<^sub>1 \<bowtie> Y\<^sub>2; X\<^sub>1 \<subseteq>\<^sub>L Y\<^sub>1; X\<^sub>2 \<subseteq>\<^sub>L Y\<^sub>2 \<rbrakk> \<Longrightarrow> X\<^sub>1 +\<^sub>L X\<^sub>2 \<subseteq>\<^sub>L Y\<^sub>1 +\<^sub>L Y\<^sub>2"
  by (metis prod_lens_comp_plus prod_vwb_lens sublens_def)

lemma lens_plus_eq_left: "\<lbrakk> X \<bowtie> Z; X \<approx>\<^sub>L Y \<rbrakk> \<Longrightarrow> X +\<^sub>L Z \<approx>\<^sub>L Y +\<^sub>L Z"
  by (meson lens_equiv_def lens_plus_mono_left sublens_pres_indep)

lemma lens_plus_eq_right: "\<lbrakk> X \<bowtie> Y; Y \<approx>\<^sub>L Z \<rbrakk> \<Longrightarrow> X +\<^sub>L Y \<approx>\<^sub>L X +\<^sub>L Z"
  by (meson lens_equiv_def lens_indep_sym lens_plus_mono_right sublens_pres_indep)

lemma lens_plus_cong:
  assumes "X\<^sub>1 \<bowtie> X\<^sub>2" "X\<^sub>1 \<approx>\<^sub>L Y\<^sub>1" "X\<^sub>2 \<approx>\<^sub>L Y\<^sub>2"
  shows "X\<^sub>1 +\<^sub>L X\<^sub>2 \<approx>\<^sub>L Y\<^sub>1 +\<^sub>L Y\<^sub>2"
proof -
  have "X\<^sub>1 +\<^sub>L X\<^sub>2 \<approx>\<^sub>L Y\<^sub>1 +\<^sub>L X\<^sub>2"
    by (simp add: assms(1) assms(2) lens_plus_eq_left)
  moreover have "... \<approx>\<^sub>L Y\<^sub>1 +\<^sub>L Y\<^sub>2"
    using assms(1) assms(2) assms(3) lens_equiv_def lens_plus_eq_right sublens_pres_indep by blast
  ultimately show ?thesis
    using lens_equiv_trans by blast
qed

lemma prod_lens_sublens_cong:
  "\<lbrakk> X\<^sub>1 \<subseteq>\<^sub>L X\<^sub>2; Y\<^sub>1 \<subseteq>\<^sub>L Y\<^sub>2 \<rbrakk> \<Longrightarrow> (X\<^sub>1 \<times>\<^sub>L Y\<^sub>1) \<subseteq>\<^sub>L (X\<^sub>2 \<times>\<^sub>L Y\<^sub>2)"
  apply (auto simp add: sublens_def)
  apply (rename_tac Z\<^sub>1 Z\<^sub>2)
  apply (rule_tac x="Z\<^sub>1 \<times>\<^sub>L Z\<^sub>2" in exI)
  apply (auto)
  using prod_vwb_lens apply blast
  apply (auto simp add: lens_prod_def lens_comp_def prod.case_eq_if)
  apply (rule ext, rule ext)
  apply (auto simp add: lens_prod_def lens_comp_def prod.case_eq_if)
done

lemma prod_lens_equiv_cong:
  "\<lbrakk> X\<^sub>1 \<approx>\<^sub>L X\<^sub>2; Y\<^sub>1 \<approx>\<^sub>L Y\<^sub>2 \<rbrakk> \<Longrightarrow> (X\<^sub>1 \<times>\<^sub>L Y\<^sub>1) \<approx>\<^sub>L (X\<^sub>2 \<times>\<^sub>L Y\<^sub>2)"
  by (simp add: lens_equiv_def prod_lens_sublens_cong)

lemma lens_plus_prod_exchange:
  "(X\<^sub>1 +\<^sub>L X\<^sub>2) \<times>\<^sub>L (Y\<^sub>1 +\<^sub>L Y\<^sub>2) \<approx>\<^sub>L (X\<^sub>1 \<times>\<^sub>L Y\<^sub>1) +\<^sub>L (X\<^sub>2 \<times>\<^sub>L Y\<^sub>2)"
proof (rule lens_equivI)
  show "(X\<^sub>1 +\<^sub>L X\<^sub>2) \<times>\<^sub>L (Y\<^sub>1 +\<^sub>L Y\<^sub>2) \<subseteq>\<^sub>L (X\<^sub>1 \<times>\<^sub>L Y\<^sub>1) +\<^sub>L (X\<^sub>2 \<times>\<^sub>L Y\<^sub>2)"
    apply (simp add: sublens_def)
    apply (rule_tac x="((fst\<^sub>L ;\<^sub>L fst\<^sub>L) +\<^sub>L (fst\<^sub>L ;\<^sub>L snd\<^sub>L)) +\<^sub>L ((snd\<^sub>L ;\<^sub>L fst\<^sub>L) +\<^sub>L (snd\<^sub>L ;\<^sub>L snd\<^sub>L))" in exI)
    apply (auto)
    apply (auto intro!: plus_vwb_lens comp_vwb_lens fst_vwb_lens snd_vwb_lens lens_indep_right_comp)
    apply (auto intro!: lens_indepI simp add: lens_comp_def lens_plus_def fst_lens_def snd_lens_def)
    apply (auto simp add: lens_prod_def lens_plus_def lens_comp_def fst_lens_def snd_lens_def prod.case_eq_if comp_def)[1]
    apply (rule ext, rule ext, auto simp add: prod.case_eq_if)
  done
  show "(X\<^sub>1 \<times>\<^sub>L Y\<^sub>1) +\<^sub>L (X\<^sub>2 \<times>\<^sub>L Y\<^sub>2) \<subseteq>\<^sub>L (X\<^sub>1 +\<^sub>L X\<^sub>2) \<times>\<^sub>L (Y\<^sub>1 +\<^sub>L Y\<^sub>2)"
    apply (simp add: sublens_def)
    apply (rule_tac x="((fst\<^sub>L ;\<^sub>L fst\<^sub>L) +\<^sub>L (fst\<^sub>L ;\<^sub>L snd\<^sub>L)) +\<^sub>L ((snd\<^sub>L ;\<^sub>L fst\<^sub>L) +\<^sub>L (snd\<^sub>L ;\<^sub>L snd\<^sub>L))" in exI)
    apply (auto)
    apply (auto intro!: plus_vwb_lens comp_vwb_lens fst_vwb_lens snd_vwb_lens lens_indep_right_comp)
    apply (auto intro!: lens_indepI simp add: lens_comp_def lens_plus_def fst_lens_def snd_lens_def)
    apply (auto simp add: lens_prod_def lens_plus_def lens_comp_def fst_lens_def snd_lens_def prod.case_eq_if comp_def)[1]
    apply (rule ext, rule ext, auto simp add: lens_prod_def prod.case_eq_if)
  done
qed

lemma bij_lens_inv_left:
  "bij_lens X \<Longrightarrow> inv\<^sub>L X ;\<^sub>L X = 1\<^sub>L"
  by (auto simp add: lens_inv_def lens_comp_def comp_def id_lens_def, rule ext, auto)

lemma bij_lens_inv_right:
  "bij_lens X \<Longrightarrow> X ;\<^sub>L inv\<^sub>L X = 1\<^sub>L"
  by (auto simp add: lens_inv_def lens_comp_def comp_def id_lens_def, rule ext, auto)

text \<open>Bijective lenses are precisely those that are equivalent to identity\<close>

lemma bij_lens_equiv_id:
  "bij_lens X \<longleftrightarrow> X \<approx>\<^sub>L 1\<^sub>L"
  apply (auto)
  apply (rule lens_equivI)
  apply (simp_all add: sublens_def)
  apply (rule_tac x="lens_inv X" in exI)
  apply (simp add: bij_lens_inv_left lens_inv_bij)
  apply (auto simp add: lens_equiv_def sublens_def id_lens_def lens_comp_def comp_def)
  apply (unfold_locales)
  apply (simp)
  apply (simp)
  apply (metis (no_types, lifting) vwb_lens_wb wb_lens_weak weak_lens.put_get)
done

lemma bij_lens_equiv:
  "\<lbrakk> bij_lens X; X \<approx>\<^sub>L Y \<rbrakk> \<Longrightarrow> bij_lens Y"
  by (meson bij_lens_equiv_id lens_equiv_def sublens_trans)

lemma lens_id_unique:
  "weak_lens Y \<Longrightarrow> Y = X ;\<^sub>L Y \<Longrightarrow> X = 1\<^sub>L"
  apply (cases Y)
  apply (cases X)
  apply (auto simp add: lens_comp_def comp_def id_lens_def fun_eq_iff)
  apply (metis select_convs(1) weak_lens.create_get)
  apply (metis select_convs(1) select_convs(2) weak_lens.put_get)
done

lemma bij_lens_via_comp_id_left:
  "\<lbrakk> wb_lens X; wb_lens Y; X ;\<^sub>L Y = 1\<^sub>L \<rbrakk> \<Longrightarrow> bij_lens X"
  apply (cases Y)
  apply (cases X)
  apply (auto simp add: lens_comp_def comp_def id_lens_def fun_eq_iff)
  apply (unfold_locales)
  apply (simp_all)
  using vwb_lens_wb wb_lens_weak weak_lens.put_get apply fastforce
  apply (metis select_convs(1) select_convs(2) wb_lens_weak weak_lens.put_get)
done

lemma bij_lens_via_comp_id_right:
  "\<lbrakk> wb_lens X; wb_lens Y; X ;\<^sub>L Y = 1\<^sub>L \<rbrakk> \<Longrightarrow> bij_lens Y"
  apply (cases Y)
  apply (cases X)
  apply (auto simp add: lens_comp_def comp_def id_lens_def fun_eq_iff)
  apply (unfold_locales)
  apply (simp_all)
  using vwb_lens_wb wb_lens_weak weak_lens.put_get apply fastforce
  apply (metis select_convs(1) select_convs(2) wb_lens_weak weak_lens.put_get)
done

text \<open>An equivalence can be proved by demonstrating a suitable bijective lens\<close>

lemma lens_equiv_via_bij:
  assumes "bij_lens Z" "X = Z ;\<^sub>L Y"
  shows "X \<approx>\<^sub>L Y"
  using assms
  apply (auto simp add: lens_equiv_def sublens_def)
  using bij_lens_vwb apply blast
  apply (rule_tac x="lens_inv Z" in exI)
  apply (auto simp add: lens_comp_assoc bij_lens_inv_left)
  using bij_lens_vwb lens_inv_bij apply blast
  apply (simp add: bij_lens_inv_left lens_comp_assoc[THEN sym])
done

lemma lens_equiv_iff_bij:
  assumes "weak_lens Y"
  shows "X \<approx>\<^sub>L Y \<longleftrightarrow> (\<exists> Z. bij_lens Z \<and> X = Z ;\<^sub>L Y)"
  apply (rule iffI)
  apply (auto simp add: lens_equiv_def sublens_def lens_id_unique)[1]
  apply (rename_tac Z\<^sub>1 Z\<^sub>2)
  apply (rule_tac x="Z\<^sub>1" in exI)
  apply (simp)
  apply (subgoal_tac "Z\<^sub>2 ;\<^sub>L Z\<^sub>1 = 1\<^sub>L")
  apply (meson bij_lens_via_comp_id_right vwb_lens_wb)
  apply (metis assms lens_comp_assoc lens_id_unique)
  using lens_equiv_via_bij apply blast
done

text \<open>Lens override laws\<close>

lemma lens_override_id:
  "S\<^sub>1 \<oplus>\<^sub>L S\<^sub>2 on 1\<^sub>L = S\<^sub>2"
  by (simp add: lens_override_def id_lens_def)

lemma lens_override_unit:
  "S\<^sub>1 \<oplus>\<^sub>L S\<^sub>2 on 0\<^sub>L = S\<^sub>1"
  by (simp add: lens_override_def zero_lens_def)

lemma lens_override_overshadow:
  assumes "mwb_lens Y"  "X \<subseteq>\<^sub>L Y"
  shows "(S\<^sub>1 \<oplus>\<^sub>L S\<^sub>2 on X) \<oplus>\<^sub>L S\<^sub>3 on Y = S\<^sub>1 \<oplus>\<^sub>L S\<^sub>3 on Y"
  using assms by (simp add: lens_override_def sublens_put_put)

lemma lens_override_plus:
  "X \<bowtie> Y \<Longrightarrow> S\<^sub>1 \<oplus>\<^sub>L S\<^sub>2 on (X +\<^sub>L Y) = (S\<^sub>1 \<oplus>\<^sub>L S\<^sub>2 on X) \<oplus>\<^sub>L S\<^sub>2 on Y"
  by (simp add: lens_indep_comm lens_override_def lens_plus_def)
end


(*<*)
theory ex12
imports
  Complex_Main
  "HOL-Library.Multiset"
begin
(*>*)
text {* \ExerciseSheet{12}{29.~6.~2018} *}

text \<open>
  \Exercise{Sparse Binary Numbers}

  Implement operations carry, inc, and add on sparse binary numbers,
  analogously to the operations link, ins, and meld on binomial heaps.

  Show that the operations have logarithmic worst-case complexity.
\<close>

type_synonym rank = nat
type_synonym snat = "rank list"

abbreviation invar :: "snat \<Rightarrow> bool" where "invar s \<equiv> sorted_wrt op< s"
definition \<alpha> :: "snat \<Rightarrow> nat" where "\<alpha> s = (\<Sum>i\<leftarrow>s. 2^i)"

lemmas [simp] = sorted_wrt_Cons sorted_wrt_append

(*<*)
lemma \<alpha>_Nil[simp]: "\<alpha> [] = 0"
  unfolding \<alpha>_def by auto

lemma \<alpha>_Cons[simp]: "\<alpha> (r#rs) = 2^r + \<alpha> rs"
  unfolding \<alpha>_def by auto

lemma \<alpha>_append[simp]: "\<alpha> (rs\<^sub>1@rs\<^sub>2) = \<alpha> rs\<^sub>1 + \<alpha> rs\<^sub>2"
  unfolding \<alpha>_def by auto

(*>*)

fun carry :: "rank \<Rightarrow> snat \<Rightarrow> snat"
(*<*)
  where
  "carry r [] = [r]"
| "carry r (r'#rest) = (if r<r' then r#r'#rest else carry (r+1) rest)"
(*>*)

lemma carry_invar[simp]:
(*<*)
  assumes "invar rs"
  shows "invar (carry r rs)"
  using assms
  apply (induction r rs rule: carry.induct)
  apply (auto)
  done
(*>*)

lemma carry_\<alpha>:
(*<*)
  assumes "invar rs"
  assumes "\<forall>r'\<in>set rs. r\<le>r'"
  shows "\<alpha> (carry r rs) = 2^r + \<alpha> rs"
  using assms
  by (induction r rs rule: carry.induct) force+
(*>*)

(*<*)
lemma carry_rank_bound:
  assumes "r' \<in> set (carry r rs)"
  assumes "\<forall>r'\<in>set rs. r\<^sub>0 < r'"
  assumes "r\<^sub>0 < r"
  shows "r\<^sub>0 < r'"
  using assms
  by (induction r rs rule: carry.induct) (auto split: if_splits)
(*>*)

definition inc :: "snat \<Rightarrow> snat"
(*<*)
  where "inc rs = carry 0 rs"
(*>*)

lemma inc_invar[simp]: "invar rs \<Longrightarrow> invar (inc rs)"
(*<*)
  unfolding inc_def by auto
(*>*)

lemma inc_\<alpha>[simp]: "invar rs \<Longrightarrow> \<alpha> (inc rs) = Suc (\<alpha> rs)"
(*<*)
  unfolding inc_def by (auto simp: carry_\<alpha>)
(*>*)

fun add :: "snat \<Rightarrow> snat \<Rightarrow> snat"
(*<*)
  where
  "add rs [] = rs"
| "add [] rs = rs"
| "add (r\<^sub>1#rs\<^sub>1) (r\<^sub>2#rs\<^sub>2) = (
    if r\<^sub>1 < r\<^sub>2 then r\<^sub>1#add rs\<^sub>1 (r\<^sub>2#rs\<^sub>2)
    else if r\<^sub>2<r\<^sub>1 then r\<^sub>2#add (r\<^sub>1#rs\<^sub>1) rs\<^sub>2
    else carry (r\<^sub>1 + 1) (add rs\<^sub>1 rs\<^sub>2)
    )"
(*>*)

(*<*)
lemma add_rank_bound:
  assumes "r' \<in> set (add rs\<^sub>1 rs\<^sub>2)"
  assumes "\<forall>r'\<in>set rs\<^sub>1. r < r'"
  assumes "\<forall>r'\<in>set rs\<^sub>2. r < r'"
  shows "r < r'"
  using assms
  apply (induction rs\<^sub>1 rs\<^sub>2 arbitrary: r' rule: add.induct)
  apply (auto split: if_splits simp: carry_rank_bound)
  done
(*>*)

lemma add_invar[simp]:
  assumes "invar rs\<^sub>1"
  assumes "invar rs\<^sub>2"
  shows "invar (add rs\<^sub>1 rs\<^sub>2)"
(*<*)
  using assms
proof (induction rs\<^sub>1 rs\<^sub>2 rule: add.induct)
  case (3 r\<^sub>1 rs\<^sub>1 r\<^sub>2 rs\<^sub>2)

  consider (LT) "r\<^sub>1 < r\<^sub>2"
         | (GT) "r\<^sub>1 > r\<^sub>2"
         | (EQ) "r\<^sub>1 = r\<^sub>2"
    using antisym_conv3 by blast
  then show ?case proof cases
    case LT
    then show ?thesis using 3
      by (force elim!: add_rank_bound)
  next
    case GT
    then show ?thesis using 3
      by (force elim!: add_rank_bound)
  next
    case [simp]: EQ

    from "3.IH"(3) "3.prems" have [simp]: "invar (add rs\<^sub>1 rs\<^sub>2)"
      by auto

    have "r\<^sub>2 < r'" if "r' \<in> set (add rs\<^sub>1 rs\<^sub>2)" for r'
      using that
      apply (rule add_rank_bound)
      using "3.prems" by auto
    with EQ show ?thesis by auto
  qed
qed simp_all
(*>*)

lemma add_\<alpha>[simp]:
  assumes "invar rs\<^sub>1"
  assumes "invar rs\<^sub>2"
  shows "\<alpha> (add rs\<^sub>1 rs\<^sub>2) = \<alpha> rs\<^sub>1 + \<alpha> rs\<^sub>2"
(*<*)
  using assms
  apply (induction rs\<^sub>1 rs\<^sub>2 rule: add.induct)
  apply (auto simp: carry_\<alpha> Suc_leI add_rank_bound)
  done
(*>*)

lemma size_snat:
  assumes "invar rs"
  shows "2^length rs \<le> \<alpha> rs + 1"
(*<*)
proof -
  have "(2::nat)^length rs = (\<Sum>i\<in>{0..<length rs}. 2^i) + 1"
    by (simp add: sum_power2)
  also have "\<dots> \<le> \<alpha> rs + 1"
    using assms unfolding \<alpha>_def
    by (simp add: sorted_wrt_less_sum_mono_lowerbound)
  finally show ?thesis .
qed
(*>*)

fun t_carry :: "rank \<Rightarrow> snat \<Rightarrow> nat"
(*<*)
  where
  "t_carry r [] = 1"
| "t_carry r (r'#rest) = (if r<r' then 1 else 1 + t_carry (r+1) rest)"
(*>*)

definition t_inc :: "snat \<Rightarrow> nat"
(*<*)
  where "t_inc rs = t_carry 0 rs"
(*>*)

lemma t_inc_bound:
  assumes "invar rs"
  shows "t_inc rs \<le> log 2 (\<alpha> rs + 1) + 1"
(*<*)
proof -
  have "t_carry r rs \<le> length rs + 1" for r
    by (induction r rs rule: t_carry.induct) auto
  hence "t_inc rs \<le> length rs + 1" unfolding t_inc_def by auto
  hence "(2::nat)^t_inc rs \<le> 2^(length rs + 1)"
    by (rule power_increasing) auto
  also have "\<dots> \<le> 2*(\<alpha> rs + 1)" using size_snat[OF \<open>invar rs\<close>] by auto
  finally have "2 ^ t_inc rs \<le> 2 * (\<alpha> rs + 1)" .
  from le_log2_of_power[OF this] show ?thesis
    by (simp only: log_mult of_nat_mult) auto
qed
(*>*)

fun t_add :: "snat \<Rightarrow> snat \<Rightarrow> nat"
(*<*)
  where
  "t_add rs [] = 1"
| "t_add [] rs = 1"
| "t_add (r\<^sub>1#rs\<^sub>1) (r\<^sub>2#rs\<^sub>2) = 1 + (
    if r\<^sub>1 < r\<^sub>2 then t_add rs\<^sub>1 (r\<^sub>2#rs\<^sub>2)
    else if r\<^sub>2<r\<^sub>1 then t_add (r\<^sub>1#rs\<^sub>1) rs\<^sub>2
    else t_carry (r\<^sub>1 + 1) (add rs\<^sub>1 rs\<^sub>2) + t_add rs\<^sub>1 rs\<^sub>2
    )"
(*>*)

(*<*)
lemma l_carry_estimate:
  "t_carry r rs + length (carry r rs) = 2 + length rs"
  by (induction r rs rule: carry.induct) auto

lemma l_add_estimate:
  "length (add rs\<^sub>1 rs\<^sub>2) + t_add rs\<^sub>1 rs\<^sub>2 \<le> 2 * (length rs\<^sub>1 + length rs\<^sub>2) + 1"
  apply (induction rs\<^sub>1 rs\<^sub>2 rule: t_add.induct)
  apply (auto simp: l_carry_estimate algebra_simps)
  done
(*>*)

lemma t_add_bound:
  fixes rs\<^sub>1 rs\<^sub>2
  defines "n\<^sub>1 \<equiv> \<alpha> rs\<^sub>1"
  defines "n\<^sub>2 \<equiv> \<alpha> rs\<^sub>2"
  assumes INVARS: "invar rs\<^sub>1" "invar rs\<^sub>2"
  shows "t_add rs\<^sub>1 rs\<^sub>2 \<le> 4*log 2 (n\<^sub>1 + n\<^sub>2 + 1) + 2"
(*<*)
proof -
  define n where "n = n\<^sub>1 + n\<^sub>2"

  from l_add_estimate[of rs\<^sub>1 rs\<^sub>2]
  have "t_add rs\<^sub>1 rs\<^sub>2 \<le> 2 * (length rs\<^sub>1 + length rs\<^sub>2) + 1" by auto
  hence "(2::nat)^t_add rs\<^sub>1 rs\<^sub>2 \<le> 2^(2 * (length rs\<^sub>1 + length rs\<^sub>2) + 1)"
    by (rule power_increasing) auto
  also have "\<dots> = 2*(2^length rs\<^sub>1)\<^sup>2*(2^length rs\<^sub>2)\<^sup>2"
    by (auto simp: algebra_simps power_add power_mult)
  also note INVARS(1)[THEN size_snat]
  also note INVARS(2)[THEN size_snat]
  finally have "2 ^ t_add rs\<^sub>1 rs\<^sub>2 \<le> 2 * (n\<^sub>1 + 1)\<^sup>2 * (n\<^sub>2 + 1)\<^sup>2"
    by (auto simp: power2_nat_le_eq_le n\<^sub>1_def n\<^sub>2_def)
  from le_log2_of_power[OF this] have "t_add rs\<^sub>1 rs\<^sub>2 \<le> log 2 \<dots>"
    by simp
  also have "\<dots> = log 2 2 + 2*log 2 (n\<^sub>1 + 1) + 2*log 2 (n\<^sub>2 + 1)"
    by (simp add: log_mult log_nat_power)
  also have "n\<^sub>2 \<le> n" by (auto simp: n_def)
  finally have "t_add rs\<^sub>1 rs\<^sub>2 \<le> log 2 2 + 2*log 2 (n\<^sub>1 + 1) + 2*log 2 (n + 1)"
    by auto
  also have "n\<^sub>1 \<le> n" by (auto simp: n_def)
  finally have "t_add rs\<^sub>1 rs\<^sub>2 \<le> log 2 2 + 4*log 2 (n + 1)"
    by auto
  also have "log 2 2 \<le> 2" by auto
  finally have "t_add rs\<^sub>1 rs\<^sub>2 \<le> 4*log 2 (n + 1) + 2" by auto
  thus ?thesis unfolding n_def by (auto simp: algebra_simps)
qed
(*>*)

(*<*)
end
(*>*)


(* Title:      Complete Domain
   Author:     Walter Guttmann
   Maintainer: Walter Guttmann <walter.guttmann at canterbury.ac.nz>
*)

section \<open>Complete Domain\<close>

theory Complete_Domain

imports Relative_Domain Complete_Tests

begin

class complete_antidomain_semiring = relative_antidomain_semiring + complete_tests +
  assumes a_dist_Sum: "ascending_chain f \<longrightarrow> -(Sum f) = Prod (\<lambda>n . -f n)"
  assumes a_dist_Prod: "descending_chain f \<longrightarrow> -(Prod f) = Sum (\<lambda>n . -f n)"
begin

lemma a_ascending_chain:
  "ascending_chain f \<Longrightarrow> descending_chain (\<lambda>n . -f n)"
  by (simp add: a_antitone ascending_chain_def descending_chain_def)

lemma a_descending_chain:
  "descending_chain f \<Longrightarrow> ascending_chain (\<lambda>n . -f n)"
  by (simp add: a_antitone ord.ascending_chain_def ord.descending_chain_def)

lemma d_dist_Sum:
  "ascending_chain f \<Longrightarrow> d(Sum f) = Sum (\<lambda>n . d(f n))"
  by (simp add: d_def a_ascending_chain a_dist_Prod a_dist_Sum)

lemma d_dist_Prod:
  "descending_chain f \<Longrightarrow> d(Prod f) = Prod (\<lambda>n . d(f n))"
  by (simp add: d_def a_dist_Sum a_dist_Prod a_descending_chain)

end

end


(* Property from Case-Analysis for Rippling and Inductive Proof,
   Moa Johansson, Lucas Dixon and Alan Bundy, ITP 2010.
   This Isabelle theory is produced using the TIP tool offered at the following website:
     https://github.com/tip-org/tools
   This file was originally provided as part of TIP benchmark at the following website:
     https://github.com/tip-org/benchmarks
   Yutaka Nagashima at CIIRC, CTU changed the TIP output theory file slightly
   to make it compatible with Isabelle2017.*)
  theory TIP_prop_74
  imports "../../Test_Base"
begin

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

datatype Nat = Z | S "Nat"

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

fun take :: "Nat => 'a list => 'a list" where
  "take (Z) z = nil2"
| "take (S z2) (nil2) = nil2"
| "take (S z2) (cons2 x2 x3) = cons2 x2 (take z2 x3)"

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

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

fun drop :: "Nat => 'a list => 'a list" where
  "drop (Z) z = z"
| "drop (S z2) (nil2) = nil2"
| "drop (S z2) (cons2 x2 x3) = drop z2 x3"

fun t2 :: "Nat => Nat => Nat" where
  "t2 (Z) z = Z"
| "t2 (S z2) (Z) = S z2"
| "t2 (S z2) (S x2) = t2 z2 x2"

theorem property0 :
  "((rev (take i xs)) = (drop (t2 (len xs) i) (rev xs)))"
  oops

end


(*  Title:      RSAPSS/Pdifference.thy

    Author:     Christina Lindenberg, Kai Wirt, Technische Universität Darmstadt
    Copyright:  2005 - Technische Universität Darmstadt
*)
section "Positive differences"

theory Pdifference
imports "HOL-Computational_Algebra.Primes" Mod
begin

definition
  pdifference :: "nat \<Rightarrow> nat \<Rightarrow> nat" where
  [simp]: "pdifference a b = (if a < b then (b-a) else (a-b))"

lemma timesdistributesoverpdifference:
    "m*(pdifference a b) = pdifference (m*(a::nat)) (m* (b::nat))"
  by (auto simp add: nat_distrib)

lemma addconst: "a = (b::nat) \<Longrightarrow> c+a = c+b"
  by auto

lemma invers: "a \<le> x \<Longrightarrow> (x::nat) = x - a + a"
  by auto

lemma invers2: "\<lbrakk>a \<le> b; (b-a) = p*q\<rbrakk> \<Longrightarrow> (b::nat) = a+p*q"
  apply (subst addconst [symmetric])
  apply (assumption)
  apply (subst add.commute, rule invers, simp)
  done

lemma modadd: "\<lbrakk>b = a+p*q\<rbrakk> \<Longrightarrow> (a::nat) mod p = b mod p"
  by auto

lemma equalmodstrick1: "pdifference a b mod p = 0 \<Longrightarrow> a mod p = b mod p"
  using mod_eq_dvd_iff_nat [of a b p] mod_eq_dvd_iff_nat [of b a p]
  by (cases "a < b") auto

lemma diff_add_assoc: "b \<le> c \<Longrightarrow> c - (c - b) = c - c + (b::nat)"
  by auto

lemma diff_add_assoc2: "a \<le> c \<Longrightarrow> c - (c - a + b) = (c - c + (a::nat) - b)"
  apply (subst diff_diff_left [symmetric])
  apply (subst diff_add_assoc)
  apply auto
  done

lemma diff_add_diff: "x \<le> b \<Longrightarrow> (b::nat) - x + y - b = y - x"
  by (induct b) auto

lemma equalmodstrick2:
  assumes "a mod p = b mod p"
  shows "pdifference a b mod p = 0"
proof -
  { fix a b
    assume *: "a mod p = b mod p"
    have "a - b = a div p * p + a mod p - b div p * p - b mod p"
      by simp
    also have "\<dots> = a div p * p - b div p * p"
      using * by (simp only:)
    also have "\<dots> = (a div p - b div p) * p"
      by (simp add: diff_mult_distrib)
    finally have "(a - b) mod p = 0"
      by simp
  }
  from this [OF assms] this [OF assms [symmetric]]
  show ?thesis by simp
qed

lemma primekeyrewrite:
  fixes p::nat shows "\<lbrakk>prime p; p dvd (a*b);~(p dvd a)\<rbrakk> \<Longrightarrow> p dvd b"
  apply (subst (asm) prime_dvd_mult_nat)
  apply auto
  done

lemma multzero: "\<lbrakk>0 < m mod p; m*a = 0\<rbrakk> \<Longrightarrow> (a::nat) = 0"
  by auto

lemma primekeytrick:
  fixes A B :: nat
  assumes "(M * A) mod P = (M * B) mod P"
  assumes "M mod P \<noteq> 0" and "prime P"
  shows "A mod P = B mod P"
proof -
  from assms have "M > 0"
    by (auto intro: ccontr)
  from assms have *: "\<And>q. P dvd M * q \<Longrightarrow> P dvd q"
    using primekeyrewrite [of P M] unfolding dvd_eq_mod_eq_0 [symmetric] by blast
  from equalmodstrick2 [OF assms(1)] \<open>M > 0\<close> show ?thesis
    apply -
    apply (rule equalmodstrick1)
    apply (auto intro: * dvdI simp add: dvd_eq_mod_eq_0 [symmetric] diff_mult_distrib2 [symmetric])
    done
qed

end


(* Property from Case-Analysis for Rippling and Inductive Proof,
   Moa Johansson, Lucas Dixon and Alan Bundy, ITP 2010.
   This Isabelle theory is produced using the TIP tool offered at the following website:
     https://github.com/tip-org/tools
   This file was originally provided as part of TIP benchmark at the following website:
     https://github.com/tip-org/benchmarks
   Yutaka Nagashima at CIIRC, CTU changed the TIP output theory file slightly
   to make it compatible with Isabelle2017.*)
  theory TIP_prop_30
  imports "../../Test_Base"
begin

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

datatype Nat = Z | S "Nat"

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

fun elem :: "Nat => Nat list => bool" where
  "elem y (nil2) = False"
| "elem y (cons2 z2 xs) = (if x y z2 then True else elem y xs)"

fun t2 :: "Nat => Nat => bool" where
  "t2 y (Z) = False"
| "t2 (Z) (S z2) = True"
| "t2 (S x2) (S z2) = t2 x2 z2"
  (*t2 x y = x < y*)

fun ins :: "Nat => Nat list => Nat list" where
  "ins y (nil2) = cons2 y (nil2)"
| "ins y (cons2 z2 xs) =
     (if t2 y z2 then cons2 y (cons2 z2 xs) else cons2 z2 (ins y xs))"

theorem property0 :
  "elem y (ins y xs)"
  oops

end


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

datatype ('a, 'b) pair = pair2 "'a" "'b"

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

datatype Nat = Z | S "Nat"

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

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

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

fun minus :: "Nat => Nat => Nat" where
  "minus (Z) z = Z"
| "minus (S z2) (S y2) = minus z2 y2"

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

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

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

fun sort2 :: "Nat => Nat => Nat list" where
  "sort2 y z =
   (if le y z then cons2 y (cons2 z (nil2)) else
      cons2 z (cons2 y (nil2)))"

fun take :: "Nat => 'a list => 'a list" where
  "take y z =
   (if le y Z then nil2 else
      (case z of
         nil2 => nil2
         | cons2 z2 xs => (case y of S x2 => cons2 z2 (take x2 xs))))"

(*fun did not finish the proof*)
function idiv :: "Nat => Nat => Nat" where
  "idiv y z = (if lt y z then Z else S (idiv (minus y z) z))"
  by pat_completeness auto

fun drop :: "Nat => 'a list => 'a list" where
  "drop y z =
   (if le y Z then z else
      (case z of
         nil2 => nil2
         | cons2 z2 xs1 => (case y of S x2 => drop x2 xs1)))"

fun splitAt :: "Nat => 'a list =>
              (('a list), ('a list)) pair" where
  "splitAt y z = pair2 (take y z) (drop y z)"

function stooge2sort2 :: "Nat list => Nat list"
  and stoogesort2 :: "Nat list => Nat list"
  and stooge2sort1 :: "Nat list => Nat list" where
  "stooge2sort2 y =
   (case
      splitAt (idiv (S (times (S (S Z)) (length y))) (S (S (S Z)))) y
      of
      pair2 ys2 zs1 => x (stoogesort2 ys2) zs1)"
| "stoogesort2 (nil2) = nil2"
| "stoogesort2 (cons2 z (nil2)) = cons2 z (nil2)"
| "stoogesort2 (cons2 z (cons2 y2 (nil2))) = sort2 z y2"
| "stoogesort2 (cons2 z (cons2 y2 (cons2 x3 x4))) =
     stooge2sort2
       (stooge2sort1 (stooge2sort2 (cons2 z (cons2 y2 (cons2 x3 x4)))))"
| "stooge2sort1 y =
     (case splitAt (idiv (length y) (S (S (S Z)))) y of
        pair2 ys2 zs1 => x ys2 (stoogesort2 zs1))"
  by pat_completeness auto

fun count :: "'a => 'a list => Nat" where
  "count y (nil2) = Z"
| "count y (cons2 z2 ys) =
     (if (y = z2) then plus (S Z) (count y ys) else count y ys)"

theorem property0 :
  "((count y (stoogesort2 xs)) = (count y xs))"
  oops

end


(*
  File:     Fermat_Witness.thy
  Authors:  Daniel Stüwe

  Fermat witnesses as used in Fermat's test
*)
section \<open>Fermat Witnesses\<close>
theory Fermat_Witness
  imports Euler_Witness Carmichael_Numbers
begin

definition divide_out :: "'a :: factorial_semiring \<Rightarrow> 'a \<Rightarrow> 'a \<times> nat" where
  "divide_out p x = (x div p ^ multiplicity p x, multiplicity p x)"

lemma fst_divide_out [simp]: "fst (divide_out p x) = x div p ^ multiplicity p x"
  and snd_divide_out [simp]: "snd (divide_out p x) = multiplicity p x"
  by (simp_all add: divide_out_def)

function divide_out_aux :: "'a :: factorial_semiring \<Rightarrow> 'a \<times> nat \<Rightarrow> 'a \<times> nat" where
  "divide_out_aux p (x, acc) =
     (if x = 0 \<or> is_unit p \<or> \<not>p dvd x then (x, acc) else divide_out_aux p (x div p, acc + 1))"
  by auto
termination proof (relation "measure (\<lambda>(p, x, _). multiplicity p x)")
  fix p x :: 'a and acc :: nat
  assume "\<not>(x = 0 \<or> is_unit p \<or> \<not>p dvd x)"
  thus "((p, x div p, acc + 1), p, x, acc) \<in> measure (\<lambda>(p, x, _). multiplicity p x)"
    by (auto elim!: dvdE simp: multiplicity_times_same)
qed auto

lemmas [simp del] = divide_out_aux.simps

lemma divide_out_aux_correct:
  "divide_out_aux p z = (fst z div p ^ multiplicity p (fst z), snd z + multiplicity p (fst z))"
proof (induction p z rule: divide_out_aux.induct)
  case (1 p x acc)
  show ?case
  proof (cases "x = 0 \<or> is_unit p \<or> \<not>p dvd x")
    case False
    have "x div p div p ^ multiplicity p (x div p) = x div p ^ multiplicity p x"
      using False
      by (subst dvd_div_mult2_eq [symmetric])
         (auto elim!: dvdE simp: multiplicity_dvd multiplicity_times_same)
    with False show ?thesis using 1
      by (subst divide_out_aux.simps)
         (auto elim: dvdE simp: multiplicity_times_same multiplicity_unit_left
                                not_dvd_imp_multiplicity_0)
  qed (auto simp: divide_out_aux.simps multiplicity_unit_left not_dvd_imp_multiplicity_0)
qed

lemma divide_out_code [code]: "divide_out p x = divide_out_aux p (x, 0)"
  by (simp add: divide_out_aux_correct divide_out_def)

lemma multiplicity_code [code]: "multiplicity p x = snd (divide_out_aux p (x, 0))"
  by (simp add: divide_out_aux_correct)

(* TODO Move *)
lemma multiplicity_times_same_power:
  assumes "x \<noteq> 0" "\<not>is_unit p" "p \<noteq> 0"
  shows   "multiplicity p (p ^ k * x) = multiplicity p x + k"
  using assms by (induction k) (simp_all add: multiplicity_times_same mult.assoc)

lemma divide_out_unique_nat:
  fixes n :: nat
  assumes "\<not>is_unit p" "p \<noteq> 0" "\<not>p dvd m" and "n = p ^ k * m"
  shows   "m = n div p ^ multiplicity p n" and "k = multiplicity p n"
proof -
  from assms have "n \<noteq> 0" by (intro notI) auto
  thus *: "k = multiplicity p n"
    using assms by (auto simp: assms multiplicity_times_same_power not_dvd_imp_multiplicity_0)
  from assms show "m = n div p ^ multiplicity p n"
    unfolding * [symmetric] by auto
qed

context
  fixes a n :: nat
begin

definition "fermat_liar \<longleftrightarrow> [a^(n-1) = 1] (mod n)"
definition "fermat_witness \<longleftrightarrow> [a^(n-1) \<noteq> 1] (mod n)"

definition "strong_fermat_liar \<longleftrightarrow>
              (\<forall>k m. odd m \<longrightarrow> n - 1 = 2^k * m \<longrightarrow>
                 [a^m = 1](mod n) \<or> (\<exists>i \<in> {0..< k}. [a^(2 ^ i * m) = n-1] (mod n)))"

definition "strong_fermat_witness \<longleftrightarrow> \<not> strong_fermat_liar"

lemma fermat_liar_witness_of_composition[iff]:
  "\<not>fermat_liar = fermat_witness"
  "\<not>fermat_witness = fermat_liar"
  unfolding fermat_liar_def and fermat_witness_def
  by simp_all

lemma strong_fermat_liar_code [code]:
  "strong_fermat_liar \<longleftrightarrow>
     (let (m, k) = divide_out 2 (n - 1)
      in [a^m = 1](mod n) \<or> (\<exists>i \<in> {0..< k}. [a^(2 ^ i * m) = n-1] (mod n)))"
  (is "?lhs = ?rhs")
proof (cases "n > 1")
  case True
  define m where "m = (n - 1) div 2 ^ multiplicity 2 (n - 1)"
  define k where "k = multiplicity 2 (n - 1)"
  have mk: "odd m \<and> n - 1 = 2 ^ k * m"
    using True multiplicity_decompose[of "n - 1" 2] multiplicity_dvd[of 2 "n - 1"]
    by (auto simp: m_def k_def)
  show ?thesis
  proof
    assume ?lhs
    hence "[a^m = 1] (mod n) \<or> (\<exists>i \<in> {0..< k}. [a^(2 ^ i * m) = n-1] (mod n))"
      using True mk by (auto simp: divide_out_def strong_fermat_liar_def)
    thus ?rhs by (auto simp: Let_def divide_out_def m_def k_def)
  next
    assume ?rhs
    thus ?lhs using divide_out_unique_nat[of 2]
      by (auto simp: strong_fermat_liar_def divide_out_def)
  qed
qed (auto simp: strong_fermat_liar_def divide_out_def)

context
  assumes * : "a \<in> {1 ..< n}"
begin

lemma strong_fermat_witness_iff:
  "strong_fermat_witness =
     (\<exists>k m. odd m \<and> n - 1 = 2 ^ k * m \<and> [a ^ m \<noteq> 1] (mod n) \<and>
            (\<forall>i\<in>{0..<k}. [a ^ (2 ^ i * m) \<noteq> n-1] (mod n)))"
  unfolding strong_fermat_witness_def strong_fermat_liar_def
  by blast

lemma not_coprime_imp_witness: "\<not>coprime a n \<Longrightarrow> fermat_witness"
  using * lucas_coprime_lemma[of "n-1" a n]
  by (auto simp: fermat_witness_def)

corollary liar_imp_coprime: "fermat_liar \<Longrightarrow> coprime a n"
  using not_coprime_imp_witness fermat_liar_witness_of_composition by blast

lemma fermat_witness_imp_strong_fermat_witness:
  assumes "1 < n" "fermat_witness"
  shows "strong_fermat_witness"
proof -
  from \<open>fermat_witness\<close> have "[a^(n-1) \<noteq> 1] (mod n)"
    unfolding fermat_witness_def .

  obtain k m where "odd m" and n: "n - 1 = 2 ^ k * m"
    using * by (auto intro: multiplicity_decompose'[of "(n-1)" 2])

  moreover have "[a ^ m \<noteq> 1] (mod n)"
    using \<open>[a^(n-1) \<noteq> 1] (mod n)\<close> n ord_divides by auto

  moreover {
    fix i :: nat
    assume "i \<in> {0..<k}"
    hence "i \<le> k - 1" "0 < k" by auto
    then have "[a ^ (2 ^ i * m) \<noteq> n - 1] (mod n)" "[a ^ (2 ^ i * m) \<noteq> 1] (mod n)"
    proof(induction i rule: inc_induct)
      case base
        have * :"a ^ (n - 1) = (a ^ (2 ^ (k - 1) * m))\<^sup>2"
          using \<open>0 < k\<close> n semiring_normalization_rules(27)[of "2 :: nat" "k - 1"]
          by (auto simp flip: power_even_eq simp add: algebra_simps)

        case 1
        from * show ?case
          using \<open>[a^(n-1) \<noteq> 1] (mod n)\<close> and square_minus_one_cong_one[OF \<open>1 < n\<close>] by auto

        case 2
        from * show ?case using n \<open>[a^(n-1) \<noteq> 1] (mod n)\<close> and square_one_cong_one by metis
    next
      case (step q)
      then have
        IH2: "[a ^ (2 ^ Suc q * m) \<noteq> 1] (mod n)" using \<open>0 < k\<close> by blast+

      have * : "a ^ (2 ^ Suc q * m) = (a ^ (2 ^ q * m))\<^sup>2"
        by (auto simp flip: power_even_eq simp add: algebra_simps)

      case 1
      from * show ?case using IH2 and square_minus_one_cong_one[OF \<open>1 < n\<close>] by auto

      case 2
      from * show ?case using IH2 and square_one_cong_one by metis
    qed
  }

  ultimately show ?thesis unfolding strong_fermat_witness_iff by blast
qed

corollary strong_fermat_liar_imp_fermat_liar:
  assumes "1 < n" "strong_fermat_liar"
  shows  "fermat_liar"
    using fermat_witness_imp_strong_fermat_witness assms
    and fermat_liar_witness_of_composition strong_fermat_witness_def
    by blast

lemma euler_liar_is_fermat_liar:
  assumes "1 < n" "euler_liar a n" "coprime a n" "odd n"
  shows "fermat_liar"
proof -
  have "[Jacobi a n = a ^ ((n - 1) div 2)] (mod n)"
    using \<open>euler_liar a n\<close> unfolding euler_witness_def by simp

  hence "[(Jacobi a n)^2 = (a ^ ((n - 1) div 2))^2] (mod n)"
    by (simp add: cong_pow)

  moreover have "Jacobi a n \<in> {1, -1}"
    using Jacobi_values Jacobi_eq_0_iff_not_coprime[of n] \<open>coprime a n\<close> \<open>1 < n\<close>
    by force

  ultimately have "[1 = (a ^ ((n - 1) div 2))^2] (mod n)"
    using cong_int_iff by force

  also have "(a ^ ((n - 1) div 2))^2 = a ^ (n - 1)"
    using \<open>odd n\<close> by (simp flip: power_mult)

  finally show ?thesis
    using cong_sym fermat_liar_def
    by blast
qed

corollary fermat_witness_is_euler_witness:
  assumes "1 < n" "fermat_witness" "coprime a n" "odd n"
  shows "euler_witness a n"
  using assms euler_liar_is_fermat_liar fermat_liar_witness_of_composition
  by blast

end
end

lemma one_is_fermat_liar[simp]: "1 < n \<Longrightarrow> fermat_liar 1 n"
  using fermat_liar_def by auto

lemma one_is_strong_fermat_liar[simp]: "1 < n \<Longrightarrow> strong_fermat_liar 1 n"
  using strong_fermat_liar_def by auto

lemma prime_imp_fermat_liar:
  "prime p \<Longrightarrow> a \<in> {1 ..< p} \<Longrightarrow> fermat_liar a p"
  unfolding fermat_liar_def
  using fermat_theorem and nat_dvd_not_less by simp

lemma not_Carmichael_numberD:
  assumes "\<not>Carmichael_number n" "\<not>prime n"  and "1 < n"
  shows "\<exists> a \<in> {2 ..< n} . fermat_witness a n \<and> coprime a n"
proof -
  obtain a where "coprime a n" "[a^(n-1) \<noteq> 1] (mod n)"
    using assms unfolding Carmichael_number_def by blast

  moreover from this and \<open>1 < n\<close> have "a mod n \<in> {1..<n}"
    by (cases "a = 0") (auto intro! : gre1I_nat)

  ultimately have "a mod n \<in> {1 ..< n}"  "coprime (a mod n) n" "[(a mod n)^(n-1) \<noteq> 1] (mod n)"
    using \<open>1 < n\<close> by simp_all

  hence "fermat_witness (a mod n) n"
    using fermat_witness_def by blast

  hence "1 \<noteq> (a mod n)"
    using \<open>1 < n\<close> \<open>(a mod n) \<in> {1 ..< n}\<close> and one_is_fermat_liar fermat_liar_witness_of_composition(1)
    by metis

  thus ?thesis
    using \<open>fermat_witness (a mod n) n\<close> \<open>coprime (a mod n) n\<close> \<open>(a mod n) \<in> {1..<n}\<close>
    by fastforce
qed

proposition prime_imp_strong_fermat_witness:
  fixes p :: nat
  assumes "prime p" "2 < p" "a \<in> {1 ..< p}"
  shows "strong_fermat_liar a p"
proof -
  { fix k m :: nat
    define j where "j \<equiv> LEAST k. [a ^ (2^k * m) = 1] (mod p)"

    have "[a ^ (p - 1) = 1] (mod p)"
      using fermat_theorem[OF \<open>prime p\<close>, of a] \<open>a \<in> {1 ..< p}\<close> by force

    moreover assume "odd m" and n: "p - 1 = 2 ^ k * m"

    ultimately have "[a ^ (2 ^ k * m) = 1] (mod p)" by simp

    moreover assume "[a ^ m \<noteq> 1] (mod p)"
    then have "0 < x" if "[a ^ (2 ^ x * m) = 1] (mod p)" for x
      using that by (auto intro: gr0I)

    ultimately have "0 < j" "j \<le> k" "[a ^ (2 ^ j * m) = 1] (mod p)"
      using LeastI2[of _ k "(<) 0"] Least_le[of _ k] LeastI[of _ k]
      by (simp_all add: j_def)

    moreover from this have "[a ^ (2^(j-1) * m) \<noteq> 1] (mod p)"
      using not_less_Least[of "j - 1" "\<lambda>k. [a ^ (2^k * m) = 1] (mod p)"]
      unfolding j_def by simp

    moreover have "a ^ (2 ^ (j - 1) * m) * a ^ (2 ^ (j - 1) * m) = a ^ (2 ^ j * m)"
      using \<open>0 < j\<close>
      by (simp add: algebra_simps semiring_normalization_rules(27) flip: power2_eq_square power_even_eq)

    ultimately have "(j-1)\<in>{0..<k} " "[a ^ (2 ^ (j-1) * m) = p - 1] (mod p)"
      using cong_square_alt[OF \<open>prime p\<close>, of "a ^ (2 ^ (j-1) * m)"]
      by simp_all
  }

  then show ?thesis unfolding strong_fermat_liar_def by blast
qed

lemma ignore_one:
  fixes P :: "_ \<Rightarrow> nat \<Rightarrow> bool"
  assumes "P 1 n" "1 < n"
  shows "card {a \<in> {1..<n}. P a n} = 1 + card {a. 2 \<le> a \<and> a < n \<and> P a n}"
proof -
  have "insert 1 {a. 2 \<le> a \<and> a < n \<and> P a n} = {a. 1 \<le> a \<and> a < n \<and> P a n}"
    using assms by auto

  moreover have "card (insert 1 {a. 2 \<le> a \<and> a < n \<and> P a n}) = Suc (card {a. 2 \<le> a \<and> a < n \<and> P a n})"
    using card_insert_disjoint by auto

  ultimately show ?thesis by force
qed

text \<open>Proofs in the following section are inspired by \cite{Cornwell, MillerRabinTest, lecture_notes}.\<close>

proposition not_Carmichael_number_imp_card_fermat_witness_bound:
  fixes n :: nat
  assumes "\<not>prime n" "\<not>Carmichael_number n" "odd n" "1 < n"
  shows "(n-1) div 2 < card {a \<in> {1 ..< n}. fermat_witness a n}"
    and "(card {a. 2 \<le> a \<and> a < n \<and> strong_fermat_liar a n}) < real (n - 2) / 2"
    and "(card {a. 2 \<le> a \<and> a < n \<and> fermat_liar a n}) < real (n - 2) / 2"
proof -
  define G where "G = Residues_Mult n"
  interpret residues_mult_nat n G
    by unfold_locales (use \<open>n > 1\<close> in \<open>simp_all only: G_def\<close>)
  define h where "h \<equiv> \<lambda>a. a ^ (n - 1) mod n"
  define ker where "ker = kernel G (G\<lparr>carrier := h ` carrier G\<rparr>) h"

  have "finite ker" by (auto simp: ker_def kernel_def)
  moreover have "1 \<in> ker" using \<open>n > 1\<close> by (auto simp: ker_def kernel_def h_def)
  ultimately have [simp]: "card ker > 0"
    by (subst card_gt_0_iff) (auto simp: ker_def kernel_def h_def)

  have totatives_eq: "totatives n = {k\<in>{1..<n}. coprime k n}"
    using totatives_less[of _ n] \<open>n > 1\<close> by (force simp: totatives_def)
  have ker_altdef: "ker = {a \<in> {1..<n}. fermat_liar a n}"
    unfolding ker_def fermat_liar_def carrier_eq kernel_def totatives_eq using \<open>n > 1\<close>
    by (force simp: h_def cong_def intro: coprimeI_power_mod)

  have h_is_hom: "h \<in> hom G G"
    unfolding hom_def using nat_pow_closed
    by (auto simp: h_def power_mult_distrib mod_simps)
  then interpret h: group_hom G G h
    by unfold_locales

  obtain a where a: "a \<in> {2..<n}" "fermat_witness a n" "coprime a n"
    using assms power_one not_Carmichael_numberD by blast

  have "h a \<noteq> 1" using a by (auto simp: fermat_witness_def cong_def h_def)
  hence "2 \<le> card {1, h a}" by simp
  also have "\<dots> \<le> card (h ` carrier G)"
  proof (intro card_mono; safe?)
    from \<open>n > 1\<close> have "1 = h 1" by (simp add: h_def)
    also have "\<dots> \<in> h ` carrier G" by (intro imageI) (use \<open>n > 1\<close> in auto)
    finally show "1 \<in> h ` carrier G" .
  next
    show "h a \<in> h ` carrier G"
      using a by (intro imageI) (auto simp: totatives_def)
  qed auto
  also have "\<dots> * card ker = order G"
    using homomorphism_thm_order[OF h.group_hom_axioms] by (simp add: ker_def order_def)
  also have "order G < n - 1"
    using totient_less_not_prime[of n] assms by (simp add: order_eq)
  finally have "card ker < (n - 1) div 2"
    using \<open>odd n\<close> by (auto elim!: oddE)

  have "(n - 1) div 2 < (n - 1) - card ker"
    using \<open>card ker < (n - 1) div 2\<close> by linarith
  also have "\<dots> = card ({1..<n} - ker)"
    by (subst card_Diff_subset) (auto simp: ker_altdef)
  also have "{1..<n} - ker = {a \<in> {1..<n}. fermat_witness a n}"
    by (auto simp: fermat_witness_def fermat_liar_def ker_altdef)
  finally show "(n - 1) div 2 < card {a \<in> {1..<n}. fermat_witness a n}" .

  have "card {a. 2 \<le> a \<and> a < n \<and> fermat_liar a n} \<le> card (ker - {1})"
    by (intro card_mono) (auto simp: ker_altdef fermat_liar_def fermat_witness_def)
  also have "\<dots> = card ker - 1"
    using \<open>n > 1\<close> by (subst card_Diff_subset) (auto simp: ker_altdef fermat_liar_def)
  also have "\<dots> < (n - 2) div 2"
    using \<open>card ker < (n - 1) div 2\<close> \<open>odd n\<close> \<open>card ker > 0\<close> by linarith
  finally show *: "card {a. 2 \<le> a \<and> a < n \<and> fermat_liar a n} < real (n - 2) / 2"
    by simp

  have "card {a. 2 \<le> a \<and> a < n \<and> strong_fermat_liar a n} \<le>
          card {a. 2 \<le> a \<and> a < n \<and> fermat_liar a n}"
    by (intro card_mono) (auto intro!: strong_fermat_liar_imp_fermat_liar)
  moreover note *
  ultimately show "card {a. 2 \<le> a \<and> a < n \<and> strong_fermat_liar a n} < real (n - 2) / 2"
    by simp
qed

proposition Carmichael_number_imp_lower_bound_on_strong_fermat_witness:
  fixes n :: nat
  assumes Carmichael_number: "Carmichael_number n"
  shows "(n - 1) div 2 < card {a \<in> {1..<n}. strong_fermat_witness a n}"
    and "real (card {a . 2 \<le> a \<and> a < n \<and> strong_fermat_liar a n}) < real (n - 2) / 2"
proof -
  from assms have "n > 3" by (intro Carmichael_number_gt_3)
  hence "n - 1 \<noteq> 0" "\<not>is_unit (2 :: nat)" by auto
  obtain k m where "odd m" and n_less: "n - 1 = 2 ^ k * m"
    using multiplicity_decompose'[OF \<open>n - 1 \<noteq> 0\<close> \<open>\<not>is_unit (2::nat)\<close>] by metis

  obtain p l where n: "n = p * l" and "prime p" "\<not> p dvd l" "2 < l"
    using Carmichael_number_imp_squarefree_alt[OF Carmichael_number]
    by blast

  then have "coprime p l" using prime_imp_coprime_nat by blast

  have "odd n" using Carmichael_number_odd Carmichael_number by simp

  have "2 < n" using \<open>n > 3\<close> \<open>odd n\<close> by presburger

  note prime_gt_1_nat[OF \<open>prime p\<close>]

  have "2 < p" using \<open>odd n\<close> n \<open>prime p\<close> prime_ge_2_nat
               and dvd_triv_left le_neq_implies_less by blast

  let ?P = "\<lambda> k. (\<forall> a. coprime a p \<longrightarrow> [a^(2^k * m) = 1] (mod p))"
  define j where "j \<equiv> LEAST k. ?P k"

  define H where "H \<equiv> {a \<in> {1..<n} . coprime a n \<and> ([a^(2^(j-1) * m) = 1] (mod n) \<or>
                                                     [a^(2^(j-1) * m) = n - 1] (mod n))}"

  have k : "\<forall>a. coprime a n \<longrightarrow> [a ^ (2 ^ k * m) = 1] (mod n)"
    using Carmichael_number unfolding Carmichael_number_def n_less by blast

  obtain k' m' where "odd m'" and p_less: "p - 1 = 2 ^ k' * m'"
    using \<open>1 < p\<close> by (auto intro: multiplicity_decompose'[of "(p-1)" 2])

  have "p - 1 dvd n - 1"
    using Carmichael_number_imp_dvd[OF Carmichael_number \<open>prime p\<close>] \<open>n = p * l\<close>
    by fastforce

  then have "p - 1 dvd 2 ^ k' * m"
    unfolding n_less p_less
    using \<open>odd m\<close> \<open>odd m'\<close>
      and coprime_dvd_mult_left_iff[of "2^k'" m "2^k"] coprime_dvd_mult_right_iff[of m' "2^k" m]
    by auto

  have k': "\<forall>a. coprime a p \<longrightarrow> [a ^ (2 ^ k' * m) = 1] (mod p)"
  proof safe
    fix a
    assume "coprime a p"
    hence "\<not> p dvd a" using p_coprime_right_nat[OF \<open>prime p\<close>] by simp

    have "[a ^ (2 ^ k' * m') = 1] (mod p)"
     unfolding p_less[symmetric]
      using fermat_theorem \<open>prime p\<close> \<open>\<not> p dvd a\<close> by blast

    then show "[a ^ (2 ^ k' * m) = 1] (mod p)"
      using \<open>p - 1 dvd 2 ^ k' * m\<close>
      unfolding p_less n_less
      by (meson dvd_trans ord_divides)
  qed

  have j_prop: "[a^(2^j * m) = 1] (mod p)" if "coprime a p" for a
    using that LeastI[of ?P k', OF k', folded j_def] cong_modulus_mult coprime_mult_right_iff
    unfolding j_def n by blast

  have j_least: "[a^(2^i * m) = 1] (mod p)" if "coprime a p" "j \<le> i" for a i
  proof -
    obtain c where i: "i = j + c" using le_iff_add[of j i] \<open>j \<le> i\<close> by blast

    then have "[a ^ (2 ^ i * m) = a ^ (2 ^ (j + c) * m)] (mod p)" by simp

    also have "[a ^ (2 ^ (j + c) * m) = (a ^ (2 ^ j * m)) ^ (2 ^ c)] (mod p)"
      by (simp flip: power_mult add: algebra_simps power_add)

    also note j_prop[OF \<open>coprime a p\<close>]

    also have "[1 ^ (2 ^ c) = 1] (mod p)" by simp

    finally show ?thesis .
  qed

  have neq_p: "[p - 1 \<noteq> 1](mod p)"
    using \<open>2 < p\<close> and cong_less_modulus_unique_nat[of "p-1" 1 p]
    by linarith

  have "0 < j"
  proof (rule LeastI2[of ?P k', OF k', folded j_def], rule gr0I)
    fix x
    assume "\<forall>a. coprime a p \<longrightarrow> [a ^ (2 ^ x * m) = 1] (mod p)"
    then have "[(p - 1) ^ (2 ^ x * m) = 1] (mod p)"
      using coprime_diff_one_left_nat[of p]  prime_gt_1_nat[OF \<open>prime p\<close>]
      by simp

    moreover assume "x = 0"
    hence "[(p-1)^(2^x*m) = p - 1](mod p)"
      using \<open>odd m\<close> odd_pow_cong[OF _ \<open>odd m\<close>, of p] prime_gt_1_nat[OF \<open>prime p\<close>]
      by auto

    ultimately show False
      using \<open>[p - 1 \<noteq> 1] (mod p)\<close> by (simp add: cong_def)
  qed

  then have "j - 1 < j" by simp

  then obtain x where "coprime x p" "[x^(2^(j-1) * m) \<noteq> 1] (mod p)"
    using not_less_Least[of "j - 1" ?P, folded j_def] unfolding j_def by blast

  define G where "G = Residues_Mult n"
  interpret residues_mult_nat n G
    by unfold_locales (use \<open>n > 3\<close> in \<open>simp_all only: G_def\<close>)

  have H_subset: "H \<subseteq> carrier G" unfolding H_def by (auto simp: totatives_def)

  from \<open>n > 3\<close> have \<open>n > 1\<close> by simp
  interpret H: subgroup H G
  proof (rule subgroupI, goal_cases)
    case 1
    then show ?case using H_subset .
  next
    case 2
    then show ?case unfolding H_def using \<open>1 < n\<close> by force
  next
    case (3 a)
    define y where "y = inv\<^bsub>G\<^esub> a"

    then have "y \<in> carrier G"
      using H_subset \<open>a \<in> H\<close> by (auto simp del: carrier_eq)

    then have "1 \<le> y" "y < n" "coprime y n"
      using totatives_less[of y n] \<open>n > 3\<close> by (auto simp: totatives_def)

    moreover have "[y ^ (2 ^ (j - Suc 0) * m) = Suc 0] (mod n)"
      if "[y ^ (2 ^ (j - Suc 0) * m) \<noteq> n - Suc 0] (mod n)"
    proof -
      from \<open>a \<in> H\<close> have "[a * y = 1] (mod n)"
        using H_subset r_inv[of a] y_def by (auto simp: cong_def)
      hence "[(a * y) ^ (2 ^ (j - 1) * m) = 1 ^ (2 ^ (j - 1) * m)] (mod n)"
        by (intro cong_pow)
      hence "[(a * y) ^ (2 ^ (j - 1) * m) = 1] (mod n)"
        by simp
      hence * : "[a ^ (2 ^ (j - 1) * m) * y ^ (2 ^ (j - 1) * m) = 1] (mod n)"
          by (simp add: power_mult_distrib)
      from \<open>a \<in> H\<close> have "1 \<le> a" "a < n" "coprime a n"
        unfolding H_def by auto

      have "[a ^ (2 ^ (j - 1) * m) = 1] (mod n) \<or> [a ^ (2 ^ (j - 1) * m) = n - 1] (mod n)"
        using \<open>a \<in> H\<close> by (auto simp: H_def)
      thus ?thesis
      proof
        note *
        also assume "[a ^ (2 ^ (j - 1) * m) = 1] (mod n)"
        finally show ?thesis by simp
      next
        assume "[a ^ (2 ^ (j - 1) * m) = n - 1] (mod n)"
        then have "[y ^ (2 ^ (j - 1) * m) = n - 1] (mod n)"
          using minus_one_cong_solve[OF \<open>1 < n\<close>] * \<open>coprime a n\<close> \<open>coprime y n \<close>coprime_power_left_iff
          by blast+
        thus ?thesis using that by simp
      qed
    qed

    ultimately show ?case using \<open>a \<in> H\<close> unfolding H_def y_def by auto
  next
    case (4 a b)
    hence "a \<in> totatives n" "b \<in> totatives n"
      by (auto simp: H_def totatives_def)
    hence "a * b mod n \<in> totatives n"
      using m_closed[of a b] by simp
    hence "a * b mod n \<in> {1..<n}" "coprime (a * b) n"
      using totatives_less[of "a * b" n] \<open>n > 3\<close> by (auto simp: totatives_def)

    moreover define x y where "x = a ^ (2 ^ (j - 1) * m)" and "y = b ^ (2 ^ (j - 1) * m)"
    have "[x * y = 1] (mod n) \<or> [x * y = n - 1] (mod n)"
    proof -
      have *: "x mod n \<in> {1, n - 1}" "y mod n \<in> {1, n - 1}"
        using 4 by (auto simp: H_def x_def y_def cong_def)
      have "[x * y = (x mod n) * (y mod n)] (mod n)"
        by (intro cong_mult) auto
      moreover have "((x mod n) * (y mod n)) mod n \<in> {1, n - 1}"
        using * square_minus_one_cong_one'[OF \<open>1 < n\<close>] \<open>n > 1\<close> by (auto simp: cong_def)
      ultimately show ?thesis using \<open>n > 1\<close> by (simp add: cong_def mod_simps)
    qed

    ultimately show ?case by (auto simp: H_def x_def y_def power_mult_distrib)
  qed

  { obtain a where "[a = x] (mod p)" "[a = 1] (mod l)" "a < p * l"
      using binary_chinese_remainder_unique_nat[of p l x 1]
        and \<open>\<not> p dvd l\<close> \<open>prime p\<close> prime_imp_coprime_nat
      by auto

    moreover have "coprime a p"
      using \<open>coprime x p\<close> cong_imp_coprime[OF cong_sym[OF \<open>[a = x] (mod p)\<close>]] coprime_mult_right_iff
      unfolding n by blast

    moreover have "coprime a l"
      using coprime_1_left cong_imp_coprime[OF cong_sym[OF \<open>[a = 1] (mod l)\<close>]]
      by blast

    moreover from \<open>prime p\<close> and \<open>coprime a p\<close> have "a > 0"
      by (intro Nat.gr0I) auto

    ultimately have "a \<in> carrier G"
      using \<open>2 < l\<close> by (auto intro: gre1I_nat simp: n totatives_def)

    have "[a ^ (2^(j-1) * m) \<noteq> 1] (mod p)"
      using \<open>[x^(2^(j-1) * m) \<noteq> 1] (mod p)\<close> \<open>[a = x] (mod p)\<close> and cong_trans cong_pow cong_sym
      by blast

    then have "[a ^ (2^(j-1) * m) \<noteq> 1] (mod n)"
      using cong_modulus_mult_nat n by fast

    moreover
    have "[a ^ (2 ^ (j - Suc 0) * m) \<noteq> n - 1] (mod n)"
    proof -
      have "[a ^ (2 ^ (j - 1) * m) = 1] (mod l)"
      using cong_pow[OF \<open>[a = 1] (mod l)\<close>] by auto

      moreover have "Suc 0 \<noteq> (n - Suc 0) mod l"
        using n \<open>2 < l\<close> \<open>odd n\<close>
        by (metis mod_Suc_eq mod_less mod_mult_self2_is_0 numeral_2_eq_2 odd_Suc_minus_one zero_neq_numeral)

      then have "[1 \<noteq> n - 1] (mod l)"
          using \<open>2 < l\<close> \<open>odd n\<close> unfolding cong_def by simp

      moreover have "l \<noteq> Suc 0" using \<open>2 < l\<close> by simp

      ultimately have "[a ^ (2 ^ (j - Suc 0) * m) \<noteq> n - 1] (mod l)"
        by (auto simp add: cong_def n mod_simps dest: cong_modulus_mult_nat)

      then show ?thesis
        using cong_modulus_mult_nat mult.commute n by metis
    qed

    ultimately have "a \<notin> H" unfolding H_def by auto

    hence "H \<subset> carrier (G)"
      using H_subset subgroup.mem_carrier and \<open>a \<in> carrier (G)\<close>
      by fast
  }

  have "card H \<le> order G div 2"
    by (intro proper_subgroup_imp_bound_on_card) (use \<open>H \<subset> carrier G\<close> H.is_subgroup in \<open>auto\<close>)
  also from assms have "\<not>prime n" by (auto dest: Carmichael_number_not_prime)
  hence "order G div 2 < (n - 1) div 2"
    using totient_less_not_prime[OF \<open>\<not> prime n\<close> \<open>1 < n\<close>] \<open>odd n\<close>
    by (auto simp add: order_eq elim!: oddE)
  finally have "card H < (n - 1) div 2" .

  {
    { fix a
      assume "1 \<le> a" "a < n"
      hence "a \<in> {1..<n}" by simp

      assume "coprime a n"
      then have "coprime a p"
      unfolding n by simp

      assume "[a ^ (2 ^ (j - 1) * m) \<noteq> 1] (mod n)"
      hence "[a ^ m \<noteq> 1] (mod n)"
        by (metis dvd_trans dvd_triv_right ord_divides)

      moreover assume "strong_fermat_liar a n"

      ultimately obtain i where "i \<in> {0 ..< k}" "[a^(2^i * m) = n-1](mod n)"
        unfolding strong_fermat_liar_def using \<open>odd m\<close> n_less by blast

      then have "[a ^ (2 ^ i * m) = n - 1] (mod p)"
        unfolding n using cong_modulus_mult_nat by blast

      moreover have "[n - 1 \<noteq> 1] (mod p)"
      proof(subst cong_altdef_nat, goal_cases)
        case 1
        then show ?case using \<open>1 < n\<close> by linarith
      next
        case 2
        have "\<not> p dvd 2" using \<open>2 < p\<close> by (simp add: nat_dvd_not_less)

        moreover have "2 \<le> n" using \<open>1 < n\<close> by linarith

        moreover have "p dvd n" using n by simp

        ultimately have "\<not> p dvd n - 2" using dvd_diffD1 by blast

        then show ?case by (simp add: numeral_2_eq_2)
      qed

      ultimately have "[a ^ (2 ^ i * m) \<noteq> Suc 0] (mod p)" using cong_sym by (simp add: cong_def)

      then have "i < j" using j_least[OF \<open>coprime a p\<close>, of i] by force

      have "[(a ^ (2 ^ Suc i * m)) = 1] (mod n)"
        using square_minus_one_cong_one[OF \<open>1 < n\<close> \<open>[a^(2^i * m) = n-1](mod n)\<close>]
        by (simp add: power2_eq_square power_mult power_mult_distrib)

      { assume "i < j - 1"

        have "(2 :: nat) ^ (j - Suc 0) = ((2 ^ i) * 2 ^ (j - Suc i))"
          unfolding power_add[symmetric] using \<open>i < j - 1\<close> by simp

        then have "[a ^ (2 ^ (j - 1) * m) = (a ^ (2 ^ i * m)) ^ (2^(j - 1 - i))] (mod n)"
          by (auto intro!: cong_pow_I simp flip: power_mult simp add: algebra_simps power_add)

        also note \<open>[a ^ (2 ^ i * m) = n - 1] (mod n)\<close>

        also have "[(n - 1) ^ (2^(j - 1 - i)) = 1] (mod n) "
          using \<open>1 < n\<close> \<open>i < j - 1\<close> using even_pow_cong by auto

        finally have False
          using \<open>[a ^ (2 ^ (j - 1) * m) \<noteq> 1] (mod n)\<close>
          by blast
      }

      hence "i = j - 1" using \<open>i < j\<close> by fastforce

      hence "[a ^ (2 ^ (j - 1) * m) = n - 1] (mod n)" using \<open>[a^(2^i * m) = n-1](mod n)\<close> by simp
    }

    hence "{a \<in> {1..<n}. strong_fermat_liar a n} \<subseteq> H"
      using strong_fermat_liar_imp_fermat_liar[of _ n, OF _ \<open>1 < n\<close>]  liar_imp_coprime
      by (auto simp: H_def)
  }

  moreover have "finite H" unfolding H_def by auto

  ultimately have strong_fermat_liar_bounded: "card {a \<in> {1..<n}. strong_fermat_liar a n} < (n - 1) div 2 "
    using card_mono[of H] le_less_trans[OF _ \<open>card H < (n - 1) div 2\<close>] by blast

  moreover {
    have "{1..<n} - {a \<in> {1..<n}. strong_fermat_liar a n} = {a \<in> {1..<n}. strong_fermat_witness a n}"
      using strong_fermat_witness_def by blast

    then have "card {a \<in> {1..<n}. strong_fermat_witness a n} = (n-1) - card {a \<in> {1..<n}. strong_fermat_liar a n}"
      using card_Diff_subset[of "{a \<in> {1..<n}. strong_fermat_liar a n}" "{1..<n}"]
      by fastforce
  }

  ultimately show "(n - 1) div 2 < card {a \<in> {1..<n}. strong_fermat_witness a n}"
    by linarith

  show "real (card {a . 2 \<le> a \<and> a < n \<and> strong_fermat_liar a n}) < real (n - 2) / 2"
    using strong_fermat_liar_bounded ignore_one one_is_strong_fermat_liar \<open>1 < n\<close>
    by simp
qed

corollary strong_fermat_witness_lower_bound:
  assumes "odd n" "n > 2" "\<not>prime n"
  shows   "card {a. 2 \<le> a \<and> a < n \<and> strong_fermat_liar a n} < real (n - 2) / 2"
  using Carmichael_number_imp_lower_bound_on_strong_fermat_witness(2)[of n]
        not_Carmichael_number_imp_card_fermat_witness_bound(2)[of n] assms
  by (cases "Carmichael_number n") auto

end


(* Property from Case-Analysis for Rippling and Inductive Proof,
   Moa Johansson, Lucas Dixon and Alan Bundy, ITP 2010.
   This Isabelle theory is produced using the TIP tool offered at the following website:
     https://github.com/tip-org/tools
   This file was originally provided as part of TIP benchmark at the following website:
     https://github.com/tip-org/benchmarks
   Yutaka Nagashima at CIIRC, CTU changed the TIP output theory file slightly
   to make it compatible with Isabelle2017.
   Some proofs were added by Yutaka Nagashima.*)
theory TIP_prop_43
  imports "../../Test_Base"
begin

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

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

fun takeWhile :: "('a => bool) => 'a list => 'a list" where
  "takeWhile y (nil2) = nil2"
| "takeWhile y (cons2 z2 xs) =
     (if y z2 then cons2 z2 (takeWhile y xs) else nil2)"

fun dropWhile :: "('a => bool) => 'a list => 'a list" where
  "dropWhile y (nil2) = nil2"
| "dropWhile y (cons2 z2 xs) =
     (if y z2 then dropWhile y xs else cons2 z2 xs)"

theorem property0 :
  "((x (takeWhile p xs) (dropWhile p xs)) = xs)"
  find_proof DInd
  apply (induct)
   apply auto
  done

theorem property0' :
  "((x (takeWhile p xs) (dropWhile p xs)) = xs)"
  apply (induct xs)
   apply auto
  done

theorem property0'' :
  "((x (takeWhile p xs) (dropWhile p xs)) = xs)"
  apply (induct rule:x.induct)
  nitpick
  oops

theorem property0'' :
  "((x (takeWhile p xs) (dropWhile p xs)) = xs)"
  apply (induct "(takeWhile p xs)" rule:x.induct)
   apply fastforce
  apply clarsimp
  (*This is bad: The conclusion is equivalent to the original goal.
   * \<rightarrow> No. That does not necessarily mean it is bad. *)
  oops

end


(*
Title: Number Theoretic Transform
Author: Thomas Ammer
*)

theory NTT
  imports Preliminary_Lemmas
begin

section \<open>Number Theoretic Transform and Inverse Transform\<close>
text \<open>\label{NTT}\<close>

locale ntt = preliminary "TYPE ('a ::prime_card)" +
fixes \<omega> :: "('a::prime_card mod_ring)"
fixes \<mu> :: "('a mod_ring)"
assumes omega_properties: "\<omega>^n = 1" "\<omega> \<noteq> 1" "(\<forall> m. \<omega>^m = 1 \<and> m\<noteq>0 \<longrightarrow> m \<ge> n)"
assumes mu_properties: "\<mu> * \<omega> = 1"
begin

lemma mu_properties': "\<mu> \<noteq> 1"
  using omega_properties mu_properties by auto

subsection \<open>Definition of $NTT$ and $INTT$\<close>
text \<open>\label{NTTdef}\<close>

text \<open>
Now we can state an analogue to the $DFT$ on finite fields,
namely the \textit{Number Theoretic Transform}.
First, let us look at an informal definition of $\mathsf{NTT}$~\parencite{ntt_intro}:
\begin{equation*}
\mathsf{NTT}(\vec{x}) =
\begin{pmatrix}
 1 &     1  &        1 &     1    &  \cdots&           1 \\
 1 & \omega   & \omega^2 & \omega^3 & \cdots & \omega^{n-1} \\
 1 & \omega^2 & \omega^4 & \omega^6 & \cdots & \omega^{2\cdot(n-1)} \\
 1 & \omega^3 & \omega^6 & \omega^9 & \cdots & \omega^{3\cdot(n-1)} \\
\vdots &  \vdots &  \vdots &  \vdots  &        &      \vdots          \\
 1 & \omega^{n-1} & \omega^{2\cdot(n-1)} & \omega^{3\cdot(n-1)} & \cdots & \omega^{(n-1)\cdot(n-1)}
\end{pmatrix} \cdot \vec{x}
\end{equation*}

Or for single vector entries:
\begin{equation*}
\mathsf{NTT}(\vec{x})_i = \sum _{j = 0} ^{n-1} x_j \cdot \omega ^{i\cdot j}
\end{equation*}

\<close>

text \<open>Formally:\<close>

definition ntt::"(('a ::prime_card) mod_ring) list \<Rightarrow> nat \<Rightarrow> 'a mod_ring" where
"ntt numbers i = (\<Sum>j=0..<n. (numbers ! j) * \<omega>^(i*j)) "

definition "NTT numbers = map (ntt numbers) [0..<n]"

text \<open>\label{INTTdef}
We define the inverse transform $\mathsf{INTT}$ by matrices:
\begin{equation*}
 \mathsf{INTT}(\vec{y}) =
\begin{pmatrix}
 1 &     1  &        1 &     1    &  \cdots&           1 \\
 1 & \mu   & \mu^2 & \mu^3 & \cdots & \mu^{n-1} \\
 1 & \mu^2 & \mu^4 & \mu^6 & \cdots & \mu^{2\cdot(n-1)} \\
 1 & \mu^3 & \mu^6 & \mu^9 & \cdots & \mu^{3\cdot(n-1)} \\
\vdots &  \vdots &  \vdots &  \vdots  &        &      \vdots          \\
 1 & \mu^{n-1} & \mu^{2\cdot(n-1)} & \mu^{3\cdot(n-1)} & \cdots & \mu^{(n-1)\cdot(n-1)}
\end{pmatrix} \cdot \vec{y}
\end{equation*}
Per component:
\begin{equation*}
%
\mathsf{INTT}(\vec{y})_i = \sum _{j = 0} ^{n-1} y_j \cdot \mu ^{i\cdot j}
%
\end{equation*}

\<close>

definition "intt xs i = (\<Sum>j=0..<n. (xs ! j) * \<mu>^(i*j)) "

definition "INTT xs = map (intt xs) [0..<n]"

text \<open>Vector length is preserved.\<close>

lemma length_NTT:
  assumes n_def: "length numbers = n"
  shows "length (NTT numbers) = n"
  unfolding NTT_def ntt_def using n_def length_map[of _ "[0..<n]"]
  by simp

lemma length_INTT:
  assumes n_def: "length numbers = n"
  shows "length (INTT numbers) = n"
  unfolding INTT_def intt_def using n_def length_map[of _ "[0..<n]"]
  by simp

subsection \<open>Correctness Proof of $NTT$ and $INTT$\<close>
text \<open>\label{NTTcorr}\<close>
text \<open>
We prove $\mathsf{NTT}$ and $\mathsf{INTT}$ correct:
By taking $\mathsf{INTT}(\mathsf{NTT} (x))$ we obtain $x$ scaled by $n$.
Analogue to $DFT$, one can get rid of the factor $n$ by a simple rescaling.
First, consider an informal proof sketch using the matrix form:
\begin{equation*}
\begin{split}
\mathsf{INTT}(\mathsf{NTT}(\vec{x})) = \hspace{11cm}\\
%
\begin{pmatrix}
 1 &     1  &            1    &  \cdots&           1 \\
 1 & \mu   & \mu^2 &  \cdots & \mu^{n-1} \\
 1 & \mu^2 & \mu^4 &  \cdots & \mu^{2\cdot(n-1)} \\
\vdots &  \vdots &    \vdots  &        &      \vdots          \\
 1 & \mu^{n-1} & \mu^{2\cdot(n-1)}& \cdots & \mu^{(n-1)\cdot(n-1)}
\end{pmatrix}
%
\cdot
%
\begin{pmatrix}
 1 &     1  &        1 &  \cdots&           1 \\
 1 & \omega   & \omega^2 & \cdots & \omega^{n-1} \\
 1 & \omega^2 & \omega^4  & \cdots & \omega^{2\cdot(n-1)} \\
\vdots &  \vdots &  \vdots  &        &      \vdots          \\
 1 & \omega^{n-1} & \omega^{2\cdot(n-1)} & \cdots & \omega^{(n-1)\cdot(n-1)}
\end{pmatrix}
\cdot
%
\vec{x}
%
\end{split}
\end{equation*}

A resulting entry is of the following form:

\begin{equation*}
%
\mathsf{INTT}(\mathsf{NTT}(x))_i = \sum _ {j = 0} ^{n-1} (\sum _{k = 0} ^{n-1} \mu^{i\cdot k} \cdot \omega^{j\cdot k}) \cdot x_j
%
\end{equation*}

Now, we analyze the interior sum by cases on $i = j$.

\paragraph \noindent Case $i = j$.
\begin{align*}
\sum _{k = 0} ^{n-1} \mu^{i\cdot k} \cdot \omega^{j\cdot k}
&= \sum _{k = 0} ^{n-1} (\mu \cdot \omega)^{i \cdot k} \\
&= n \cdot (\mu \cdot \omega)^{i \cdot k} \\
&=  n \cdot 1 ^{i \cdot k} \\ &= n
\end{align*}
Note that $\omega$ and $\mu$ are mutually inverse.
\paragraph \noindent Case $i \neq j$. Wlog assume $i > j$, otherwise replace $\omega$ by $\mu$ and $i -j$ by $j - i$ respectively.
\begin{align*}
\sum _{k = 0} ^{n-1} \mu^{i\cdot k} \cdot \omega^{j\cdot k}
&= \sum _{k = 0} ^{n-1} (\mu \cdot \omega)^{j \cdot k} \cdot \omega^{(i-j) \cdot k} \\
&= \sum _{k = 0} ^{n-1} \omega^{(i-j) \cdot k} \\
&=  (1 - \omega ^{(i-j)\cdot n}) \cdot (1 - \omega^{i-j})^{-1} && \text{by lemma on geometric sum}\\
&=  (1 - 1^n) \cdot (1 - \omega^{i-j})^{-1} \\
&= 0
\end{align*}

We conclude that $\sum \limits _ {j = 0} ^{n-1} (\sum \limits _{k = 0} ^{n-1} \mu^{i\cdot k} \cdot \omega^{j\cdot k}) \cdot x_j = n \cdot x_i$.

\<close>

theorem ntt_correct:
  assumes n_def: "length numbers = n"
  shows "INTT (NTT numbers) = map (\<lambda> x. (of_int_mod_ring n) * x ) numbers"
proof-
  have 0:"\<And> i. i < n \<Longrightarrow> (INTT (NTT numbers)) ! i = intt (NTT numbers) i " using n_def length_NTT
    unfolding INTT_def NTT_def intt_def by simp

  text \<open>Major sublemma.\<close>

  have 1:"\<And> i. i < n \<Longrightarrow>intt (NTT numbers) i = (of_int_mod_ring n)*numbers ! i"
  proof-
    fix i
    assume i_assms:"i < n"

    text \<open>First, simplify by some chains of equations.\<close>

    hence 1:"intt (NTT numbers) i  =
            (\<Sum>l = 0..<n.
              (\<Sum>j = 0..<n. numbers ! j * \<omega> ^ (l * j)) * \<mu> ^ (i * l))"
      unfolding NTT_def intt_def ntt_def using n_def length_map nth_map by simp
    also have 2:"\<dots> =
            (\<Sum>l = 0..<n.
              (\<Sum>j = 0..<n. (numbers ! j * \<omega> ^ (l * j)) * \<mu> ^ (i * l)))"
      using sum_in by (simp add: sum_distrib_right)
    also have 3:"\<dots> =
            (\<Sum>j = 0..<n.
              (\<Sum>l = 0..<n. (numbers ! j * \<omega> ^ (l * j) * \<mu> ^ (i * l))))" using sum_swap by fast

    text \<open>As in the informal proof, we consider three cases. First $j = i$.\<close>

    have iisj:"\<And> j. j = i \<Longrightarrow> (\<Sum>l = 0..<n. (numbers ! j * \<omega> ^ (l * j) * \<mu> ^ (i * l))) = (numbers ! j)* (of_int_mod_ring n)"
    proof-
      fix j
      assume "j=i"
      hence "\<And> l. l < n \<Longrightarrow> (numbers ! j * \<omega> ^ (l * j) * \<mu> ^ (i * l))= (numbers ! j)"
        by (simp add: left_right_inverse_power mult.commute mu_properties(1))
      moreover have "\<And> l. l < n  \<Longrightarrow> numbers ! j *  \<omega> ^ (l * j) * \<mu> ^ (i * l) = numbers ! j"
        using calculation by blast

      text \<open>$\omega^{il}\cdot \omega^{jl} = 1$. Thus, we sum over $1$ $n$ times, which gives the goal.\<close>

      ultimately show "(\<Sum>l = 0..<n. (numbers ! j * \<omega> ^ (l * j) * \<mu> ^ (i * l))) =
        (numbers ! j)* (of_int_mod_ring n)"
        using n_def sum_const[of "numbers ! j" n] exp_rule[of \<omega> \<mu>] mu_properties(1)
        by (metis (no_types, lifting) atLeastLessThan_iff mult.commute sum.cong)

    qed

    text \<open>Case $j < i$.\<close>

    have jlsi:"\<And> j. j < i \<Longrightarrow> (\<Sum>l = 0..<n. (numbers ! j * \<omega> ^ (l * j) * \<mu> ^ (i * l))) = 0"
    proof-
      fix j
      assume j_assms:"j < i"
      hence 00:"\<And>  (c::('a::prime_card) mod_ring) a b. c * a^j*b^i  = (a*b)^j*(c * b^(i-j))"
         using  algebra_simps
         by (smt (z3) le_less ordered_cancel_comm_monoid_diff_class.add_diff_inverse power_add)

       text \<open>A geometric sum over $\mu^l$ remains.\<close>

      have 01:" (\<Sum>l = 0..<n. (numbers ! j * \<omega> ^ (l * j) * \<mu> ^ (i * l))) =
                (\<Sum>l = 0..<n. (numbers ! j *  (\<mu>^l)^(i-j)))"
           apply(rule sum_eq)
           using mu_properties(1) 00 algebra_simps(23)
           by (smt (z3) mult.commute mult.left_neutral power_mult power_one)
      have 02:"\<dots> = numbers ! j *(\<Sum>l = 0..<n. ((\<mu>^l)^(i-j))) "
           using sum_in[of "\<lambda> l. numbers ! j * (\<mu> ^ l) ^ (i - j)" " numbers ! j" n]
           by (simp add: mult_hom.hom_sum)
      moreover have 03:"(\<Sum>l = 0..<n. ((\<mu>^l)^(i-j))) =
                     (\<Sum>l = 0..<n. ((\<mu>^(i-j))^l)) "
        by(rule sum_eq) (metis mult.commute power_mult)
      have "\<mu>^(i-j) \<noteq> 1"
      proof
        assume "\<mu> ^ (i - j) = 1"
        hence "ord p (to_int_mod_ring \<mu>) \<le> i-j"
          by (simp add: j_assms not_le ord_max)
        moreover hence "ord p (to_int_mod_ring \<omega>) \<le> i-j"
          by (metis \<open>\<mu> ^ (i - j) = 1\<close> diff_is_0_eq exp_rule j_assms leD mult.comm_neutral mult.commute mu_properties(1) ord_max)
        moreover hence "i-j < n"
          using j_assms i_assms p_fact k_bound n_lst2 by linarith
        moreover have "ord p (to_int_mod_ring \<omega>) = n" using omega_properties n_lst2 unfolding ord_def
          by (metis (no_types) \<open>\<mu> ^ (i - j) = 1\<close> calculation(3) diff_is_0_eq j_assms leD left_right_inverse_power mult.comm_neutral mult_cancel_left mu_properties(1) omega_properties(3) zero_neq_one)
        ultimately show False by simp
      qed

      text \<open>Application of the lemma for geometric sums.\<close>

      ultimately have "(1-\<mu>^(i-j))*(\<Sum>l = 0..<n. ((\<mu>^(i-j))^l)) = (1-(\<mu>^(i-j))^n)"
        using geo_sum[of "\<mu> ^ (i - j)" n] by simp
      moreover have "(\<mu>^(i-j))^n = 1"
        by (metis (no_types) left_right_inverse_power mult.commute mult.right_neutral mu_properties(1) omega_properties(1) power_mult power_one)

      text \<open>The sum for the current index is 0.\<close>

      ultimately have "(\<Sum>l = 0..<n. ((\<mu>^(i-j))^l)) = 0"
        by (metis \<open>\<mu> ^ (i - j) \<noteq> 1\<close> divisors_zero eq_iff_diff_eq_0)
      thus "(\<Sum>l = 0..<n. numbers ! j * \<omega> ^ (l * j) * \<mu> ^ (i * l)) = 0" using  01 02 03 by simp
    qed

    text \<open>Case $i < j$.
       We also rewrite the whole summation until the lemma for geometric sums is applicable.
       From this, we conclude that the term is 0.\<close>

    have ilsj:"\<And> j. i < j \<and> j < n \<Longrightarrow> (\<Sum>l = 0..<n. (numbers ! j * \<omega> ^ (l * j) * \<mu> ^ (i * l))) = 0"
    proof-
      fix j
      assume ij_Assm: "i < j \<and> j < n"
      hence 00:"\<And>  (c::('a::prime_card) mod_ring) a b. (a*b)^i*(c * b^(j-i)) = c * a^i*b^j  "
        by (auto simp: field_simps simp flip: power_add)
      have 01:" (\<Sum>l = 0..<n. (numbers ! j * \<omega> ^ (l * j) * \<mu> ^ (i * l))) =
                (\<Sum>l = 0..<n. (numbers ! j *  (\<omega>^l)^(j-i))) "
           apply(rule sum_eq) subgoal for l
           using mu_properties(1) 00[of "\<omega>^l" "\<mu>^l" "numbers ! j "] algebra_simps(23)
           by (smt (z3) "00" left_right_inverse_power mult.assoc mult.commute mult.right_neutral power_mult)
         done
      moreover have 02:"(\<Sum>l = 0..<n. (numbers ! j *   (\<omega>^l)^(j-i)))  =
                         numbers ! j *(\<Sum>l = 0..<n. ( (\<omega>^l)^(j-i))) "
        by (simp add: mult_hom.hom_sum)
      moreover have 03:"(\<Sum>l = 0..<n. ( (\<omega>^l)^(j-i))) =
                     (\<Sum>l = 0..<n. (( (\<omega>^(j-i))^l))) "
        by(rule sum_eq) (metis mult.commute power_mult)
      have "\<omega>^(j-i) \<noteq> 1"
      proof
        assume " \<omega> ^ (j - i) = 1"
        hence "ord p (to_int_mod_ring  \<omega>) \<le> j-i" using ord_max[of "j-i" \<omega>] ij_Assm by simp
        moreover have "ord p (to_int_mod_ring \<omega>) =p-1"
          by (meson \<open>\<omega> ^ (j - i) = 1\<close> diff_is_0_eq diff_le_self ij_Assm leD le_trans omega_properties(3))
        ultimately show False
          by (meson \<open>\<omega> ^ (j - i) = 1\<close> diff_is_0_eq diff_le_self ij_Assm leD le_trans omega_properties(3))
      qed

      text \<open>Geometric sum.\<close>

      ultimately have "(1-\<omega>^(j-i))* (\<Sum>l = 0..<n. ((\<omega>^(j-i))^l)) = (1-(\<omega>^(j-i))^n)"
        using geo_sum[of "\<omega> ^ (j-i)" n] by simp
      moreover have "(\<omega>^(j-i))^n = 1"
        by (metis (no_types) mult.commute  omega_properties(1) power_mult power_one)
      ultimately have "(\<Sum>l = 0..<n. ((\<omega>^(j-i))^l)) = 0"
        by (metis \<open>\<omega> ^ (j - i) \<noteq> 1\<close> eq_iff_diff_eq_0 no_zero_divisors)
      thus "(\<Sum>l = 0..<n. numbers ! j * \<omega> ^ (l * j) * \<mu> ^ (i * l)) = 0" using  01 02 03 by simp
    qed

    text \<open>We compose the cases $j <i$, $j = i$ and $j > i$ to a complete summation over index $j$.\<close>

    have " (\<Sum>j = 0..<i. \<Sum>l = 0..<n. numbers ! j * \<omega> ^ (l * j) * \<mu> ^ (i * l)) = 0" using jlsi by simp
    moreover have " (\<Sum>j = i..<i+1. \<Sum>l = 0..<n. numbers ! j * \<omega> ^ (l * j) * \<mu> ^ (i * l)) =  numbers ! i * (of_int_mod_ring n)" using iisj by simp
    moreover have " (\<Sum>j = (i+1)..<n. \<Sum>l = 0..<n. numbers ! j * \<omega> ^ (l * j) * \<mu> ^ (i * l)) = 0" using ilsj by simp
    ultimately have " (\<Sum>j = 0..<n. \<Sum>l = 0..<n. numbers ! j * \<omega> ^ (l * j) * \<mu> ^ (i * l)) =
                        numbers ! i * (of_int_mod_ring n)" using i_assms sum_split
      by (smt (z3) add.commute add.left_neutral int_ops(2) less_imp_of_nat_less of_nat_add of_nat_eq_iff of_nat_less_imp_less)

    text \<open>Index-wise equality can be shown.\<close>

    thus "intt (NTT numbers) i = of_int_mod_ring (int n) * numbers ! i" using 1 2 3
      by (metis mult.commute)
  qed
  have 2: "\<And> i. i < n \<Longrightarrow> (map ((*) (of_int_mod_ring (int n))) numbers ) ! i = (of_int_mod_ring (int n)) * (numbers ! i)"
    by (simp add: n_def)

  text \<open>We relate index-wise equality to the function definition.\<close>

   show ?thesis
     apply(rule nth_equalityI)
     subgoal my_subgoal
       unfolding INTT_def NTT_def
       apply (simp add: n_def)
       done
     subgoal for i
     using 0 1 2 n_def algebra_simps my_subgoal length_map
     apply  auto
     done
   done
qed

text \<open>Now we prove the converse to be true:
$\mathsf{NTT}(\mathsf{INTT}(\vec{x})) = n \cdot \vec{x}$.
The proof proceeds analogously with exchanged roles of $\omega$ and $\mu$.
\<close>

theorem inv_ntt_correct:
  assumes n_def: "length numbers = n"
  shows "NTT (INTT numbers) = map (\<lambda> x. (of_int_mod_ring n) * x ) numbers"
proof-
  have 0:"\<And> i. i < n \<Longrightarrow> (NTT (INTT numbers)) ! i = ntt (INTT numbers) i " using n_def length_NTT
    unfolding INTT_def NTT_def intt_def by simp
  have 1:"\<And> i. i < n \<Longrightarrow>ntt (INTT numbers) i = (of_int_mod_ring n)*numbers ! i"
  proof-
    fix i
    assume i_assms:"i < n"
    hence 1:"ntt (INTT numbers) i  =
            (\<Sum>l = 0..<n.
               (\<Sum>j = 0..<n. numbers ! j * \<mu> ^ (l * j)) * \<omega> ^ (i * l))"
      unfolding INTT_def ntt_def intt_def using n_def length_map nth_map by simp
    hence 2:"\<dots> = (\<Sum>l = 0..<n.
                     (\<Sum>j = 0..<n. (numbers ! j * \<mu> ^ (l * j)) * \<omega> ^ (i * l)))" using sum_in by simp
    have 3:" \<dots> =(\<Sum>j = 0..<n.
                  (\<Sum>l = 0..<n. (numbers ! j * \<mu> ^ (l * j) * \<omega> ^ (i * l))))" using sum_swap by fast
    have iisj:"\<And> j. j = i \<Longrightarrow> (\<Sum>l = 0..<n. (numbers ! j * \<mu> ^ (l * j) * \<omega> ^ (i * l))) = (numbers ! j)* (of_int_mod_ring n)"
    proof-
      fix j
      assume "j=i"
      hence "\<And> l. l < n \<Longrightarrow> (numbers ! j * \<mu> ^ (l * j) * \<omega> ^ (i * l))= (numbers ! j)"
        by (simp add: left_right_inverse_power mult.commute mu_properties(1))
      moreover have "\<And> l. l < n  \<Longrightarrow> numbers ! j *  \<mu> ^ (l * j) * \<omega> ^ (i * l) = numbers ! j"
        using calculation by blast
      ultimately show "(\<Sum>l = 0..<n. (numbers ! j * \<mu> ^ (l * j) * \<omega> ^ (i * l))) = (numbers ! j)* (of_int_mod_ring n)"
        using n_def sum_const[of "numbers ! j" n] exp_rule[of \<omega> \<mu>] mu_properties(1)
        by (metis (no_types, lifting) atLeastLessThan_iff mult.commute sum.cong)
    qed
    have jlsi:"\<And> j. j < i \<Longrightarrow> (\<Sum>l = 0..<n. (numbers ! j * \<mu> ^ (l * j) * \<omega> ^ (i * l))) = 0"
    proof-
      fix j
      assume j_assms:"j < i"
      hence 00:"\<And>  (c::('a::prime_card) mod_ring) a b. c * a^j*b^i  = (a*b)^j*(c * b^(i-j))"
         using  algebra_simps
         by (smt (z3) le_less ordered_cancel_comm_monoid_diff_class.add_diff_inverse power_add)
      have 01:" (\<Sum>l = 0..<n. (numbers ! j * \<mu> ^ (l * j) * \<omega> ^ (i * l))) =
                (\<Sum>l = 0..<n. (numbers ! j *  (\<omega>^l)^(i-j))) "
           apply(rule sum_eq)
           using mu_properties(1) 00 algebra_simps(23)
           by (smt (z3) mult.commute mult.left_neutral power_mult power_one)
      moreover have 02: "\<dots>=  numbers ! j *(\<Sum>l = 0..<n. ((\<omega>^l)^(i-j))) "
           using sum_in[of "\<lambda> l. numbers ! j * (\<mu> ^ l) ^ (i - j)" " numbers ! j" n]
        by (simp add: mult_hom.hom_sum)
      moreover have 03:"(\<Sum>l = 0..<n. ((\<omega>^l)^(i-j))) =
                     (\<Sum>l = 0..<n. ((\<omega>^(i-j))^l)) "
        by(rule sum_eq) (metis mult.commute power_mult)
      have "\<omega>^(i-j) \<noteq> 1"
      proof
        assume "\<omega> ^ (i - j) = 1"
        hence "ord p (to_int_mod_ring \<omega>) \<le> i-j"
          by (simp add: j_assms not_le ord_max)
         moreover have "ord p (to_int_mod_ring \<omega>) = n" using omega_properties n_lst2 unfolding ord_def
           by (meson \<open>\<omega> ^ (i - j) = 1\<close> diff_is_0_eq diff_le_self i_assms j_assms leD le_trans)
         ultimately show False
           by (metis i_assms leD less_imp_diff_less)
      qed
      ultimately have "(1-\<omega>^(i-j))*(\<Sum>l = 0..<n. ((\<omega>^(i-j))^l)) = (1-(\<omega>^(i-j))^n)"
        using geo_sum[of "\<omega> ^ (i - j)" n] by simp
      moreover have "(\<omega>^(i-j))^n = 1"
        by (metis (no_types)  mult.commute omega_properties(1) power_mult power_one)
      ultimately have "(\<Sum>l = 0..<n. ((\<omega>^(i-j))^l)) = 0"
        by (metis \<open>\<omega> ^ (i - j) \<noteq> 1\<close> divisors_zero eq_iff_diff_eq_0)
      thus "(\<Sum>l = 0..<n. numbers ! j * \<mu> ^ (l * j) * \<omega> ^ (i * l)) = 0" using  01 02 03 by simp
    qed
    have ilsj:"\<And> j. i < j \<and> j < n \<Longrightarrow> (\<Sum>l = 0..<n. (numbers ! j * \<mu> ^ (l * j) * \<omega> ^ (i * l))) = 0"
    proof-
      fix j
      assume ij_Assm: "i < j \<and> j < n"
      hence 00:"\<And>  (c::('a::prime_card) mod_ring) a b. (a*b)^i*(c * b^(j-i)) = c * a^i*b^j  "
        by (simp add: field_simps flip: power_add)
      have 01:" (\<Sum>l = 0..<n. (numbers ! j * \<mu> ^ (l * j) * \<omega> ^ (i * l))) =
                (\<Sum>l = 0..<n. (numbers ! j *  (\<mu>^l)^(j-i))) "
           apply(rule sum_eq) subgoal for l
           using mu_properties(1) 00[of "\<omega>^l" "\<mu>^l" "numbers ! j "] algebra_simps(23)
           by (smt (z3) "00" left_right_inverse_power mult.assoc mult.commute mult.right_neutral power_mult)
         done
      moreover have 02:"(\<Sum>l = 0..<n. (numbers ! j *   (\<mu>^l)^(j-i)))  =
            numbers ! j *(\<Sum>l = 0..<n. ( (\<mu>^l)^(j-i))) "
        by (simp add: mult_hom.hom_sum)
      moreover have 03:"(\<Sum>l = 0..<n. ( (\<mu>^l)^(j-i))) =
                     (\<Sum>l = 0..<n. (( (\<mu>^(j-i))^l))) "
        by(rule sum_eq) (metis mult.commute power_mult)
      have "\<mu>^(j-i) \<noteq> 1"
       proof
        assume "\<mu> ^ (j - i) = 1"
        hence "ord p (to_int_mod_ring \<mu>) \<le> j -i "
          by (simp add: ij_Assm not_le ord_max)
        moreover hence "ord p (to_int_mod_ring \<omega>) \<le> j-i"
          by (metis \<open>\<mu> ^ (j - i) = 1\<close> diff_is_0_eq exp_rule ij_Assm leD mult.comm_neutral mult.commute mu_properties(1) ord_max)
        moreover hence "j-i < n" using ij_Assm i_assms p_fact k_bound n_lst2 by linarith
        moreover have "ord p (to_int_mod_ring \<omega>) = n" using omega_properties n_lst2 unfolding ord_def
          by (metis (no_types) \<open>\<mu> ^ (j-i) = 1\<close> calculation(3) diff_is_0_eq ij_Assm leD left_right_inverse_power mult.comm_neutral mult_cancel_left mu_properties(1) omega_properties(3) zero_neq_one)
        ultimately show False by simp
      qed
      ultimately have "(1-\<mu>^(j-i))* (\<Sum>l = 0..<n. ((\<mu>^(j-i))^l)) = (1-(\<mu>^(j-i))^n)"
        using geo_sum[of "\<mu> ^ (j-i)" n] by simp
      moreover have "(\<mu>^(j-i))^n = 1"
        by (metis (no_types) left_right_inverse_power mult.commute mult.right_neutral mu_properties(1) omega_properties(1) power_mult power_one)
      ultimately have "(\<Sum>l = 0..<n. ((\<mu>^(j-i))^l)) = 0"
        by (metis \<open>\<mu> ^ (j - i) \<noteq> 1\<close> eq_iff_diff_eq_0 no_zero_divisors)
      thus "(\<Sum>l = 0..<n. numbers ! j * \<mu> ^ (l * j) * \<omega> ^ (i * l)) = 0" using  01 02 03 by simp
    qed
    have " (\<Sum>j = 0..<i. \<Sum>l = 0..<n. numbers ! j * \<mu> ^ (l * j) * \<omega> ^ (i * l)) = 0" using jlsi by simp
    moreover have " (\<Sum>j = i..<i+1. \<Sum>l = 0..<n. numbers ! j * \<mu> ^ (l * j) * \<omega> ^ (i * l)) =  numbers ! i * (of_int_mod_ring n)" using iisj by simp
    moreover have " (\<Sum>j = (i+1)..<n. \<Sum>l = 0..<n. numbers ! j * \<mu> ^ (l * j) * \<omega> ^ (i * l)) = 0" using ilsj by simp
    ultimately have " (\<Sum>j = 0..<n. \<Sum>l = 0..<n. numbers ! j * \<mu> ^ (l * j) * \<omega> ^ (i * l)) =
                        numbers ! i * (of_int_mod_ring n)" using i_assms sum_split
      by (smt (z3) add.commute add.left_neutral int_ops(2) less_imp_of_nat_less of_nat_add of_nat_eq_iff of_nat_less_imp_less)
    thus "ntt (INTT numbers) i = of_int_mod_ring (int n) * numbers ! i" using 1 2 3
      by (metis mult.commute)
  qed
  have 2: "\<And> i. i < n \<Longrightarrow> (map ((*) (of_int_mod_ring (int n))) numbers ) ! i = (of_int_mod_ring (int n)) * (numbers ! i)"
     by (simp add: n_def)
   show ?thesis
     apply(rule nth_equalityI)
     subgoal my_little_subgoal
       unfolding INTT_def NTT_def
       apply (simp add: n_def)
       done
     subgoal for i
       using 0 1 2 n_def algebra_simps  my_little_subgoal length_map
       apply  auto
     done
   done
qed

end
end