section \<open>Characteristic of Rings\label{sec:ring_char}\<close>

theory Ring_Characteristic
  imports
    "Finite_Fields_Factorization_Ext"
    "HOL-Algebra.IntRing"
    "HOL-Algebra.Embedded_Algebras"
begin

locale finite_field = field +
  assumes finite_carrier: "finite (carrier R)"
begin

lemma finite_field_min_order:
  "order R > 1"
proof (rule ccontr)
  assume a:"\<not>(1 < order R)"
  have "{\<zero>\<^bsub>R\<^esub>,\<one>\<^bsub>R\<^esub>} \<subseteq> carrier R" by auto
  hence "card {\<zero>\<^bsub>R\<^esub>,\<one>\<^bsub>R\<^esub>} \<le> card (carrier R)"
    using card_mono finite_carrier by blast
  also have "... \<le> 1" using a by (simp add:order_def)
  finally have "card {\<zero>\<^bsub>R\<^esub>,\<one>\<^bsub>R\<^esub>} \<le> 1" by blast
  thus "False" by simp
qed

lemma (in finite_field) order_pow_eq_self:
  assumes "x \<in> carrier R"
  shows "x [^] (order R) = x"
proof (cases "x = \<zero>")
  case True
  have "order R > 0"
    using assms(1) order_gt_0_iff_finite finite_carrier by simp
  then obtain n where n_def:"order R = Suc n"
    using lessE by blast
  have "x [^] (order R) = \<zero>"
    unfolding n_def using True by (subst nat_pow_Suc, simp)
  thus ?thesis using True by simp
next
  case False
  have x_carr:"x \<in> carrier (mult_of R)"
    using False assms by simp

  have carr_non_empty: "card (carrier R) > 0"
    using order_gt_0_iff_finite finite_carrier
    unfolding order_def by simp
  have "x [^] (order R) = x [^]\<^bsub>mult_of R\<^esub> (order R)"
    by (simp add:nat_pow_mult_of)
  also have "... = x [^]\<^bsub>mult_of R\<^esub> (order (mult_of R)+1)"
    using carr_non_empty unfolding order_def
    by (intro arg_cong[where f="\<lambda>t. x [^]\<^bsub>mult_of R\<^esub> t"]) (simp)
  also have "... = x"
    using x_carr
    by (simp add:mult_of.pow_order_eq_1)
  finally show "x [^] (order R) = x"
    by simp
qed

lemma (in finite_field) order_pow_eq_self':
  assumes "x \<in> carrier R"
  shows "x [^] (order R ^ d) = x"
proof (induction d)
  case 0
  then show ?case using assms by simp
next
  case (Suc d)
  have "x [^] order R ^ (Suc d) = x [^] (order R ^ d * order R)"
    by (simp add:mult.commute)
  also have "... = (x [^] (order R ^ d)) [^] order R"
    using assms by (simp add: nat_pow_pow)
  also have "... = (x [^] (order R ^ d))"
    using order_pow_eq_self assms by simp
  also have "... = x"
    using Suc by simp
  finally show ?case by simp
qed

end

lemma finite_fieldI:
  assumes "field R"
  assumes "finite (carrier R)"
  shows "finite_field R"
  using assms
  unfolding finite_field_def finite_field_axioms_def
  by auto

lemma (in domain) finite_domain_units:
  assumes "finite (carrier R)"
  shows "Units R = carrier R - {\<zero>}" (is "?lhs = ?rhs")
proof
  have "Units R \<subseteq> carrier R" by (simp add:Units_def)
  moreover have "\<zero> \<notin> Units R"
    by (meson zero_is_prime(1) primeE)
  ultimately show "Units R \<subseteq> carrier R - {\<zero>}" by blast
next
  have "x \<in> Units R" if a: "x \<in> carrier R - {\<zero>}" for x
  proof -
    have x_carr: "x \<in> carrier R" using a by blast
    define f where "f = (\<lambda>y. y \<otimes>\<^bsub>R\<^esub> x)"
    have "inj_on f (carrier R)" unfolding f_def
      by (rule inj_onI, metis DiffD1 DiffD2 a m_rcancel insertI1)
    hence "card (carrier R) = card (f ` carrier R)"
      by (metis card_image)
    moreover have "f ` carrier R \<subseteq> carrier R" unfolding f_def
      by (rule image_subsetI, simp add: ring.ring_simprules x_carr)
    ultimately have "f ` carrier R = carrier R"
      using card_subset_eq assms by metis
    moreover have "\<one>\<^bsub>R\<^esub> \<in> carrier R" by simp
    ultimately have "\<exists>y \<in> carrier R. f y = \<one>\<^bsub>R\<^esub>"
      by (metis image_iff)
    then obtain y
      where y_carrier: "y \<in> carrier R"
        and y_left_inv: "y \<otimes>\<^bsub>R\<^esub> x = \<one>\<^bsub>R\<^esub>"
      using f_def by blast
    hence  y_right_inv: "x \<otimes>\<^bsub>R\<^esub> y = \<one>\<^bsub>R\<^esub>"
      by (metis DiffD1 a cring_simprules(14))
    show "x \<in> Units R"
      using y_carrier y_left_inv y_right_inv
      by (metis DiffD1 a divides_one factor_def)
  qed
  thus "?rhs \<subseteq> ?lhs" by auto
qed

text \<open>The following theorem can be found in Lidl and Niederreiter~\<^cite>\<open>\<open>Theorem 1.31\<close> in "lidl1986"\<close>.\<close>

theorem finite_domains_are_fields:
  assumes "domain R"
  assumes "finite (carrier R)"
  shows "finite_field R"
proof -
  interpret domain R using assms by auto
  have "Units R = carrier R - {\<zero>\<^bsub>R\<^esub>}"
    using finite_domain_units[OF assms(2)] by simp
  then have "field R"
    by (simp add: assms(1) field.intro field_axioms.intro)
  thus ?thesis
    using assms(2) finite_fieldI by auto
qed

definition zfact_iso :: "nat \<Rightarrow> nat \<Rightarrow> int set" where
  "zfact_iso p k = Idl\<^bsub>\<Z>\<^esub> {int p} +>\<^bsub>\<Z>\<^esub> (int k)"

context
  fixes n :: nat
  assumes n_gt_0: "n > 0"
begin

private abbreviation I where "I \<equiv> Idl\<^bsub>\<Z>\<^esub> {int n}"

private lemma ideal_I: "ideal I \<Z>"
  by (simp add: int.genideal_ideal)

lemma int_cosetI:
  assumes "u mod (int n) = v mod (int n)"
  shows "Idl\<^bsub>\<Z>\<^esub> {int n} +>\<^bsub>\<Z>\<^esub> u = Idl\<^bsub>\<Z>\<^esub> {int n} +>\<^bsub>\<Z>\<^esub> v"
proof -
  have "u - v \<in> I"
    by (metis Idl_subset_eq_dvd assms int_Idl_subset_ideal mod_eq_dvd_iff)
  thus ?thesis
    using ideal_I int.quotient_eq_iff_same_a_r_cos by simp
qed

lemma zfact_iso_inj:
  "inj_on (zfact_iso n) {..<n}"
proof (rule inj_onI)
  fix x y
  assume a:"x \<in> {..<n}" "y \<in> {..<n}"
  assume "zfact_iso n x = zfact_iso n y"
  hence "I +>\<^bsub>\<Z>\<^esub> (int x) = I +>\<^bsub>\<Z>\<^esub> (int y)"
    by (simp add:zfact_iso_def)
  hence "int x - int y \<in> I"
    by (subst int.quotient_eq_iff_same_a_r_cos[OF ideal_I], auto)
  hence "int x mod int n = int y mod int n"
    by (meson Idl_subset_eq_dvd int_Idl_subset_ideal mod_eq_dvd_iff)
  thus "x = y"
    using a by simp
qed

lemma zfact_iso_ran:
  "zfact_iso n ` {..<n} = carrier (ZFact (int n))"
proof -
  have "zfact_iso n ` {..<n} \<subseteq> carrier (ZFact (int n))"
    unfolding zfact_iso_def ZFact_def FactRing_simps
    using int.a_rcosetsI by auto
  moreover have "x \<in> zfact_iso n ` {..<n}"
    if a:"x \<in> carrier (ZFact (int n))" for x
  proof -
    obtain y where y_def: "x = I +>\<^bsub>\<Z>\<^esub> y"
      using a unfolding ZFact_def FactRing_simps by auto
    define z where \<open>z = nat (y mod int n)\<close>
    with n_gt_0 have z_def: \<open>int z mod int n = y mod int n\<close> \<open>z < n\<close>
      by (simp_all add: z_def nat_less_iff)
    have "x = I  +>\<^bsub>\<Z>\<^esub> y"
      by (simp add:y_def)
    also have "... = I +>\<^bsub>\<Z>\<^esub> (int z)"
      by (intro int_cosetI, simp add:z_def)
    also have "... = zfact_iso n z"
      by (simp add:zfact_iso_def)
    finally have "x = zfact_iso n z"
      by simp
    thus "x \<in> zfact_iso n ` {..<n}"
      using z_def(2) by blast
  qed
  ultimately show ?thesis by auto
qed

lemma zfact_iso_bij:
  "bij_betw (zfact_iso n) {..<n} (carrier (ZFact (int n)))"
  using  bij_betw_def zfact_iso_inj zfact_iso_ran by blast

lemma card_zfact_carr: "card (carrier (ZFact (int n))) = n"
  using bij_betw_same_card[OF zfact_iso_bij] by simp

lemma fin_zfact: "finite (carrier (ZFact (int n)))"
  using card_zfact_carr n_gt_0 card_ge_0_finite by force

end

lemma zfact_prime_is_finite_field:
  assumes "Factorial_Ring.prime p"
  shows "finite_field (ZFact (int p))"
proof -
  have p_gt_0: "p > 0" using assms(1) prime_gt_0_nat by simp
  have "Factorial_Ring.prime (int p)"
    using assms by simp
  moreover have "finite (carrier (ZFact (int p)))"
    using fin_zfact[OF p_gt_0] by simp
  ultimately show ?thesis
    by (intro finite_domains_are_fields ZFact_prime_is_domain, auto)
qed

definition int_embed :: "_ \<Rightarrow> int \<Rightarrow> _"  where
  "int_embed R k = add_pow R k \<one>\<^bsub>R\<^esub>"

lemma (in ring) add_pow_consistent:
  fixes i :: "int"
  assumes "subring K R"
  assumes "k \<in> K"
  shows "add_pow R i k = add_pow (R \<lparr> carrier := K \<rparr>) i k"
    (is "?lhs = ?rhs")
proof -
  have a:"subgroup K (add_monoid R)"
    using assms(1) subring.axioms by auto
  have "add_pow R i k = k [^]\<^bsub>add_monoid R\<lparr>carrier := K\<rparr>\<^esub> i"
    using add.int_pow_consistent[OF a assms(2)] by simp
  also have "... = ?rhs"
    unfolding add_pow_def by simp
  finally show ?thesis by simp
qed

lemma (in ring) int_embed_consistent:
  assumes "subring K R"
  shows "int_embed R i = int_embed (R \<lparr> carrier := K \<rparr>) i"
proof -
  have a:"\<one> = \<one>\<^bsub>R \<lparr> carrier := K \<rparr>\<^esub>" by simp
  have b:"\<one>\<^bsub>R\<lparr>carrier := K\<rparr>\<^esub> \<in> K"
    using assms subringE(3) by auto
  show ?thesis
    unfolding int_embed_def a using b add_pow_consistent[OF assms(1)] by simp
qed

lemma (in ring) int_embed_closed:
  "int_embed R k \<in> carrier R"
  unfolding int_embed_def using add.int_pow_closed by simp

lemma (in ring) int_embed_range:
  assumes "subring K R"
  shows "int_embed R k \<in> K"
proof -
  let ?R' =  "R \<lparr> carrier := K \<rparr>"
  interpret x:ring ?R'
    using subring_is_ring[OF assms] by simp
  have "int_embed R k = int_embed ?R' k"
    using int_embed_consistent[OF assms] by simp
  also have "...  \<in> K"
    using x.int_embed_closed by simp
  finally show ?thesis by simp
qed

lemma (in ring) int_embed_zero:
  "int_embed R 0 = \<zero>\<^bsub>R\<^esub>"
  by (simp add:int_embed_def add_pow_def)

lemma (in ring) int_embed_one:
  "int_embed R 1 = \<one>\<^bsub>R\<^esub>"
  by (simp add:int_embed_def)

lemma (in ring) int_embed_add:
  "int_embed R (x+y) = int_embed R x \<oplus>\<^bsub>R\<^esub> int_embed R y"
  by (simp add:int_embed_def add.int_pow_mult)

lemma (in ring) int_embed_inv:
  "int_embed R (-x) = \<ominus>\<^bsub>R\<^esub> int_embed R x" (is "?lhs = ?rhs")
proof -
  have "?lhs = int_embed R (-x) \<oplus> (int_embed R x \<ominus> int_embed R x)"
    using int_embed_closed by simp
  also have
    "... = int_embed R (-x) \<oplus> int_embed R x \<oplus> (\<ominus> int_embed R x)"
    using int_embed_closed by (subst a_minus_def, subst a_assoc, auto)
  also have "... = int_embed R (-x +x) \<oplus> (\<ominus> int_embed R x)"
    by (subst int_embed_add, simp)
  also have "... = ?rhs"
    using int_embed_closed
    by (simp add:int_embed_zero)
  finally show ?thesis by simp
