subsection\<open>Okamoto \<open>\<Sigma>\<close>-protocol\<close>

theory Okamoto_Sigma_Commit imports
  Commitment_Schemes
  Sigma_Protocols
  Cyclic_Group_Ext
  Discrete_Log
  "HOL.GCD"
  Number_Theory_Aux
  Uniform_Sampling
begin

locale okamoto_base =
  fixes \<G> :: "'grp cyclic_group" (structure)
    and x :: nat
  assumes prime_order: "prime (order \<G>)"
begin

definition "g' = \<^bold>g [^] x"

lemma order_gt_1: "order \<G> > 1"
  using prime_order
  using prime_gt_1_nat by blast

lemma order_gt_0 [simp]:"order \<G> > 0"
  using order_gt_1 by simp

definition "response r w e = do {
  let (r1,r2) = r;
  let (x1,x2) = w;
  let z1 = (e * x1 + r1) mod (order \<G>);
  let z2 = (e * x2 + r2) mod (order \<G>);
  return_spmf ((z1,z2))}"

lemma lossless_response: "lossless_spmf (response r w e)"
  by(simp add: response_def split_def)

type_synonym witness = "nat \<times> nat"
type_synonym rand = "nat \<times> nat"
type_synonym 'grp' msg = "'grp'"
type_synonym response = "(nat \<times> nat)"
type_synonym challenge = nat
type_synonym 'grp' pub_in = "'grp'"