qed

lemma (in ring) int_embed_diff:
  "int_embed R (x-y) = int_embed R x \<ominus>\<^bsub>R\<^esub> int_embed R y"
  (is "?lhs = ?rhs")
proof -
  have "?lhs = int_embed R (x + (-y))"  by simp
  also have "... = ?rhs"
    by (subst int_embed_add, simp add:a_minus_def int_embed_inv)
  finally show ?thesis by simp
qed

lemma (in ring) int_embed_mult_aux:
  "int_embed R (x*int y) = int_embed R x \<otimes> int_embed R y"
proof (induction y)
  case 0
  then show ?case by (simp add:int_embed_closed int_embed_zero)
next
  case (Suc y)
  have "int_embed R (x * int (Suc y)) = int_embed R (x + x * int y)"
    by (simp add:algebra_simps)
  also have "... = int_embed R x \<oplus> int_embed R (x * int y)"
    by (subst int_embed_add, simp)
  also have
    "... = int_embed R x \<otimes> \<one> \<oplus> int_embed R x \<otimes> int_embed R y"
    using int_embed_closed
    by (subst Suc, simp)
  also have "... = int_embed R x \<otimes> (int_embed R 1 \<oplus> int_embed R y)"
    using int_embed_closed by (subst r_distr, simp_all add:int_embed_one)
  also have "... = int_embed R x \<otimes> int_embed R (1+int y)"
    by (subst int_embed_add, simp)
  also have "... = int_embed R x \<otimes> int_embed R (Suc y)"
    by simp
  finally show ?case by simp
qed

lemma (in ring) int_embed_mult:
  "int_embed R (x*y) = int_embed R x \<otimes>\<^bsub>R\<^esub> int_embed R y"
proof (cases "y \<ge> 0")
  case True
  then obtain y' where y_def: "y = int y'"
    using nonneg_int_cases by auto
  have "int_embed R (x * y) = int_embed R (x * int y')"
    unfolding y_def by simp
  also have "... = int_embed R x \<otimes> int_embed R y'"
    by (subst int_embed_mult_aux, simp)
  also have "... = int_embed R x \<otimes> int_embed R y"
    unfolding y_def by simp
  finally show ?thesis by simp
next
  case False
  then obtain y' where y_def: "y = - int y'"
    by (meson nle_le nonpos_int_cases)
  have "int_embed R (x * y) = int_embed R (-(x * int y'))"
    unfolding y_def by simp
  also have "... = \<ominus> (int_embed R (x * int y'))"
    by (subst int_embed_inv, simp)
  also have "... = \<ominus> (int_embed R x \<otimes> int_embed R y')"
    by (subst int_embed_mult_aux, simp)
  also have "... = int_embed R x \<otimes> \<ominus> int_embed R y'"
    using int_embed_closed by algebra
  also have "... = int_embed R x \<otimes> int_embed R (-y')"
    by (subst int_embed_inv, simp)
  also have "... = int_embed R x \<otimes> int_embed R y"
    unfolding y_def by simp
  finally show ?thesis by simp
qed

lemma (in ring) int_embed_ring_hom:
  "ring_hom_ring int_ring R (int_embed R)"
proof (rule ring_hom_ringI)
  show "ring int_ring" using int.ring_axioms by simp
  show "ring R" using ring_axioms by simp
  show "int_embed R x \<in> carrier R" if "x \<in> carrier \<Z>" for x
    using int_embed_closed by simp
  show "int_embed R (x\<otimes>\<^bsub>\<Z>\<^esub>y) = int_embed R x \<otimes> int_embed R y"
    if "x \<in> carrier \<Z>" "y \<in> carrier \<Z>" for x y
    using int_embed_mult by simp
  show "int_embed R (x\<oplus>\<^bsub>\<Z>\<^esub>y) = int_embed R x \<oplus> int_embed R y"
    if "x \<in> carrier \<Z>" "y \<in> carrier \<Z>" for x y
    using int_embed_add by simp
  show "int_embed R \<one>\<^bsub>\<Z>\<^esub> = \<one>"
    by (simp add:int_embed_one)
qed

abbreviation char_subring where
  "char_subring R \<equiv> int_embed R ` UNIV"

definition char where
  "char R = card (char_subring R)"

text \<open>This is a non-standard definition for the characteristic of a ring.

Commonly~\<^cite>\<open>\<open>Definition 1.43\<close> in "lidl1986"\<close> it is defined to be the smallest natural number $n$ such
that n-times repeated addition of any number is zero. If no such number exists then it is defined
to be $0$. In the case of rings with unit elements --- not that the locale @{locale "ring"} requires
unit elements --- the above definition can be simplified to the number of times the unit elements
needs to be repeatedly added to reach $0$.

The following three lemmas imply that the definition of the characteristic here coincides with the
latter definition.\<close>

lemma (in ring) char_bound:
  assumes "x > 0"
  assumes "int_embed R (int x) = \<zero>"
  shows "char R \<le> x" "char R > 0"
proof -
  have "char_subring R \<subseteq> int_embed R ` ({0..<int x})"
  proof (rule image_subsetI)
    fix y :: int
    assume "y \<in> UNIV"
    define u where "u = y div (int x)"
    define v where "v = y mod (int x)"
    have "int x > 0" using assms by simp
    hence y_exp: "y = u * int x + v" "v \<ge> 0" "v < int x"
      unfolding u_def v_def by simp_all
    have "int_embed R y = int_embed R v"
      using int_embed_closed unfolding y_exp
      by (simp add:int_embed_mult int_embed_add assms(2))
    also have "... \<in> int_embed R ` ({0..<int x})"
      using y_exp(2,3) by simp
    finally show "int_embed R y \<in> int_embed R ` {0..<int x}"
      by simp
  qed
  hence a:"char_subring R = int_embed R ` {0..<int x}"
    by auto
  hence "char R = card (int_embed R ` ({0..<int x}))"
    unfolding char_def a by simp
  also have "... \<le> card {0..<int x}"
    by (intro card_image_le, simp)
  also have "... = x" by simp
  finally show "char R \<le> x" by simp
  have "1 = card {int_embed R 0}" by simp
  also have "... \<le> card (int_embed R ` {0..<int x})"
    using assms(1) by (intro card_mono finite_imageI, simp_all)
  also have "... = char R"
    unfolding char_def a by simp
  finally show "char R > 0" by simp
qed

lemma (in ring) embed_char_eq_0:
  "int_embed R (int (char R)) = \<zero>"
proof (cases "finite (char_subring R)")
  case True
  interpret h: ring_hom_ring "int_ring" R "(int_embed R)"
    using int_embed_ring_hom by simp

  define A where "A = {0..int (char R)}"
  have "card (int_embed R ` A) \<le> card (char_subring R)"
    by (intro card_mono[OF True] image_subsetI, simp)
  also have "... = char R"
    unfolding char_def by simp
  also have "... < card A"
    unfolding A_def by simp
  finally have "card (int_embed R ` A) < card A" by simp
  hence "\<not>inj_on (int_embed R) A"
    using pigeonhole by simp
  then obtain x y where xy:
    "x \<in> A" "y \<in> A" "x \<noteq> y" "int_embed R x = int_embed R y"
    unfolding inj_on_def by auto
  define v where "v = nat (max x y - min x y)"
  have a:"int_embed R v = \<zero>"
    using xy int_embed_closed
    by (cases "x < y", simp_all add:int_embed_diff v_def)
  moreover have "v > 0"
    using xy by (cases "x < y", simp_all add:v_def)
  ultimately have "char R \<le> v" using char_bound by simp
  moreover have "v \<le> char R"
    using xy v_def A_def by (cases "x < y", simp_all)
  ultimately have "char R = v" by simp
  then show ?thesis using a by simp
next
  case False
  hence "char R = 0"
    unfolding char_def by simp
  then show ?thesis by (simp add:int_embed_zero)
qed

lemma (in ring) embed_char_eq_0_iff:
  fixes n :: int
  shows "int_embed R n = \<zero> \<longleftrightarrow> char R dvd n"
proof (cases "char R > 0")
  case True
  define r where "r = n mod char R"
  define s where "s = n div char R"
  have rs: "r < char R" "r \<ge> 0" "n = r + s * char R"
    using True by (simp_all add:r_def s_def)

  have "int_embed R n = int_embed R r"
    using int_embed_closed unfolding rs(3)
    by (simp add: int_embed_add  int_embed_mult embed_char_eq_0)

  moreover have "nat r < char R" using rs by simp
  hence "int_embed R (nat r) \<noteq> \<zero> \<or> nat r = 0"
    using True char_bound not_less by blast
  hence "int_embed R r \<noteq> \<zero> \<or> r = 0"
    using rs by simp

  ultimately have "int_embed R n = \<zero> \<longleftrightarrow> r = 0"
    using int_embed_zero by auto
  also have "r = 0 \<longleftrightarrow> char R dvd n"
    using r_def by auto
  finally show ?thesis by simp
next
  case False
  hence "char R = 0" by simp
  hence a:"x > 0 \<Longrightarrow> int_embed R (int x) \<noteq> \<zero>" for x
    using char_bound by auto

  have c:"int_embed R (abs x) \<noteq> \<zero> \<longleftrightarrow> int_embed R x \<noteq> \<zero>" for x
    using int_embed_closed
    by (cases "x > 0", simp, simp add:int_embed_inv)

  have "int_embed R x \<noteq> \<zero>" if b:"x \<noteq> 0" for x
  proof -
    have "nat (abs x) > 0" using b by simp
    hence "int_embed R (nat (abs x)) \<noteq> \<zero>"
      using a by blast
    hence "int_embed R (abs x) \<noteq> \<zero>" by simp
    thus ?thesis using c by simp
  qed
  hence "int_embed R n = \<zero> \<longleftrightarrow> n = 0"
    using int_embed_zero by auto
  also have "n = 0 \<longleftrightarrow> char R dvd n" using False by simp
  finally show ?thesis by simp
qed

text \<open>This result can be found in \<^cite>\<open>\<open>Theorem 1.44\<close> in "lidl1986"\<close>.\<close>

lemma (in domain) characteristic_is_prime:
  assumes "char R > 0"
  shows "prime (char R)"
proof (rule ccontr)
  have "\<not>(char R = 1)"
    using embed_char_eq_0 int_embed_one by auto
  hence "\<not>(char R dvd 1)" using assms(1) by simp
  moreover assume "\<not>(prime (char R))"
  hence "\<not>(irreducible (char R))"
    using irreducible_imp_prime_elem_gcd prime_elem_nat_iff by blast
  ultimately obtain p q where pq_def: "p * q = char R" "p > 1" "q > 1"
    using assms
    unfolding Factorial_Ring.irreducible_def by auto
  have "int_embed R p \<otimes> int_embed R q = \<zero>"
    using embed_char_eq_0 pq_def
    by (subst int_embed_mult[symmetric]) (metis of_nat_mult)
  hence "int_embed R p = \<zero> \<or> int_embed R q = \<zero>"
    using integral int_embed_closed by simp
  hence "p*q \<le> p \<or> p*q \<le> q"
    using char_bound pq_def by auto
  thus "False"
    using pq_def(2,3) by simp
qed

lemma (in ring) char_ring_is_subring:
  "subring (char_subring R) R"
proof -
  have "subring (int_embed R ` carrier int_ring) R"
    by (intro ring.carrier_is_subring int.ring_axioms
        ring_hom_ring.img_is_subring[OF int_embed_ring_hom])
  thus ?thesis by simp
qed

lemma (in cring) char_ring_is_subcring:
  "subcring (char_subring R) R"
  using subcringI'[OF char_ring_is_subring] by auto

lemma (in domain) char_ring_is_subdomain:
  "subdomain (char_subring R) R"
  using subdomainI'[OF char_ring_is_subring] by auto

lemma image_set_eqI:
  assumes "\<And>x. x \<in> A \<Longrightarrow> f x \<in> B"
  assumes "\<And>x. x \<in> B \<Longrightarrow> g x \<in> A \<and> f (g x) = x"
  shows  "f ` A = B"
  using assms by force

text \<open>This is the binomial expansion theorem for commutative rings.\<close>

lemma (in cring) binomial_expansion:
  fixes n :: nat
  assumes [simp]: "x \<in> carrier R" "y \<in> carrier R"
  shows "(x \<oplus> y) [^] n =
    (\<Oplus>k \<in> {..n}. int_embed R (n choose k) \<otimes> x [^] k \<otimes> y [^] (n-k))"