definition init :: "'grp pub_in \<Rightarrow> witness \<Rightarrow> (rand \<times> 'grp msg) spmf"
  where "init y w = do {
    let (x1,x2) = w;
    r1 \<leftarrow> sample_uniform (order \<G>);
    r2 \<leftarrow> sample_uniform (order \<G>);
    return_spmf ((r1,r2), \<^bold>g [^] r1 \<otimes> g' [^] r2)}"

lemma lossless_init: "lossless_spmf (init h  w)"
  by(simp add: init_def)

definition check :: "'grp pub_in \<Rightarrow> 'grp msg \<Rightarrow> challenge \<Rightarrow> response \<Rightarrow> bool"
  where "check h a e z = (\<^bold>g [^] (fst z) \<otimes> g' [^] (snd z) = a \<otimes> (h [^] e) \<and> a \<in> carrier \<G>)"

definition R :: "('grp pub_in \<times> witness) set"
  where "R \<equiv> {(h, w). (h = \<^bold>g [^] (fst w) \<otimes> g' [^] (snd w))}"

definition G :: "('grp pub_in \<times> witness) spmf"
  where "G = do {
    w1 \<leftarrow> sample_uniform (order \<G>);
    w2 \<leftarrow> sample_uniform (order \<G>);
    return_spmf (\<^bold>g [^] w1 \<otimes> g' [^] w2 , (w1,w2))}"

definition "challenge_space = {..< order \<G>}"

lemma lossless_G: "lossless_spmf G"
  by(simp add: G_def)

definition S2 :: "'grp pub_in \<Rightarrow> challenge \<Rightarrow> ('grp msg, response) sim_out spmf"
  where "S2 h c = do {
    z1 \<leftarrow> sample_uniform  (order \<G>);
    z2 \<leftarrow> sample_uniform  (order \<G>);
  let a =  (\<^bold>g [^] z1 \<otimes> g' [^] z2) \<otimes> (inv h [^] c);
  return_spmf (a, (z1,z2))}"

definition R2 :: "'grp pub_in \<Rightarrow> witness \<Rightarrow> challenge \<Rightarrow> ('grp msg, challenge, response) conv_tuple spmf"
  where "R2 h w c = do {
    let (x1,x2) = w;
    r1 \<leftarrow> sample_uniform (order \<G>);
    r2 \<leftarrow> sample_uniform (order \<G>);
    let z1 = (c * x1 + r1) mod (order \<G>);
    let z2 = (c * x2 + r2) mod (order \<G>);
    return_spmf (\<^bold>g [^] r1 \<otimes> g' [^] r2 ,c,(z1,z2))}"

definition ss_adversary :: "'grp \<Rightarrow> ('grp msg, challenge, response) conv_tuple \<Rightarrow> ('grp msg, challenge, response) conv_tuple \<Rightarrow> (nat \<times> nat) spmf"
  where "ss_adversary y c1 c2 = do {
    let (a, e, (z1,z2)) = c1;
    let (a', e', (z1',z2')) = c2;
    return_spmf (if (e > e') then (nat ((int z1 - int z1') * inverse (e - e') (order \<G>) mod order \<G>)) else
                      (nat ((int z1' - int z1) * inverse (e' - e) (order \<G>) mod order \<G>)),
                 if (e > e') then (nat ((int z2  - int z2') * inverse (e - e') (order \<G>) mod order \<G>)) else
                      (nat ((int z2' - int z2) * inverse (e' - e) (order \<G>) mod order \<G>)))}"

definition "valid_pub = carrier \<G>"
end

locale okamoto = okamoto_base + cyclic_group \<G>
begin

lemma g'_in_carrier [simp]: "g' \<in> carrier \<G>"
  using g'_def by auto

sublocale \<Sigma>_protocols_base: \<Sigma>_protocols_base init response check R S2 ss_adversary challenge_space valid_pub
  by unfold_locales (auto simp add: R_def valid_pub_def)

lemma "\<Sigma>_protocols_base.R h w c = R2 h w c"
  by(simp add: \<Sigma>_protocols_base.R_def R2_def; simp add: init_def split_def response_def)

lemma completeness:
  shows "\<Sigma>_protocols_base.completeness"
proof-
  have "(\<^bold>g [^] ((e * fst w' + y) mod order \<G>) \<otimes> g' [^] ((e * snd w' + ya) mod order \<G>) = \<^bold>g [^] y \<otimes> g' [^] ya \<otimes> (\<^bold>g [^] fst w' \<otimes> g' [^] snd w') [^] e)"
    for e y ya :: nat and w' :: "nat \<times> nat"
  proof-
    have "\<^bold>g [^] ((e * fst w' + y) mod order \<G>) \<otimes> g' [^] ((e * snd w' + ya) mod order \<G>) = \<^bold>g [^] ((y + e * fst w')) \<otimes> g' [^] ((ya + e * snd w'))"
      by (simp add: cyclic_group.pow_carrier_mod cyclic_group_axioms g'_def add.commute pow_generator_mod)
    also have "... = \<^bold>g [^] y \<otimes> \<^bold>g [^] (e * fst w') \<otimes> g' [^] ya \<otimes> g' [^] (e * snd w')"
      by (simp add: g'_def m_assoc nat_pow_mult)
    also have "... = \<^bold>g [^] y \<otimes> g' [^] ya \<otimes> \<^bold>g [^] (e * fst w') \<otimes> g' [^] (e * snd w')"
      by (smt add.commute g'_def generator_closed m_assoc nat_pow_closed nat_pow_mult nat_pow_pow)
    also have "... = \<^bold>g [^] y \<otimes> g' [^] ya \<otimes> ((\<^bold>g [^] fst w') [^] e \<otimes> (g' [^] snd w') [^] e)"
      by (simp add: m_assoc mult.commute nat_pow_pow)
    also have "... =  \<^bold>g [^] y \<otimes> g' [^] ya \<otimes> ((\<^bold>g [^] fst w' \<otimes> g' [^] snd w') [^] e)"
      by (smt power_distrib g'_def generator_closed mult.commute nat_pow_closed nat_pow_mult nat_pow_pow)
    ultimately show ?thesis by simp
  qed
  thus ?thesis
  unfolding \<Sigma>_protocols_base.completeness_def \<Sigma>_protocols_base.completeness_game_def
  by(simp add: R_def challenge_space_def init_def check_def response_def split_def bind_spmf_const)
qed

lemma hvzk_z_r:
  assumes r1: "r1 < order \<G>"
  shows "r1 = ((r1 + c * (x1 :: nat)) mod (order \<G>) + order \<G> * c * x1 - c * x1) mod (order \<G>)"
proof(cases "x1 = 0")
  case True
  then show ?thesis using r1 by simp
next
  case x1_neq_0: False
  have z1_eq: "[(r1 + c * x1) mod (order \<G>) + order \<G> * c * x1 = r1 + c * x1] (mod (order \<G>))"
    using gr_implies_not_zero order_gt_1
    by (simp add: Groups.mult_ac(1) cong_def)
  hence "[(r1 + c * x1) mod (order \<G>) + order \<G> * c * x1 - c * x1 = r1] (mod (order \<G>))"
  proof(cases "c = 0")
    case True
    then show ?thesis
      using z1_eq by auto
  next
    case False
    have "order \<G> * c * x1 - c * x1 > 0" using x1_neq_0 False
      using prime_gt_1_nat prime_order by auto
    thus ?thesis
      by (smt Groups.add_ac(2) add_diff_inverse_nat cong_add_lcancel_nat diff_is_0_eq le_simps(1) neq0_conv trans_less_add2 z1_eq zero_less_diff)
  qed
  thus ?thesis
    by (simp add: r1 cong_def)
qed

lemma hvzk_z1_r1_tuple_rewrite:
  assumes r1: "r1 < order \<G>"
  shows "(\<^bold>g [^] r1 \<otimes> g' [^] r2, c, (r1 + c * x1) mod order \<G>, (r2 + c * x2) mod order \<G>) =
              (\<^bold>g [^] (((r1 + c * x1) mod order \<G> + order \<G> * c * x1 - c * x1) mod order \<G>)
                  \<otimes> g' [^] r2, c, (r1 + c * x1) mod order \<G>, (r2 + c * x2) mod order \<G>)"
proof-
  have "\<^bold>g [^] r1 = \<^bold>g [^] (((r1 + c * x1) mod order \<G> + order \<G> * c * x1 - c * x1) mod order \<G>)"
    using assms hvzk_z_r by simp
  thus ?thesis by argo
qed

lemma hvzk_z2_r2_tuple_rewrite:
  assumes "xb < order \<G>"
  shows "(\<^bold>g [^] (((x' + xa * x1) mod order \<G> + order \<G> * xa * x1 - xa * x1) mod order \<G>)
            \<otimes> g' [^] xb, xa, (x' + xa * x1) mod order \<G>, (xb + xa * x2) mod order \<G>) =
               (\<^bold>g [^] (((x' + xa * x1) mod order \<G> + order \<G> * xa * x1 - xa * x1) mod order \<G>)
                \<otimes> g' [^] (((xb + xa * x2) mod order \<G> + order \<G> * xa * x2 - xa * x2) mod order \<G>), xa, (x' + xa * x1) mod order \<G>, (xb + xa * x2) mod order \<G>)"
proof-
  have "g' [^] xb = g' [^] (((xb + xa * x2) mod order \<G> + order \<G> * xa * x2 - xa * x2) mod order \<G>)"
    using hvzk_z_r assms by simp
    thus ?thesis by argo
qed

lemma hvzk_sim_inverse_rewrite:
  assumes h: "h =  \<^bold>g [^] (x1 :: nat) \<otimes> g' [^] (x2 :: nat)"
  shows "\<^bold>g [^] (((z1::nat) + order \<G> * c * x1 - c * x1) mod (order \<G>))
            \<otimes> g' [^] (((z2::nat) + order \<G> * c * x2 - c * x2) mod (order \<G>))
                = (\<^bold>g [^] z1 \<otimes> g' [^] z2) \<otimes> (inv h [^] c)"
(is "?lhs = ?rhs")
proof-
  have in_carrier1: "(g' [^] x2) [^] c \<in> carrier \<G>" by simp
  have in_carrier2: "(\<^bold>g [^] x1) [^] c \<in> carrier \<G>" by simp
  have pow_distrib1: "order \<G> * c * x1 - c * x1 = (order \<G> - 1) * c * x1"
    and pow_distrib2: "order \<G> * c * x2 - c * x2 = (order \<G> - 1) * c * x2"
    using assms by (simp add: diff_mult_distrib)+
  have "?lhs = \<^bold>g [^] (z1 + order \<G> * c * x1 - c * x1) \<otimes> g' [^] (z2 + order \<G> * c  * x2 - c * x2)"
    by (simp add: pow_carrier_mod)
  also have "... = \<^bold>g [^] (z1 + (order \<G> * c * x1 - c * x1)) \<otimes> g' [^] (z2 + (order \<G> * c * x2 - c * x2))"
    using h
    by (smt Nat.add_diff_assoc diff_zero le_simps(1) nat_0_less_mult_iff neq0_conv pow_distrib1 pow_distrib2 prime_gt_1_nat prime_order zero_less_diff)
  also have "... =  \<^bold>g [^] z1 \<otimes> \<^bold>g [^] (order \<G> * c * x1 - c * x1) \<otimes> g' [^] z2 \<otimes> g' [^] (order \<G> * c * x2 - c * x2)"
    using nat_pow_mult
    by (simp add: m_assoc)
  also have "... = \<^bold>g [^] z1 \<otimes> g' [^] z2 \<otimes> \<^bold>g [^] (order \<G> * c * x1 - c * x1) \<otimes> g' [^] (order \<G> * c * x2 - c * x2)"
    by (smt add.commute g'_def generator_closed m_assoc nat_pow_closed nat_pow_mult nat_pow_pow)
  also have "... = \<^bold>g [^] z1 \<otimes> g' [^] z2 \<otimes> \<^bold>g [^] ((order \<G> - 1) * c * x1) \<otimes> g' [^] ((order \<G> - 1) * c * x2)"
    using pow_distrib1 pow_distrib2 by argo
  also have "... = \<^bold>g [^] z1 \<otimes> g' [^] z2 \<otimes> (\<^bold>g [^] (order \<G> - 1)) [^] (c * x1) \<otimes> (g' [^] ((order \<G> - 1))) [^] (c * x2)"
    by (simp add: more_arith_simps(11) nat_pow_pow)
  also have "... = \<^bold>g [^] z1 \<otimes> g' [^] z2 \<otimes> (inv (\<^bold>g [^] c)) [^] x1 \<otimes> (inv (g' [^] c)) [^] x2"
    using assms neg_power_inverse  inverse_pow_pow nat_pow_pow prime_gt_1_nat prime_order by auto
  also have "... = \<^bold>g [^] z1 \<otimes> g' [^] z2 \<otimes> (inv ((\<^bold>g [^] c) [^] x1)) \<otimes> (inv ((g' [^] c) [^] x2))"
    by (simp add: inverse_pow_pow)
  also have "... = \<^bold>g [^] z1 \<otimes> g' [^] z2 \<otimes> ((inv ((\<^bold>g [^] x1) [^] c)) \<otimes> (inv ((g' [^] x2) [^] c)))"
    by (simp add: mult.commute cyclic_group_assoc nat_pow_pow)
  also have "... = \<^bold>g [^] z1 \<otimes> g' [^] z2 \<otimes> inv ((\<^bold>g [^] x1) [^] c \<otimes> (g' [^] x2) [^] c)"
    using inverse_split in_carrier2 in_carrier1 by simp
  also have "... = \<^bold>g [^] z1 \<otimes> g' [^] z2 \<otimes> inv (h [^] c)"
    using h  cyclic_group_commute monoid_comm_monoidI
    by (simp add: pow_mult_distrib)
  ultimately show ?thesis
    by (simp add: h inverse_pow_pow)
qed

lemma hv_zk:
  assumes "h =  \<^bold>g [^] x1 \<otimes> g' [^] x2"
  shows "\<Sigma>_protocols_base.R h (x1,x2) c = \<Sigma>_protocols_base.S h c"
  including monad_normalisation
proof-
  have "\<Sigma>_protocols_base.R h (x1,x2) c = do {
    r1 \<leftarrow> sample_uniform (order \<G>);
    r2 \<leftarrow> sample_uniform (order \<G>);
    let z1 = (r1 + c * x1) mod (order \<G>);
    let z2 = (r2 + c * x2) mod (order \<G>);
    return_spmf ( \<^bold>g [^] r1 \<otimes> g' [^] r2 ,c,(z1,z2))}"
      by(simp add: \<Sigma>_protocols_base.R_def R2_def; simp add: add.commute init_def split_def response_def)
    also have "... = do {
    r2 \<leftarrow> sample_uniform (order \<G>);
    z1 \<leftarrow> map_spmf (\<lambda> r1. (r1 + c * x1) mod (order \<G>)) (sample_uniform (order \<G>));
    let z2 = (r2 + c * x2) mod (order \<G>);
    return_spmf (\<^bold>g [^] ((z1 + order \<G> * c * x1 - c * x1) mod (order \<G>)) \<otimes> g' [^] r2 ,c,(z1,z2))}"
      by(simp add: bind_map_spmf o_def Let_def hvzk_z1_r1_tuple_rewrite assms cong: bind_spmf_cong_simp)
  also have "... = do {
    z1 \<leftarrow> map_spmf (\<lambda> r1. (r1 + c * x1) mod (order \<G>)) (sample_uniform (order \<G>));
    z2 \<leftarrow> map_spmf (\<lambda> r2. (r2 + c * x2) mod (order \<G>)) (sample_uniform (order \<G>));
    return_spmf (\<^bold>g [^] ((z1 + order \<G> * c * x1 - c * x1) mod (order \<G>)) \<otimes> g' [^] ((z2 + order \<G> * c * x2 - c * x2) mod (order \<G>)) ,c,(z1,z2))}"
    by(simp add: bind_map_spmf o_def Let_def hvzk_z2_r2_tuple_rewrite cong: bind_spmf_cong_simp)
  also have "... = do {
    z1 \<leftarrow> map_spmf (\<lambda> r1. (c * x1 + r1) mod (order \<G>)) (sample_uniform (order \<G>));
    z2 \<leftarrow> map_spmf (\<lambda> r2. (c * x2 + r2) mod (order \<G>)) (sample_uniform (order \<G>));
    return_spmf (\<^bold>g [^] ((z1 + order \<G> * c * x1 - c * x1) mod (order \<G>)) \<otimes> g' [^] ((z2 + order \<G> * c * x2 - c * x2) mod (order \<G>)) ,c,(z1,z2))}"
    by(simp add: add.commute)
  also have "... = do {
    z1 \<leftarrow> (sample_uniform (order \<G>));
    z2 \<leftarrow> (sample_uniform (order \<G>));
    return_spmf (\<^bold>g [^] ((z1 + order \<G> * c * x1 - c * x1) mod (order \<G>)) \<otimes> g' [^] ((z2 + order \<G> * c * x2 - c * x2) mod (order \<G>)) ,c,(z1,z2))}"
      by(simp add: samp_uni_plus_one_time_pad)
  also have "... = do {
    z1 \<leftarrow> (sample_uniform (order \<G>));
    z2 \<leftarrow> (sample_uniform (order \<G>));
    return_spmf ((\<^bold>g [^] z1 \<otimes> g' [^] z2) \<otimes> (inv h [^] c) ,c,(z1,z2))}"
      by(simp add: hvzk_sim_inverse_rewrite assms cong: bind_spmf_cong_simp)
  ultimately show ?thesis
    by(simp add: \<Sigma>_protocols_base.S_def S2_def bind_map_spmf map_spmf_conv_bind_spmf)
qed

lemma HVZK:
  shows "\<Sigma>_protocols_base.HVZK"
  unfolding \<Sigma>_protocols_base.HVZK_def
  apply(auto simp add: R_def challenge_space_def hv_zk S2_def check_def valid_pub_def)
  by (metis (no_types, lifting) cyclic_group_commute g'_in_carrier generator_closed inv_closed inv_solve_left inverse_pow_pow m_closed nat_pow_closed)

lemma ss_rewrite:
  assumes "h \<in> carrier \<G>"
    and "a \<in> carrier \<G>"
    and "e < order \<G>"
    and "\<^bold>g [^] z1 \<otimes> g' [^] z1' = a \<otimes> h [^] e"
    and "e' < e"
    and "\<^bold>g [^] z2 \<otimes> g' [^] z2' = a \<otimes> h [^] e' "
  shows "h = \<^bold>g [^] ((int z1 - int z2) * fst (bezw (e - e') (order \<G>)) mod int (order \<G>)) \<otimes> g' [^] ((int z1' - int z2') * fst (bezw (e - e') (order \<G>)) mod int (order \<G>))"
proof-
  have gcd: "gcd (e - e') (order \<G>) = 1"
    using prime_field assms prime_order by simp
  have "\<^bold>g [^] z1 \<otimes> g' [^] z1' \<otimes> inv (h [^] e) = a"
    by (simp add: inv_solve_right' assms)
  moreover have "\<^bold>g [^] z2 \<otimes> g' [^] z2' \<otimes> inv (h [^] e') = a"
    by (simp add: assms inv_solve_right')
  ultimately have "\<^bold>g [^] z2 \<otimes> g' [^] z2' \<otimes> inv (h [^] e') = \<^bold>g [^] z1 \<otimes> g' [^] z1' \<otimes> inv (h [^] e)"
    using g'_def by (simp add: nat_pow_pow)
  moreover obtain t :: nat where t: "h = \<^bold>g [^] t"
    using assms generatorE by blast
  ultimately have "\<^bold>g [^] z2 \<otimes> \<^bold>g [^] (x * z2') \<otimes> \<^bold>g [^] (t * e) = \<^bold>g [^] z1 \<otimes> \<^bold>g [^] (x * z1') \<otimes> (\<^bold>g [^] (t * e'))"
    using assms(2) assms(4) cyclic_group_commute m_assoc g'_def nat_pow_pow by auto
  hence "\<^bold>g [^] (z2 + x * z2' + t * e) = \<^bold>g [^] (z1 + x * z1' + t * e')"
    by (simp add: nat_pow_mult)
  hence "[z2 + x * z2' + t * e = z1 + x * z1' + t * e'] (mod order \<G>)"
    using group_eq_pow_eq_mod order_gt_0 by blast
  hence "[int z2 + int x * int z2' + int t * int e = int z1 + int x * int z1' + int t * int e'] (mod order \<G>)"
    using cong_int_iff by force
  hence "[int z1 + int x * int z1' - int z2 - int x * int z2' = int t * int e - int t * int e'] (mod order \<G>)"
    by (smt cong_diff_iff_cong_0 cong_sym)
  hence "[int z1 + int x * int z1' - int z2 - int x * int z2' = int t * (e - e')] (mod order \<G>)"
    using int_distrib(4) assms by (simp add: of_nat_diff)
  hence "[(int z1 + int x * int z1' - int z2 - int x * int z2') * fst (bezw (e - e') (order \<G>)) = int t * (e - e') * fst (bezw (e - e') (order \<G>))] (mod order \<G>)"
    using cong_scalar_right by blast
  hence "[(int z1 + int x * int z1' - int z2 - int x * int z2') * fst (bezw (e - e') (order \<G>)) = int t * ((e - e') * fst (bezw (e - e') (order \<G>)))] (mod order \<G>)"
    by (simp add: mult.assoc)
  hence "[(int z1 + int x * int z1' - int z2 - int x * int z2') * fst (bezw (e - e') (order \<G>)) = int t * 1] (mod order \<G>)"
    by (metis (no_types, hide_lams) cong_scalar_left cong_trans inverse gcd)
  hence "[(int z1 - int z2 + int x * int z1' - int x * int z2') * fst (bezw (e - e') (order \<G>)) = int t] (mod order \<G>)"
    by smt
  hence "[(int z1 - int z2 + int x * (int z1' - int z2')) * fst (bezw (e - e') (order \<G>)) = int t] (mod order \<G>)"
    by (simp add: Rings.ring_distribs(4) add_diff_eq)
  hence "[nat ((int z1 - int z2 + int x * (int z1' - int z2')) * fst (bezw (e - e') (order \<G>)) mod (order \<G>)) = int t] (mod order \<G>)"
    by auto
  hence "\<^bold>g [^] (nat ((int z1 - int z2 + int x * (int z1' - int z2')) * fst (bezw (e - e') (order \<G>)) mod (order \<G>))) = \<^bold>g [^] t"
    using cong_int_iff finite_carrier pow_generator_eq_iff_cong by blast
  hence "\<^bold>g [^] ((int z1 - int z2 + int x * (int z1' - int z2')) * fst (bezw (e - e') (order \<G>))) = \<^bold>g [^] t"
    using pow_generator_mod_int by auto
  hence "\<^bold>g [^] ((int z1 - int z2) * fst (bezw (e - e') (order \<G>)) + int x * (int z1' - int z2') * fst (bezw (e - e') (order \<G>))) = \<^bold>g [^] t"
    by (metis Rings.ring_distribs(2) t)
  hence "\<^bold>g [^] ((int z1 - int z2) * fst (bezw (e - e') (order \<G>))) \<otimes> \<^bold>g [^] (int x * (int z1' - int z2') * fst (bezw (e - e') (order \<G>))) = \<^bold>g [^] t"
    using int_pow_mult by auto
  thus ?thesis
    by (metis (mono_tags, hide_lams) g'_def generator_closed int_pow_int int_pow_pow mod_mult_right_eq more_arith_simps(11) pow_generator_mod_int t)
qed

lemma
  assumes h_mem: "h \<in> carrier \<G>"
    and a_mem: "a \<in> carrier \<G>"
    and a: "\<^bold>g [^] fst z \<otimes> g' [^] snd z = a \<otimes> h [^] e"
    and a': "\<^bold>g [^] fst z' \<otimes> g' [^] snd z' = a \<otimes> h [^] e'"
    and e_e'_mod: "e' mod order \<G> < e mod order \<G>"
  shows "h = \<^bold>g [^] ((int (fst z) - int (fst z')) * fst (bezw ((e mod order \<G> - e' mod order \<G>) mod order \<G>) (order \<G>)) mod int (order \<G>))
              \<otimes> g' [^] ((int (snd z) - int (snd z')) * fst (bezw ((e mod order \<G> - e' mod order \<G>) mod order \<G>) (order \<G>)) mod int (order \<G>))"
proof-
  have gcd: "gcd ((e mod order \<G> - e' mod order \<G>) mod order \<G>) (order \<G>) = 1"
    using prime_field
    by (simp add: assms less_imp_diff_less linorder_not_le prime_order)
  have "\<^bold>g [^] fst z \<otimes> g' [^] snd z \<otimes> inv (h [^] e) = a"
    using a h_mem a_mem by (simp add: inv_solve_right')
  moreover have "\<^bold>g [^] fst z' \<otimes> g' [^] snd z' \<otimes> inv (h [^] e') = a"
    using a h_mem a_mem by (simp add: assms(4) inv_solve_right')
  ultimately have "\<^bold>g [^] fst z \<otimes> \<^bold>g [^] (x * snd z) \<otimes> inv (h [^] e) = \<^bold>g [^] fst z' \<otimes> \<^bold>g [^] (x * snd z') \<otimes> inv (h [^] e')"
    using g'_def by (simp add: nat_pow_pow)
  moreover obtain t :: nat where t: "h = \<^bold>g [^] t"
    using h_mem generatorE by blast
  ultimately have "\<^bold>g [^] fst z \<otimes> \<^bold>g [^] (x * snd z) \<otimes> \<^bold>g [^] (t * e') = \<^bold>g [^] fst z' \<otimes> \<^bold>g [^] (x * snd z') \<otimes> \<^bold>g [^] (t * e)"
    using a_mem assms(3) assms(4) cyclic_group_assoc cyclic_group_commute g'_def nat_pow_pow by auto
  hence "\<^bold>g [^] (fst z + x * snd z + t * e') = \<^bold>g [^] (fst z' + x * snd z' + t * e)"
    by (simp add: nat_pow_mult)
  hence "[fst z + x * snd z + t * e' = fst z' + x * snd z' + t * e] (mod order \<G>)"
    using group_eq_pow_eq_mod order_gt_0 by blast
  hence "[int (fst z) + int x * int (snd z) + int t * int e' = int (fst z') + int x * int (snd z') + int t * int e] (mod order \<G>)"
    using cong_int_iff by force
  hence "[int (fst z) - int (fst z') + int x * int (snd z) - int x * int (snd z') =  int t * int e - int t  * int e'] (mod order \<G>)"
    by (smt cong_diff_iff_cong_0)
  hence "[int (fst z) - int (fst z') + int x * (int (snd z) - int (snd z')) =  int t * (int e -  int e')] (mod order \<G>)"
  proof -
    have "[int (fst z) + (int (x * snd z) - (int (fst z') + int (x * snd z'))) = int t * (int e - int e')] (mod int (order \<G>))"
      by (simp add: Rings.ring_distribs(4) \<open>[int (fst z) - int (fst z') + int x * int (snd z) - int x * int (snd z') = int t * int e - int t * int e'] (mod int (order \<G>))\<close> add_diff_add add_diff_eq)
    then have "\<exists>i. [int (fst z) + (int x * int (snd z) - (int (fst z') + i * int (snd z'))) = int t * (int e - int e') + int (snd z') * (int x - i)] (mod int (order \<G>))"
      by (metis (no_types) add.commute arith_simps(49) cancel_comm_monoid_add_class.diff_cancel int_ops(7) mult_eq_0_iff)
    then have "\<exists>i. [int (fst z) - int (fst z') + (int x * (int (snd z) - int (snd z')) + i) = int t * (int e - int e') + i] (mod int (order \<G>))"
      by (metis (no_types) add_diff_add add_diff_eq mult_diff_mult mult_of_nat_commute)
    then show ?thesis
      by (metis (no_types) add.assoc cong_add_rcancel)
  qed
  hence "[int (fst z) - int (fst z') + int x * (int (snd z) - int (snd z')) =  int t * (int e mod order \<G> - int e' mod order \<G>) mod order \<G>] (mod order \<G>)"
    by (metis (mono_tags, lifting) cong_def mod_diff_eq mod_mod_trivial mod_mult_right_eq)
  hence "[int (fst z) - int (fst z') + int x * (int (snd z) - int (snd z')) =  int t * (e mod order \<G> - e' mod order \<G>) mod order \<G>] (mod order \<G>)"
    using e_e'_mod
    by (simp add: int_ops(9) of_nat_diff)
  hence "[(int (fst z) - int (fst z') + int x * (int (snd z) - int (snd z')))
            * fst (bezw ((e mod order \<G> - e' mod order \<G>) mod order \<G>) (order \<G>)) mod order \<G>
               =  int t * (e mod order \<G> - e' mod order \<G>) mod order \<G>
                  * fst (bezw ((e mod order \<G> - e' mod order \<G>) mod order \<G>) (order \<G>)) mod order \<G>] (mod order \<G>)"
    using cong_cong_mod_int cong_scalar_right by blast
  hence "[(int (fst z) - int (fst z') + int x * (int (snd z) - int (snd z')))
            * fst (bezw ((e mod order \<G> - e' mod order \<G>) mod order \<G>) (order \<G>)) mod order \<G>
               =  int t * ((e mod order \<G> - e' mod order \<G>) mod order \<G>
                  * fst (bezw ((e mod order \<G> - e' mod order \<G>) mod order \<G>) (order \<G>)) mod order \<G>)] (mod order \<G>)"
    by (metis (no_types, lifting) Groups.mult_ac(1) cong_mod_right less_imp_diff_less mod_less mod_mult_left_eq mod_mult_right_eq order_gt_0 unique_euclidean_semiring_numeral_class.pos_mod_bound)
  hence "[(int (fst z) - int (fst z') + int x * (int (snd z) - int (snd z')))
            * fst (bezw ((e mod order \<G> - e' mod order \<G>) mod order \<G>) (order \<G>)) mod order \<G>
               =  int t * 1] (mod order \<G>)"
    using inverse gcd
    by (smt Num.of_nat_simps(5) Number_Theory_Aux.inverse cong_def mod_mult_right_eq more_arith_simps(6) of_nat_1)
  hence "[((int (fst z) - int (fst z')) + (int x * (int (snd z) - int (snd z'))))
            * fst (bezw ((e mod order \<G> - e' mod order \<G>) mod order \<G>) (order \<G>)) mod order \<G>
               = int t] (mod order \<G>)"
    by auto
  hence "[(int (fst z) - int (fst z')) * (fst (bezw ((e mod order \<G> - e' mod order \<G>) mod order \<G>) (order \<G>)) mod order \<G>) + (int x * (int (snd z) - int (snd z')))
            * (fst (bezw ((e mod order \<G> - e' mod order \<G>) mod order \<G>) (order \<G>)) mod order \<G>)
               = int t] (mod order \<G>)"
    by (metis (no_types, hide_lams) cong_mod_left distrib_right mod_mult_right_eq)
  hence "[(int (fst z) - int (fst z')) * fst (bezw ((e mod order \<G> - e' mod order \<G>) mod order \<G>) (order \<G>)) mod order \<G> + (int x * (int (snd z) - int (snd z')))
            * (fst (bezw ((e mod order \<G> - e' mod order \<G>) mod order \<G>) (order \<G>)) mod order \<G>)
               = t] (mod order \<G>)"
  proof -
    have "[(int (fst z) - int (fst z')) * fst (bezw ((e mod order \<G> - e' mod order \<G>) mod order \<G>) (order \<G>)) = (int (fst z) - int (fst z')) * (fst (bezw ((e mod order \<G> - e' mod order \<G>) mod order \<G>) (order \<G>)) mod int (order \<G>))] (mod int (order \<G>))"
      by (metis (no_types) cong_def mod_mult_right_eq)
    then show ?thesis
      by (meson \<open>[(int (fst z) - int (fst z')) * (fst (bezw ((e mod order \<G> - e' mod order \<G>) mod order \<G>) (order \<G>)) mod int (order \<G>)) + int x * (int (snd z) - int (snd z')) * (fst (bezw ((e mod order \<G> - e' mod order \<G>) mod order \<G>) (order \<G>)) mod int (order \<G>)) = int t] (mod int (order \<G>))\<close> cong_add_rcancel cong_mod_left cong_trans)
  qed
  hence "[(int (fst z) - int (fst z')) * fst (bezw ((e mod order \<G> - e' mod order \<G>) mod order \<G>) (order \<G>)) mod order \<G> + (int x * (int (snd z) - int (snd z')))
            * fst (bezw ((e mod order \<G> - e' mod order \<G>) mod order \<G>) (order \<G>)) mod order \<G>
               = t] (mod order \<G>)"
  proof -
    have "int x * ((int (snd z) - int (snd z')) * (fst (bezw ((e mod order \<G> - e' mod order \<G>) mod order \<G>) (order \<G>)) mod int (order \<G>))) mod int (order \<G>) = int x * ((int (snd z) - int (snd z')) * fst (bezw ((e mod order \<G> - e' mod order \<G>) mod order \<G>) (order \<G>))) mod int (order \<G>) mod int (order \<G>)"
      by (metis (no_types) mod_mod_trivial mod_mult_right_eq)
    then have "[int x * ((int (snd z) - int (snd z')) * fst (bezw ((e mod order \<G> - e' mod order \<G>) mod order \<G>) (order \<G>))) mod int (order \<G>) = int x * ((int (snd z) - int (snd z')) * (fst (bezw ((e mod order \<G> - e' mod order \<G>) mod order \<G>) (order \<G>)) mod int (order \<G>)))] (mod int (order \<G>))"
      by (metis (no_types) cong_def)
    then have "[(int (fst z) - int (fst z')) * fst (bezw ((e mod order \<G> - e' mod order \<G>) mod order \<G>) (order \<G>)) mod int (order \<G>) + int x * ((int (snd z) - int (snd z')) * fst (bezw ((e mod order \<G> - e' mod order \<G>) mod order \<G>) (order \<G>))) mod int (order \<G>) = (int (fst z) - int (fst z')) * fst (bezw ((e mod order \<G> - e' mod order \<G>) mod order \<G>) (order \<G>)) mod int (order \<G>) + int x * (int (snd z) - int (snd z')) * (fst (bezw ((e mod order \<G> - e' mod order \<G>) mod order \<G>) (order \<G>)) mod int (order \<G>))] (mod int (order \<G>))"
      by (metis (no_types) Groups.mult_ac(1) cong_add cong_refl)
    then have "[(int (fst z) - int (fst z')) * fst (bezw ((e mod order \<G> - e' mod order \<G>) mod order \<G>) (order \<G>)) mod int (order \<G>) + int x * ((int (snd z) - int (snd z')) * fst (bezw ((e mod order \<G> - e' mod order \<G>) mod order \<G>) (order \<G>))) mod int (order \<G>) = int t] (mod int (order \<G>))"
      using \<open>[(int (fst z) - int (fst z')) * fst (bezw ((e mod order \<G> - e' mod order \<G>) mod order \<G>) (order \<G>)) mod int (order \<G>) + int x * (int (snd z) - int (snd z')) * (fst (bezw ((e mod order \<G> - e' mod order \<G>) mod order \<G>) (order \<G>)) mod int (order \<G>)) = int t] (mod int (order \<G>))\<close> cong_trans by blast
    then show ?thesis
      by (metis (no_types) Groups.mult_ac(1))
  qed
  hence "\<^bold>g [^] ((int (fst z) - int (fst z')) * fst (bezw ((e mod order \<G> - e' mod order \<G>) mod order \<G>) (order \<G>)) mod order \<G> + (int x * (int (snd z) - int (snd z')))
            * fst (bezw ((e mod order \<G> - e' mod order \<G>) mod order \<G>) (order \<G>)) mod order \<G>)
               = \<^bold>g [^] t"
    by (metis cong_def int_pow_int pow_generator_mod_int)
  hence "\<^bold>g [^] ((int (fst z) - int (fst z')) * fst (bezw ((e mod order \<G> - e' mod order \<G>) mod order \<G>) (order \<G>)) mod order \<G>) \<otimes> \<^bold>g [^] ((int x * (int (snd z) - int (snd z')))
            * fst (bezw ((e mod order \<G> - e' mod order \<G>) mod order \<G>) (order \<G>)) mod order \<G>)
               = \<^bold>g [^] t"
    using int_pow_mult by auto
  hence "\<^bold>g [^] ((int (fst z) - int (fst z')) * fst (bezw ((e mod order \<G> - e' mod order \<G>) mod order \<G>) (order \<G>)) mod order \<G>) \<otimes> \<^bold>g [^] ((int x * ((int (snd z) - int (snd z')))
            * fst (bezw ((e mod order \<G> - e' mod order \<G>) mod order \<G>) (order \<G>)) mod order \<G>))
               = \<^bold>g [^] t"
    by blast
  hence "\<^bold>g [^] ((int (fst z) - int (fst z')) * fst (bezw ((e mod order \<G> - e' mod order \<G>) mod order \<G>) (order \<G>)) mod order \<G>) \<otimes> g' [^] ((((int (snd z) - int (snd z')))
            * fst (bezw ((e mod order \<G> - e' mod order \<G>) mod order \<G>) (order \<G>)) mod order \<G>))
               = \<^bold>g [^] t"
    by (smt g'_def cyclic_group.generator_closed int_pow_int int_pow_pow mod_mult_right_eq more_arith_simps(11) okamoto_axioms okamoto_def pow_generator_mod_int)
  thus ?thesis using t by simp
qed

lemma special_soundness:
  shows "\<Sigma>_protocols_base.special_soundness"
  unfolding \<Sigma>_protocols_base.special_soundness_def
  by(auto simp add: valid_pub_def check_def R_def ss_adversary_def Let_def ss_rewrite challenge_space_def split_def)

theorem \<Sigma>_protocol:
  shows "\<Sigma>_protocols_base.\<Sigma>_protocol"
  by(simp add: \<Sigma>_protocols_base.\<Sigma>_protocol_def completeness HVZK special_soundness)

sublocale okamoto_\<Sigma>_commit: \<Sigma>_protocols_to_commitments init response check R S2 ss_adversary challenge_space valid_pub G
  apply unfold_locales
  apply(auto simp add: \<Sigma>_protocol)
  by(auto simp add: G_def R_def lossless_init lossless_response)

sublocale dis_log: dis_log \<G>
  unfolding dis_log_def by simp

sublocale dis_log_alt: dis_log_alt \<G> x
  unfolding dis_log_alt_def
  by(simp add:)

lemma reduction_to_dis_log:
  shows "okamoto_\<Sigma>_commit.rel_advantage \<A> = dis_log.advantage (dis_log_alt.adversary2 \<A>)"
proof-
  have exp_rewrite: "\<^bold>g [^] w1 \<otimes> g' [^] w2 =  \<^bold>g [^] (w1 + x * w2)" for w1 w2 :: nat
    by (simp add: nat_pow_mult nat_pow_pow g'_def)
  have "okamoto_\<Sigma>_commit.rel_game \<A> = TRY do {
    w1 \<leftarrow> sample_uniform (order \<G>);
    w2 \<leftarrow> sample_uniform (order \<G>);
    let h = (\<^bold>g [^] w1 \<otimes> g' [^] w2);
    (w1',w2') \<leftarrow> \<A> h;
    return_spmf (h = \<^bold>g [^] w1' \<otimes> g' [^] w2')} ELSE return_spmf False"
    unfolding okamoto_\<Sigma>_commit.rel_game_def
    by(simp add: Let_def split_def R_def G_def)
  also have "... = TRY do {
    w1 \<leftarrow> sample_uniform (order \<G>);
    w2 \<leftarrow> sample_uniform (order \<G>);
    let w = (w1 + x * w2) mod (order \<G>);
    let h = \<^bold>g [^] w;
    (w1',w2') \<leftarrow> \<A> h;
    return_spmf (h = \<^bold>g [^] w1' \<otimes> g' [^] w2')} ELSE return_spmf False"
    using g'_def exp_rewrite pow_generator_mod by simp
  also have "... = TRY do {
    w2 \<leftarrow> sample_uniform (order \<G>);
    w \<leftarrow> map_spmf (\<lambda> w1. (x * w2 + w1) mod (order \<G>)) (sample_uniform (order \<G>));
    let h = \<^bold>g [^] w;
    (w1',w2') \<leftarrow> \<A> h;
    return_spmf (h = \<^bold>g [^] w1' \<otimes> g' [^] w2')} ELSE return_spmf False"
    including monad_normalisation
    by(simp add: bind_map_spmf o_def Let_def add.commute)
  also have "... = TRY do {
    w2 :: nat \<leftarrow> sample_uniform (order \<G>);
    w \<leftarrow> sample_uniform (order \<G>);
    let h = \<^bold>g [^] w;
    (w1',w2') \<leftarrow> \<A> h;
    return_spmf (h = \<^bold>g [^] w1' \<otimes> g' [^] w2')} ELSE return_spmf False"
    using samp_uni_plus_one_time_pad add.commute by simp
  also have "... = TRY do {
    w \<leftarrow> sample_uniform (order \<G>);
    let h = \<^bold>g [^] w;
    (w1',w2') \<leftarrow> \<A> h;
    return_spmf (h = \<^bold>g [^] w1' \<otimes> g' [^] w2')} ELSE return_spmf False"
    by(simp add: bind_spmf_const)
  also have "... = dis_log_alt.dis_log2 \<A>"
    apply(simp add: dis_log_alt.dis_log2_def Let_def dis_log_alt.g'_def g'_def)
    apply(intro try_spmf_cong)
     apply(intro bind_spmf_cong[OF refl]; clarsimp?)
     apply auto
    using exp_rewrite pow_generator_mod g'_def
     apply (metis group_eq_pow_eq_mod okamoto_axioms okamoto_base.order_gt_0 okamoto_def)
    using exp_rewrite g'_def order_gt_0_iff_finite pow_generator_eq_iff_cong by auto
  ultimately have "okamoto_\<Sigma>_commit.rel_game \<A> = dis_log_alt.dis_log2 \<A>"
    by simp
  hence "okamoto_\<Sigma>_commit.rel_advantage \<A> = dis_log_alt.advantage2 \<A>"
    by(simp add: okamoto_\<Sigma>_commit.rel_advantage_def dis_log_alt.advantage2_def)
  thus ?thesis
    by (simp add: dis_log_alt_reductions.dis_log_adv2 cyclic_group_axioms dis_log_alt.dis_log_alt_axioms dis_log_alt_reductions.intro)
qed

lemma commitment_correct: "okamoto_\<Sigma>_commit.abstract_com.correct"
  by(simp add: okamoto_\<Sigma>_commit.commit_correct)

lemma "okamoto_\<Sigma>_commit.abstract_com.perfect_hiding_ind_cpa \<A>"
  using okamoto_\<Sigma>_commit.perfect_hiding by blast

end

locale okamoto_asymp =
  fixes \<G> :: "nat \<Rightarrow> 'grp cyclic_group"
    and x :: nat
  assumes okamoto: "\<And>\<eta>. okamoto (\<G> \<eta>)"
begin

sublocale okamoto "\<G> \<eta>" for \<eta>
  by(simp add: okamoto)

text\<open>The \<open>\<Sigma>\<close>-protocol statement comes easily in the asympotic setting.\<close>

theorem sigma_protocol:
  shows "\<Sigma>_protocols_base.\<Sigma>_protocol n"
  by(simp add: \<Sigma>_protocol)

text\<open>We now show the statements of security for the commitment scheme in the asymptotic setting, the main difference is that
we are able to show the binding advantage is negligible in the security parameter.\<close>

lemma asymp_correct: "okamoto_\<Sigma>_commit.abstract_com.correct n"
  using  okamoto_\<Sigma>_commit.commit_correct by simp

lemma asymp_perfect_hiding: "okamoto_\<Sigma>_commit.abstract_com.perfect_hiding_ind_cpa n (\<A> n)"
  using okamoto_\<Sigma>_commit.perfect_hiding by blast

end

end


(* Title:      Antidomain Semirings
   Author:     Victor B. F. Gomes, Walter Guttmann, Peter Höfner, Georg Struth, Tjark Weber
   Maintainer: Walter Guttmann <walter.guttman at canterbury.ac.nz>
               Georg Struth <g.struth at sheffield.ac.uk>
               Tjark Weber <tjark.weber at it.uu.se>
*)

section \<open>Antidomain Semirings\<close>

theory Antidomain_Semiring
imports Domain_Semiring
begin

subsection \<open>Antidomain Monoids\<close>

text \<open>We axiomatise antidomain monoids, using the axioms of~\cite{DesharnaisJipsenStruth}.\<close>

class antidomain_op =
  fixes antidomain_op :: "'a \<Rightarrow> 'a" ("ad")

class antidomain_left_monoid = monoid_mult + antidomain_op +
  assumes am1 [simp]: "ad x \<cdot> x = ad 1"
  and am2: "ad x \<cdot> ad y = ad y \<cdot> ad x"
  and am3 [simp]: "ad (ad x) \<cdot> x = x"
  and am4 [simp]: "ad (x \<cdot> y) \<cdot> ad (x \<cdot> ad y) = ad x"
  and am5 [simp]: "ad (x \<cdot> y) \<cdot> x \<cdot> ad y = ad (x \<cdot> y) \<cdot> x"

begin

no_notation domain_op ("d")
no_notation zero_class.zero ("0")

text \<open>We define a zero element and operations of domain and addition.\<close>

definition a_zero :: "'a" ("0") where
  "0 = ad 1"

definition am_d :: "'a \<Rightarrow> 'a" ("d") where
   "d x = ad (ad x)"

definition am_add_op :: "'a \<Rightarrow> 'a \<Rightarrow> 'a" (infixl "\<oplus>" 65) where
  "x \<oplus> y \<equiv> ad (ad x \<cdot> ad y)"

lemma a_d_zero [simp]: "ad x \<cdot> d x = 0"
  by (metis am1 am2 a_zero_def am_d_def)

lemma a_d_one [simp]: "d x \<oplus> ad x = 1"
  by (metis am1 am3 mult_1_right am_d_def am_add_op_def)

lemma n_annil [simp]: "0 \<cdot> x = 0"
proof -
  have "0 \<cdot> x = d x \<cdot> ad x \<cdot> x"
    by (simp add: a_zero_def am_d_def)
  also have "... = d x \<cdot> 0"
    by (metis am1 mult_assoc a_zero_def)
  thus ?thesis
    by (metis am1 am2 am3 mult_assoc a_zero_def)
qed

lemma a_mult_idem [simp]: "ad x \<cdot> ad x = ad x"
proof -
  have "ad x \<cdot> ad x = ad (1 \<cdot> x) \<cdot> 1 \<cdot> ad x"
    by simp
  also have "... = ad (1 \<cdot> x) \<cdot> 1"
    using am5 by blast
  finally show ?thesis
    by simp
qed

lemma a_add_idem [simp]: "ad x \<oplus> ad x = ad x"
  by (metis am1 am3 am4 mult_1_right am_add_op_def)

text \<open>The next three axioms suffice to show that the domain elements form a Boolean algebra.\<close>

lemma a_add_comm: "x \<oplus> y = y \<oplus> x"
  using am2 am_add_op_def by auto

lemma a_add_assoc: "x \<oplus> (y \<oplus> z) = (x \<oplus> y) \<oplus> z"
proof -
  have "\<And>x y. ad x \<cdot> ad (x \<cdot> y) = ad x"
    by (metis a_mult_idem am2 am4 mult_assoc)
  thus ?thesis
    by (metis a_add_comm am_add_op_def local.am3 local.am4 mult_assoc)
qed

lemma huntington [simp]: "ad (x \<oplus> y) \<oplus> ad (x \<oplus> ad y) = ad x"
  using a_add_idem am_add_op_def by auto

lemma a_absorb1 [simp]: "(ad x \<oplus> ad y) \<cdot> ad x = ad x"
  by (metis a_add_idem a_mult_idem am4 mult_assoc am_add_op_def)

lemma a_absorb2 [simp]: "ad x \<oplus> ad x \<cdot> ad y = ad x"
proof -
  have "ad (ad x) \<cdot> ad (ad x \<cdot> ad y) = ad (ad x)"
    by (metis (no_types) a_mult_idem local.am4 local.mult.semigroup_axioms semigroup.assoc)
  then show ?thesis
    using a_add_idem am_add_op_def by auto
qed

text \<open>The distributivity laws remain to be proved; our proofs follow those of Maddux~\cite{Maddux}.\<close>

lemma prod_split [simp]: "ad x \<cdot> ad y \<oplus> ad x \<cdot> d y = ad x"
  using a_add_idem am_d_def am_add_op_def by auto

lemma sum_split [simp]: "(ad x \<oplus> ad y) \<cdot> (ad x \<oplus> d y) = ad x"
  using a_add_idem am_d_def am_add_op_def by fastforce

lemma a_comp_simp [simp]: "(ad x \<oplus> ad y) \<cdot> d x = ad y \<cdot> d x"
proof -
  have f1: "(ad x \<oplus> ad y) \<cdot> d x = ad (ad (ad x) \<cdot> ad (ad y)) \<cdot> ad (ad x) \<cdot> ad (ad (ad y))"
    by (simp add: am_add_op_def am_d_def)
  have f2: "ad y = ad (ad (ad y))"
    using a_add_idem am_add_op_def by auto
  have "ad y = ad (ad (ad x) \<cdot> ad (ad y)) \<cdot> ad y"
    by (metis (no_types) a_absorb1 a_add_comm am_add_op_def)
  then show ?thesis
    using f2 f1 by (simp add: am_d_def local.am2 local.mult.semigroup_axioms semigroup.assoc)
qed

lemma a_distrib1: "ad x \<cdot> (ad y \<oplus> ad z) = ad x \<cdot> ad y \<oplus> ad x \<cdot> ad z"
proof -
  have f1: "\<And>a. ad (ad (ad (a::'a)) \<cdot> ad (ad a)) = ad a"
    using a_add_idem am_add_op_def by auto
  have f2: "\<And>a aa. ad ((a::'a) \<cdot> aa) \<cdot> (a \<cdot> ad aa) = ad (a \<cdot> aa) \<cdot> a"
    using local.am5 mult_assoc by auto
  have f3: "\<And>a. ad (ad (ad (a::'a))) = ad a"
    using f1 by simp
  have "\<And>a. ad (a::'a) \<cdot> ad a = ad a"
    by simp
  then have "\<And>a aa. ad (ad (ad (a::'a) \<cdot> ad aa)) = ad aa \<cdot> ad a"
    using f3 f2 by (metis (no_types) local.am2 local.am4 mult_assoc)
  then have  "ad x \<cdot> (ad y \<oplus> ad z) = ad x \<cdot> (ad y \<oplus> ad z) \<cdot> ad y \<oplus> ad x \<cdot> (ad y \<oplus> ad z) \<cdot> d y"
    using am_add_op_def am_d_def local.am2 local.am4 by presburger
  also have "... = ad x \<cdot> ad y \<oplus> ad x \<cdot> (ad y \<oplus> ad z) \<cdot> d y"
    by (simp add: mult_assoc)
  also have "... = ad x \<cdot> ad y \<oplus> ad x \<cdot> ad z \<cdot> d y"
    by (simp add: mult_assoc)
  also have "... = ad x \<cdot> ad y \<oplus> ad x \<cdot> ad y \<cdot> ad z \<oplus> ad x \<cdot> ad z \<cdot> d y"
    by (metis a_add_idem a_mult_idem local.am4 mult_assoc am_add_op_def)
  also have "... = ad x \<cdot> ad y \<oplus> (ad x \<cdot> ad z \<cdot> ad y \<oplus> ad x \<cdot> ad z \<cdot> d y)"
    by (metis am2 mult_assoc a_add_assoc)
  finally show ?thesis
    by (metis a_add_idem a_mult_idem am4 am_d_def am_add_op_def)
qed

lemma a_distrib2: "ad x \<oplus> ad y \<cdot> ad z = (ad x \<oplus> ad y) \<cdot> (ad x \<oplus> ad z)"
proof -
  have f1: "\<And>a aa ab. ad (ad (ad (a::'a) \<cdot> ad aa) \<cdot> ad (ad a \<cdot> ad ab)) = ad a \<cdot> ad (ad (ad aa) \<cdot> ad (ad ab))"
    using a_distrib1 am_add_op_def by auto
  have "\<And>a. ad (ad (ad (a::'a))) = ad a"
    by (metis a_absorb2 a_mult_idem am_add_op_def)
  then have "ad (ad (ad x) \<cdot> ad (ad y)) \<cdot> ad (ad (ad x) \<cdot> ad (ad z)) = ad (ad (ad x) \<cdot> ad (ad y \<cdot> ad z))"
    using f1 by (metis (full_types))
  then show ?thesis
    by (simp add: am_add_op_def)
qed

lemma aa_loc [simp]: "d (x \<cdot> d y) = d (x \<cdot> y)"
proof -
  have f1: "x \<cdot> d y \<cdot> y = x \<cdot> y"
    by (metis am3 mult_assoc am_d_def)
  have f2: "\<And>w z. ad (w \<cdot> z) \<cdot> (w \<cdot> ad z) = ad (w \<cdot> z) \<cdot> w"
    by (metis am5 mult_assoc)
  hence f3: "\<And>z. ad (x \<cdot> y) \<cdot> (x \<cdot> z) = ad (x \<cdot> y) \<cdot> (x \<cdot> (ad (ad (ad y) \<cdot> y) \<cdot> z))"
    using f1 by (metis (no_types) mult_assoc am_d_def)
  have "ad (x \<cdot> ad (ad y)) \<cdot> (x \<cdot> y) = 0" using f1
    by (metis am1 mult_assoc n_annil a_zero_def am_d_def)
  thus ?thesis
    by (metis a_d_zero am_d_def f3 local.am1 local.am2 local.am3 local.am4)
qed

lemma a_loc [simp]: "ad (x \<cdot> d y) = ad (x \<cdot> y)"
proof -
  have "\<And>a. ad (ad (ad (a::'a))) = ad a"
    using am_add_op_def am_d_def prod_split by auto
  then show ?thesis
    by (metis (full_types) aa_loc am_d_def)
qed

lemma d_a_export [simp]: "d (ad x \<cdot> y) = ad x \<cdot> d y"
proof -
  have f1: "\<And>a aa. ad ((a::'a) \<cdot> ad (ad aa)) = ad (a \<cdot> aa)"
    using a_loc am_d_def by auto
  have "\<And>a. ad (ad (a::'a) \<cdot> a) = 1"
    using a_d_one am_add_op_def am_d_def by auto
  then have "\<And>a aa. ad (ad (ad (a::'a) \<cdot> ad aa)) = ad a \<cdot> ad aa"
    using f1 by (metis a_distrib2 am_add_op_def local.mult_1_left)
  then show ?thesis
    using f1 by (metis (no_types) am_d_def)
qed

text \<open>Every antidomain monoid is a domain monoid.\<close>

sublocale dm: domain_monoid am_d "(\<cdot>)" 1
  apply (unfold_locales)
  apply (simp add: am_d_def)
  apply simp
  using am_d_def d_a_export apply auto[1]
  by (simp add: am_d_def local.am2)

lemma ds_ord_iso1: "x \<sqsubseteq> y \<Longrightarrow> z \<cdot> x \<sqsubseteq> z \<cdot> y"
(*nitpick [expect=genuine]*)
oops

lemma a_very_costrict: "ad x = 1 \<longleftrightarrow> x = 0"
proof
  assume a: "ad x = 1"
  hence "0 = ad x \<cdot> x"
    using a_zero_def by force
  thus "x = 0"
    by (simp add: a)
next
  assume "x = 0"
  thus "ad x = 1"
    using a_zero_def am_d_def dm.dom_one by auto
qed

lemma a_weak_loc: "x \<cdot> y = 0 \<longleftrightarrow> x \<cdot> d y = 0"
proof -
  have "x \<cdot> y = 0 \<longleftrightarrow> ad (x \<cdot> y) = 1"
    by (simp add: a_very_costrict)
  also have "... \<longleftrightarrow> ad (x \<cdot> d y) = 1"
    by simp
  finally show ?thesis
    using a_very_costrict by blast
qed

lemma a_closure [simp]: "d (ad x) = ad x"
  using a_add_idem am_add_op_def am_d_def by auto

lemma a_d_mult_closure [simp]: "d (ad x \<cdot> ad y) = ad x \<cdot> ad y"
  by simp

lemma kat_3': "d x \<cdot> y \<cdot> ad z = 0 \<Longrightarrow> d x \<cdot> y = d x \<cdot> y \<cdot> d z"
  by (metis dm.dom_one local.am5 local.mult_1_left a_zero_def am_d_def)

lemma s4 [simp]: "ad x \<cdot> ad (ad x \<cdot> y) = ad x \<cdot> ad y"
proof -
  have "\<And>a aa. ad (a::'a) \<cdot> ad (ad aa) = ad (ad (ad a \<cdot> aa))"
    using am_d_def d_a_export by presburger
  then have "\<And>a aa. ad (ad (a::'a)) \<cdot> ad aa = ad (ad (ad aa \<cdot> a))"
    using local.am2 by presburger
  then show ?thesis
    by (metis a_comp_simp a_d_mult_closure am_add_op_def am_d_def local.am2)
qed

end

class antidomain_monoid = antidomain_left_monoid +
  assumes am6 [simp]: "x \<cdot> ad 1 = ad 1"

begin

lemma kat_3_equiv: "d x \<cdot> y \<cdot> ad z = 0 \<longleftrightarrow> d x \<cdot> y = d x \<cdot> y \<cdot> d z"
  apply standard
  apply (metis kat_3')
  by (simp add: mult_assoc a_zero_def am_d_def)

no_notation a_zero ("0")
no_notation am_d ("d")

end

subsection \<open>Antidomain Near-Semirings\<close>

text \<open>We define antidomain near-semirings. We do not consider units separately. The axioms are taken from~\cite{DesharnaisStruthAMAST}.\<close>

notation zero_class.zero ("0")

class antidomain_near_semiring = ab_near_semiring_one_zerol + antidomain_op + plus_ord +
  assumes ans1 [simp]: "ad x \<cdot> x = 0"
  and ans2 [simp]: "ad (x \<cdot> y) + ad (x \<cdot> ad (ad y)) = ad (x \<cdot> ad (ad y))"
  and ans3 [simp]: "ad (ad x) + ad x = 1"
  and ans4 [simp]: "ad (x + y) = ad x \<cdot> ad y"

begin

definition ans_d :: "'a \<Rightarrow> 'a" ("d") where
   "d x = ad (ad x)"

lemma a_a_one [simp]: "d 1 = 1"
proof -
  have "d 1 = d 1 + 0"
    by simp
  also have "... = d 1 + ad 1"
    by (metis ans1 mult_1_right)
  finally show ?thesis
    by (simp add: ans_d_def)
qed

lemma a_very_costrict': "ad x = 1 \<longleftrightarrow> x = 0"
proof
  assume "ad x = 1"
  hence "x = ad x \<cdot> x"
    by simp
  thus "x = 0"
    by auto
next
  assume "x = 0"
  hence "ad x = ad 0"
    by blast
  thus "ad x = 1"
    by (metis a_a_one ans_d_def local.ans1 local.mult_1_right)
qed

lemma one_idem [simp]: "1 + 1 = 1"
proof -
  have "1 + 1 = d 1 + d 1"
    by simp
  also have "... = ad (ad 1 \<cdot> 1) + ad (ad 1 \<cdot> d 1)"
    using a_a_one ans_d_def by auto
  also have "... = ad (ad 1 \<cdot> d 1)"
    using ans_d_def local.ans2 by presburger
  also have "... = ad (ad 1 \<cdot> 1)"
    by simp
  also have "... = d 1"
    by (simp add: ans_d_def)
  finally show ?thesis
    by simp
qed

text \<open>Every antidomain near-semiring is automatically a dioid, and therefore ordered.\<close>

subclass near_dioid_one_zerol
proof
  show "\<And>x. x + x = x"
  proof -
    fix x
    have "x + x = 1 \<cdot> x + 1 \<cdot> x"
      by simp
    also have "... = (1 + 1) \<cdot> x"
      using distrib_right' by presburger
    finally show "x + x = x"
      by simp
  qed
qed

lemma d1_a [simp]: "d x \<cdot> x = x"
proof -
  have "x = (d x + ad x) \<cdot> x"
    by (simp add: ans_d_def)
  also have "... = d x \<cdot> x + ad x \<cdot> x"
    using distrib_right' by blast
  also have "... = d x \<cdot> x + 0"
    by simp
  finally show ?thesis
    by auto
qed

lemma a_comm: "ad x \<cdot> ad y = ad y \<cdot> ad x"
  using add_commute ans4 by fastforce

lemma a_subid: "ad x \<le> 1"
  using local.ans3 local.join.sup_ge2 by fastforce

lemma a_subid_aux1: "ad x \<cdot> y \<le> y"
  using a_subid mult_isor by fastforce

lemma a_subdist: "ad (x + y) \<le> ad x"
  by (metis a_subid_aux1 ans4 add_comm)

lemma a_antitone: "x \<le> y \<Longrightarrow> ad y \<le> ad x"
  using a_subdist local.order_prop by auto

lemma a_gla1: "ad x \<cdot> y = 0 \<Longrightarrow> ad x \<le> ad y"
proof -
  assume "ad x \<cdot> y = 0"
  hence a: "ad x \<cdot> d y = 0"
    by (metis a_subid a_very_costrict' ans_d_def local.ans2 local.join.sup.order_iff)
  have "ad x = (d y + ad y ) \<cdot> ad x"
    by (simp add: ans_d_def)
  also have "... = d y \<cdot> ad x + ad y \<cdot> ad x"
    using distrib_right' by blast
  also have "... = ad x \<cdot> d y + ad x \<cdot> ad y"
    using a_comm ans_d_def by auto
  also have "... = ad x \<cdot> ad y"
    by (simp add: a)
  finally show "ad x \<le> ad y"
    by (metis a_subid_aux1)
qed

lemma a_gla2: "ad x \<le> ad y \<Longrightarrow> ad x \<cdot> y = 0"
proof -
  assume "ad x \<le> ad y"
  hence "ad x \<cdot> y \<le> ad y \<cdot> y"
    using mult_isor by blast
  thus ?thesis
    by (simp add: join.le_bot)
qed

lemma a2_eq [simp]: "ad (x \<cdot> d y) = ad (x \<cdot> y)"
proof (rule antisym)
  show "ad (x \<cdot> y) \<le> ad (x \<cdot> d y)"
    by (simp add: ans_d_def local.less_eq_def)
next
  show "ad (x \<cdot> d y) \<le> ad (x \<cdot> y)"
    by (metis a_gla1 a_mul_d ans1 d1_a mult_assoc)
qed

lemma a_export' [simp]: "ad (ad x \<cdot> y) = d x + ad y"
proof (rule antisym)
  have "ad (ad x \<cdot> y) \<cdot> ad x \<cdot> d y = 0"
    by (simp add: a_gla2 local.mult.semigroup_axioms semigroup.assoc)
  hence a: "ad (ad x \<cdot> y) \<cdot> d y \<le> ad (ad x)"
    by (metis a_comm a_gla1 ans4 mult_assoc ans_d_def)
  have "ad (ad x \<cdot> y) = ad (ad x \<cdot> y) \<cdot> d y + ad (ad x \<cdot> y) \<cdot> ad y"
    by (metis (no_types) add_commute ans3 ans4 distrib_right' mult_onel ans_d_def)
  thus "ad (ad x \<cdot> y) \<le> d x + ad y"
    by (metis a_subid_aux1 a join.sup_mono ans_d_def)
next
  show "d x + ad y \<le> ad (ad x \<cdot> y)"
    by (metis a2_eq a_antitone a_comm a_subid_aux1 join.sup_least ans_d_def)
qed

text \<open>Every antidomain near-semiring is a domain near-semiring.\<close>

sublocale dnsz: domain_near_semiring_one_zerol "(+)" "(\<cdot>)" 1 0 "ans_d" "(\<le>)" "(<)"
  apply (unfold_locales)
  apply simp
  using a2_eq ans_d_def apply auto[1]
  apply (simp add: a_subid ans_d_def local.join.sup_absorb2)
  apply (simp add: ans_d_def)
  apply (simp add: a_comm ans_d_def)
  using a_a_one a_very_costrict' ans_d_def by force

lemma a_idem [simp]: "ad x \<cdot> ad x = ad x"
proof -
  have "ad x = (d x + ad x ) \<cdot> ad x"
    by (simp add: ans_d_def)
  also have "... = d x \<cdot> ad x + ad x \<cdot> ad x"
    using distrib_right' by blast
  finally show ?thesis
    by (simp add: ans_d_def)
qed

lemma a_3_var [simp]: "ad x \<cdot> ad y \<cdot> (x + y) = 0"
  by (metis ans1 ans4)

lemma a_3 [simp]: "ad x \<cdot> ad y \<cdot> d (x + y) = 0"
  by (metis a_mul_d ans4)

lemma a_closure' [simp]: "d (ad x) = ad x"
proof -
  have "d (ad x) = ad (1 \<cdot> d x)"
    by (simp add: ans_d_def)
  also have "... = ad (1 \<cdot> x)"
    using a2_eq by blast
  finally show ?thesis
    by simp
qed

text \<open>The following counterexamples show that some of the antidomain monoid axioms do not need to hold.\<close>

lemma "x \<cdot> ad 1 = ad 1"
(*nitpick [expect=genuine]*)
oops

lemma "ad (x \<cdot> y) \<cdot> ad (x \<cdot> ad y) = ad x"
(*nitpick [expect=genuine]*)
oops

lemma "ad (x \<cdot> y) \<cdot> ad (x \<cdot> ad y) = ad x"
(*nitpick [expect=genuine]*)
oops

lemma phl_seq_inv: "d v \<cdot> x \<cdot> y \<cdot> ad w = 0 \<Longrightarrow> \<exists>z. d v \<cdot> x \<cdot> d z = 0 \<and> ad z \<cdot> y \<cdot> ad w = 0"
proof -
  assume "d v \<cdot> x \<cdot> y \<cdot> ad w = 0"
  hence "d v \<cdot> x \<cdot> d (y \<cdot> ad w) = 0 \<and> ad (y \<cdot> ad w) \<cdot> y \<cdot> ad w = 0"
    by (metis dnsz.dom_weakly_local local.ans1 mult_assoc)
  thus "\<exists>z. d v \<cdot> x \<cdot> d z = 0 \<and> ad z \<cdot> y \<cdot> ad w = 0"
    by blast
qed

lemma a_fixpoint: "ad x = x \<Longrightarrow> (\<forall>y. y = 0)"
proof -
  assume a1: "ad x = x"
  { fix aa :: 'a
    have "aa = 0"
      using a1 by (metis (no_types) a_mul_d ans_d_def local.annil local.ans3 local.join.sup.idem local.mult_1_left)
  }
  then show ?thesis
    by blast
qed

no_notation ans_d ("d")

end

subsection \<open>Antidomain Pre-Dioids\<close>

text \<open>Antidomain pre-diods are based on a different set of axioms, which are again taken from~\cite{DesharnaisStruthAMAST}.\<close>

class antidomain_pre_dioid = pre_dioid_one_zerol + antidomain_op +
  assumes apd1 [simp]: "ad x \<cdot> x = 0"
  and apd2 [simp]: "ad (x \<cdot> y) \<le> ad (x \<cdot> ad (ad y))"
  and apd3 [simp]: "ad (ad x) + ad x = 1"

begin

definition apd_d :: "'a \<Rightarrow> 'a" ("d") where
   "d x = ad (ad x)"

lemma a_very_costrict'': "ad x = 1 \<longleftrightarrow> x = 0"
  by (metis add_commute local.add_zerol local.antisym local.apd1 local.apd3 local.join.bot_least local.mult_1_right local.phl_skip)

lemma a_subid': "ad x \<le> 1"
  using local.apd3 local.join.sup_ge2 by fastforce

lemma d1_a' [simp]: "d x \<cdot> x = x"
proof -
  have "x = (d x + ad x) \<cdot> x"
    by (simp add: apd_d_def)
  also have "... = d x \<cdot> x + ad x \<cdot> x"
    using distrib_right' by blast
  also have "... = d x \<cdot> x + 0"
    by simp
  finally show ?thesis
    by auto
qed

lemma a_subid_aux1': "ad x \<cdot> y \<le> y"
  using a_subid' mult_isor by fastforce

lemma a_mul_d' [simp]: "ad x \<cdot> d x = 0"
proof -
  have "1 = ad (ad x \<cdot> x)"
    using a_very_costrict'' by force
  thus ?thesis
    by (metis a_subid' a_very_costrict'' apd_d_def local.antisym local.apd2)
qed

lemma meet_ord_def: "ad x \<le> ad y \<longleftrightarrow> ad x \<cdot> ad y = ad x"
  by (metis a_d_closed a_subid_aux1' d1_a' eq_iff mult_1_right mult_isol)

lemma d_weak_loc: "x \<cdot> y = 0 \<longleftrightarrow> x \<cdot> d y = 0"
proof -
  have "x \<cdot> y = 0 \<longleftrightarrow> ad (x \<cdot> y) = 1"
    by (simp add: a_very_costrict'')
  also have "... \<longleftrightarrow> ad (x \<cdot> d y) = 1"
    by (metis apd1 apd2 a_subid' apd_d_def d1_a' eq_iff mult_1_left mult_assoc)
  finally show ?thesis
    by (simp add: a_very_costrict'')
qed

lemma gla_1: "ad x \<cdot> y = 0 \<Longrightarrow> ad x \<le> ad y"
proof -
  assume "ad x \<cdot> y = 0"
  hence a: "ad x \<cdot> d y = 0"
    using d_weak_loc by force
  hence "d y = ad x \<cdot> d y + d y"
    by simp
  also have "... = (1 + ad x) \<cdot> d y"
    using join.sup_commute by auto
  also have "... = (d x + ad x) \<cdot> d y"
    using apd_d_def calculation by auto
  also have "... = d x \<cdot> d y"
    by (simp add: a join.sup_commute)
  finally have "d y \<le> d x"
    by (metis apd_d_def a_subid' mult_1_right mult_isol)
  hence "d y \<cdot> ad x = 0"
    by (metis apd_d_def a_d_closed a_mul_d' distrib_right' less_eq_def no_trivial_inverse)
  hence "ad x = ad y \<cdot> ad x"
    by (metis apd_d_def apd3 add_0_left distrib_right' mult_1_left)
  thus "ad x \<le> ad y"
    by (metis add_commute apd3 mult_oner subdistl)
qed

lemma a2_eq' [simp]: "ad (x \<cdot> d y) = ad (x \<cdot> y)"
proof (rule antisym)
  show "ad (x \<cdot> y) \<le> ad (x \<cdot> d y)"
    by (simp add: apd_d_def)
next
  show "ad (x \<cdot> d y) \<le> ad (x \<cdot> y)"
    by (metis gla_1 apd1 a_mul_d' d1_a' mult_assoc)
qed

lemma a_supdist_var: "ad (x + y) \<le> ad x"
  by (metis gla_1 apd1 join.le_bot subdistl)

lemma a_antitone': "x \<le> y \<Longrightarrow> ad y \<le> ad x"
  using a_supdist_var local.order_prop by auto

lemma a_comm_var: "ad x \<cdot> ad y \<le> ad y \<cdot> ad x"
proof -
  have "ad x \<cdot> ad y = d (ad x \<cdot> ad y) \<cdot> ad x \<cdot> ad y"
    by (simp add: mult_assoc)
  also have "... \<le> d (ad x \<cdot> ad y) \<cdot> ad x"
    using a_subid' mult_isol by fastforce
  also have "... \<le> d (ad y) \<cdot> ad x"
    by (simp add: a_antitone' a_subid_aux1' apd_d_def local.mult_isor)
  finally show ?thesis
    by simp
qed

lemma a_comm': "ad x \<cdot> ad y = ad y \<cdot> ad x"
  by (simp add: a_comm_var eq_iff)

lemma a_closed [simp]: "d (ad x \<cdot> ad y) = ad x \<cdot> ad y"
proof -
  have f1: "\<And>x y. ad x \<le> ad (ad y \<cdot> x)"
    by (simp add: a_antitone' a_subid_aux1')
  have "\<And>x y. d (ad x \<cdot> y) \<le> ad x"
    by (metis a2_eq' a_antitone' a_comm' a_d_closed apd_d_def f1)
  hence "\<And>x y. d (ad x \<cdot> y) \<cdot> y = ad x \<cdot> y"
    by (metis d1_a' meet_ord_def mult_assoc apd_d_def)
  thus ?thesis
    by (metis f1 a_comm' apd_d_def meet_ord_def)
qed

lemma a_export'' [simp]: "ad (ad x \<cdot> y) = d x + ad y"
proof (rule antisym)
  have "ad (ad x \<cdot> y) \<cdot> ad x \<cdot> d y = 0"
    using d_weak_loc mult_assoc by fastforce
  hence a: "ad (ad x \<cdot> y) \<cdot> d y \<le> d x"
    by (metis a_closed a_comm' apd_d_def gla_1 mult_assoc)
  have "ad (ad x \<cdot> y) = ad (ad x \<cdot> y) \<cdot> d y + ad (ad x \<cdot> y) \<cdot> ad y"
    by (metis apd3 a_comm' d1_a' distrib_right' mult_1_right apd_d_def)
  thus "ad (ad x \<cdot> y) \<le> d x + ad y"
    by (metis a_subid_aux1' a join.sup_mono)
next
  have "ad y \<le> ad (ad x \<cdot> y)"
    by (simp add: a_antitone' a_subid_aux1')
  thus "d x + ad y \<le> ad (ad x \<cdot> y)"
    by (metis apd_d_def a_mul_d' d1_a' gla_1 apd1 join.sup_least mult_assoc)
qed

lemma d1_sum_var: "x + y \<le> (d x + d y) \<cdot> (x + y)"
proof -
  have "x + y = d x \<cdot> x + d y \<cdot> y"
    by simp
  also have "... \<le> (d x + d y) \<cdot> x + (d x + d y) \<cdot> y"
    using local.distrib_right' local.join.sup_ge1 local.join.sup_ge2 local.join.sup_mono by presburger
  finally show ?thesis
    using order_trans subdistl_var by blast
qed

lemma a4': "ad (x + y) = ad x \<cdot> ad y"
proof (rule antisym)
  show "ad (x + y) \<le> ad x \<cdot> ad y"
    by (metis a_d_closed a_supdist_var add_commute d1_a' local.mult_isol_var)
  hence "ad x \<cdot> ad y = ad x \<cdot> ad y + ad (x + y)"
    using less_eq_def add_commute by simp
  also have "... = ad (ad (ad x \<cdot> ad y) \<cdot> (x + y))"
    by (metis a_closed a_export'')
  finally show "ad x \<cdot> ad y \<le> ad (x + y)"
    using a_antitone' apd_d_def d1_sum_var by auto
qed

text \<open>Antidomain pre-dioids are domain pre-dioids and antidomain near-semirings, but still not antidomain monoids.\<close>

sublocale dpdz: domain_pre_dioid_one_zerol "(+)" "(\<cdot>)" 1 0 "(\<le>)" "(<)" "\<lambda>x. ad (ad x)"
  apply (unfold_locales)
  using apd_d_def d1_a' apply auto[1]
  using a2_eq' apd_d_def apply auto[1]
  apply (simp add: a_subid')
  apply (simp add: a4' apd_d_def)
  by (metis a_mul_d' a_very_costrict'' apd_d_def local.mult_onel)

subclass antidomain_near_semiring
  apply (unfold_locales)
  apply simp
  using local.apd2 local.less_eq_def apply blast
  apply simp
  by (simp add: a4')

lemma a_supdist: "ad (x + y) \<le> ad x + ad y"
  using a_supdist_var local.join.le_supI1 by auto

lemma a_gla: "ad x \<cdot> y = 0 \<longleftrightarrow> ad x \<le> ad y"
  using gla_1 a_gla2 by blast

lemma a_subid_aux2: "x \<cdot> ad y \<le> x"
  using a_subid' mult_isol by fastforce

lemma a42_var: "d x \<cdot> d y \<le> ad (ad x + ad y)"
  by (simp add: apd_d_def)

lemma d1_weak [simp]: "(d x + d y) \<cdot> x = x"
proof -
  have "(d x + d y) \<cdot> x = (1 + d y) \<cdot> x"
    by simp
  thus ?thesis
   by (metis add_commute apd_d_def dpdz.dnso3 local.mult_1_left)
qed

lemma "x \<cdot> ad 1 = ad 1"
(*nitpick [expect=genuine]*)
oops

lemma "ad x \<cdot> (y + z) = ad x \<cdot> y + ad x \<cdot> z"
(*nitpick [expect=genuine]*)
oops

lemma "ad (x \<cdot> y) \<cdot> ad (x \<cdot> ad y) = ad x"
(*nitpick [expect=genuine]*)
oops

lemma "ad (x \<cdot> y) \<cdot> ad (x \<cdot> ad y) = ad x"
(*nitpick [expect=genuine]*)
oops

no_notation apd_d ("d")

end

subsection \<open>Antidomain Semirings\<close>

text \<open>Antidomain semirings are direct expansions of antidomain pre-dioids, but do not require idempotency of addition. Hence we give a slightly different axiomatisation, following~\cite{DesharnaisStruthSCP}.\<close>

class antidomain_semiringl = semiring_one_zerol + plus_ord + antidomain_op +
  assumes as1 [simp]: "ad x \<cdot> x = 0"
  and as2 [simp]: "ad (x \<cdot> y) + ad (x \<cdot> ad (ad y)) = ad (x \<cdot> ad (ad y))"
  and as3 [simp]: "ad (ad x) + ad x = 1"

begin

definition ads_d :: "'a \<Rightarrow> 'a" ("d") where
  "d x = ad (ad x)"

lemma one_idem': "1 + 1 = 1"
  by (metis as1 as2 as3 add_zeror mult.right_neutral)

text \<open>Every antidomain semiring is a dioid and an antidomain pre-dioid.\<close>

subclass dioid
  by (standard, metis distrib_left mult.right_neutral one_idem')

subclass antidomain_pre_dioid
  by (unfold_locales, auto simp: local.less_eq_def)

lemma am5_lem [simp]: "ad (x \<cdot> y) \<cdot> ad (x \<cdot> ad y) = ad x"
proof -
  have "ad (x \<cdot> y ) \<cdot> ad (x \<cdot> ad y) = ad (x \<cdot> d y) \<cdot> ad (x \<cdot> ad y)"
    using ads_d_def local.a2_eq' local.apd_d_def by auto
  also have "... = ad (x \<cdot> d y + x \<cdot> ad y)"
    using ans4 by presburger
  also have "... = ad (x \<cdot> (d y + ad y))"
    using distrib_left by presburger
  finally show ?thesis
    by (simp add: ads_d_def)
qed

lemma am6_lem [simp]: "ad (x \<cdot> y) \<cdot> x \<cdot> ad y = ad (x \<cdot> y) \<cdot> x"
proof -
  fix x y
  have "ad (x \<cdot> y) \<cdot> x \<cdot> ad y = ad (x \<cdot> y) \<cdot> x \<cdot> ad y + 0"
    by simp
  also have "... = ad (x \<cdot> y) \<cdot> x \<cdot> ad y + ad (x \<cdot> d y) \<cdot> x \<cdot> d y"
    using ans1 mult_assoc by presburger
  also have "... = ad (x \<cdot> y) \<cdot> x \<cdot> (ad y + d y)"
    using ads_d_def local.a2_eq' local.apd_d_def local.distrib_left by auto
  finally show "ad (x \<cdot> y) \<cdot> x \<cdot> ad y = ad (x \<cdot> y) \<cdot> x"
    using add_commute ads_d_def local.as3 by auto
qed

lemma a_zero [simp]: "ad 0 = 1"
  by (simp add: local.a_very_costrict'')

lemma a_one [simp]: "ad 1 = 0"
  using a_zero local.dpdz.dpd5 by blast

subclass antidomain_left_monoid
  by (unfold_locales, auto simp:  local.a_comm')

text \<open>Every antidomain left semiring is a domain left semiring.\<close>

no_notation domain_semiringl_class.fd ("( |_\<rangle> _)" [61,81] 82)

definition fdia :: "'a \<Rightarrow> 'a \<Rightarrow> 'a" ("( |_\<rangle> _)" [61,81] 82) where
  "|x\<rangle> y = ad (ad (x \<cdot> y))"

sublocale ds: domain_semiringl "(+)" "(\<cdot>)" 1 0 "\<lambda>x. ad (ad x)" "(\<le>)" "(<)"
  rewrites "ds.fd x y \<equiv> fdia x y"
proof -
  show "class.domain_semiringl (+) (\<cdot>) 1 0 (\<lambda>x. ad (ad x)) (\<le>) (<) "
    by (unfold_locales, auto simp: local.dpdz.dpd4 ans_d_def)
  then interpret ds: domain_semiringl "(+)" "(\<cdot>)" 1 0 "\<lambda>x. ad (ad x)" "(\<le>)" "(<)" .
  show "ds.fd x y \<equiv> fdia x y"
    by (auto simp: fdia_def ds.fd_def)
qed

lemma fd_eq_fdia [simp]: "domain_semiringl.fd (\<cdot>) d x y \<equiv> fdia x y"
proof -
  have "class.domain_semiringl (+) (\<cdot>) 1 0 d (\<le>) (<)"
    by (unfold_locales, auto simp: ads_d_def local.ans_d_def)
  hence "domain_semiringl.fd (\<cdot>) d x y = d ((\<cdot>) x y)"
    by (rule domain_semiringl.fd_def)
  also have "... = ds.fd x y"
    by (simp add: ds.fd_def ads_d_def)
  finally show "domain_semiringl.fd (\<cdot>) d x y \<equiv> |x\<rangle> y"
    by auto
qed

end

class antidomain_semiring = antidomain_semiringl + semiring_one_zero

begin

text \<open>Every antidomain semiring is an antidomain monoid.\<close>

subclass antidomain_monoid
  by (standard, metis ans1 mult_1_right annir)

lemma "a_zero = 0"
  by (simp add: local.a_zero_def)

sublocale ds: domain_semiring "(+)" "(\<cdot>)" 1 0 "\<lambda>x. ad (ad x)" "(\<le>)" "(<)"
  rewrites "ds.fd x y \<equiv> fdia x y"
  by unfold_locales

end

subsection \<open>The Boolean Algebra of Domain Elements\<close>

typedef (overloaded) 'a a2_element = "{x :: 'a :: antidomain_semiring. x = d x}"
  by (rule_tac x=1 in exI, auto simp: ads_d_def)

setup_lifting type_definition_a2_element

instantiation a2_element :: (antidomain_semiring) boolean_algebra

begin

lift_definition less_eq_a2_element :: "'a a2_element \<Rightarrow> 'a a2_element \<Rightarrow> bool" is "(\<le>)" .

lift_definition less_a2_element :: "'a a2_element \<Rightarrow> 'a a2_element \<Rightarrow> bool" is "(<)" .

lift_definition bot_a2_element :: "'a a2_element" is 0
  by (simp add: ads_d_def)

lift_definition top_a2_element :: "'a a2_element" is 1
  by (simp add: ads_d_def)

lift_definition inf_a2_element :: "'a a2_element \<Rightarrow> 'a a2_element \<Rightarrow> 'a a2_element" is "(\<cdot>)"
  by (metis (no_types, lifting) ads_d_def dpdz.dom_mult_closed)

lift_definition sup_a2_element :: "'a a2_element \<Rightarrow> 'a a2_element \<Rightarrow> 'a a2_element" is "(+)"
  by (metis ads_d_def ds.dsr5)

lift_definition minus_a2_element :: "'a a2_element \<Rightarrow> 'a a2_element \<Rightarrow> 'a a2_element" is "\<lambda>x y. x \<cdot> ad y"
  by (metis (no_types, lifting) ads_d_def dpdz.domain_export'')

lift_definition uminus_a2_element :: "'a a2_element \<Rightarrow> 'a a2_element" is antidomain_op
  by (simp add: ads_d_def)

instance
  apply (standard; transfer)
  apply (simp add: less_le_not_le)
  apply simp
  apply auto[1]
  apply simp
  apply (metis a_subid_aux2 ads_d_def)
  apply (metis a_subid_aux1' ads_d_def)
  apply (metis (no_types, lifting) ads_d_def dpdz.dom_glb)
  apply simp
  apply simp
  apply simp
  apply simp
  apply (metis a_subid' ads_d_def)
  apply (metis (no_types, lifting) ads_d_def dpdz.dom_distrib)
  apply (metis ads_d_def ans1)
  apply (metis ads_d_def ans3)
  by simp

end

subsection \<open>Further Properties\<close>

context antidomain_semiringl

begin

lemma a_2_var: "ad x \<cdot> d y = 0 \<longleftrightarrow> ad x \<le> ad y"
  using local.a_gla local.ads_d_def local.dpdz.dom_weakly_local by auto

text \<open>The following two lemmas give the Galois connection of Heyting algebras.\<close>

lemma da_shunt1: "x \<le> d y + z \<Longrightarrow> x \<cdot> ad y \<le> z"
proof -
  assume "x \<le> d y + z"
  hence "x \<cdot> ad y \<le> (d y + z) \<cdot> ad y"
    using mult_isor by blast
  also have "... = d y \<cdot> ad y + z \<cdot> ad y"
    by simp
  also have "... \<le> z"
    by (simp add: a_subid_aux2 ads_d_def)
  finally show "x \<cdot> ad y \<le> z"
    by simp
qed

lemma da_shunt2: "x \<le> ad y + z \<Longrightarrow> x \<cdot> d y \<le> z"
  using da_shunt1 local.a_add_idem local.ads_d_def am_add_op_def by auto

lemma d_a_galois1: "d x \<cdot> ad y \<le> d z \<longleftrightarrow> d x \<le> d z + d y"
  by (metis add_assoc local.a_gla local.ads_d_def local.am2 local.ans4 local.ans_d_def local.dnsz.dnso4)

lemma d_a_galois2: "d x \<cdot> d y \<le> d z \<longleftrightarrow> d x \<le> d z + ad y"
proof -
  have "\<And>a aa. ad ((a::'a) \<cdot> ad (ad aa)) = ad (a \<cdot> aa)"
    using local.a2_eq' local.apd_d_def by force
  then show ?thesis
    by (metis d_a_galois1 local.a_export' local.ads_d_def local.ans_d_def)
qed

lemma d_cancellation_1: "d x \<le> d y + d x \<cdot> ad y"
proof -
  have a: "d (d x \<cdot> ad y) = ad y \<cdot> d x"
    using local.a_closure' local.ads_d_def local.am2 local.ans_d_def by auto
  hence "d x \<le> d (d x \<cdot> ad y) + d y"
    using d_a_galois1 local.a_comm_var local.ads_d_def by fastforce
  thus ?thesis
    using a add_commute local.ads_d_def local.am2 by auto
qed

lemma d_cancellation_2: "(d z + d y) \<cdot> ad y \<le> d z"
  by (simp add: da_shunt1)

lemma a_de_morgan: "ad (ad x \<cdot> ad y) = d (x + y)"
  by (simp add: local.ads_d_def)

lemma a_de_morgan_var_3: "ad (d x + d y) = ad x \<cdot> ad y"
  using local.a_add_idem local.ads_d_def am_add_op_def by auto

lemma a_de_morgan_var_4: "ad (d x \<cdot> d y) = ad x + ad y"
  using local.a_add_idem local.ads_d_def am_add_op_def by auto

lemma a_4: "ad x \<le> ad (x \<cdot> y)"
  using local.a_add_idem local.a_antitone' local.dpdz.domain_1'' am_add_op_def by fastforce

lemma a_6: "ad (d x \<cdot> y) = ad x + ad y"
  using a_de_morgan_var_4 local.ads_d_def by auto

lemma a_7: "d x \<cdot> ad (d y + d z) = d x \<cdot> ad y \<cdot> ad z"
  using a_de_morgan_var_3 local.mult.semigroup_axioms semigroup.assoc by fastforce

lemma a_d_add_closure [simp]: "d (ad x + ad y) = ad x + ad y"
  using local.a_add_idem local.ads_d_def am_add_op_def by auto

lemma d_6 [simp]: "d x + ad x \<cdot> d y = d x + d y"
proof -
  have "ad (ad x \<cdot> (x + ad y)) = d (x + y)"
    by (simp add: distrib_left ads_d_def)
  thus ?thesis
    by (simp add: local.ads_d_def local.ans_d_def)
qed

lemma d_7 [simp]: "ad x + d x \<cdot> ad y = ad x + ad y"
  by (metis a_d_add_closure local.ads_d_def local.ans4 local.s4)

lemma a_mult_add: "ad x \<cdot> (y + x) = ad x \<cdot> y"
  by (simp add: distrib_left)

lemma kat_2: "y \<cdot> ad z \<le> ad x \<cdot> y \<Longrightarrow> d x \<cdot> y \<cdot> ad z = 0"
proof -
  assume a: "y \<cdot> ad z \<le> ad x \<cdot> y"
  hence "d x \<cdot> y \<cdot> ad z \<le> d x \<cdot> ad x \<cdot> y"
    using local.mult_isol mult_assoc by presburger
  thus ?thesis
    using local.join.le_bot ads_d_def by auto
qed

lemma kat_3: "d x \<cdot> y \<cdot> ad z = 0 \<Longrightarrow> d x \<cdot> y = d x \<cdot> y \<cdot> d z"
  using local.a_zero_def local.ads_d_def local.am_d_def local.kat_3' by auto

lemma kat_4: "d x \<cdot> y = d x \<cdot> y \<cdot> d z \<Longrightarrow> d x \<cdot> y \<le> y \<cdot> d z"
  using a_subid_aux1 mult_assoc ads_d_def by auto

lemma kat_2_equiv: "y \<cdot> ad z \<le> ad x \<cdot> y \<longleftrightarrow> d x \<cdot> y \<cdot> ad z = 0"
proof
  assume "y \<cdot> ad z \<le> ad x \<cdot> y"
  thus "d x \<cdot> y \<cdot> ad z = 0"
    by (simp add: kat_2)
next
  assume 1: "d x \<cdot> y \<cdot> ad z = 0"
  have "y \<cdot> ad z = (d x + ad x) \<cdot> y \<cdot> ad z"
    by (simp add: local.ads_d_def)
  also have "... = d x \<cdot> y \<cdot> ad z + ad x \<cdot> y \<cdot> ad z"
    using local.distrib_right by presburger
  also have "... = ad x \<cdot> y \<cdot> ad z"
    using "1" by auto
  also have "... \<le> ad x \<cdot> y"
    by (simp add: local.a_subid_aux2)
  finally show "y \<cdot> ad z \<le> ad x \<cdot> y" .
qed

lemma kat_4_equiv: "d x \<cdot> y = d x \<cdot> y \<cdot> d z \<longleftrightarrow> d x \<cdot> y \<le> y \<cdot> d z"
  using local.ads_d_def local.dpdz.d_preserves_equation by auto

lemma kat_3_equiv_opp: "ad z \<cdot> y \<cdot> d x = 0 \<longleftrightarrow> y \<cdot> d x = d z \<cdot> y \<cdot> d x"
proof -
  have "ad z \<cdot> (y \<cdot> d x) = 0 \<longrightarrow> (ad z \<cdot> y \<cdot> d x = 0) = (y \<cdot> d x = d z \<cdot> y \<cdot> d x)"
    by (metis (no_types, hide_lams) add_commute local.add_zerol local.ads_d_def local.as3 local.distrib_right' local.mult_1_left mult_assoc)
  thus ?thesis
    by (metis a_4 local.a_add_idem local.a_gla2 local.ads_d_def mult_assoc am_add_op_def)
qed

lemma kat_4_equiv_opp: "y \<cdot> d x = d z \<cdot> y \<cdot> d x \<longleftrightarrow> y \<cdot> d x \<le> d z \<cdot> y"
  using kat_2_equiv kat_3_equiv_opp local.ads_d_def by auto

subsection \<open>Forward Box and Diamond Operators\<close>

lemma fdemodalisation22: "|x\<rangle> y \<le> d z \<longleftrightarrow> ad z \<cdot> x \<cdot> d y = 0"
proof -
  have "|x\<rangle> y \<le> d z \<longleftrightarrow> d (x \<cdot> y) \<le> d z"
    by (simp add: fdia_def ads_d_def)
  also have "... \<longleftrightarrow> ad z \<cdot> d (x \<cdot> y) = 0"
    by (metis add_commute local.a_gla local.ads_d_def local.ans4)
  also have "... \<longleftrightarrow> ad z \<cdot> x \<cdot> y = 0"
    using dpdz.dom_weakly_local mult_assoc ads_d_def by auto
  finally show ?thesis
    using dpdz.dom_weakly_local ads_d_def by auto
qed

lemma dia_diff_var: "|x\<rangle> y \<le> |x\<rangle> (d y \<cdot> ad z) + |x\<rangle> z"
proof -
  have 1: "|x\<rangle> (d y \<cdot> d z) \<le> |x\<rangle> (1 \<cdot> d z)"
    using dpdz.dom_glb_eq ds.fd_subdist fdia_def ads_d_def by force
  have "|x\<rangle> y = |x\<rangle> (d y \<cdot> (ad z + d z))"
    by (metis as3 add_comm ds.fdia_d_simp mult_1_right ads_d_def)
  also have "... = |x\<rangle> (d y \<cdot> ad z) + |x\<rangle> (d y \<cdot> d z)"
    by (simp add: local.distrib_left local.ds.fdia_add1)
  also have "... \<le> |x\<rangle> (d y \<cdot> ad z) + |x\<rangle> (1 \<cdot> d z)"
    using "1" local.join.sup.mono by blast
  finally show ?thesis
    by (simp add: fdia_def ads_d_def)
qed

lemma dia_diff: "|x\<rangle> y \<cdot> ad ( |x\<rangle> z ) \<le> |x\<rangle> (d y \<cdot> ad z)"
  using fdia_def dia_diff_var d_a_galois2 ads_d_def by metis

lemma fdia_export_2: "ad y \<cdot> |x\<rangle> z = |ad y \<cdot> x\<rangle> z"
  using local.am_d_def local.d_a_export local.fdia_def mult_assoc by auto

lemma fdia_split: "|x\<rangle> y = d z \<cdot> |x\<rangle> y + ad z \<cdot> |x\<rangle> y"
  by (metis mult_onel ans3 distrib_right ads_d_def)

definition fbox :: "'a \<Rightarrow> 'a \<Rightarrow> 'a" ("( |_] _)" [61,81] 82) where
  "|x] y = ad (x \<cdot> ad y)"

text \<open>The next lemmas establish the De Morgan duality between boxes and diamonds.\<close>

lemma fdia_fbox_de_morgan_2: "ad ( |x\<rangle> y) = |x] ad y"
  using fbox_def local.a_closure local.a_loc local.am_d_def local.fdia_def by auto

lemma fbox_simp: "|x] y = |x] d y"
  using fbox_def local.a_add_idem local.ads_d_def am_add_op_def by auto

lemma fbox_dom [simp]: "|x] 0 = ad x"
  by (simp add: fbox_def)

lemma fbox_add1: "|x] (d y \<cdot> d z) = |x] y \<cdot> |x] z"
  using a_de_morgan_var_4 fbox_def local.distrib_left by auto

lemma fbox_add2: "|x + y] z = |x] z \<cdot> |y] z"
  by (simp add: fbox_def)

lemma fbox_mult: "|x \<cdot> y] z = |x] |y] z"
  using fbox_def local.a2_eq' local.apd_d_def mult_assoc by auto

lemma fbox_zero [simp]: "|0] x = 1"
  by (simp add: fbox_def)

lemma fbox_one [simp]: "|1] x = d x"
  by (simp add: fbox_def ads_d_def)

lemma fbox_iso: "d x \<le> d y \<Longrightarrow> |z] x \<le> |z] y"
proof -
  assume "d x \<le> d y"
  hence "ad y \<le> ad x"
    using local.a_add_idem local.a_antitone' local.ads_d_def am_add_op_def by fastforce
  hence "z \<cdot> ad y \<le> z \<cdot> ad x"
    by (simp add: mult_isol)
  thus "|z] x \<le> |z] y"
    by (simp add: fbox_def a_antitone')
qed

lemma fbox_antitone_var: "x \<le> y \<Longrightarrow> |y] z \<le> |x] z"
  by (simp add: fbox_def a_antitone mult_isor)

lemma fbox_subdist_1: "|x] (d y \<cdot> d z) \<le> |x] y"
  using a_de_morgan_var_4 fbox_def local.a_supdist_var local.distrib_left by force

lemma fbox_subdist_2: "|x] y \<le>|x] (d y + d z)"
  by (simp add: fbox_iso ads_d_def)

lemma fbox_diff_var: "|x] (d y + ad z) \<cdot> |x] z \<le> |x] y"
proof -
  have "ad (ad y) \<cdot> ad (ad z) = ad (ad z + ad y)"
    using local.dpdz.dsg4 by auto
  then have "d (d (d y + ad z) \<cdot> d z) \<le> d y"
    by (simp add: local.a_subid_aux1' local.ads_d_def)
  then show ?thesis
    by (metis fbox_add1 fbox_iso)
qed

lemma fbox_diff: "|x] (d y + ad z) \<le> |x] y + ad ( |x] z )"
proof -
  have f1: "\<And>a. ad (ad (ad (a::'a))) = ad a"
    using local.a_closure' local.ans_d_def by force
  have f2: "\<And>a aa. ad (ad (a::'a)) + ad aa = ad (ad a \<cdot> aa)"
    using local.ans_d_def by auto
  have f3: "\<And>a aa. ad ((a::'a) + aa) = ad (aa + a)"
    by (simp add: local.am2)
  then have f4: "\<And>a aa. ad (ad (ad (a::'a) \<cdot> aa)) = ad (ad aa + a)"
    using f2 f1 by (metis (no_types) local.ans4)
  have f5: "\<And>a aa ab. ad ((a::'a) \<cdot> (aa + ab)) = ad (a \<cdot> (ab + aa))"
    using f3 local.distrib_left by presburger
  have f6: "\<And>a aa. ad (ad (ad (a::'a) + aa)) = ad (ad aa \<cdot> a)"
    using f3 f1 by fastforce
  have "ad (x \<cdot> ad (y + ad z)) \<le> ad (ad (x \<cdot> ad z) \<cdot> (x \<cdot> ad y))"
    using f5 f2 f1 by (metis (no_types) a_mult_add fbox_def fbox_subdist_1 local.a_gla2 local.ads_d_def local.ans4 local.distrib_left local.gla_1 mult_assoc)
  then show ?thesis
    using f6 f4 f3 f1 by (simp add: fbox_def local.ads_d_def)
qed

end

context antidomain_semiring

begin

lemma kat_1: "d x \<cdot> y \<le> y \<cdot> d z \<Longrightarrow> y \<cdot> ad z \<le> ad x \<cdot> y"
proof -
  assume a: "d x \<cdot> y \<le> y \<cdot> d z"
  have "y \<cdot> ad z = d x \<cdot> y \<cdot> ad z + ad x \<cdot> y \<cdot> ad z"
    by (metis local.ads_d_def local.as3 local.distrib_right local.mult_1_left)
  also have "... \<le> y \<cdot> (d z \<cdot> ad z) + ad x \<cdot> y \<cdot> ad z"
    by (metis a add_iso mult_isor mult_assoc)
  also have "... = ad x \<cdot> y \<cdot> ad z"
    by (simp add: ads_d_def)
  finally show "y \<cdot> ad z \<le> ad x \<cdot> y"
    using local.a_subid_aux2 local.dual_order.trans by blast
qed

lemma kat_1_equiv: "d x \<cdot> y \<le> y \<cdot> d z \<longleftrightarrow> y \<cdot> ad z \<le> ad x \<cdot> y"
  using kat_1 kat_2 kat_3 kat_4 by blast

lemma kat_3_equiv': "d x \<cdot> y \<cdot> ad z = 0 \<longleftrightarrow> d x \<cdot> y = d x \<cdot> y \<cdot> d z"
  by (simp add: kat_1_equiv local.kat_2_equiv local.kat_4_equiv)

lemma kat_1_equiv_opp: "y \<cdot> d x \<le> d z \<cdot> y \<longleftrightarrow> ad z \<cdot> y \<le> y \<cdot> ad x"
  by (metis kat_1_equiv local.a_closure' local.ads_d_def local.ans_d_def)

lemma kat_2_equiv_opp: "ad z \<cdot> y \<le> y \<cdot> ad x \<longleftrightarrow> ad z \<cdot> y \<cdot> d x = 0"
  by (simp add: kat_1_equiv_opp local.kat_3_equiv_opp local.kat_4_equiv_opp)

lemma fbox_one_1 [simp]: "|x] 1 = 1"
  by (simp add: fbox_def)

lemma fbox_demodalisation3: "d y \<le> |x] d z \<longleftrightarrow> d y \<cdot> x \<le> x \<cdot> d z"
  by (simp add: fbox_def a_gla kat_2_equiv_opp mult_assoc ads_d_def)

end

subsection \<open>Antidomain Kleene Algebras\<close>

class antidomain_left_kleene_algebra = antidomain_semiringl + left_kleene_algebra_zerol

begin

sublocale dka: domain_left_kleene_algebra "(+)" "(\<cdot>)" 1 0 d "(\<le>)" "(<)" star
  rewrites "domain_semiringl.fd (\<cdot>) d x y \<equiv> |x\<rangle> y"
  by (unfold_locales, auto simp add: local.ads_d_def ans_d_def)

lemma fbox_star_unfold [simp]: "|1] z \<cdot> |x] |x\<^sup>\<star>] z = |x\<^sup>\<star>] z"
proof -
  have "ad (ad z + x \<cdot> (x\<^sup>\<star> \<cdot> ad z)) = ad (x\<^sup>\<star> \<cdot> ad z)"
    using local.conway.dagger_unfoldl_distr mult_assoc by auto
  then show ?thesis
    using local.a_closure' local.ans_d_def local.fbox_def local.fdia_def local.fdia_fbox_de_morgan_2 by fastforce
qed

lemma fbox_star_unfold_var [simp]: "d z \<cdot> |x] |x\<^sup>\<star>] z = |x\<^sup>\<star>] z"
  using fbox_star_unfold by auto

lemma fbox_star_unfoldr [simp]: "|1] z \<cdot> |x\<^sup>\<star>] |x] z = |x\<^sup>\<star>] z"
  by (metis fbox_star_unfold fbox_mult star_slide_var)

lemma fbox_star_unfoldr_var [simp]: "d z \<cdot> |x\<^sup>\<star>] |x] z = |x\<^sup>\<star>] z"
  using fbox_star_unfoldr by auto

lemma fbox_star_induct_var: "d y \<le> |x] y \<Longrightarrow> d y \<le> |x\<^sup>\<star>] y"
proof -
  assume a1: "d y \<le> |x] y"
  have "\<And>a. ad (ad (ad (a::'a))) = ad a"
    using local.a_closure' local.ans_d_def by auto
  then have "ad (ad (x\<^sup>\<star> \<cdot> ad y)) \<le> ad y"
    using a1 by (metis dka.fdia_star_induct local.a_export' local.ads_d_def local.ans4 local.ans_d_def local.eq_refl local.fbox_def local.fdia_def local.meet_ord_def)
  then have "ad (ad y + ad (x\<^sup>\<star> \<cdot> ad y)) = zero_class.zero"
    by (metis (no_types) add_commute local.a_2_var local.ads_d_def local.ans4)
  then show ?thesis
    using local.a_2_var local.ads_d_def local.fbox_def by auto
qed

lemma fbox_star_induct: "d y \<le> d z \<cdot> |x] y \<Longrightarrow> d y \<le> |x\<^sup>\<star>] z"
proof -
  assume a1: "d y \<le> d z \<cdot> |x] y"
  hence a: "d y \<le> d z" and "d y \<le> |x] y"
    apply (metis local.a_subid_aux2 local.dual_order.trans local.fbox_def)
    using a1 dka.dom_subid_aux2 local.dual_order.trans by blast
  hence "d y \<le> |x\<^sup>\<star>] y"
    using fbox_star_induct_var by blast
  thus ?thesis
    using a local.fbox_iso local.order.trans by blast
qed

lemma fbox_star_induct_eq: "d z \<cdot> |x] y = d y \<Longrightarrow> d y \<le> |x\<^sup>\<star>] z"
  by (simp add: fbox_star_induct)

lemma fbox_export_1: "ad y + |x] y = |d y \<cdot> x] y"
  by (simp add: local.a_6 local.fbox_def mult_assoc)

lemma fbox_export_2: "d y + |x] y = |ad y \<cdot> x] y"
  by (simp add: local.ads_d_def local.ans_d_def local.fbox_def mult_assoc)

end

class antidomain_kleene_algebra = antidomain_semiring + kleene_algebra

begin

subclass antidomain_left_kleene_algebra ..

lemma "d p \<le> |(d t \<cdot> x)\<^sup>\<star> \<cdot> ad t] (d q \<cdot> ad t) \<Longrightarrow> d p \<le> |d t \<cdot> x] d q"
(*nitpick [expect=genuine]*)
oops

end

end


(*
  Theory: Poisson.thy
  Author: Manuel Eberl
*)

header {* Poisson Distribution *}

theory Poisson
imports Probability PDF_Misc
begin

class poisson = linordered_semiring +
  fixes poisson_density :: "real \<Rightarrow> 'a \<Rightarrow> ereal"
  fixes poisson_density' :: "real \<Rightarrow> 'a \<Rightarrow> real"
  assumes measurable_poisson_density[measurable]:
            "split poisson_density \<in> borel_measurable (borel \<Otimes>\<^sub>M count_space UNIV)"
  assumes poisson_density_ge_0: "rate \<ge> 0 \<Longrightarrow> poisson_density rate x \<ge> 0"
  assumes poisson_density_of_neg_eq_0: "x < 0 \<Longrightarrow> poisson_density rate x = 0"
  assumes poisson_density_integral_eq_1:
            "rate \<ge> 0 \<Longrightarrow> (\<integral>\<^sup>+x. poisson_density rate x \<partial>count_space UNIV) = 1"
  assumes poisson_density_real[simp]: "real (poisson_density rate x) = poisson_density' rate x"
  assumes poisson_density'_ereal[simp]: "ereal (poisson_density' rate x) = poisson_density rate x"
begin

  definition "poisson_space rate \<equiv> density (count_space UNIV) (poisson_density rate)"

  lemma poisson_density'_ge_0: "rate \<ge> 0 \<Longrightarrow> poisson_density' rate x \<ge> 0"
    using poisson_density_ge_0
    by (simp add: poisson_density'_ereal[symmetric] del: poisson_density'_ereal)

  lemma poisson_density'_of_neg_eq_0: "x < 0 \<Longrightarrow> poisson_density' rate x = 0"
    using poisson_density_of_neg_eq_0
    by (simp add: poisson_density'_ereal[symmetric] del: poisson_density'_ereal)

  lemma space_poisson_space: "space (poisson_space rate) = UNIV"
    unfolding poisson_space_def by simp

  lemma sets_poisson_space: "sets (poisson_space rate) = UNIV"
    unfolding poisson_space_def by simp

  lemma emeasure_poisson_space:
      "emeasure (poisson_space rate) A =
         \<integral>\<^sup>+x. poisson_density rate x * indicator A x \<partial>count_space UNIV"
    by (simp add: poisson_space_def emeasure_density)

  lemma prob_space_poisson[intro]: "rate \<ge> 0 \<Longrightarrow> prob_space (poisson_space rate)"
    by (auto intro!: prob_spaceI
             simp: poisson_density_integral_eq_1 emeasure_poisson_space space_poisson_space)

  lemma measurable_poisson_space_eq1[simp]:
    "measurable (poisson_space rate) N = measurable (count_space UNIV) N"
    by (intro measurable_cong_sets) (simp_all add: sets_poisson_space)

  lemma measurable_poisson_space_eq2[simp]:
    "measurable M (poisson_space rate) = measurable M (count_space UNIV)"
    by (intro measurable_cong_sets) (simp_all add: sets_poisson_space)

end

lemma poisson_density_nat_integral_eq_1:
  assumes "rate \<ge> 0"
  shows "(\<integral>\<^sup>+(x::nat). rate ^ x / fact x * exp (-rate) \<partial>count_space UNIV) = 1"
proof-
  have summable: "summable (\<lambda>x::nat. rate ^ x / fact x)" using summable_exp
      by (simp add: field_simps field_divide_inverse[symmetric])
  have "(\<integral>\<^sup>+(x::nat). rate ^ x / fact x * exp (-rate) \<partial>count_space UNIV) =
            exp (-rate) * (\<integral>\<^sup>+(x::nat). rate ^ x / fact x \<partial>count_space UNIV)"
      by (simp add: field_simps nn_integral_cmult[symmetric])
  also from assms have "(\<integral>\<^sup>+(x::nat). rate ^ x / fact x \<partial>count_space UNIV) = (\<Sum>x. rate ^ x / fact x)"
      by (simp_all add: nn_integral_count_space_nat
                        suminf_ereal summable suminf_ereal_finite)
  also have "... = exp rate" unfolding exp_def
      by (simp add: field_simps field_divide_inverse[symmetric] transfer_int_nat_factorial)
  also have "ereal (exp (-rate)) * ereal (exp rate) = 1" by (simp add: mult_exp_exp)
  finally show ?thesis .
qed

instantiation nat :: poisson
begin
  definition poisson_density_nat :: "real \<Rightarrow> nat \<Rightarrow> ereal" where
    "poisson_density_nat rate k = rate ^ k / fact k * exp (-rate)"
  definition poisson_density'_nat :: "real \<Rightarrow> nat \<Rightarrow> real" where
    "poisson_density'_nat rate k = rate ^ k / fact k * exp (-rate)"

  instance proof
    show "split (poisson_density :: _ \<Rightarrow> nat \<Rightarrow> _) \<in> borel_measurable (borel \<Otimes>\<^sub>M count_space UNIV)"
      unfolding poisson_density_nat_def[abs_def] by measurable
  next
    fix rate :: real assume "rate \<ge> 0"
    thus "(\<integral>\<^sup>+(x::nat). poisson_density rate x \<partial>count_space UNIV) = 1"
      unfolding poisson_density_nat_def
      by (rule poisson_density_nat_integral_eq_1)
  qed (simp_all add: poisson_density_nat_def poisson_density'_nat_def)
end

instantiation int :: poisson
begin
  definition poisson_density_int :: "real \<Rightarrow> int \<Rightarrow> ereal" where
    "poisson_density_int rate k = rate ^ (nat k) / fact k * exp (-rate)"
  definition poisson_density'_int :: "real \<Rightarrow> int \<Rightarrow> real" where
    "poisson_density'_int rate k = rate ^ (nat k) / fact k * exp (-rate)"

  instance proof
    show "split (poisson_density :: _ \<Rightarrow> int \<Rightarrow> _) \<in> borel_measurable (borel \<Otimes>\<^sub>M count_space UNIV)"
      unfolding poisson_density_int_def[abs_def] by measurable
  next
    fix rate :: real assume r: "rate \<ge> 0"
    have "(\<integral>\<^sup>+(x::int). poisson_density rate x \<partial>count_space UNIV) =
              \<integral>\<^sup>+(x::int). rate ^ nat x / real (fact x) * exp (-rate) \<partial>count_space UNIV"
      unfolding poisson_density_int_def by simp
    also from r have "... = \<integral>\<^sup>+(x::nat). rate ^ x / real (fact x) * exp (-rate) \<partial>count_space UNIV"
      by (simp add: nn_integral_nat_int transfer_int_nat_factorial)
    also from r have "... = 1" by (rule poisson_density_nat_integral_eq_1)
    finally show "(\<integral>\<^sup>+(x::int). poisson_density rate x \<partial>count_space UNIV) = 1" .
  qed (simp_all add: poisson_density_int_def poisson_density'_int_def)
end

lemma transfer_nat_int_poisson_density:
  "(x::int) \<ge> 0 \<Longrightarrow> poisson_density rate (nat x) = poisson_density rate x"
  unfolding poisson_density_nat_def poisson_density_int_def
  by (simp add: transfer_nat_int_factorial)

declare transfer_morphism_nat_int[transfer add return: transfer_nat_int_poisson_density]

lemma transfer_int_nat_poisson_density:
  "poisson_density rate (int x) = poisson_density rate x"
  unfolding poisson_density_nat_def poisson_density_int_def
  by (simp add: transfer_int_nat_factorial)

declare transfer_morphism_int_nat[transfer add return: transfer_int_nat_poisson_density]

lemma poisson_space_nat_distr:
  assumes "rate \<ge> 0"
  shows "poisson_space rate = distr (poisson_space rate) (count_space UNIV) (nat :: int \<Rightarrow> nat)"
    (is "?M1 = ?M2")
proof (intro measure_eqI)
  fix X :: "nat set" assume X: "X \<in> sets (poisson_space rate)"
  have [simp]: "\<And>x. indicator (nat -` X) x = indicator X (nat x)" by (simp add: indicator_def)
  from X and assms
    have "emeasure ?M1 X = \<integral>\<^sup>+ x. poisson_density rate x * indicator X x \<partial>count_space UNIV"
    by (simp add: sets_poisson_space emeasure_poisson_space)
  also from assms have "... = \<integral>\<^sup>+ x. poisson_density rate x * indicator X (nat x) \<partial>count_space UNIV"
    by (subst nn_integral_nat_int)
       (simp_all add: transfer_int_nat_poisson_density poisson_density_ge_0
                      poisson_density_of_neg_eq_0)
  also from X have "... = emeasure ?M2 X"
    by (simp add: emeasure_distr emeasure_poisson_space space_poisson_space)
  finally show "emeasure ?M1 X = emeasure ?M2 X" .
qed (simp add: sets_poisson_space)

lemma poisson_space_int_distr:
  assumes "rate \<ge> 0"
  shows "poisson_space rate = distr (poisson_space rate) (count_space UNIV) (int :: nat \<Rightarrow> int)"
    (is "?M1 = ?M2")
proof (intro measure_eqI)
  fix X :: "int set" assume X: "X \<in> sets (poisson_space rate)"
  have [simp]: "\<And>x. indicator (int -` X) x = indicator X (int x)" by (simp add: indicator_def)
  from X and assms
    have "emeasure ?M1 X = \<integral>\<^sup>+ x. poisson_density rate x * indicator X x \<partial>count_space UNIV"
    by (simp add: sets_poisson_space emeasure_poisson_space)
  also from assms have "... = \<integral>\<^sup>+ x. poisson_density rate x * indicator X (int x) \<partial>count_space UNIV"
    by (subst nn_integral_nat_int)
       (simp_all add: transfer_int_nat_poisson_density poisson_density_ge_0
                      poisson_density_of_neg_eq_0)
  also from X have "... = emeasure ?M2 X"
    by (simp add: emeasure_distr emeasure_poisson_space space_poisson_space)
  finally show "emeasure ?M1 X = emeasure ?M2 X" .
qed (simp add: sets_poisson_space)

(*
lemma expectation_poisson_nat:
  fixes M :: "'a measure" and X :: "'a \<Rightarrow> nat"
  assumes "prob_space M"
  assumes r: "rate \<ge> 0" and dist: "distributed M (count_space UNIV) X (poisson_density rate)"
  shows "integral\<^sup>L M (\<lambda>x. real (X x)) = rate"
proof-
  from r have [simp]: "\<And>x::nat. poisson_density' rate x * real x \<ge> 0"
    by (case_tac "x \<ge> 0") (simp_all add: poisson_density'_ge_0 poisson_density'_of_neg_eq_0)
  have "(\<integral>\<^sup>+(x::nat). ereal (- (poisson_density' rate x * real x)) \<partial>count_space UNIV) = 0"
    by (subst nn_integral_0_iff_AE, simp)
       (auto simp: poisson_density'_ge_0 intro!: AE_I'[of "{}"])
  moreover {
    from r have "1 = (\<integral>\<^sup>+(x::nat). ereal (poisson_density' rate x) \<partial>count_space UNIV)"
      by (simp add: poisson_density_integral_eq_1)
    also from r have "... = (\<Sum>x. ereal (poisson_density' rate x))"
       by (subst nn_integral_count_space_nat) (simp_all add: poisson_density_ge_0)
    finally have A: "(\<Sum>x. ereal (poisson_density' rate x)) = 1" ..
    with r have B: "summable (poisson_density' rate)"
      by (intro summable_ereal) (simp_all add: poisson_density'_ge_0)
    hence "(\<Sum>x. poisson_density' rate x) = exp (-rate) + (\<Sum>x. poisson_density' rate (x+1))"
      by (subst suminf_split_initial_segment[where k = 1]) (simp_all add: poisson_density'_nat_def)
    also have "(\<Sum>x. poisson_density' rate (x+1)) = rate * (\<Sum>x. poisson_density' rate (x+1) * (x + 1))"
  }

  interpret prob_space M by fact
  from dist have "expectation (\<lambda>x. real (X x)) =
                      integral\<^sup>L (distr M (count_space UNIV) X) real"
    unfolding distributed_def by (subst integral_distr) simp_all
  also from dist have "distr M (count_space UNIV) X =
                           density (count_space UNIV) (poisson_density' rate)"
    unfolding distributed_def by simp
  also from r and dist
    have "integral\<^sup>L ... real =
              integral\<^sup>L (count_space UNIV) (\<lambda>x::nat. poisson_density' rate x * real x)"
    by (subst integral_density) (simp_all add: poisson_density'_ge_0)
  also
  hence "integral\<^sup>L (count_space UNIV) (\<lambda>x::nat. poisson_density' rate x * real x) =
             (\<Sum>x. poisson_density' rate x * real x)"
apply (intro integral_count_space_nat)
apply (unfold integrable_def)
apply auto
apply (subst (asm) times_ereal.simps[symmetric])
apply (subst (asm) poisson_density'_ereal)
apply simp
  also have "(\<lambda>x::nat. poisson_density' rate x * real x) = T"
apply (simp add: poisson_density'_nat_def)
*)

end