proof -
  define A where "A = (\<lambda>k. {A. A \<subseteq> {..<n} \<and> card A = k})"

  have fin_A: "finite (A i)" for i
    unfolding A_def by simp
  have disj_A: "pairwise (\<lambda>i j. disjnt (A i) (A j)) {..n}"
    unfolding pairwise_def disjnt_def A_def by auto
  have card_A: "B \<in> A i \<Longrightarrow> card B = i" if " i \<in> {..n}" for i B
    unfolding A_def by simp
  have card_A2: "card (A i) = (n choose i)" if "i \<in> {..n}" for i
    unfolding A_def using n_subsets[where A="{..<n}"] by simp

  have card_bound: "card A \<le> n"
    if "A \<subseteq> {..<n}" for n A
    by (metis card_lessThan finite_lessThan card_mono that)
  have card_insert: "card (insert n A) = card A + 1"
    if "A \<subseteq> {..<(n::nat)}" for n A
    using finite_subset that by (subst card_insert_disjoint, auto)

  have embed_distr: "[m] \<cdot> y = int_embed R (int m) \<otimes> y"
    if "y \<in> carrier R" for m y
    unfolding int_embed_def add_pow_def using that
    by (simp add:add_pow_def[symmetric] int_pow_int add_pow_ldistr)

  have "(x \<oplus> y) [^] n =
    (\<Oplus>A \<in> Pow {..<n}. x [^] (card A) \<otimes> y [^] (n-card A))"
  proof (induction n)
    case 0
    then show ?case by simp
  next
    case (Suc n)
    have s1:
      "insert n ` Pow {..<n} = {A. A \<subseteq> {..<n+1} \<and> n \<in> A}"
      by (intro image_set_eqI[where g="\<lambda>x. x \<inter> {..<n}"], auto)
    have s2:
      "Pow {..<n} = {A. A \<subseteq> {..<n+1} \<and> n \<notin> A}"
      using lessThan_Suc by auto

    have "(x \<oplus> y) [^] Suc n = (x \<oplus> y) [^] n \<otimes> (x \<oplus> y)" by simp
    also have "... =
      (\<Oplus>A \<in> Pow {..<n}. x [^] (card A) \<otimes> y [^] (n-card A)) \<otimes>
      (x \<oplus> y)"
      by (subst Suc, simp)
    also have "... =
      (\<Oplus>A \<in> Pow {..<n}. x [^] (card A) \<otimes> y [^] (n-card A)) \<otimes> x \<oplus>
      (\<Oplus>A \<in> Pow {..<n}. x [^] (card A) \<otimes> y [^] (n-card A)) \<otimes> y"
      by (subst r_distr, auto)
    also have "... =
      (\<Oplus>A \<in> Pow {..<n}. x [^] (card A) \<otimes> y [^] (n-card A) \<otimes> x) \<oplus>
      (\<Oplus>A \<in> Pow {..<n}. x [^] (card A) \<otimes> y [^] (n-card A) \<otimes> y)"
      by (simp add:finsum_ldistr)
    also have "... =
      (\<Oplus>A \<in> Pow {..<n}. x [^] (card A+1) \<otimes> y [^] (n-card A)) \<oplus>
      (\<Oplus>A \<in> Pow {..<n}. x [^] (card A) \<otimes> y [^] (n-card A+1))"
      using m_assoc m_comm
      by (intro arg_cong2[where f="(\<oplus>)"] finsum_cong', auto)
    also have "... =
      (\<Oplus>A \<in> Pow {..<n}. x [^] (card (insert n A))
        \<otimes> y [^] (n+1-card (insert n A))) \<oplus>
      (\<Oplus>A \<in> Pow {..<n}. x [^] (card A) \<otimes> y [^] (n+1-card A))"
      using finite_subset card_bound card_insert Suc_diff_le
      by (intro arg_cong2[where f="(\<oplus>)"] finsum_cong', simp_all)
    also have "... =
      (\<Oplus>A \<in> insert n ` Pow {..<n}. x [^] (card A)
        \<otimes> y [^] (n+1-card A)) \<oplus>
      (\<Oplus>A \<in> Pow {..<n}. x [^] (card A) \<otimes> y [^] (n+1-card A))"
      by (subst finsum_reindex, auto simp add:inj_on_def)
    also have "... =
      (\<Oplus>A \<in> {A. A \<subseteq> {..<n+1} \<and> n \<in> A}.
        x [^] (card A) \<otimes> y [^] (n+1-card A)) \<oplus>
      (\<Oplus>A \<in> {A. A \<subseteq> {..<n+1} \<and> n \<notin> A}.
        x [^] (card A) \<otimes> y [^] (n+1-card A))"
      by (intro arg_cong2[where f="(\<oplus>)"] finsum_cong' s1 s2, simp_all)
    also have "... = (\<Oplus>A \<in>
      {A. A \<subseteq> {..<n+1} \<and> n \<in> A} \<union> {A. A \<subseteq> {..<n+1} \<and> n \<notin> A}.
        x [^] (card A) \<otimes> y [^] (n+1-card A))"
      by (subst finsum_Un_disjoint, auto)
    also have "... =
      (\<Oplus>A \<in> Pow {..<n+1}. x [^] (card A) \<otimes> y [^] (n+1-card A))"
      by (intro finsum_cong', auto)
    finally show ?case by simp
  qed
  also have "... =
    (\<Oplus>A \<in> (\<Union> (A ` {..n})). x [^] (card A) \<otimes> y [^] (n-card A))"
    using card_bound by (intro finsum_cong', auto simp add:A_def)
  also have "... =
    (\<Oplus> k \<in> {..n}. (\<Oplus> A \<in> A k. x [^] (card A) \<otimes> y [^] (n-card A)))"
    using fin_A disj_A by (subst add.finprod_UN_disjoint, auto)
  also have "... = (\<Oplus> k \<in> {..n}. (\<Oplus> A \<in> A k. x [^] k \<otimes> y [^] (n-k)))"
    using card_A by (intro finsum_cong', auto)
  also have "... =
    (\<Oplus> k \<in> {..n}. int_embed R (card (A k)) \<otimes> x [^] k \<otimes> y [^] (n-k))"
    using int_embed_closed
    by (subst add.finprod_const, simp_all add:embed_distr m_assoc)
  also have "... =
    (\<Oplus> k \<in> {..n}. int_embed R (n choose k) \<otimes> x [^] k \<otimes> y [^] (n-k))"
    using int_embed_closed card_A2 by (intro finsum_cong', simp_all)
  finally show ?thesis by simp
qed

lemma bin_prime_factor:
  assumes "prime p"
  assumes "k > 0" "k < p"
  shows "p dvd (p choose k)"
proof -
  have "p dvd fact p"
    using assms(1) prime_dvd_fact_iff by auto
  hence "p dvd fact k * fact (p - k) * (p choose k)"
    using binomial_fact_lemma assms by simp
  hence "p dvd fact k \<or> p dvd fact (p-k) \<or> p dvd (p choose k)"
    by (simp add: assms(1) prime_dvd_mult_eq_nat)
  thus "p dvd (p choose k)"
    using assms(1,2,3) prime_dvd_fact_iff by auto
qed

theorem (in domain) freshmans_dream:
  assumes "char R > 0"
  assumes [simp]: "x \<in> carrier R" "y \<in> carrier R"
  shows "(x \<oplus> y) [^] (char R) = x [^] char R \<oplus> y [^] char R"
    (is "?lhs = ?rhs")
proof -
  have c:"prime (char R)"
    using assms(1) characteristic_is_prime by auto
  have a:"int_embed R (char R choose i) = \<zero>"
    if "i \<in> {..char R} - {0, char R}" for i
  proof -
    have "i > 0" "i < char R" using that by auto
    hence "char R dvd char R choose i"
      using c bin_prime_factor by simp
    thus ?thesis using embed_char_eq_0_iff by simp
  qed

  have "?lhs = (\<Oplus>k \<in> {..char R}. int_embed R (char R choose k)
    \<otimes> x [^] k \<otimes> y [^] (char R-k))"
    using binomial_expansion[OF assms(2,3)] by simp
  also have "... = (\<Oplus>k \<in> {0,char R}.int_embed R (char R choose k)
    \<otimes> x [^] k \<otimes> y [^] (char R-k))"
    using a int_embed_closed
    by (intro add.finprod_mono_neutral_cong_right, simp, simp_all)
  also have "... = ?rhs"
    using int_embed_closed assms(1) by (simp add:int_embed_one a_comm)
  finally show ?thesis by simp
qed

text \<open>The following theorem is somtimes called Freshman's dream for obvious reasons,
it can be found in Lidl and Niederreiter~\<^cite>\<open>\<open>Theorem 1.46\<close> in "lidl1986"\<close>.\<close>

lemma (in domain) freshmans_dream_ext:
  fixes m
  assumes "char R > 0"
  assumes [simp]: "x \<in> carrier R" "y \<in> carrier R"
  defines "n \<equiv> char R^m"
  shows "(x \<oplus> y) [^] n = x [^] n \<oplus> y [^] n"
    (is "?lhs = ?rhs")
  unfolding n_def
proof (induction m)
  case 0
  then show ?case by simp
next
  case (Suc m)
  have "(x \<oplus> y) [^] (char R^(m+1)) =
    (x \<oplus> y) [^] (char R^m * char R)"
    by (simp add:mult.commute)
  also have "... = ((x \<oplus> y) [^] (char R^m)) [^] char R"
    using nat_pow_pow by simp
  also have "... = (x [^] (char R^m) \<oplus> y [^] (char R^m)) [^] char R"
    by (subst Suc, simp)
  also have "... =
    (x [^] (char R^m)) [^] char R \<oplus> (y [^] (char R^m)) [^] char R"
    by (subst freshmans_dream[OF assms(1), symmetric], simp_all)
  also have "... =
    x [^] (char R^m * char R) \<oplus> y [^] (char R^m * char R)"
    by (simp add:nat_pow_pow)
  also have "... = x [^] (char R^Suc m) \<oplus> y [^] (char R^Suc m)"
    by (simp add:mult.commute)
  finally show ?case by simp
qed

text \<open>The following is a generalized version of the Frobenius homomorphism. The classic version
of the theorem is the case where @{term "(k::nat) = 1"}.\<close>

theorem (in domain) frobenius_hom:
  assumes "char R  > 0"
  assumes "m = char R ^ k"
  shows "ring_hom_cring R R (\<lambda>x. x [^] m)"
proof -
  have a:"(x \<otimes> y) [^] m = x [^] m \<otimes> y [^] m"
    if b:"x \<in> carrier R" "y \<in> carrier R" for x y
    using b nat_pow_distrib by simp
  have b:"(x \<oplus> y) [^] m = x [^] m \<oplus> y [^] m"
    if b:"x \<in> carrier R" "y \<in> carrier R" for x y
    unfolding assms(2) freshmans_dream_ext[OF assms(1) b]
    by simp

  have "ring_hom_ring R R (\<lambda>x. x [^] m)"
    by  (intro ring_hom_ringI a b ring_axioms, simp_all)

  thus "?thesis"
    using RingHom.ring_hom_cringI is_cring by blast
qed

lemma (in domain) char_ring_is_subfield:
  assumes "char R > 0"
  shows "subfield (char_subring R) R"
proof -
  interpret d:domain "R \<lparr> carrier := char_subring R \<rparr>"
    using char_ring_is_subdomain subdomain_is_domain by simp

  have "finite (char_subring R)"
    using char_def assms by (metis card_ge_0_finite)
  hence "Units (R \<lparr> carrier := char_subring R \<rparr>)
    = char_subring R - {\<zero>}"
    using d.finite_domain_units by simp

  thus ?thesis
    using subfieldI[OF char_ring_is_subcring] by simp
qed

lemma card_lists_length_eq':
  fixes A :: "'a set"
  shows "card {xs. set xs \<subseteq> A \<and> length xs = n} = card A ^ n"
proof (cases "finite A")
  case True
  then show ?thesis using card_lists_length_eq by auto
next
  case False
  hence inf_A: "infinite A" by simp
  show ?thesis
  proof (cases "n = 0")
    case True
    hence "card {xs. set xs \<subseteq> A \<and> length xs = n} = card {([] :: 'a list)}"
      by (intro arg_cong[where f="card"], auto simp add:set_eq_iff)
    also have "... = 1" by simp
    also have "... = card A^n" using True inf_A by simp
    finally show ?thesis by simp
  next
    case False
    hence "inj (replicate n)"
      by (meson inj_onI replicate_eq_replicate)
    hence "inj_on (replicate n) A" using inj_on_subset
      by (metis subset_UNIV)
    hence "infinite (replicate n ` A)"
      using inf_A finite_image_iff by auto
    moreover have
      "replicate n ` A \<subseteq> {xs. set xs \<subseteq> A \<and> length xs  = n}"
      by (intro image_subsetI, auto)
    ultimately have "infinite {xs. set xs \<subseteq> A \<and> length xs  = n}"
      using infinite_super by auto
    hence "card {xs. set xs \<subseteq> A \<and> length xs  = n} = 0" by simp
    then show ?thesis using inf_A False by simp
  qed
qed

lemma (in ring) card_span:
  assumes "subfield K R"
  assumes "independent K w"
  assumes "set w \<subseteq> carrier R"
  shows "card (Span K w) = card K^(length w)"
proof -
  define A where "A = {x. set x \<subseteq> K \<and> length x = length w}"
  define f where "f = (\<lambda>x. combine x w)"

  have "x \<in> f ` A" if a:"x \<in> Span K w" for x
  proof -
    obtain y where "y \<in> A" "x = f y"
      unfolding A_def f_def
      using unique_decomposition[OF assms(1,2) a] by auto
    thus ?thesis by simp
  qed
  moreover have "f x \<in> Span K w" if a: "x \<in> A" for x
    using Span_eq_combine_set[OF assms(1,3)] a
    unfolding A_def f_def by auto
  ultimately have b:"Span K w = f ` A" by auto

  have "False" if a: "x \<in> A" "y \<in> A" "f x = f y" "x \<noteq> y" for x y
  proof -
    have "f x \<in> Span K w" using b a by simp
    thus "False"
      using a unique_decomposition[OF assms(1,2)]
      unfolding f_def A_def by blast
  qed
  hence f_inj: "inj_on f A"
    unfolding inj_on_def by auto

  have "card (Span K w) = card (f ` A)" using b by simp
  also have "... = card A" by (intro card_image f_inj)
  also have "... = card K^length w"
    unfolding A_def by (intro card_lists_length_eq')
  finally show ?thesis by simp
qed

lemma (in ring) finite_carr_imp_char_ge_0:
  assumes "finite (carrier R)"
  shows "char R > 0"
proof -
  have "char_subring R \<subseteq> carrier R"
    using int_embed_closed by auto
  hence "finite (char_subring R)"
    using finite_subset assms by auto
  hence "card (char_subring R) > 0"
    using card_range_greater_zero by simp
  thus "char R > 0"
    unfolding char_def by simp
qed

lemma (in ring) char_consistent:
  assumes "subring H R"
  shows "char (R \<lparr> carrier := H \<rparr>) = char R"
proof -
  show ?thesis
    using int_embed_consistent[OF assms(1)]
    unfolding char_def by simp
qed

lemma (in ring_hom_ring) char_consistent:
  assumes "inj_on h (carrier R)"
  shows "char R = char S"
proof -
  have a:"h (int_embed R (int n)) = int_embed S (int n)" for n
    using R.int_embed_range[OF R.carrier_is_subring]
    using R.int_embed_range[OF R.carrier_is_subring]
    using S.int_embed_one R.int_embed_one
    using S.int_embed_zero R.int_embed_zero
    using S.int_embed_add R.int_embed_add
    by (induction n, simp_all)

  have b:"h (int_embed R (-(int n))) = int_embed S (-(int n))" for n
    using R.int_embed_range[OF R.carrier_is_subring]
    using S.int_embed_range[OF S.carrier_is_subring] a
    by (simp add:R.int_embed_inv S.int_embed_inv)

  have c:"h (int_embed R n) = int_embed S n" for n
  proof (cases "n \<ge> 0")
    case True
    then obtain m where "n = int m"
      using nonneg_int_cases by auto
    then show ?thesis
      by (simp add:a)
  next
    case False
    hence "n \<le> 0" by simp
    then obtain m where "n = -int m"
      using nonpos_int_cases by auto
    then show ?thesis by (simp add:b)
  qed

  have "char S = card (h ` char_subring R)"
    unfolding char_def image_image c by simp
  also have "... = card (char_subring R)"
    using R.int_embed_range[OF R.carrier_is_subring]
    by (intro card_image inj_on_subset[OF assms(1)]) auto
  also have "... = char R" unfolding char_def by simp
  finally show ?thesis
    by simp
qed

definition char_iso :: "_ \<Rightarrow> int set \<Rightarrow> 'a"
  where "char_iso R x = the_elem (int_embed R ` x)"

text \<open>The function @{term "char_iso R"} denotes the isomorphism between @{term "ZFact (char R)"} and
the characteristic subring.\<close>

lemma (in ring) char_iso: "char_iso R \<in>
  ring_iso (ZFact (char R)) (R\<lparr>carrier := char_subring R\<rparr>)"
proof -
  interpret h: ring_hom_ring "int_ring" "R" "int_embed R"
    using int_embed_ring_hom by simp

  have "a_kernel \<Z> R (int_embed R) = {x. int_embed R x = \<zero>}"
    unfolding a_kernel_def kernel_def by simp
  also have "... = {x. char R dvd x}"
    using embed_char_eq_0_iff by simp
  also have "... = PIdl\<^bsub>\<Z>\<^esub> (int (char R))"
    unfolding cgenideal_def by auto
  also have "... = Idl\<^bsub>\<Z>\<^esub> {int (char R)}"
    using int.cgenideal_eq_genideal by simp
  finally have a:"a_kernel \<Z> R (int_embed R) = Idl\<^bsub>\<Z>\<^esub> {int (char R)}"
    by simp
  show  "?thesis"
    unfolding char_iso_def ZFact_def a[symmetric]
    by (intro h.FactRing_iso_set_aux)
qed

text \<open>The size of a finite field must be a prime power.
This can be found in Ireland and Rosen~\<^cite>\<open>\<open>Proposition 7.1.3\<close> in "ireland1982"\<close>.\<close>

theorem (in finite_field) finite_field_order:
  "\<exists>n. order R = char R ^ n \<and> n > 0"
proof -
  have a:"char R > 0"
    using finite_carr_imp_char_ge_0[OF finite_carrier]
    by simp
  let ?CR = "char_subring R"

  obtain v where v_def: "set v = carrier R"
    using finite_carrier finite_list by auto
  hence b:"set v \<subseteq> carrier R" by auto

  have "carrier R = set v" using v_def by simp
  also have "... \<subseteq> Span ?CR v"
    using Span_base_incl[OF char_ring_is_subfield[OF a] b] by simp
  finally have "carrier R \<subseteq> Span ?CR v" by simp
  moreover have "Span ?CR v \<subseteq> carrier R"
    using int_embed_closed v_def by (intro Span_in_carrier, auto)
  ultimately have Span_v: "Span ?CR v = carrier R" by simp

  obtain w where w_def:
    "set w \<subseteq> carrier R"
    "independent ?CR w"
    "Span ?CR v = Span ?CR w"
    using b filter_base[OF char_ring_is_subfield[OF a]]
    by metis

  have Span_w: "Span ?CR w = carrier R"
    using w_def(3) Span_v by simp

  hence "order R = card (Span ?CR w)" by (simp add:order_def)
  also have "... = card ?CR^length w"
    by (intro card_span char_ring_is_subfield[OF a] w_def(1,2))
  finally have c:
    "order R = char R^(length w)"
    by (simp add:char_def)
  have "length w > 0"
    using finite_field_min_order c by auto
  thus ?thesis using c by auto
qed

end


(* Author: Gerwin Klein, Tobias Nipkow *)

subsection "Big-Step Semantics of Commands"

theory Big_Step imports Com begin

text \<open>
The big-step semantics is a straight-forward inductive definition
with concrete syntax. Note that the first parameter is a tuple,
so the syntax becomes \<open>(c,s) \<Rightarrow> s'\<close>.
\<close>

text_raw\<open>\snip{BigStepdef}{0}{1}{%\<close>
inductive
  big_step :: "com \<times> state \<Rightarrow> state \<Rightarrow> bool" (infix "\<Rightarrow>" 55)
where
Skip: "(SKIP,s) \<Rightarrow> s" |
Assign: "(x ::= a,s) \<Rightarrow> s(x := aval a s)" |
Seq: "\<lbrakk> (c\<^sub>1,s\<^sub>1) \<Rightarrow> s\<^sub>2;  (c\<^sub>2,s\<^sub>2) \<Rightarrow> s\<^sub>3 \<rbrakk> \<Longrightarrow> (c\<^sub>1;;c\<^sub>2, s\<^sub>1) \<Rightarrow> s\<^sub>3" |
IfTrue: "\<lbrakk> bval b s;  (c\<^sub>1,s) \<Rightarrow> t \<rbrakk> \<Longrightarrow> (IF b THEN c\<^sub>1 ELSE c\<^sub>2, s) \<Rightarrow> t" |
IfFalse: "\<lbrakk> \<not>bval b s;  (c\<^sub>2,s) \<Rightarrow> t \<rbrakk> \<Longrightarrow> (IF b THEN c\<^sub>1 ELSE c\<^sub>2, s) \<Rightarrow> t" |
WhileFalse: "\<not>bval b s \<Longrightarrow> (WHILE b DO c,s) \<Rightarrow> s" |
WhileTrue:
"\<lbrakk> bval b s\<^sub>1;  (c,s\<^sub>1) \<Rightarrow> s\<^sub>2;  (WHILE b DO c, s\<^sub>2) \<Rightarrow> s\<^sub>3 \<rbrakk>
\<Longrightarrow> (WHILE b DO c, s\<^sub>1) \<Rightarrow> s\<^sub>3"
text_raw\<open>}%endsnip\<close>

text_raw\<open>\snip{BigStepEx}{1}{2}{%\<close>
schematic_goal ex: "(''x'' ::= N 5;; ''y'' ::= V ''x'', s) \<Rightarrow> ?t"
apply(rule Seq)
apply(rule Assign)
apply simp
apply(rule Assign)
done
text_raw\<open>}%endsnip\<close>

thm ex[simplified]

text\<open>We want to execute the big-step rules:\<close>

code_pred big_step .

text\<open>For inductive definitions we need command
       \texttt{values} instead of \texttt{value}.\<close>

values "{t. (SKIP, \<lambda>_. 0) \<Rightarrow> t}"

text\<open>We need to translate the result state into a list
to display it.\<close>

values "{map t [''x''] |t. (SKIP, <''x'' := 42>) \<Rightarrow> t}"

values "{map t [''x''] |t. (''x'' ::= N 2, <''x'' := 42>) \<Rightarrow> t}"

values "{map t [''x'',''y''] |t.
  (WHILE Less (V ''x'') (V ''y'') DO (''x'' ::= Plus (V ''x'') (N 5)),
   <''x'' := 0, ''y'' := 13>) \<Rightarrow> t}"

text\<open>Proof automation:\<close>

text \<open>The introduction rules are good for automatically
construction small program executions. The recursive cases
may require backtracking, so we declare the set as unsafe
intro rules.\<close>
declare big_step.intros [intro]

text\<open>The standard induction rule
@{thm [display] big_step.induct [no_vars]}\<close>

thm big_step.induct

text\<open>
This induction schema is almost perfect for our purposes, but
our trick for reusing the tuple syntax means that the induction
schema has two parameters instead of the \<open>c\<close>, \<open>s\<close>,
and \<open>s'\<close> that we are likely to encounter. Splitting
the tuple parameter fixes this:
\<close>
lemmas big_step_induct = big_step.induct[split_format(complete)]
thm big_step_induct
text \<open>
@{thm [display] big_step_induct [no_vars]}
\<close>

subsection "Rule inversion"

text\<open>What can we deduce from \<^prop>\<open>(SKIP,s) \<Rightarrow> t\<close> ?
That \<^prop>\<open>s = t\<close>. This is how we can automatically prove it:\<close>

inductive_cases SkipE[elim!]: "(SKIP,s) \<Rightarrow> t"
thm SkipE

text\<open>This is an \emph{elimination rule}. The [elim] attribute tells auto,
blast and friends (but not simp!) to use it automatically; [elim!] means that
it is applied eagerly.

Similarly for the other commands:\<close>

inductive_cases AssignE[elim!]: "(x ::= a,s) \<Rightarrow> t"
thm AssignE
inductive_cases SeqE[elim!]: "(c1;;c2,s1) \<Rightarrow> s3"
thm SeqE
inductive_cases IfE[elim!]: "(IF b THEN c1 ELSE c2,s) \<Rightarrow> t"
thm IfE

inductive_cases WhileE[elim]: "(WHILE b DO c,s) \<Rightarrow> t"
thm WhileE
text\<open>Only [elim]: [elim!] would not terminate.\<close>

text\<open>An automatic example:\<close>

lemma "(IF b THEN SKIP ELSE SKIP, s) \<Rightarrow> t \<Longrightarrow> t = s"
by blast

text\<open>Rule inversion by hand via the ``cases'' method:\<close>

lemma assumes "(IF b THEN SKIP ELSE SKIP, s) \<Rightarrow> t"
shows "t = s"
proof-
  from assms show ?thesis
  proof cases  \<comment> \<open>inverting assms\<close>
    case IfTrue thm IfTrue
    thus ?thesis by blast
  next
    case IfFalse thus ?thesis by blast
  qed
qed

(* Using rule inversion to prove simplification rules: *)
lemma assign_simp:
  "(x ::= a,s) \<Rightarrow> s' \<longleftrightarrow> (s' = s(x := aval a s))"
  by auto

text \<open>An example combining rule inversion and derivations\<close>
lemma Seq_assoc:
  "(c1;; c2;; c3, s) \<Rightarrow> s' \<longleftrightarrow> (c1;; (c2;; c3), s) \<Rightarrow> s'"
proof
  assume "(c1;; c2;; c3, s) \<Rightarrow> s'"
  then obtain s1 s2 where
    c1: "(c1, s) \<Rightarrow> s1" and
    c2: "(c2, s1) \<Rightarrow> s2" and
    c3: "(c3, s2) \<Rightarrow> s'" by auto
  from c2 c3
  have "(c2;; c3, s1) \<Rightarrow> s'" by (rule Seq)
  with c1
  show "(c1;; (c2;; c3), s) \<Rightarrow> s'" by (rule Seq)
next
  \<comment> \<open>The other direction is analogous\<close>
  assume "(c1;; (c2;; c3), s) \<Rightarrow> s'"
  thus "(c1;; c2;; c3, s) \<Rightarrow> s'" by auto
qed

subsection "Command Equivalence"

text \<open>
  We call two statements \<open>c\<close> and \<open>c'\<close> equivalent wrt.\ the
  big-step semantics when \emph{\<open>c\<close> started in \<open>s\<close> terminates
  in \<open>s'\<close> iff \<open>c'\<close> started in the same \<open>s\<close> also terminates
  in the same \<open>s'\<close>}. Formally:
\<close>
text_raw\<open>\snip{BigStepEquiv}{0}{1}{%\<close>
abbreviation
  equiv_c :: "com \<Rightarrow> com \<Rightarrow> bool" (infix "\<sim>" 50) where
  "c \<sim> c' \<equiv> (\<forall>s t. (c,s) \<Rightarrow> t  =  (c',s) \<Rightarrow> t)"
text_raw\<open>}%endsnip\<close>

text \<open>
Warning: \<open>\<sim>\<close> is the symbol written \verb!\ < s i m >! (without spaces).

  As an example, we show that loop unfolding is an equivalence
  transformation on programs:
\<close>
lemma unfold_while:
  "(WHILE b DO c) \<sim> (IF b THEN c;; WHILE b DO c ELSE SKIP)" (is "?w \<sim> ?iw")
proof -
  \<comment> \<open>to show the equivalence, we look at the derivation tree for\<close>
  \<comment> \<open>each side and from that construct a derivation tree for the other side\<close>
  have "(?iw, s) \<Rightarrow> t" if assm: "(?w, s) \<Rightarrow> t" for s t
  proof -
    from assm show ?thesis
    proof cases \<comment> \<open>rule inversion on \<open>(?w, s) \<Rightarrow> t\<close>\<close>
      case WhileFalse
      thus ?thesis by blast
    next
      case WhileTrue
      from \<open>bval b s\<close> \<open>(?w, s) \<Rightarrow> t\<close> obtain s' where
        "(c, s) \<Rightarrow> s'" and "(?w, s') \<Rightarrow> t" by auto
      \<comment> \<open>now we can build a derivation tree for the \<^text>\<open>IF\<close>\<close>
      \<comment> \<open>first, the body of the True-branch:\<close>
      hence "(c;; ?w, s) \<Rightarrow> t" by (rule Seq)
      \<comment> \<open>then the whole \<^text>\<open>IF\<close>\<close>
      with \<open>bval b s\<close> show ?thesis by (rule IfTrue)
    qed
  qed
  moreover
  \<comment> \<open>now the other direction:\<close>
  have "(?w, s) \<Rightarrow> t" if assm: "(?iw, s) \<Rightarrow> t" for s t
  proof -
    from assm show ?thesis
    proof cases \<comment> \<open>rule inversion on \<open>(?iw, s) \<Rightarrow> t\<close>\<close>
      case IfFalse
      hence "s = t" using \<open>(?iw, s) \<Rightarrow> t\<close> by blast
      thus ?thesis using \<open>\<not>bval b s\<close> by blast
    next
      case IfTrue
      \<comment> \<open>and for this, only the Seq-rule is applicable:\<close>
      from \<open>(c;; ?w, s) \<Rightarrow> t\<close> obtain s' where
        "(c, s) \<Rightarrow> s'" and "(?w, s') \<Rightarrow> t" by auto
      \<comment> \<open>with this information, we can build a derivation tree for \<^text>\<open>WHILE\<close>\<close>
      with \<open>bval b s\<close> show ?thesis by (rule WhileTrue)
    qed
  qed
  ultimately
  show ?thesis by blast
qed

text \<open>Luckily, such lengthy proofs are seldom necessary.  Isabelle can
prove many such facts automatically.\<close>

lemma while_unfold:
  "(WHILE b DO c) \<sim> (IF b THEN c;; WHILE b DO c ELSE SKIP)"
by blast

lemma triv_if:
  "(IF b THEN c ELSE c) \<sim> c"
by blast

lemma commute_if:
  "(IF b1 THEN (IF b2 THEN c11 ELSE c12) ELSE c2)
   \<sim>
   (IF b2 THEN (IF b1 THEN c11 ELSE c2) ELSE (IF b1 THEN c12 ELSE c2))"
by blast

lemma sim_while_cong_aux:
  "(WHILE b DO c,s) \<Rightarrow> t  \<Longrightarrow> c \<sim> c' \<Longrightarrow>  (WHILE b DO c',s) \<Rightarrow> t"
apply(induction "WHILE b DO c" s t arbitrary: b c rule: big_step_induct)
 apply blast
apply blast
done

lemma sim_while_cong: "c \<sim> c' \<Longrightarrow> WHILE b DO c \<sim> WHILE b DO c'"
by (metis sim_while_cong_aux)

text \<open>Command equivalence is an equivalence relation, i.e.\ it is
reflexive, symmetric, and transitive. Because we used an abbreviation
above, Isabelle derives this automatically.\<close>

lemma sim_refl:  "c \<sim> c" by simp
lemma sim_sym:   "(c \<sim> c') = (c' \<sim> c)" by auto
lemma sim_trans: "c \<sim> c' \<Longrightarrow> c' \<sim> c'' \<Longrightarrow> c \<sim> c''" by auto

subsection "Execution is deterministic"

text \<open>This proof is automatic.\<close>

theorem big_step_determ: "\<lbrakk> (c,s) \<Rightarrow> t; (c,s) \<Rightarrow> u \<rbrakk> \<Longrightarrow> u = t"
  by (induction arbitrary: u rule: big_step.induct) blast+

text \<open>
  This is the proof as you might present it in a lecture. The remaining
  cases are simple enough to be proved automatically:
\<close>
text_raw\<open>\snip{BigStepDetLong}{0}{2}{%\<close>
theorem
  "(c,s) \<Rightarrow> t  \<Longrightarrow>  (c,s) \<Rightarrow> t'  \<Longrightarrow>  t' = t"
proof (induction arbitrary: t' rule: big_step.induct)
  \<comment> \<open>the only interesting case, \<^text>\<open>WhileTrue\<close>:\<close>
  fix b c s s\<^sub>1 t t'
  \<comment> \<open>The assumptions of the rule:\<close>
  assume "bval b s" and "(c,s) \<Rightarrow> s\<^sub>1" and "(WHILE b DO c,s\<^sub>1) \<Rightarrow> t"
  \<comment> \<open>Ind.Hyp; note the \<^text>\<open>\<And>\<close> because of arbitrary:\<close>
  assume IHc: "\<And>t'. (c,s) \<Rightarrow> t' \<Longrightarrow> t' = s\<^sub>1"
  assume IHw: "\<And>t'. (WHILE b DO c,s\<^sub>1) \<Rightarrow> t' \<Longrightarrow> t' = t"
  \<comment> \<open>Premise of implication:\<close>
  assume "(WHILE b DO c,s) \<Rightarrow> t'"
  with \<open>bval b s\<close> obtain s\<^sub>1' where
      c: "(c,s) \<Rightarrow> s\<^sub>1'" and
      w: "(WHILE b DO c,s\<^sub>1') \<Rightarrow> t'"
    by auto
  from c IHc have "s\<^sub>1' = s\<^sub>1" by blast
  with w IHw show "t' = t" by blast
qed blast+ \<comment> \<open>prove the rest automatically\<close>
text_raw\<open>}%endsnip\<close>

end


theory Indexed_FSet
imports
  "HOL-Library.FSet"
begin

text \<open>It is convenient to address the members of a finite set by a natural number, and
also to convert a finite set to a list.\<close>

context includes fset.lifting
begin
lift_definition fset_from_list :: "'a list => 'a fset" is set by (rule finite_set)
lemma mem_fset_from_list[simp]: "x |\<in>| fset_from_list l  \<longleftrightarrow> x \<in> set l" by transfer rule
lemma fimage_fset_from_list[simp]: "f |`| fset_from_list l = fset_from_list (map f l)"  by transfer auto
lemma fset_fset_from_list[simp]: "fset (fset_from_list l) = set l"  by transfer auto
lemmas fset_simps[simp] = set_simps[Transfer.transferred]
lemma size_fset_from_list[simp]: "distinct l \<Longrightarrow> size (fset_from_list l) = length l"
  by (induction l) auto

definition list_of_fset :: "'a fset \<Rightarrow> 'a list" where
  "list_of_fset s = (SOME l. fset_from_list l = s \<and> distinct l)"

lemma fset_from_list_of_fset[simp]: "fset_from_list (list_of_fset s) = s"
  and distinct_list_of_fset[simp]: "distinct (list_of_fset s)"
  unfolding atomize_conj list_of_fset_def
  by (transfer, rule someI_ex, rule finite_distinct_list)

lemma length_list_of_fset[simp]: "length (list_of_fset s) = size s"
  by (metis distinct_list_of_fset fset_from_list_of_fset size_fset_from_list)

lemma nth_list_of_fset_mem[simp]: "i < size s \<Longrightarrow> list_of_fset s ! i |\<in>| s"
  by (metis fset_from_list_of_fset length_list_of_fset mem_fset_from_list nth_mem)

inductive indexed_fmember :: "'a \<Rightarrow> nat \<Rightarrow> 'a fset \<Rightarrow> bool" ("_ |\<in>|\<^bsub>_\<^esub> _" [50,50,50] 50 ) where
  "i < size s \<Longrightarrow> list_of_fset s ! i |\<in>|\<^bsub>i\<^esub> s"

lemma indexed_fmember_is_fmember: "x |\<in>|\<^bsub>i\<^esub> s \<Longrightarrow> x |\<in>| s"
proof (induction rule: indexed_fmember.induct)
case (1 i s)
   hence "i < length (list_of_fset s)" by (metis length_list_of_fset)
   hence "list_of_fset s ! i \<in> set (list_of_fset s)" by (rule nth_mem)
   thus "list_of_fset s ! i |\<in>| s" by (metis mem_fset_from_list fset_from_list_of_fset)
qed

lemma fmember_is_indexed_fmember:
  assumes "x |\<in>| s"
  shows "\<exists>i. x |\<in>|\<^bsub>i\<^esub> s"
proof-
  from assms
  have "x \<in> set (list_of_fset s)" using mem_fset_from_list by fastforce
  then obtain i where "i < length (list_of_fset s)" and "x = list_of_fset s ! i" by (metis in_set_conv_nth)
  hence "x |\<in>|\<^bsub>i\<^esub> s"  by (simp add: indexed_fmember.simps)
  thus ?thesis..
qed

lemma indexed_fmember_unique: "x |\<in>|\<^bsub>i\<^esub> s \<Longrightarrow> y |\<in>|\<^bsub>j\<^esub> s \<Longrightarrow> x = y \<longleftrightarrow> i = j"
  by (metis distinct_list_of_fset indexed_fmember.cases length_list_of_fset nth_eq_iff_index_eq)

definition indexed_members :: "'a fset \<Rightarrow> (nat \<times> 'a) list" where
  "indexed_members s = zip [0..<size s] (list_of_fset s)"

lemma mem_set_indexed_members:
  "(i,x) \<in> set (indexed_members s) \<longleftrightarrow> x |\<in>|\<^bsub>i\<^esub> s"
  unfolding indexed_members_def indexed_fmember.simps
  by (force simp add: set_zip)

lemma mem_set_indexed_members'[simp]:
  "t \<in> set (indexed_members s) \<longleftrightarrow> snd t |\<in>|\<^bsub>fst t\<^esub> s"
  by (cases t, simp add: mem_set_indexed_members)

definition fnth (infixl "|!|" 100)  where
  "s |!| n = list_of_fset s ! n"
lemma fnth_indexed_fmember: "i < size s \<Longrightarrow> s |!| i |\<in>|\<^bsub>i\<^esub> s"
  unfolding fnth_def by (rule indexed_fmember.intros)
lemma indexed_fmember_fnth: "x |\<in>|\<^bsub>i\<^esub> s \<longleftrightarrow> (s |!| i = x \<and> i < size s)"
 unfolding fnth_def by (metis indexed_fmember.simps)
end

definition fidx :: "'a fset \<Rightarrow> 'a \<Rightarrow> nat" where
  "fidx s x = (SOME i. x |\<in>|\<^bsub>i\<^esub> s)"

lemma fidx_eq[simp]: "x |\<in>|\<^bsub>i\<^esub> s \<Longrightarrow> fidx s x = i"
  unfolding fidx_def
  by (rule someI2)(auto simp add: indexed_fmember_fnth fnth_def nth_eq_iff_index_eq)

lemma fidx_inj[simp]: "x |\<in>| s \<Longrightarrow> y |\<in>| s \<Longrightarrow> fidx s x = fidx s y \<longleftrightarrow> x = y"
  by (auto dest!: fmember_is_indexed_fmember simp add: indexed_fmember_unique)

lemma inj_on_fidx: "inj_on (fidx vertices) (fset vertices)"
  by (rule inj_onI) (auto simp: fmember.rep_eq [symmetric])

end


theory pn
  imports Main
begin

declare[[typedef_overloaded]]

(* First, we have a finite number of players *)
consts num_players :: "nat"

(* Next, the domain for players is then defined as the
   numbers 0, 1, ..., num_players *)
typedef players = "{ i . i \<le> num_players}"
  apply(rule_tac x = 0 in exI)
  by simp

(* Similarily we have finite number of places *)
consts num_places :: "nat"

(* The domain of places is defined similarily to
   players, but with num_places instead *)
typedef places = "{ i . i \<le> num_places}"
  apply(rule_tac x = 0 in exI)
  by simp

(* We have a finite number of transitions *)
consts num_transitions :: "nat"

(* Transitions are defined similarily to players and
   places, but with num_transitions instead *)
typedef transitions = "{ i . i \<le> num_transitions}"
  apply(rule_tac x = 0 in exI)
  by simp

(* Each transition is owned by exactly one player *)
type_synonym trans_owner = "transitions \<Rightarrow> players"

(* An arc is either going from a place to a transition
   or vice-versa
*)
datatype arc = PT places transitions
             | TP transitions places

(* Before we define our marking, we first define a
   bound, which restricts the number of tokens that
   may simultaneously appear on a place. This is in
   place to enforce that there only exists finitely
   many markings.
*)
consts bound :: "nat"

(* A marking is simply a function that assigns tokens
   to places*)
type_synonym marking = "places \<Rightarrow> nat"

(* Every arc has a weight. Either this is the token
   cost going in to the transition, or the resulting
    tokens going into the output *)
type_synonym weights = "arc \<Rightarrow> nat"

(* Finally, a Petri-Net is a 4-tuple, consisting of
   1. a finite set of places,
   2. a finite set of transitions
   3. a function mapping each function to a player
   4. a function mapping all arcs to a weight
*)
type_synonym PN = "(places set) * (transitions set) *
                   trans_owner * weights"

(* We instantiate an arbitrary Petri-Net*)
consts PetriNet :: "PN"

(* We define the components of our Petri-Net*)
definition P :: "places set" where
  "P \<equiv> (fst PetriNet)"
definition T :: "transitions set" where
  "T \<equiv> (fst (snd PetriNet))"
definition Q :: "trans_owner" where
  "Q \<equiv> (fst (snd (snd PetriNet)))"
definition W :: "weights" where
  "W \<equiv> (snd (snd (snd PetriNet)))"

(* All the enabled transitions in a given marking *)
fun en :: "marking \<Rightarrow> (transitions set)"
  where
    "en m =
      { t \<in> T . \<forall>p \<in> P .
        ((m p) \<ge> (W (PT p t))) \<and>
        ((m p) \<le> bound)
      }"

(* All the enabled transitions for a given player at a
   given marking *)
fun en_p :: "marking \<Rightarrow> players \<Rightarrow> (transitions set)" where
  "en_p m p = { t . (t \<in> (en m)) \<and> ((Q t) = p) }"

(* Gives the marking resulting from firing a
   transition no matter if that transition is enabled
   or not
*)
fun resulting_marking :: "marking \<Rightarrow> transitions \<Rightarrow> marking"
  where
 "resulting_marking m t = (\<lambda>p. (m p) - (W (PT p t)) + (W (TP t p)))"

(* The firing of a marking produces another marking *)
fun fire :: "marking \<Rightarrow> transitions \<Rightarrow> (marking option)"
  where
  "fire m t = (if t \<in> (en m)
      then Some (resulting_marking m t)
      else None)"

(* If no transition is fireable if its not enabled *)
lemma cannot_fire[simp]:
  "(t \<notin> (en m)) = (fire m t = None)"
  apply(simp)
  done

(* If a transition is enabled, then it exists *)
lemma enabled_trans: "t \<in> (en m) \<Longrightarrow> t \<in> T"
  apply(simp)
  done

(* Given that a transition is enabled, if its owned by
   a player then its also enabled for that player  *)
lemma player_can_fire:
  assumes "t \<in> (en m)"
  shows "((Q t) = (Abs_players p)) = (t \<in> (en_p m (Abs_players p)))"
  using assms by auto

(* The operators allowed in expressions *)
datatype exprop = Plus | Minus | Mult

(* The syntax of our expressions *)
datatype Expr = Constant nat
              | Place places
              | Enabled players
              | Expr Expr exprop Expr

(* The operators allowed in our predicates *)
datatype predop = Le | Leq | Eq | Neq | Ge | Geq

(* Evaluation of an expression wrt. a marking *)
fun eval_e :: "marking \<Rightarrow> Expr \<Rightarrow> nat" where
  "eval_e _ (Constant c) = c" |
  "eval_e m (Place p) = (m p)" |
  "eval_e m (Enabled a) = (card (en_p m a))" |
  "eval_e m (Expr e1 Plus e2) =
    ((eval_e m e1) + (eval_e m e2))" |
  "eval_e m (Expr e1 Minus e2) =
    ((eval_e m e1) - (eval_e m e2))" |
  "eval_e m (Expr e1 Mult e2) =
    ((eval_e m e1) * (eval_e m e2))"

(* The syntax of our queries *)
datatype formula = Boolean bool
                 | Equation Expr predop Expr
                 | Disjunction formula formula
                 | Negation formula
                 | Next players formula
                 | Until players formula formula

(* Evaluation of formula *)
function eval_f :: "(marking set) \<Rightarrow> marking \<Rightarrow> formula \<Rightarrow> bool"
  ("(_,_ \<Turnstile> _)" [80,80,80] 80) where
  (* Predicate formulas *)
  "eval_f _ _ (Boolean a) = a" |
  "eval_f _ m (Equation a Le c) =
    ((eval_e m a) < (eval_e m c))" |
  "eval_f _ m (Equation a Leq c) =
    ((eval_e m a) \<le> (eval_e m c))" |
  "eval_f _ m (Equation a Eq c) =
    ((eval_e m a) = (eval_e m c))" |
  "eval_f _ m (Equation a Neq c) =
    ((eval_e m a) \<noteq> (eval_e m c))" |
  "eval_f _ m (Equation a Ge c) =
    ((eval_e m a) > (eval_e m c))" |
  "eval_f _ m (Equation a Geq c) =
    ((eval_e m a) \<ge> (eval_e m c))" |
  (* State formulas*)
  "eval_f r m (Disjunction f1 f2) =
    ((r,m \<Turnstile> f1) \<or> (r,m \<Turnstile> f2))" |
  "eval_f r m (Negation f) =
    (\<not> (r,m \<Turnstile> f))" |
  (* Path formulas *)
  "eval_f r m (Next p f) =
    (\<exists>t \<in> T .
      let m' = (fire m t) in
        (case m' of
          None     \<Rightarrow> False |
          Some m'' \<Rightarrow> (({m} \<union> r),m'' \<Turnstile> f)))" |
  "eval_f r m (Until p f1 f2) =
    ((r,m \<Turnstile> f2) \<or>
      ((r,m \<Turnstile> f1) \<and>
        ((m \<notin> r) \<and>
          (r,m \<Turnstile> (Next p (Until p f1 f2))))))"
  by pat_completeness auto

end


section \<open>Prisms\<close>

theory Prisms
  imports Lenses
begin

subsection \<open> Signature and Axioms \<close>

text \<open>Prisms are like lenses, but they act on sum types rather than product types~\cite{Gibbons17}.
  See \url{https://hackage.haskell.org/package/lens-4.15.2/docs/Control-Lens-Prism.html}
  for more information.\<close>

record ('v, 's) prism =
  prism_match :: "'s \<Rightarrow> 'v option" ("match\<index>")
  prism_build :: "'v \<Rightarrow> 's" ("build\<index>")

type_notation
  prism (infixr "\<Longrightarrow>\<^sub>\<triangle>" 0)

locale wb_prism =
  fixes x :: "'v \<Longrightarrow>\<^sub>\<triangle> 's" (structure)
  assumes match_build: "match (build v) = Some v"
  and build_match: "match s = Some v \<Longrightarrow> s = build v"
begin

  lemma build_match_iff: "match s = Some v \<longleftrightarrow> s = build v"
    using build_match match_build by blast

  lemma range_build: "range build = dom match"
    using build_match match_build by fastforce
end

declare wb_prism.match_build [simp]
declare wb_prism.build_match [simp]

subsection \<open> Co-dependence \<close>

text \<open> The relation states that two prisms construct disjoint elements of the source. This
  can occur, for example, when the two prisms characterise different constructors of an
  algebraic datatype. \<close>

definition prism_diff :: "('a \<Longrightarrow>\<^sub>\<triangle> 's) \<Rightarrow> ('b \<Longrightarrow>\<^sub>\<triangle> 's) \<Rightarrow> bool" (infix "\<nabla>" 50) where
"prism_diff X Y = (range build\<^bsub>X\<^esub> \<inter> range build\<^bsub>Y\<^esub> = {})"

lemma prism_diff_intro:
  "(\<And> s\<^sub>1 s\<^sub>2. build\<^bsub>X\<^esub> s\<^sub>1 = build\<^bsub>Y\<^esub> s\<^sub>2 \<Longrightarrow> False) \<Longrightarrow> X \<nabla> Y"
  by (auto simp add: prism_diff_def)

lemma prism_diff_irrefl: "\<not> X \<nabla> X"
  by (simp add: prism_diff_def)

lemma prism_diff_sym: "X \<nabla> Y \<Longrightarrow> Y \<nabla> X"
  by (auto simp add: prism_diff_def)

lemma prism_diff_build: "X \<nabla> Y \<Longrightarrow> build\<^bsub>X\<^esub> u \<noteq> build\<^bsub>Y\<^esub> v"
  by (simp add: disjoint_iff_not_equal prism_diff_def)

subsection \<open> Summation \<close>

definition prism_plus :: "('a \<Longrightarrow>\<^sub>\<triangle> 's) \<Rightarrow> ('b \<Longrightarrow>\<^sub>\<triangle> 's) \<Rightarrow> 'a + 'b \<Longrightarrow>\<^sub>\<triangle> 's" (infixl "+\<^sub>\<triangle>" 85)
  where
"X +\<^sub>\<triangle> Y = \<lparr> prism_match = (\<lambda> s. case (match\<^bsub>X\<^esub> s, match\<^bsub>Y\<^esub> s) of
                                 (Some u, _) \<Rightarrow> Some (Inl u) |
                                 (None, Some v) \<Rightarrow> Some (Inr v) |
                                 (None, None) \<Rightarrow> None),
           prism_build = (\<lambda> v. case v of Inl x \<Rightarrow> build\<^bsub>X\<^esub> x | Inr y \<Rightarrow> build\<^bsub>Y\<^esub> y) \<rparr>"

subsection \<open> Instances \<close>

definition prism_suml :: "('a, 'a + 'b) prism" ("Inl\<^sub>\<triangle>") where
[lens_defs]: "prism_suml = \<lparr> prism_match = (\<lambda> v. case v of Inl x \<Rightarrow> Some x | _ \<Rightarrow> None), prism_build = Inl \<rparr>"

definition prism_sumr :: "('b, 'a + 'b) prism" ("Inr\<^sub>\<triangle>") where
[lens_defs]: "prism_sumr = \<lparr> prism_match = (\<lambda> v. case v of Inr x \<Rightarrow> Some x | _ \<Rightarrow> None), prism_build = Inr \<rparr>"

lemma wb_prim_suml: "wb_prism Inl\<^sub>\<triangle>"
  apply (unfold_locales)
   apply (simp_all add: prism_suml_def sum.case_eq_if)
  apply (metis option.inject option.simps(3) sum.collapse(1))
  done

lemma wb_prim_sumr: "wb_prism Inr\<^sub>\<triangle>"
  apply (unfold_locales)
   apply (simp_all add: prism_sumr_def sum.case_eq_if)
  apply (metis option.distinct(1) option.inject sum.collapse(2))
  done

lemma prism_suml_indep_sumr [simp]: "Inl\<^sub>\<triangle> \<nabla> Inr\<^sub>\<triangle>"
  by (auto simp add: prism_diff_def lens_defs)

subsection \<open> Lens correspondence \<close>

text \<open> Every well-behaved prism can be represented by a partial bijective lens. We prove
  this by exhibiting conversion functions and showing they are (almost) inverses. \<close>

definition prism_lens :: "('a, 's) prism \<Rightarrow> ('a \<Longrightarrow> 's)" where
"prism_lens X = \<lparr> lens_get = (\<lambda> s. the (match\<^bsub>X\<^esub> s)), lens_put = (\<lambda> s v. build\<^bsub>X\<^esub> v) \<rparr>"

definition lens_prism :: "('a \<Longrightarrow> 's) \<Rightarrow> ('a, 's) prism" where
"lens_prism X = \<lparr> prism_match = (\<lambda> s. if (s \<in> \<S>\<^bsub>X\<^esub>) then Some (get\<^bsub>X\<^esub> s) else None)
                , prism_build = create\<^bsub>X\<^esub> \<rparr>"

lemma get_prism_lens: "get\<^bsub>prism_lens X\<^esub> = the \<circ> match\<^bsub>X\<^esub>"
  by (simp add: prism_lens_def fun_eq_iff)

lemma src_prism_lens: "\<S>\<^bsub>prism_lens X\<^esub> = range (build\<^bsub>X\<^esub>)"
  by (auto simp add: prism_lens_def lens_source_def)

lemma create_prism_lens: "create\<^bsub>prism_lens X\<^esub> = build\<^bsub>X\<^esub>"
  by (simp add: prism_lens_def lens_create_def fun_eq_iff)

lemma prism_lens_inverse:
  "wb_prism X \<Longrightarrow> lens_prism (prism_lens X) = X"
  unfolding lens_prism_def src_prism_lens create_prism_lens get_prism_lens
  by (auto intro: prism.equality simp add: fun_eq_iff domIff wb_prism.range_build)

text \<open> Function @{const lens_prism} is almost inverted by @{const prism_lens}. The $put$
  functions are identical, but the $get$ functions differ when applied to a source where
  the prism @{term X} is undefined. \<close>

lemma lens_prism_put_inverse:
  "pbij_lens X \<Longrightarrow> put\<^bsub>prism_lens (lens_prism X)\<^esub> = put\<^bsub>X\<^esub>"
  unfolding prism_lens_def lens_prism_def
  by (auto simp add: fun_eq_iff pbij_lens.put_is_create)

lemma wb_prism_implies_pbij_lens:
  "wb_prism X \<Longrightarrow> pbij_lens (prism_lens X)"
  by (unfold_locales, simp_all add: prism_lens_def)

lemma pbij_lens_implies_wb_prism:
  assumes "pbij_lens X"
  shows "wb_prism (lens_prism X)"
proof (unfold_locales)
  fix s v
  show "match\<^bsub>lens_prism X\<^esub> (build\<^bsub>lens_prism X\<^esub> v) = Some v"
    by (simp add: lens_prism_def weak_lens.create_closure assms)
  assume a: "match\<^bsub>lens_prism X\<^esub> s = Some v"
  show "s = build\<^bsub>lens_prism X\<^esub> v"
  proof (cases "s \<in> \<S>\<^bsub>X\<^esub>")
    case True
    with a assms show ?thesis
      by (simp add: lens_prism_def lens_create_def,
          metis mwb_lens.weak_get_put pbij_lens.put_det pbij_lens_mwb)
  next
    case False
    with a assms show ?thesis by (simp add: lens_prism_def)
  qed
qed

ML_file \<open>Prism_Lib.ML\<close>

end


chapter \<open>Representability Assumptions\<close>

(*<*)
theory Abstract_Representability imports Abstract_Encoding
begin
(*>*)

text \<open>Here we make assumptions about various functions or relations being
representable.\<close>

section \<open>Representability of Negation\<close>

text \<open>The negation function neg is assumed to be representable by a
two-variable formula N.\<close>

locale Repr_Neg =
Deduct2_with_False
  var trm fmla Var FvarsT substT Fvars subst
  eql cnj imp all exi
  fls
  num
  prv bprv
+
Encode
  var trm fmla Var FvarsT substT Fvars subst
  num
  enc
for
var :: "'var set" and trm :: "'trm set" and fmla :: "'fmla set"
and Var FvarsT substT Fvars subst
and eql cnj imp all exi
and fls
and num
and prv bprv
and enc ("\<langle>_\<rangle>")
+
fixes N :: 'fmla
assumes
N[simp,intro!]: "N \<in> fmla"
and
Fvars_N[simp]: "Fvars N = {xx,yy}"
and
neg_implies_prv_N:
"\<And> \<phi>.
  let NN = (\<lambda> t1 t2. psubst N [(t1,xx), (t2,yy)]) in
   \<phi> \<in> fmla \<longrightarrow> Fvars \<phi> = {} \<longrightarrow> bprv (NN \<langle>\<phi>\<rangle> \<langle>neg \<phi>\<rangle>)"
and
N_unique:
"\<And> \<phi>.
  let NN = (\<lambda> t1 t2. psubst N [(t1,xx), (t2,yy)]) in
  \<phi> \<in> fmla \<longrightarrow> Fvars \<phi> = {} \<longrightarrow>
  bprv (all yy (all yy'
    (imp (cnj (NN \<langle>\<phi>\<rangle> (Var yy)) (NN \<langle>\<phi>\<rangle> (Var yy')))
         (eql (Var yy) (Var yy')))))"
begin

text \<open>NN is a notation for the predicate that takes terms and returns corresponding instances
of N, obtained by substituting its free variables with these terms. This is very convenient
for reasoning, and will be done for all the representing formulas we will consider.\<close>

definition NN where "NN \<equiv> \<lambda> t1 t2. psubst N [(t1,xx), (t2,yy)]"

lemma NN_def2: "t1 \<in> trm \<Longrightarrow> t2 \<in> trm \<Longrightarrow> yy \<notin> FvarsT t1 \<Longrightarrow>
 NN t1 t2 = subst (subst N t1 xx) t2 yy"
  unfolding NN_def by (rule psubst_eq_rawpsubst2[simplified]) auto

lemma NN_neg:
"\<phi> \<in> fmla \<Longrightarrow> Fvars \<phi> = {} \<Longrightarrow> bprv (NN \<langle>\<phi>\<rangle> \<langle>neg \<phi>\<rangle>)"
  using neg_implies_prv_N unfolding Let_def NN_def by meson

lemma NN_unique:
  assumes "\<phi> \<in> fmla" "Fvars \<phi> = {}"
  shows "bprv (all yy (all yy'
    (imp (cnj (NN \<langle>\<phi>\<rangle> (Var yy)) (NN \<langle>\<phi>\<rangle> (Var yy')))
         (eql (Var yy) (Var yy')))))"
  using assms N_unique unfolding Let_def NN_def by meson

lemma NN[simp,intro]:
"t1 \<in> trm \<Longrightarrow> t2 \<in> trm \<Longrightarrow> NN t1 t2 \<in> fmla"
unfolding NN_def by auto

lemma Fvars_NN[simp]: "t1 \<in> trm \<Longrightarrow> t2 \<in> trm \<Longrightarrow> yy \<notin> FvarsT t1 \<Longrightarrow>
Fvars (NN t1 t2) = FvarsT t1 \<union> FvarsT t2"
by (auto simp add: NN_def2 subst2_fresh_switch)

(* Here and elsewhere: hard to make into one or two uniform statements,
given that we don't assume sufficiently powerful properties for trm substitution.
So such lists would need to be maintained on an ad hoc basis, keeping adding instances
when needed. *)

lemma NN_unique2:
assumes [simp]:"\<phi> \<in> fmla" "Fvars \<phi> = {}"
shows
"bprv (all yy
     (imp (NN \<langle>\<phi>\<rangle> (Var yy))
          (eql \<langle>neg \<phi>\<rangle> (Var yy))))"
proof-
  have 1: "bprv (NN \<langle>\<phi>\<rangle> \<langle>neg \<phi>\<rangle>)"
    using NN_neg[OF assms] .
  have 2: "bprv (all yy' (
             imp (cnj (NN \<langle>\<phi>\<rangle> \<langle>neg \<phi>\<rangle>)
                      (NN \<langle>\<phi>\<rangle> (Var yy')))
                 (eql \<langle>neg \<phi>\<rangle> (Var yy'))))"
    using B.prv_allE[of yy, OF _ _ _ NN_unique, of "\<phi>" "\<langle>neg \<phi>\<rangle>"]
    by fastforce
  have 31: "bprv (all yy' (
             imp (NN \<langle>\<phi>\<rangle> \<langle>neg \<phi>\<rangle>)
                 (imp (NN \<langle>\<phi>\<rangle> (Var yy'))
                      (eql \<langle>neg \<phi>\<rangle> (Var yy')))))"
    using B.prv_all_imp_cnj_rev[OF _ _ _ _ 2] by simp
  have 32: "bprv (imp (NN \<langle>\<phi>\<rangle> \<langle>neg \<phi>\<rangle>)
                      (all yy' (imp (NN \<langle>\<phi>\<rangle> (Var yy'))
                                    (eql \<langle>neg \<phi>\<rangle> (Var yy')))))"
    by (rule B.prv_all_imp[OF _ _ _ _ 31]) (auto simp: NN_def2)
  have 33: "bprv (all yy' (imp (NN \<langle>\<phi>\<rangle> (Var yy'))
                              (eql \<langle>neg \<phi>\<rangle> (Var yy'))))"
    by (rule B.prv_imp_mp [OF _ _ 32 1]) auto
  thus ?thesis using B.all_subst_rename_prv[OF _ _ _ _ 33, of yy] by simp
qed

lemma NN_neg_unique:
assumes [simp]:"\<phi> \<in> fmla" "Fvars \<phi> = {}"
shows
"bprv (imp (NN \<langle>\<phi>\<rangle> (Var yy))
           (eql \<langle>neg \<phi>\<rangle> (Var yy)))" (is "bprv ?A")
proof-
  have 0: "bprv (all yy ?A)"
    using NN_unique2[of "\<phi>"] by simp
  show ?thesis by (rule B.allE_id[OF _ _ 0]) auto
qed

lemma NN_exi_cnj:
assumes \<phi>[simp]: "\<phi> \<in> fmla" "Fvars \<phi> = {}" and \<chi>[simp]: "\<chi> \<in> fmla"
assumes f: "Fvars \<chi> = {yy}"
shows "bprv (eqv (subst \<chi> \<langle>neg \<phi>\<rangle> yy)
                 (exi yy (cnj \<chi> (NN \<langle>\<phi>\<rangle> (Var yy)))))"
(is "bprv (eqv ?A ?B)")
proof(intro B.prv_eqvI)
  have yy: "yy \<in> var" by simp
  let ?N = "NN \<langle>\<phi>\<rangle> (Var yy)"
  have "bprv (imp (subst \<chi> \<langle>neg \<phi>\<rangle> yy) ((subst (cnj \<chi> ?N) \<langle>neg \<phi>\<rangle> yy)))" using NN_neg[OF \<phi>]
    by (simp add: B.prv_imp_cnj B.prv_imp_refl B.prv_imp_triv)
  thus "bprv (imp ?A ?B)"
    by (elim B.prv_prv_imp_trans[rotated 3], intro B.prv_exi_inst) auto
next
  have 00: "bprv (imp (eql \<langle>neg \<phi>\<rangle> (Var yy)) (imp \<chi> (subst \<chi> \<langle>neg \<phi>\<rangle> yy)))"
    by (rule B.prv_eql_subst_trm_id_rev) auto
  have 11: "bprv (imp (NN \<langle>\<phi>\<rangle> (Var yy)) (imp \<chi> (subst \<chi> \<langle>neg \<phi>\<rangle> yy)))"
    using 00 NN_neg_unique[OF \<phi>]
    using NN num Var Variable \<phi> \<chi> eql imp subst B.prv_prv_imp_trans
    by (metis (no_types, lifting) enc in_num neg)
  hence "bprv (imp (cnj \<chi> (NN \<langle>\<phi>\<rangle> (Var yy))) (subst \<chi> \<langle>neg \<phi>\<rangle> yy))"
    by (simp add: 11 B.prv_cnj_imp_monoR2 B.prv_imp_com)
  hence 1: "bprv (all yy (imp (cnj \<chi> (NN \<langle>\<phi>\<rangle> (Var yy))) (subst \<chi> \<langle>neg \<phi>\<rangle> yy)))"
    by (simp add: B.prv_all_gen)
  have 2: "Fvars (subst \<chi> \<langle>neg \<phi>\<rangle> yy) = {}" using f by simp
  show "bprv (imp ?B ?A)" using 1 2
    by (simp add: B.prv_exi_imp)
qed auto

end \<comment> \<open>context @{locale Repr_Neg}\<close>

section \<open>Representability of Self-Substitution\<close>

text \<open>Self-substitution is the function that takes a formula @{term \<phi>}
and returns $\phi[\langle\phi\rangle/\mathit{xx}]$ (for the fixed variable @{term xx}). This is all that
will be needed for the diagonalization lemma.\<close>

locale Repr_SelfSubst =
Encode
  var trm fmla Var FvarsT substT Fvars subst
  num
  enc
+
Deduct2
  var trm fmla Var FvarsT substT Fvars subst
  num
  eql cnj imp all exi
  prv bprv
for
var :: "'var set" and trm :: "'trm set" and fmla :: "'fmla set"
and Var FvarsT substT Fvars subst
and num
and eql cnj imp all exi
and prv bprv
and enc ("\<langle>_\<rangle>")
+
fixes S :: 'fmla
assumes
S[simp,intro!]: "S \<in> fmla"
and
Fvars_S[simp]: "Fvars S = {xx,yy}"
and
subst_implies_prv_S:
"\<And> \<phi>.
  let SS = (\<lambda> t1 t2. psubst S [(t1,xx), (t2,yy)]) in
  \<phi> \<in> fmla \<longrightarrow> Fvars \<phi> = {xx} \<longrightarrow>
  bprv (SS \<langle>\<phi>\<rangle> \<langle>subst \<phi> \<langle>\<phi>\<rangle> xx\<rangle>)"
and
S_unique:
"\<And> \<phi>.
  let SS = (\<lambda> t1 t2. psubst S [(t1,xx), (t2,yy)]) in
  \<phi> \<in> fmla \<longrightarrow> Fvars \<phi> = {xx} \<longrightarrow>
  bprv (all yy (all yy'
     (imp (cnj (SS \<langle>\<phi>\<rangle> (Var yy)) (SS \<langle>\<phi>\<rangle> (Var yy')))
          (eql (Var yy) (Var yy')))))"
begin

text \<open>SS is the instantiation combinator of S:\<close>
definition SS where "SS \<equiv> \<lambda> t1 t2. psubst S [(t1,xx), (t2,yy)]"

lemma SS_def2: "t1 \<in> trm \<Longrightarrow> t2 \<in> trm \<Longrightarrow>
 yy \<notin> FvarsT t1 \<Longrightarrow>
 SS t1 t2 = subst (subst S t1 xx) t2 yy"
  unfolding SS_def by (rule psubst_eq_rawpsubst2[simplified]) auto

lemma subst_implies_prv_SS:
"\<phi> \<in> fmla \<Longrightarrow> Fvars \<phi> = {xx} \<Longrightarrow> bprv (SS \<langle>\<phi>\<rangle> \<langle>subst \<phi> \<langle>\<phi>\<rangle> xx\<rangle>)"
using subst_implies_prv_S unfolding Let_def SS_def by meson

lemma SS_unique:
"\<phi> \<in> fmla \<Longrightarrow> Fvars \<phi> = {xx} \<Longrightarrow>
 bprv (all yy (all yy'
      (imp (cnj (SS \<langle>\<phi>\<rangle> (Var yy)) (SS \<langle>\<phi>\<rangle> (Var yy')))
           (eql (Var yy) (Var yy')))))"
using S_unique unfolding Let_def SS_def by meson

lemma SS[simp,intro]:
"t1 \<in> trm \<Longrightarrow> t2 \<in> trm \<Longrightarrow> SS t1 t2 \<in> fmla"
unfolding SS_def by auto

lemma Fvars_SS[simp]: "t1 \<in> trm \<Longrightarrow> t2 \<in> trm \<Longrightarrow> yy \<notin> FvarsT t1 \<Longrightarrow>
Fvars (SS t1 t2) = FvarsT t1 \<union> FvarsT t2"
by (auto simp add: SS_def2 subst2_fresh_switch)

lemma [simp]:
"m \<in> num \<Longrightarrow> p \<in> num \<Longrightarrow> subst (SS m (Var yy)) p yy = SS m p"
"m \<in> num \<Longrightarrow> subst (SS m (Var yy')) (Var yy) yy' = SS m (Var yy)"
"m \<in> num \<Longrightarrow> p \<in> num \<Longrightarrow> subst (SS m (Var yy')) p yy' = SS m p"
"m \<in> num \<Longrightarrow> p \<in> num \<Longrightarrow> subst (SS m (Var yy')) p yy = SS m (Var yy')"
"m \<in> num \<Longrightarrow> subst (SS (Var xx) (Var yy)) m xx = SS m (Var yy)"
by (auto simp add: SS_def2 subst_comp_num Let_def)

end \<comment> \<open>context @{locale Repr_SelfSubst}\<close>

section \<open>Representability of Self-Soft-Substitution\<close>

text \<open>The soft substitution function performs substitution logically instead of
syntactically. In particular, its "self" version sends @{term \<phi>} to
@{term "exi xx (cnj (eql (Var xx) (enc \<phi>)) \<phi>)"}. Representability of self-soft-substitution will be
an alternative assumption in the diagonalization lemma.\<close>

locale Repr_SelfSoftSubst =
Encode
  var trm fmla Var FvarsT substT Fvars subst
  num
  enc
+
Deduct2
  var trm fmla Var FvarsT substT Fvars subst
  num
  eql cnj imp all exi
  prv bprv
for
var :: "'var set" and trm :: "'trm set" and fmla :: "'fmla set"
and Var FvarsT substT Fvars subst
and num
and eql cnj imp all exi
and prv bprv
and enc ("\<langle>_\<rangle>")
+
fixes S :: 'fmla
assumes
S[simp,intro!]: "S \<in> fmla"
and
Fvars_S[simp]: "Fvars S = {xx,yy}"
and
softSubst_implies_prv_S:
"\<And> \<phi>.
  let SS = (\<lambda> t1 t2. psubst S [(t1,xx), (t2,yy)]) in
  \<phi> \<in> fmla \<longrightarrow> Fvars \<phi> = {xx} \<longrightarrow>
  bprv (SS \<langle>\<phi>\<rangle> \<langle>softSubst \<phi> \<langle>\<phi>\<rangle> xx\<rangle>)"
and
S_unique:
"\<And> \<phi>.
  let SS = (\<lambda> t1 t2. psubst S [(t1,xx), (t2,yy)]) in
  \<phi> \<in> fmla \<longrightarrow> Fvars \<phi> = {xx} \<longrightarrow>
  bprv (all yy (all yy'
     (imp (cnj (SS \<langle>\<phi>\<rangle> (Var yy)) (SS \<langle>\<phi>\<rangle> (Var yy')))
          (eql (Var yy) (Var yy')))))"
begin

text \<open>SS is the instantiation combinator of S:\<close>
definition SS where "SS \<equiv> \<lambda> t1 t2. psubst S [(t1,xx), (t2,yy)]"

lemma SS_def2: "t1 \<in> trm \<Longrightarrow> t2 \<in> trm \<Longrightarrow>
 yy \<notin> FvarsT t1 \<Longrightarrow>
 SS t1 t2 = subst (subst S t1 xx) t2 yy"
  unfolding SS_def by (rule psubst_eq_rawpsubst2[simplified]) auto

lemma softSubst_implies_prv_SS:
"\<phi> \<in> fmla \<Longrightarrow> Fvars \<phi> = {xx} \<Longrightarrow> bprv (SS \<langle>\<phi>\<rangle> \<langle>softSubst \<phi> \<langle>\<phi>\<rangle> xx\<rangle>)"
using softSubst_implies_prv_S unfolding Let_def SS_def by meson

lemma SS_unique:
"\<phi> \<in> fmla \<Longrightarrow> Fvars \<phi> = {xx} \<Longrightarrow>
 bprv (all yy (all yy'
     (imp (cnj (SS \<langle>\<phi>\<rangle> (Var yy)) (SS \<langle>\<phi>\<rangle> (Var yy')))
          (eql (Var yy) (Var yy')))))"
using S_unique unfolding Let_def SS_def by meson

lemma SS[simp,intro]:
"t1 \<in> trm \<Longrightarrow> t2 \<in> trm \<Longrightarrow> SS t1 t2 \<in> fmla"
unfolding SS_def by auto

lemma Fvars_SS[simp]: "t1 \<in> trm \<Longrightarrow> t2 \<in> trm \<Longrightarrow> yy \<notin> FvarsT t1 \<Longrightarrow>
Fvars (SS t1 t2) = FvarsT t1 \<union> FvarsT t2"
by (auto simp add: SS_def2 subst2_fresh_switch)

lemma [simp]:
"m \<in> num \<Longrightarrow> p \<in> num \<Longrightarrow> subst (SS m (Var yy)) p yy = SS m p"
"m \<in> num \<Longrightarrow> subst (SS m (Var yy')) (Var yy) yy' = SS m (Var yy)"
"m \<in> num \<Longrightarrow> p \<in> num \<Longrightarrow> subst (SS m (Var yy')) p yy' = SS m p"
"m \<in> num \<Longrightarrow> p \<in> num \<Longrightarrow> subst (SS m (Var yy')) p yy = SS m (Var yy')"
"m \<in> num \<Longrightarrow> subst (SS (Var xx) (Var yy)) m xx = SS m (Var yy)"
by (auto simp add: SS_def2 subst_comp_num Let_def)

end \<comment> \<open>context @{locale Repr_SelfSoftSubst}\<close>

section \<open>Clean Representability of the "Proof-of" Relation\<close>

text\<open>For the proof-of relation, we must assume a stronger version of
representability, namely clean representability on the first argument, which
is dedicated to encoding the proof component. The property asks that the
representation predicate is provably false on numerals that do not encode
proofs; it would hold trivially for surjective proof encodings.

Cleanness is not a standard concept in the literature -- we have
introduced it in our CADE 2019 paper~\<^cite>\<open>"DBLP:conf/cade/0001T19"\<close>.\<close>

locale CleanRepr_Proofs =
Encode_Proofs
  var trm fmla Var FvarsT substT Fvars subst
  num
  eql cnj imp all exi
  prv bprv
  enc
  fls
  dsj
  "proof" prfOf
  encPf
for
var :: "'var set" and trm :: "'trm set" and fmla :: "'fmla set"
and Var FvarsT substT Fvars subst
and num
and eql cnj imp all exi
and prv bprv
and enc ("\<langle>_\<rangle>")
and fls dsj
and "proof" :: "'proof set" and prfOf
and encPf
+
fixes Pf :: 'fmla
assumes
Pf[simp,intro!]: "Pf \<in> fmla"
and
Fvars_Pf[simp]: "Fvars Pf = {yy,xx}"
and
prfOf_Pf:
"\<And> prf \<phi>.
  let PPf = (\<lambda> t1 t2. psubst Pf [(t1,yy), (t2,xx)]) in
  (prf \<in> proof \<and> \<phi> \<in> fmla \<and> Fvars \<phi> = {} \<longrightarrow>
   prfOf prf \<phi>
   \<longrightarrow>
   bprv (PPf (encPf prf) \<langle>\<phi>\<rangle>))"
and
not_prfOf_Pf:
"\<And> prf \<phi>.
  let PPf = (\<lambda> t1 t2. psubst Pf [(t1,yy), (t2,xx)]) in
  (prf \<in> proof \<and> \<phi> \<in> fmla \<and> Fvars \<phi> = {} \<longrightarrow>
   \<not> prfOf prf \<phi>
   \<longrightarrow>
   bprv (neg (PPf (encPf prf) \<langle>\<phi>\<rangle>)))"
and
Clean_Pf_encPf:
"\<And> p \<phi>. let PPf = (\<lambda> t1 t2. psubst Pf [(t1,yy), (t2,xx)]) in
  p \<in> num \<and> \<phi> \<in> fmla \<and> Fvars \<phi> = {} \<longrightarrow> p \<notin> encPf ` proof \<longrightarrow> bprv (neg (PPf p \<langle>\<phi>\<rangle>))"
begin

text \<open>PPf is the instantiation combinator of Pf:\<close>
definition PPf where "PPf \<equiv> \<lambda> t1 t2. psubst Pf [(t1,yy), (t2,xx)]"

lemma prfOf_PPf:
assumes "prf \<in> proof" "\<phi> \<in> fmla" "Fvars \<phi> = {}" "prfOf prf \<phi>"
shows "bprv (PPf (encPf prf) \<langle>\<phi>\<rangle>)"
  using assms prfOf_Pf unfolding PPf_def by auto

lemma not_prfOf_PPf:
assumes "prf \<in> proof" "\<phi> \<in> fmla" "Fvars \<phi> = {}" "\<not> prfOf prf \<phi>"
shows "bprv (neg (PPf (encPf prf) \<langle>\<phi>\<rangle>))"
  using assms not_prfOf_Pf unfolding PPf_def by auto

lemma Clean_PPf_encPf:
  assumes "\<phi> \<in> fmla" "Fvars \<phi> = {}" and "p \<in> num" "p \<notin> encPf ` proof"
  shows "bprv (neg (PPf p \<langle>\<phi>\<rangle>))"
using assms Clean_Pf_encPf unfolding PPf_def by auto

lemma PPf[simp,intro!]: "t1 \<in> trm \<Longrightarrow> t2 \<in> trm \<Longrightarrow> xx \<notin> FvarsT t1 \<Longrightarrow> PPf t1 t2 \<in> fmla"
  unfolding PPf_def by auto

lemma PPf_def2: "t1 \<in> trm \<Longrightarrow> t2 \<in> trm \<Longrightarrow> xx \<notin> FvarsT t1 \<Longrightarrow>
  PPf t1 t2 = subst (subst Pf t1 yy) t2 xx"
  unfolding PPf_def by (rule psubst_eq_rawpsubst2[simplified]) auto

lemma Fvars_PPf[simp]:
"t1 \<in> trm \<Longrightarrow> t2 \<in> trm \<Longrightarrow> xx \<notin> FvarsT t1 \<Longrightarrow>
 Fvars (PPf t1 t2) = FvarsT t1 \<union> FvarsT t2"
by (auto simp add: PPf_def2 subst2_fresh_switch)

lemma [simp]:
"n \<in> num \<Longrightarrow> subst (PPf (Var yy) (Var xx)) n xx = PPf (Var yy) n"
"m \<in> num \<Longrightarrow> n \<in> num \<Longrightarrow> subst (PPf (Var yy) m) n yy = PPf n m"
"n \<in> num \<Longrightarrow> subst (PPf (Var yy) (Var xx)) n yy = PPf n (Var xx)"
"m \<in> num \<Longrightarrow> n \<in> num \<Longrightarrow> subst (PPf m (Var xx)) n xx = PPf m n"
"m \<in> num \<Longrightarrow> subst (PPf (Var zz) (Var xx')) m zz = PPf m (Var xx')"
"m \<in> num \<Longrightarrow> n \<in> num \<Longrightarrow> subst (PPf m (Var xx')) n xx' = PPf m n"
"n \<in> num \<Longrightarrow> subst (PPf (Var zz) (Var xx')) n xx' = PPf (Var zz) n"
"m \<in> num \<Longrightarrow> n \<in> num \<Longrightarrow> subst (PPf (Var zz) n) m zz = PPf m n"
by (auto simp add: PPf_def2 subst2_fresh_switch)

lemma B_consistent_prfOf_iff_PPf:
"B.consistent \<Longrightarrow> prf \<in> proof \<Longrightarrow> \<phi> \<in> fmla \<Longrightarrow> Fvars \<phi> = {} \<longrightarrow> prfOf prf \<phi> \<longleftrightarrow> bprv (PPf (encPf prf) \<langle>\<phi>\<rangle>)"
  unfolding B.consistent_def3 using not_prfOf_PPf[of "prf" \<phi>] prfOf_PPf[of "prf" \<phi>] by force

lemma consistent_prfOf_iff_PPf:
"consistent \<Longrightarrow> prf \<in> proof \<Longrightarrow> \<phi> \<in> fmla \<Longrightarrow> Fvars \<phi> = {} \<longrightarrow> prfOf prf \<phi> \<longleftrightarrow> bprv (PPf (encPf prf) \<langle>\<phi>\<rangle>)"
  using B_consistent_prfOf_iff_PPf[OF dwf_dwfd.consistent_B_consistent] .

end \<comment> \<open>context @{locale CleanRepr_Proofs}\<close>

(*<*)
end
(*>*)