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

text\<open>In this section we show the Schnoor protocol \cite{DBLP:journals/joc/Schnorr91} is a \<open>\<Sigma>\<close>-protocol and then use it to construct a commitment scheme.
The security statements for the resulting commitment scheme come for free from our general proof of the construction.\<close>

theory Schnorr_Sigma_Commit imports
  Commitment_Schemes
  Sigma_Protocols
  Cyclic_Group_Ext
  Discrete_Log
  Number_Theory_Aux
  Uniform_Sampling
  "HOL-Number_Theory.Cong"
begin

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

lemma order_gt_0 [simp]: "order \<G> > 0"
  using prime_order prime_gt_0_nat by blast

text\<open>The types for the \<open>\<Sigma>\<close>-protocol.\<close>

type_synonym witness = "nat"
type_synonym rand = nat
type_synonym 'grp' msg = "'grp'"
type_synonym response = nat
type_synonym challenge = nat
type_synonym 'grp' pub_in = "'grp'"

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

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

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

definition "response r w c = return_spmf ((w*c + r) mod (order \<G>))"

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

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

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

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

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

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

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

definition "valid_pub = carrier \<G>"

text\<open>We now use the Schnorr \<open>\<Sigma>\<close>-protocol use Schnorr to construct a commitment scheme.\<close>

type_synonym 'grp' ck = "'grp'"
type_synonym 'grp' vk = "'grp' \<times> nat"
type_synonym plain = "nat"
type_synonym 'grp' commit = "'grp'"
type_synonym opening = "nat"

text\<open>The adversary we use in the discrete log game to reduce the binding property to the discrete log assumption.\<close>

definition dis_log_\<A> :: "('grp ck, plain, 'grp commit, opening) bind_adversary \<Rightarrow> 'grp ck \<Rightarrow> nat spmf"
  where "dis_log_\<A> \<A> h = do {
  (c, e, z, e', z') \<leftarrow> \<A> h;
  _ :: unit \<leftarrow> assert_spmf (e > e' \<and> \<not> [e = e'] (mod order \<G>) \<and> (gcd (e - e') (order \<G>) = 1) \<and> c \<in> carrier \<G>);
  _ :: unit \<leftarrow> assert_spmf (((c \<otimes> h [^] e) = \<^bold>g [^] z) \<and> (c \<otimes> h [^] e') = \<^bold>g [^] z');
  return_spmf  (nat ((int z - int z') * inverse ((e - e')) (order \<G>) mod order \<G>))}"

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

end

locale schnorr_sigma_protocol = schnorr_base + cyclic_group \<G>
begin

sublocale Schnorr_\<Sigma>: \<Sigma>_protocols_base init response check R_DL S2 ss_adversary challenge_space valid_pub
  apply unfold_locales
  by(simp add: R_DL_def valid_pub_def; blast)

text\<open>The Schnorr \<open>\<Sigma>\<close>-protocol is complete.\<close>

lemma completeness: "Schnorr_\<Sigma>.completeness"
proof-
  have "\<^bold>g [^] y \<otimes> (\<^bold>g [^] w') [^] e = \<^bold>g [^] (y + w' * e)" for y e w' :: nat
    using nat_pow_pow nat_pow_mult by simp
  then show ?thesis
    unfolding Schnorr_\<Sigma>.completeness_game_def Schnorr_\<Sigma>.completeness_def
    by(auto simp add: init_def response_def check_def pow_generator_mod R_DL_def add.commute bind_spmf_const)
qed

text\<open>The next two lemmas help us rewrite terms in the proof  of honest verfier zero knowledge.\<close>

lemma zr_rewrite:
  assumes z: "z = (x*c + r) mod (order \<G>)"
    and r: "r < order \<G>"
  shows "(z + (order \<G>)*x*c - x*c) mod (order \<G>) = r"
proof(cases "x = 0")
  case True
  then show ?thesis using assms by simp
next
  case x_neq_0: False
  then show ?thesis
  proof(cases "c = 0")
    case True
    then show ?thesis
      by (simp add: assms)
  next
    case False
    have cong: "[z + (order \<G>)*x*c = x*c + r] (mod (order \<G>))"
      by (simp add: cong_def mult.assoc z)
    hence "[z + (order \<G>)*x*c - x*c = r] (mod (order \<G>))"
    proof-
      have "z + (order \<G>)*x*c > x*c"
        by (metis One_nat_def mult_less_cancel2 n_less_m_mult_n neq0_conv prime_gt_1_nat prime_order trans_less_add2 x_neq_0 False)
      then show ?thesis
        by (metis cong add_diff_inverse_nat cong_add_lcancel_nat less_imp_le linorder_not_le)
    qed
    then show ?thesis
      by(simp add: cong_def r)
  qed
qed

lemma h_sub_rewrite:
  assumes "h = \<^bold>g [^] x"
    and z: "z < order \<G>"
  shows "\<^bold>g [^] ((z + (order \<G>)*x*c - x*c)) = \<^bold>g [^] z \<otimes> inv (h [^] c)"
    (is "?lhs = ?rhs")
proof(cases "x = 0")
  case True
  then show ?thesis using assms by simp
next
  case x_neq_0: False
  then show ?thesis
  proof-
    have "(z + order \<G> * x * c - x * c) = (z + (order \<G> * x * c - x * c))"
      using z by (simp add: less_imp_le_nat mult_le_mono)
    then have lhs: "?lhs = \<^bold>g [^] z \<otimes> \<^bold>g [^] ((order \<G>)*x*c - x*c)"
      by(simp add: nat_pow_mult)
    have " \<^bold>g [^] ((order \<G>)*x*c - x*c) =  inv (h [^] c)"
    proof(cases "c = 0")
      case True
      then show ?thesis by simp
    next
      case False
      hence bound: "((order \<G>)*x*c - x*c) > 0"
        using assms x_neq_0 prime_gt_1_nat prime_order by auto
      then have "\<^bold>g [^] ((order \<G>)*x*c- x*c) = \<^bold>g [^] int ((order \<G>)*x*c - x*c)"
        by (simp add: int_pow_int)
      also have "... = \<^bold>g [^] int ((order \<G>)*x*c) \<otimes> inv (\<^bold>g [^] (x*c))"
        by (metis bound generator_closed int_ops(6) int_pow_int of_nat_eq_0_iff of_nat_less_0_iff of_nat_less_iff int_pow_diff)
      also have "... = \<^bold>g [^] ((order \<G>)*x*c) \<otimes> inv (\<^bold>g [^] (x*c))"
        by (metis int_pow_int)
      also have "... = \<^bold>g [^] ((order \<G>)*x*c) \<otimes> inv ((\<^bold>g [^] x) [^] c)"
        by(simp add: nat_pow_pow)
      also have "... = \<^bold>g [^] ((order \<G>)*x*c) \<otimes> inv (h [^] c)"
        using assms by simp
      also have "... = \<one> \<otimes> inv (h [^] c)"
        using generator_pow_order
        by (metis generator_closed mult_is_0 nat_pow_0 nat_pow_pow)
      ultimately show ?thesis
        by (simp add: assms(1))
    qed
    then show ?thesis using lhs by simp
  qed
qed

lemma hvzk_R_rewrite_grp:
  fixes x c r :: nat
  assumes "r < order \<G>"
  shows "\<^bold>g [^] (((x * c + order \<G> - r) mod order \<G> + order \<G> * x * c - x * c) mod order \<G>) = inv \<^bold>g [^] r"
    (is "?lhs = ?rhs")
proof-
  have "[(x * c + order \<G> - r) mod order \<G> + order \<G> * x * c - x * c = order \<G> - r] (mod order \<G>)"
  proof-
    have "[(x * c + order \<G> - r) mod order \<G> + order \<G> * x * c - x * c
              = x * c + order \<G> - r + order \<G> * x * c - x * c] (mod order \<G>)"
      by (smt cong_def One_nat_def add_diff_inverse_nat cong_diff_nat less_imp_le_nat linorder_not_less mod_add_left_eq mult.assoc n_less_m_mult_n prime_gt_1_nat prime_order trans_less_add2 zero_less_diff)
    hence "[(x * c + order \<G> - r) mod order \<G> + order \<G> * x * c - x * c
              =  order \<G> - r + order \<G> * x * c] (mod order \<G>)"
      using assms by auto
    thus ?thesis
      by (simp add: cong_def mult.assoc)
  qed
  hence "\<^bold>g [^] ((x * c + order \<G> - r) mod order \<G> + order \<G> * x * c - x * c) = \<^bold>g [^] (order \<G> - r)"
    using finite_carrier pow_generator_eq_iff_cong by blast
  thus ?thesis using neg_power_inverse
    by (simp add: assms inverse_pow_pow pow_generator_mod)
qed

lemma hv_zk:
  assumes "(h,x) \<in> R_DL"
  shows "Schnorr_\<Sigma>.R h x c = Schnorr_\<Sigma>.S h c"
  including monad_normalisation
proof-
  have "Schnorr_\<Sigma>.R h x c = do {
      r \<leftarrow> sample_uniform (order \<G>);
      let z = (x*c + r) mod (order \<G>);
      let a = \<^bold>g [^] ((z + (order \<G>)*x*c - x*c) mod (order \<G>));
      return_spmf (a,c,z)}"
    apply(simp add: Let_def Schnorr_\<Sigma>.R_def init_def response_def)
    using assms zr_rewrite R_DL_def
    by(simp cong: bind_spmf_cong_simp)
  also have "... = do {
      z \<leftarrow> map_spmf (\<lambda> r. (x*c + r) mod (order \<G>)) (sample_uniform (order \<G>));
      let a = \<^bold>g [^] ((z + (order \<G>)*x*c - x*c) mod (order \<G>));
      return_spmf (a,c,z)}"
    by(simp add: bind_map_spmf o_def Let_def)
  also have "... = do {
      z \<leftarrow>  (sample_uniform (order \<G>));
      let a = \<^bold>g [^] ((z + (order \<G>)*x*c - x*c));
      return_spmf (a,c,z)}"
    by(simp add: samp_uni_plus_one_time_pad pow_generator_mod)
  also have "... = do {
      z \<leftarrow>  (sample_uniform (order \<G>));
      let a = \<^bold>g [^] z \<otimes> inv (h [^] c);
      return_spmf (a,c,z)}"
    using h_sub_rewrite assms R_DL_def
    by(simp cong: bind_spmf_cong_simp)
  ultimately show ?thesis
    by(simp add: Schnorr_\<Sigma>.S_def S2_def map_spmf_conv_bind_spmf)
qed

text\<open>We can now prove that honest verifier zero knowledge holds for the Schnorr \<open>\<Sigma>\<close>-protocol.\<close>

lemma honest_verifier_ZK:
  shows "Schnorr_\<Sigma>.HVZK"
  unfolding Schnorr_\<Sigma>.HVZK_def
  by(auto simp add: hv_zk R_DL_def S2_def check_def valid_pub_def challenge_space_def cyclic_group_assoc)

text\<open>It is left to prove the special soundness property. First we prove a lemma we use to rewrite a
term in the special soundness proof and then prove the property itself.\<close>

lemma ss_rewrite:
  assumes "e' < e"
    and "e < order \<G>"
    and a_mem:"a  \<in> carrier \<G>"
    and h_mem: "h \<in> carrier \<G>"
    and a: "a \<otimes> h [^] e = \<^bold>g [^] z"
    and a': "a \<otimes> h [^] e' = \<^bold>g [^] z'"
  shows  "h = \<^bold>g [^] ((int z - int z') * inverse ((e - e')) (order \<G>) mod int (order \<G>))"
proof-
  have gcd: "gcd (nat (int e - int e') mod (order \<G>)) (order \<G>) = 1"
    using prime_field
    by (metis Primes.prime_nat_def assms(1) assms(2) coprime_imp_gcd_eq_1 diff_is_0_eq less_imp_diff_less
            mod_less nat_minus_as_int not_less schnorr_base.prime_order schnorr_base_axioms)
  have "a = \<^bold>g [^] z \<otimes> inv (h [^] e)"
    using a a_mem
    by (simp add: h_mem group.inv_solve_right)
  moreover have "a = \<^bold>g [^] z' \<otimes> inv (h [^] e')"
    using a' a_mem
    by (simp add: h_mem group.inv_solve_right)
  ultimately have "\<^bold>g [^] z \<otimes> h [^] e'  = \<^bold>g [^] z' \<otimes> h [^] e"
    using h_mem
    by (metis (no_types, lifting) a a' h_mem a_mem cyclic_group_assoc cyclic_group_commute nat_pow_closed)
  moreover obtain t :: nat where  t: "h = \<^bold>g  [^] t"
    using h_mem generatorE by blast
  ultimately have "\<^bold>g [^] (z + t * e')  = \<^bold>g [^] (z' +  t * e) "
    by (simp add: monoid.nat_pow_mult nat_pow_pow)
  hence "[z + t * e' = z' +  t * e] (mod  order \<G>)"
    using group_eq_pow_eq_mod order_gt_0 by blast
  hence "[int z + int t * int e' = int z' +  int t * int e] (mod  order \<G>)"
    using cong_int_iff by force
  hence "[int z - int z' = int t * int e - int t * int e'] (mod  order \<G>)"
    by (smt cong_iff_lin)
  hence "[int z - int z' = int t * (int e - int e')] (mod  order \<G>)"
    by (simp add: \<open>[int z - int z' = int t * int e - int t * int e'] (mod int (order \<G>))\<close> right_diff_distrib)
  hence "[int z - int z' = int t * (int e - int e')] (mod  order \<G>)"
    by (meson cong_diff cong_mod_left cong_mult cong_refl cong_trans)
  hence *: "[int z - int z' = int t * (int e - int e')] (mod  order \<G>)"
    using assms
    by (simp add: int_ops(9) of_nat_diff)
  hence "[int z - int z' = int t * nat (int e - int e')] (mod  order \<G>)"
    using assms
    by auto
  hence **: "[(int z - int z') * fst (bezw ((nat (int e - int e'))) (order \<G>))
              = int t * (nat (int e - int e')
                  * fst (bezw ((nat (int e - int e'))) (order \<G>)))] (mod  order \<G>)"
    by (smt \<open>[int z - int z' = int t * (int e - int e')] (mod int (order \<G>))\<close> assms(1) assms(2)
          cong_scalar_right int_nat_eq less_imp_of_nat_less mod_less more_arith_simps(11) nat_less_iff of_nat_0_le_iff)
  hence "[(int z - int z') * fst (bezw ((nat (int e - int e'))) (order \<G>)) = int t * 1] (mod  order \<G>)"
    by (metis (no_types, hide_lams) gcd inverse assms(2) cong_scalar_left cong_trans less_imp_diff_less mod_less mult.comm_neutral nat_minus_as_int)
  hence "[(int z - int z') * fst (bezw ((nat (int e - int e'))) (order \<G>))
              = t] (mod  order \<G>)" by simp
  hence "[ ((int z - int z') * fst (bezw ((nat (int e - int e'))) (order \<G>)))mod order \<G>
              = t] (mod  order \<G>)"
    using cong_mod_left by blast
  hence  **: "[nat (((int z - int z') * fst (bezw ((nat (int e - int e'))) (order \<G>)))mod order \<G>)
              = t] (mod  order \<G>)"
    by (metis Euclidean_Division.pos_mod_sign cong_int_iff int_nat_eq of_nat_0_less_iff order_gt_0)
  hence "\<^bold>g [^] (nat (((int z - int z') * fst (bezw ((nat (int e - int e'))) (order \<G>)))mod order \<G>)) = \<^bold>g [^] t"
    using cyclic_group.pow_generator_eq_iff_cong cyclic_group_axioms order_gt_0 order_gt_0_iff_finite by blast
  thus ?thesis using t
    by (smt Euclidean_Division.pos_mod_sign discrete_log.order_gt_0 int_pow_def2 nat_minus_as_int of_nat_0_less_iff)
qed

text\<open>The special soundness property for the Schnorr \<open>\<Sigma>\<close>-protocol.\<close>

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

text\<open>We are now able to prove that the Schnorr \<open>\<Sigma>\<close>-protocol is a \<open>\<Sigma>\<close>-protocol, the proof comes from the properties of
completeness, HVZK and special soundness we have previously proven.\<close>

theorem sigma_protocol:
  shows "Schnorr_\<Sigma>.\<Sigma>_protocol"
  by(simp add: Schnorr_\<Sigma>.\<Sigma>_protocol_def completeness honest_verifier_ZK special_soundness)

text\<open>Having proven the \<open>\<Sigma>\<close>-protocol property is satisfied we can show the commitment scheme we construct from the
Schnorr \<open>\<Sigma>\<close>-protocol has the desired properties. This result comes with very little proof effort as we can instantiate
our general proof.\<close>

sublocale Schnorr_\<Sigma>_commit: \<Sigma>_protocols_to_commitments init response check R_DL S2 ss_adversary challenge_space valid_pub G
  unfolding \<Sigma>_protocols_to_commitments_def \<Sigma>_protocols_to_commitments_axioms_def
  apply(auto simp add: \<Sigma>_protocols_base_def)
       apply(simp add: R_DL_def valid_pub_def)
      apply(auto simp add: sigma_protocol lossless_G lossless_init lossless_response)
  by(simp add: R_DL_def G_def)

lemma "Schnorr_\<Sigma>_commit.abstract_com.correct"
  by(fact Schnorr_\<Sigma>_commit.commit_correct)

lemma "Schnorr_\<Sigma>_commit.abstract_com.perfect_hiding_ind_cpa \<A>"
  by(fact Schnorr_\<Sigma>_commit.perfect_hiding)

lemma rel_adv_eq_dis_log_adv:
  "Schnorr_\<Sigma>_commit.rel_advantage \<A> = discrete_log.advantage \<A>"
proof-
  have "Schnorr_\<Sigma>_commit.rel_game \<A> = discrete_log.dis_log \<A>"
    unfolding Schnorr_\<Sigma>_commit.rel_game_def discrete_log.dis_log_def
    by(auto intro: try_spmf_cong bind_spmf_cong[OF refl]
       simp add: G_def R_DL_def cong_less_modulus_unique_nat group_eq_pow_eq_mod finite_carrier pow_generator_eq_iff_cong)
  thus ?thesis
    using Schnorr_\<Sigma>_commit.rel_advantage_def discrete_log.advantage_def by simp
qed

lemma bind_advantage_bound_dis_log:
  "Schnorr_\<Sigma>_commit.abstract_com.bind_advantage \<A> \<le> discrete_log.advantage (Schnorr_\<Sigma>_commit.adversary \<A>)"
  using Schnorr_\<Sigma>_commit.bind_advantage rel_adv_eq_dis_log_adv by simp

end

locale schnorr_asymp =
  fixes \<G> :: "nat \<Rightarrow> 'grp cyclic_group"
  assumes schnorr: "\<And>\<eta>. schnorr_sigma_protocol (\<G> \<eta>)"
begin

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

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

theorem sigma_protocol:
  shows "Schnorr_\<Sigma>.\<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: "Schnorr_\<Sigma>_commit.abstract_com.correct n"
  using  Schnorr_\<Sigma>_commit.commit_correct by simp

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

end

end


(*
Auction Theory Toolbox (http://formare.github.io/auctions/)

Authors:
* Marco B. Caminati http://caminati.co.nr
* Manfred Kerber <mnfrd.krbr@gmail.com>
* Christoph Lange <math.semantic.web@gmail.com>
* Colin Rowat <c.rowat@bham.ac.uk>

Dually licenced under
* Creative Commons Attribution (CC-BY) 3.0
* ISC License (1-clause BSD License)
See LICENSE file for details
(Rationale for this dual licence: http://arxiv.org/abs/1107.3212)
*)

section \<open>Termination theorem for uniform tie-breaking\<close>

theory UniformTieBreaking

imports
StrictCombinatorialAuction
Universes
"HOL-Library.Code_Target_Nat"

begin

subsection \<open>Uniform tie breaking: definitions\<close>
text\<open>Let us repeat the general context. Each bidder has made their bids and the VCG algorithm up
 to now allocates goods to the higher bidders. If there are several high bidders tie breaking has
to take place. To do tie breaking we generate out of a random number a second bid vector so that
the same algorithm can be run again to determine a unique allocation.

To this end, we associate to each allocation the bid in which each participant bids for a set
of goods an amount equal to the cardinality of the intersection of the bid with the set
she gets in this allocation.
By construction, the revenue of an auction run using this bid is maximal on the given allocation,
and this maximal is unique.
We can then use the bid constructed this way @{term tiebids} to break ties by running an auction
having the same form as a normal auction (that is why we use the adjective ``uniform''),
only with this special bid vector.\<close>

(* omega pair is a tool to compute cardinalities of pairs, e.g. for a pair made of a participant 1 and a set of goods {11,12,13}, the result will be the set of pairs: {(1,{11}), (1,{12}), (1,{13})}.
*)
abbreviation "omega pair == {fst pair} \<times> (finestpart (snd pair))"

(* pseudo allocation is like an allocation, but without uniqueness of the elements allocated *)
definition "pseudoAllocation allocation == \<Union> (omega ` allocation)"

(* some abbreviation to defined tiebids below *)
abbreviation "bidMaximizedBy allocation N G ==
              pseudoAllocation allocation <|| ((N \<times> (finestpart G)))"
(* functional version of the above *)
abbreviation "maxbid a N G ==
              toFunction (bidMaximizedBy a N G)"

(* For bidding the cardinality of the second element of a single pair, i.e.,
   (bidder, goods) \<rightarrow> ((bidder, goods), bid) *)
abbreviation "summedBid bids pair ==
              (pair, sum (%g. bids (fst pair, g)) (finestpart (snd pair)))"

(* returns just the bid in the above *)
abbreviation "summedBidSecond bids pair ==
              sum (%g. bids (fst pair, g)) (finestpart (snd pair))"

(* apply summedBid to each possible pair *)
abbreviation "summedBidVectorRel bids N G == (summedBid bids) ` (N \<times> (Pow G - {{}}))"

(* functional version of above *)
abbreviation "summedBidVector bids N G == toFunction (summedBidVectorRel bids N G)"

(* tiebids returns a bid vector that when the VCG algorithm runs on it yields the singleton {allocation}. Functional version *)
abbreviation "tiebids allocation N G == summedBidVector (maxbid allocation N G) N G"

(* relational version of the above *)
abbreviation "Tiebids allocation N G == summedBidVectorRel (real\<circ>maxbid allocation N G) N G"

(* Assumed we have a list and a random we take the random-th element of the list. However, if the
   random number is bigger than the list is long we take it modulo the length of the list *)
definition "randomEl list (random::integer) = list ! ((nat_of_integer random) mod (size list))"

value "nat_of_integer (-3::integer) mod 2"

(* The randomEl taken out of a list is in the list *)
lemma randomElLemma:
   assumes "set list \<noteq> {}"
   shows "randomEl list random \<in> set list"
   using assms by (simp add: randomEl_def)

(* The chosen allocation takes the random-th element of all possible winning allocations. This is
   done by taking the element given by randomEl list random defined above. *)
abbreviation "chosenAllocation N G bids random ==
   randomEl (takeAll (%x. x\<in>(winningAllocationsRel N (set G) bids))
                     (allAllocationsAlg N G))
            random"

(* find the bid vector in random values that returns the chosen winning allocation *)
abbreviation "resolvingBid N G bids random ==
  tiebids (chosenAllocation N G bids random) N (set G)"

subsection \<open>Termination theorem for the uniform tie-breaking scheme\<close>

corollary winningAllocationPossible:
  "winningAllocationsRel N G b \<subseteq> allAllocations N G"
  using injectionsFromEmptyAreEmpty mem_Collect_eq subsetI by auto

lemma subsetAllocation:
  assumes "a \<in> allocationsUniverse" "c \<subseteq> a"
  shows "c \<in> allocationsUniverse"
proof -
  have "c=a-(a-c)" using assms(2) by blast
  thus ?thesis using assms(1) reducedAllocation by (metis (no_types))
qed

lemma lm001:
  assumes "a \<in> allocationsUniverse"
  shows "a outside X \<in> allocationsUniverse"
  using assms reducedAllocation Outside_def by (metis (no_types))

corollary lm002:
  "{x}\<times>({X}-{{}}) \<in> allocationsUniverse"
  using allocationUniverseProperty pairDifference by metis

(* TPTP? *)
corollary lm003:
  "{(x,{y})} \<in> allocationsUniverse"
proof -
  have "\<And>x1. {} - {x1::'a \<times> 'b set} = {}" by simp
  thus "{(x, {y})} \<in> allocationsUniverse"
  by (metis (no_types) allocationUniverseProperty empty_iff insert_Diff_if insert_iff prod.inject)
qed

corollary lm004:
  "allocationsUniverse \<noteq> {}"
  using lm003 by fast

corollary lm005:
  "{} \<in> allocationsUniverse"
  using subsetAllocation lm003 by (metis (lifting, mono_tags) empty_subsetI)

lemma lm006:
  assumes "G \<noteq> {}"
  shows "{G} \<in> all_partitions G"
  using all_partitions_def is_partition_of_def is_non_overlapping_def assms by force

lemma lm007:
  assumes "n \<in> N"
  shows "{(G,n)} \<in> totalRels {G} N"
  using assms by force

lemma lm008:
  assumes "n\<in>N"
  shows "{(G,n)} \<in> injections {G} N"
  using assms injections_def singlePairInInjectionsUniverse by fastforce

corollary lm009:
  assumes " G\<noteq>{}" "n\<in>N"
  shows "{(G,n)} \<in> possible_allocations_rel G N"
proof -
  have "{(G,n)} \<in> injections {G} N" using assms lm008 by fast
  moreover have "{G} \<in> all_partitions G" using assms lm006 by metis
  ultimately show ?thesis by auto
qed

corollary lm010:
  assumes "N \<noteq> {}" "G\<noteq>{}"
  shows "allAllocations N G \<noteq> {}"
  using assms lm009
  by (metis (hide_lams, no_types) equals0I image_insert insert_absorb insert_not_empty)

corollary lm011:
  assumes "N \<noteq> {}" "finite N" "G \<noteq> {}" "finite G"
  shows "winningAllocationsRel N G bids \<noteq> {} & finite (winningAllocationsRel N G bids)"
  using assms lm010 allAllocationsFinite argmax_non_empty_iff
  by (metis winningAllocationPossible rev_finite_subset)

lemma lm012:
  "allAllocations N {} \<subseteq> {{}}"
  using emptyset_part_emptyset3 rangeEmpty characterizationallAllocations
        mem_Collect_eq subsetI vimage_def by metis

lemma lm013:
  assumes "a \<in> allAllocations N G" "finite G"
  shows "finite (Range a)"
  using assms elementOfPartitionOfFiniteSetIsFinite by (metis allocationReverseInjective)

corollary allocationFinite:
  assumes "a \<in> allAllocations N G" "finite G"
  shows "finite a"
  using assms finite_converse Range_converse imageE allocationProperty finiteDomainImpliesFinite lm013
  by (metis (erased, lifting))

lemma lm014:
  assumes "a \<in> allAllocations N G" "finite G"
  shows "\<forall> y \<in> Range a. finite y"
  using assms is_partition_of_def allocationInverseRangeDomainProperty
  by (metis Union_upper rev_finite_subset)

(* Note that allocations are strict, that is, all goods are allocated to the bidders at this point. Later we will have the seller as participant 0 getting all goods not allocated *)
corollary lm015:
  assumes "a \<in> allAllocations N G" "finite G"
  shows "card G = sum card (Range a)"
  using assms cardSumCommute lm013 allocationInverseRangeDomainProperty by (metis is_partition_of_def)

subsection \<open>Results on summed bid vectors\<close>

lemma lm016:
  "summedBidVectorRel bids N G =
   {(pair, sum (%g. bids (fst pair, g)) (finestpart (snd pair)))|
    pair. pair \<in> N \<times> (Pow G-{{}})}"
  by blast

(* Note that || stands for restriction, here to an allocation a *)
corollary lm017:
  "{(pair, sum (%g. bids (fst pair, g)) (finestpart (snd pair))) |
    pair. pair \<in> (N \<times> (Pow G-{{}})) } || a =
   {(pair, sum (%g. bids (fst pair, g)) (finestpart (snd pair))) |
    pair. pair \<in> (N \<times> (Pow G-{{}}))   \<inter>  a}"
  by (metis restrictionVsIntersection)

corollary lm018:
  "(summedBidVectorRel bids N G) || a =
   {(pair, sum (%g. bids (fst pair, g)) (finestpart (snd pair))) |
    pair. pair \<in> (N \<times> (Pow G - {{}})) \<inter> a}"
   (is "?L = ?R")
proof -
  let ?l = summedBidVectorRel
  let ?M = "{(pair, sum (%g. bids (fst pair, g)) (finestpart (snd pair))) |
             pair. pair \<in> N \<times> (Pow G-{{}})}"
  have "?l bids N G = ?M" by (rule lm016)
  then have "?L = (?M || a)" by presburger
  moreover have "... = ?R" by (rule lm017)
  ultimately show ?thesis by simp
qed

lemma lm019:
  "(summedBid bids) ` ((N \<times> (Pow G - {{}})) \<inter> a) =
   {(pair, sum (%g. bids (fst pair, g)) (finestpart (snd pair))) |
    pair. pair \<in> (N \<times> (Pow G - {{}})) \<inter> a}"
  by blast

corollary lm020:
  "(summedBidVectorRel bids N G) || a = (summedBid bids) ` ((N \<times> (Pow G - {{}})) \<inter> a)"
  (is "?L=?R")
proof -
  let ?l=summedBidVectorRel
  let ?p=summedBid
  let ?M="{(pair, sum (%g. bids (fst pair, g)) (finestpart (snd pair))) |
           pair. pair \<in> (N \<times> (Pow G - {{}})) \<inter> a}"
  have "?L = ?M" by (rule lm018)
  moreover have "... = ?R" using lm019 by blast
  ultimately show ?thesis by simp
qed

(* the function made by (summedBid bids) is always injective, that is, also with domain UNIV *)
lemma summedBidInjective:
  "inj_on (summedBid bids) UNIV"
  using fst_conv inj_on_inverseI by (metis (lifting))

(* restrict above to any set X *)
corollary lm021:
  "inj_on (summedBid bids) X"
  using fst_conv inj_on_inverseI by (metis (lifting))

(* relationship between different formalizations of summedBid *)
lemma lm022:
  "sum snd (summedBidVectorRel bids N G) =
   sum (snd \<circ> (summedBid bids)) (N \<times> (Pow G - {{}}))"
  using lm021 sum.reindex by blast

(* remember: omega of (1,{11,12,13}) is {(1,{11}), (1,{12}), (1,{13})} *)
corollary lm023:
  "snd (summedBid bids pair) = sum bids (omega pair)"
  using sumCurry by force

(* restatement of the above *)
corollary lm024:
  "snd \<circ> summedBid bids = (sum bids) \<circ> omega"
  using lm023 by fastforce

lemma lm025:
  assumes "finite  (finestpart (snd pair))"
  shows "card (omega pair) = card (finestpart (snd pair))"
  using assms by force

corollary lm026:
  assumes "finite (snd pair)"
  shows "card (omega pair) = card (snd pair)"
  using assms cardFinestpart card_cartesian_product_singleton by metis

lemma lm027:
  assumes "{} \<notin> Range f" "runiq f"
  shows "is_non_overlapping (omega ` f)"
proof -
let ?X="omega ` f" let ?p=finestpart
  { fix y1 y2
    assume "y1 \<in> ?X \<and> y2 \<in> ?X"
    then obtain pair1 pair2 where
      "y1 = omega pair1 & y2 = omega pair2 & pair1 \<in> f & pair2 \<in> f" by blast
    then moreover have "snd pair1 \<noteq> {} & snd pair1 \<noteq> {}"
      using assms by (metis rev_image_eqI snd_eq_Range)
    ultimately moreover have "fst pair1 = fst pair2 \<longleftrightarrow> pair1 = pair2"
      using assms runiq_basic surjective_pairing by metis
    ultimately moreover have "y1 \<inter> y2 \<noteq> {} \<longrightarrow> y1 = y2" using assms by fast
    ultimately have "y1 = y2 \<longleftrightarrow> y1 \<inter> y2 \<noteq> {}"
      using assms notEmptyFinestpart by (metis Int_absorb Times_empty insert_not_empty)
    }
  thus ?thesis using is_non_overlapping_def
    by (metis (lifting, no_types) inf_commute inf_sup_aci(1))
qed

lemma lm028:
  assumes "{} \<notin> Range X"
  shows "inj_on omega X"
proof -
  let ?p=finestpart
  {
    fix pair1 pair2
    assume "pair1 \<in> X & pair2 \<in> X"
    then have "snd pair1 \<noteq> {} & snd pair2 \<noteq> {}"
      using assms by (metis Range.intros surjective_pairing)
    moreover assume "omega pair1 = omega pair2"
    then moreover have "?p (snd pair1) = ?p (snd pair2)" by blast
    then moreover have "snd pair1 = snd pair2" by (metis finestPart nonEqualitySetOfSets)
    ultimately moreover have "{fst pair1} = {fst pair2}" using notEmptyFinestpart
      by (metis fst_image_times)
    ultimately have "pair1 = pair2" by (metis prod_eqI singleton_inject)
  }
  thus ?thesis by (metis (lifting, no_types) inj_onI)
qed

lemma lm029:
  assumes "{} \<notin> Range a" "\<forall>X \<in> omega ` a. finite X"
          "is_non_overlapping (omega ` a)"
  shows "card (pseudoAllocation a) = sum (card \<circ> omega) a"
  (is "?L = ?R")
proof -
  have "?L = sum card (omega ` a)"
  unfolding pseudoAllocation_def
  using assms by (simp add: cardinalityPreservation)
  moreover have "... = ?R" using assms(1) lm028 sum.reindex by blast
  ultimately show ?thesis by simp
qed

lemma lm030:
  "card (omega pair)= card (snd pair)"
  using cardFinestpart card_cartesian_product_singleton by metis

corollary lm031:
  "card \<circ> omega = card \<circ> snd"
  using lm030 by fastforce

(* set image of omega on a set of pair is called pseudoAllocation *)
corollary lm032:
  assumes "{} \<notin> Range a" "\<forall> pair \<in> a. finite (snd pair)" "finite a" "runiq a"
  shows "card (pseudoAllocation a) = sum (card \<circ> snd) a"
proof -
  let ?P=pseudoAllocation
  let ?c=card
  have "\<forall> pair \<in> a. finite (omega pair)" using finiteFinestpart assms by blast
  moreover have "is_non_overlapping (omega ` a)" using assms lm027 by force
  ultimately have "?c (?P a) = sum (?c \<circ> omega) a" using assms lm029 by force
  moreover have "... = sum (?c \<circ> snd) a" using lm031 by metis
  ultimately show ?thesis by simp
qed

corollary lm033:
  assumes "runiq (a^-1)" "runiq a" "finite a" "{} \<notin> Range a" "\<forall> pair \<in> a. finite (snd pair)"
  shows "card (pseudoAllocation a) = sum card (Range a)"
  using assms sumPairsInverse lm032 by force

corollary lm034:
  assumes "a \<in> allAllocations N G" "finite G"
  shows "card (pseudoAllocation a) = card G"
proof -
  have "{} \<notin> Range a" using assms by (metis emptyNotInRange)
  moreover have "\<forall> pair \<in> a. finite (snd pair)" using assms lm014 finitePairSecondRange by metis
  moreover have "finite a" using assms allocationFinite by blast
  moreover have "runiq a" using assms
    by (metis (lifting) Int_lower1 in_mono allocationInjectionsUnivervseProperty mem_Collect_eq)
  moreover have "runiq (a^-1)" using assms
    by (metis (mono_tags) injections_def characterizationallAllocations mem_Collect_eq)
  ultimately have "card (pseudoAllocation a) = sum card (Range a)" using lm033 by fast
  moreover have "... = card G" using assms lm015 by metis
  ultimately show ?thesis by simp
qed

corollary lm035:
  assumes "pseudoAllocation aa \<subseteq> pseudoAllocation a \<union> (N \<times> (finestpart G))"
          "finite (pseudoAllocation aa)"
  shows "sum (toFunction (bidMaximizedBy a N G)) (pseudoAllocation a) -
            (sum (toFunction (bidMaximizedBy a N G)) (pseudoAllocation aa)) =
         card (pseudoAllocation a) -
            card (pseudoAllocation aa \<inter> (pseudoAllocation a))"
  using assms subsetCardinality by blast

corollary lm036:
  assumes "pseudoAllocation aa \<subseteq> pseudoAllocation a \<union> (N \<times> (finestpart G))"
          "finite (pseudoAllocation aa)"
  shows "int (sum (maxbid a N G) (pseudoAllocation a)) -
           int (sum (maxbid a N G) (pseudoAllocation aa)) =
         int (card (pseudoAllocation a)) -
           int (card (pseudoAllocation aa \<inter> (pseudoAllocation a)))"
  using differenceSumVsCardinality assms by blast

lemma lm037:
  "pseudoAllocation {} = {}"
  unfolding pseudoAllocation_def by simp

corollary lm038:
  assumes "a \<in> allAllocations N {}"
  shows "(pseudoAllocation a) = {}"
  unfolding pseudoAllocation_def using assms lm012 by blast

corollary lm039:
  assumes "a \<in> allAllocations N G" "finite G" "G \<noteq> {}"
  shows "finite (pseudoAllocation a)"
proof -
  have "card (pseudoAllocation a) = card G" using assms(1,2) lm034 by blast
  thus "finite (pseudoAllocation a)" using assms(2,3) by fastforce
qed

corollary lm040:
  assumes "a \<in> allAllocations N G" "finite G"
  shows "finite (pseudoAllocation a)"
  using assms finite.emptyI lm039 lm038 by (metis (no_types))

lemma lm041:
  assumes "a \<in> allAllocations N G" "aa \<in> allAllocations N G" "finite G"
  shows  "(card (pseudoAllocation aa \<inter> (pseudoAllocation a)) = card (pseudoAllocation a)) =
          (pseudoAllocation a = pseudoAllocation aa)"
proof -
  let ?P=pseudoAllocation
  let ?c=card
  let ?A="?P a"
  let ?AA="?P aa"
  have "?c ?A=?c G & ?c ?AA=?c G" using assms lm034 by (metis (lifting, mono_tags))
  moreover have "finite ?A & finite ?AA" using assms lm040 by blast
  ultimately show ?thesis using assms cardinalityIntersectionEquality by (metis(no_types,lifting))
qed

(* alternative definition for omega *)
lemma lm042:
  "omega pair = {fst pair} \<times> {{y}| y. y \<in> snd pair}"
  using finestpart_def finestPart by auto

(* variant of above *)
lemma lm043:
  "omega pair = {(fst pair, {y})| y. y \<in>  snd pair}"
  using lm042 setOfPairs by metis

lemma lm044:
  "pseudoAllocation a = \<Union> {{(fst pair, {y})| y. y \<in> snd pair}| pair. pair \<in> a}"
  unfolding pseudoAllocation_def using lm043 by blast

lemma lm045:
  "\<Union> {{(fst pair, {y})| y. y \<in> snd pair}| pair. pair \<in> a} =
   {(fst pair, {y})| y pair. y \<in> snd pair & pair \<in> a}"
  by blast

corollary lm046:
  "pseudoAllocation a = {(fst pair, Y)| Y pair. Y \<in> finestpart (snd pair) & pair \<in> a}"
  unfolding pseudoAllocation_def using setOfPairsEquality by fastforce

lemma lm047:
  assumes "runiq a"
  shows "{(fst pair, Y)| Y pair. Y \<in> finestpart (snd pair) & pair \<in> a} =
         {(x, Y)| Y x. Y \<in> finestpart (a,,x) & x \<in> Domain a}"
         (is "?L=?R")
  using assms Domain.DomainI fst_conv functionOnFirstEqualsSecond runiq_wrt_ex1 surjective_pairing
  by (metis(hide_lams,no_types))

corollary lm048:
  assumes "runiq a"
  shows "pseudoAllocation a = {(x, Y)| Y x. Y \<in> finestpart (a,,x) & x \<in> Domain a}"
  unfolding pseudoAllocation_def using assms lm047 lm046 by fastforce

corollary lm049:
  "Range (pseudoAllocation a) = \<Union> (finestpart ` (Range a))"
  unfolding pseudoAllocation_def
  using lm046 rangeSetOfPairs unionFinestPart  by fastforce

corollary lm050:
  "Range (pseudoAllocation a) = finestpart (\<Union> (Range a))"
  using commuteUnionFinestpart lm049 by metis

lemma lm051:
  "pseudoAllocation a = {(fst pair, {y})| y pair. y \<in> snd pair & pair \<in> a}"
  using lm044 lm045 by (metis (no_types))

lemma lm052:
  "{(fst pair, {y})| y pair. y \<in> snd pair & pair \<in> a} =
   {(x, {y})| x y. y \<in> \<Union> (a``{x}) & x \<in> Domain a}"
   by auto

lemma lm053:
  "pseudoAllocation a = {(x, {y})| x y. y \<in> \<Union> (a``{x}) & x \<in> Domain a}"
  (is "?L=?R")
proof -
  have "?L={(fst pair, {y})| y pair. y \<in> snd pair & pair \<in> a}" by (rule lm051)
  moreover have "... = ?R" by (rule lm052)
  ultimately show ?thesis by simp
qed

lemma lm054:
  "runiq (summedBidVectorRel bids N G)"
  using graph_def image_Collect_mem domainOfGraph by (metis(no_types))

corollary lm055:
  "runiq (summedBidVectorRel bids N G || a)"
  unfolding restrict_def using lm054 subrel_runiq Int_commute by blast

lemma summedBidVectorCharacterization:
  "N \<times> (Pow G - {{}}) = Domain (summedBidVectorRel bids N G)"
  by blast

corollary lm056:
  assumes "a \<in> allAllocations N G"
  shows "a \<subseteq> Domain (summedBidVectorRel bids N G)"
proof -
  let ?p=allAllocations
  let ?L=summedBidVectorRel
  have "a \<subseteq> N \<times> (Pow G - {{}})" using assms allocationPowerset by (metis(no_types))
  moreover have "N \<times> (Pow G - {{}}) = Domain (?L bids N G)" using summedBidVectorCharacterization by blast
  ultimately show ?thesis by blast
qed

corollary lm057:
  "sum (summedBidVector bids N G) (a \<inter> (Domain (summedBidVectorRel bids N G))) =
   sum snd ((summedBidVectorRel bids N G) || a)"
  using sumRestrictedToDomainInvariant lm055 by fast

corollary lm058:
  assumes "a \<in> allAllocations N G"
  shows "sum (summedBidVector bids N G) a = sum snd ((summedBidVectorRel bids N G) || a)"
proof -
  let ?l=summedBidVector let ?L=summedBidVectorRel
  have "a \<subseteq> Domain (?L bids N G)" using assms by (rule lm056)
  then have "a = a \<inter> Domain (?L bids N G)" by blast
  then have "sum (?l bids N G) a = sum (?l bids N G) (a \<inter> Domain (?L bids N G))"
       by presburger
  thus ?thesis using lm057 by auto
qed

corollary lm059:
  assumes "a \<in> allAllocations N G"
  shows "sum (summedBidVector bids N G) a =
         sum snd ((summedBid bids) ` ((N \<times> (Pow G - {{}})) \<inter> a))"
        (is "?X=?R")
proof -
  let ?p = summedBid
  let ?L = summedBidVectorRel
  let ?l = summedBidVector
  let ?A = "N \<times> (Pow G - {{}})"
  let ?inner2 = "(?p bids)`(?A \<inter> a)"
  let ?inner1 = "(?L bids N G)||a"
  have "?R = sum snd ?inner1" using assms lm020 by (metis (no_types))
  moreover have "sum (?l bids N G) a = sum snd ?inner1" using assms by (rule lm058)
  ultimately show ?thesis by simp
qed

corollary lm060:
  assumes "a \<in> allAllocations N G"
  shows "sum (summedBidVector bids N G) a = sum snd ((summedBid bids) ` a)"
  (is "?L=?R")
proof -
  let ?p=summedBid
  let ?l=summedBidVector
  have "?L = sum snd ((?p bids)`((N \<times> (Pow G - {{}}))\<inter> a))" using assms by (rule lm059)
  moreover have "... = ?R" using assms allocationPowerset Int_absorb1 by (metis (no_types))
  ultimately show ?thesis by simp
qed

corollary lm061:
  "sum snd ((summedBid bids) ` a) = sum (snd \<circ> (summedBid bids)) a"
  using sum.reindex lm021 by blast

corollary lm062:
  assumes "a \<in> allAllocations N G"
  shows "sum (summedBidVector bids N G) a = sum (snd \<circ> (summedBid bids)) a"
  (is "?L=?R")
proof -
  let ?p = summedBid
  let ?l = summedBidVector
  have "?L = sum snd ((?p bids)` a)" using assms by (rule lm060)
  moreover have "... = ?R" using assms lm061 by blast
  ultimately show ?thesis by simp
qed

corollary lm063:
  assumes "a \<in> allAllocations N G"
  shows "sum (summedBidVector bids N G) a = sum ((sum bids) \<circ> omega) a"
  (is "?L=?R")
proof -
  let ?inner1 = "snd \<circ> (summedBid bids)"
  let ?inner2="(sum bids) \<circ> omega"
  let ?M="sum ?inner1 a"
  have "?L = ?M" using assms by (rule lm062)
  moreover have "?inner1 = ?inner2" using lm023 assms by fastforce
  ultimately show "?L = ?R" using assms by metis
qed

corollary lm064:
  assumes "a \<in> allAllocations N G"
  shows "sum (summedBidVector bids N G) a = sum (sum bids) (omega` a)"
proof -
  have "{} \<notin> Range a" using assms by (metis emptyNotInRange)
  then have "inj_on omega a" using lm028 by blast
  then have "sum (sum bids) (omega ` a) = sum ((sum bids) \<circ> omega) a"
       by (rule sum.reindex)
  moreover have "sum (summedBidVector bids N G) a = sum ((sum bids) \<circ> omega) a"
       using assms lm063 by (rule Extraction.exE_realizer)
  ultimately show ?thesis by presburger
qed

lemma lm065:
  assumes "finite (snd pair)"
  shows "finite (omega pair)"
  using assms finite.emptyI finite.insertI finite_SigmaI finiteFinestpart  by (metis(no_types))

corollary lm066:
  assumes "\<forall>y\<in>(Range a). finite y"
  shows "\<forall>y\<in>(omega ` a). finite y"
  using assms lm065 imageE finitePairSecondRange by fast

corollary lm067:
  assumes "a \<in> allAllocations N G" "finite G"
  shows "\<forall>x\<in>(omega ` a). finite x"
  using assms lm066 lm014 by (metis(no_types))

corollary lm068:
  assumes "a \<in> allAllocations N G"
  shows "is_non_overlapping (omega ` a)"
proof -
  have "runiq a" by (metis (no_types) assms image_iff allocationRightUniqueRangeDomain)
  moreover have "{} \<notin> Range a" using assms by (metis emptyNotInRange)
  ultimately show ?thesis using lm027 by blast
qed

lemma lm069:
  assumes "a \<in> allAllocations N G" "finite G"
  shows "sum (sum bids) (omega` a) = sum bids (\<Union> (omega ` a))"
  using assms sumUnionDisjoint2 lm068 lm067 by (metis (lifting, mono_tags))

corollary lm070:
  assumes "a \<in> allAllocations N G" "finite G"
  shows "sum (summedBidVector bids N G) a = sum bids (pseudoAllocation a)"
  (is "?L = ?R")
proof -
  have "?L = sum (sum bids) (omega `a)" using assms lm064 by blast
  moreover have "... = sum bids (\<Union> (omega ` a))" using assms lm069 by blast
  ultimately show ?thesis unfolding pseudoAllocation_def by presburger
qed

lemma lm071:
  "Domain (pseudoAllocation a) \<subseteq> Domain a"
  unfolding pseudoAllocation_def by fastforce

corollary lm072:
  assumes "a \<in> allAllocations N G"
  shows "Domain (pseudoAllocation a) \<subseteq> N   &   Range (pseudoAllocation a) = finestpart G"
  using assms lm071 allocationInverseRangeDomainProperty lm050 is_partition_of_def subset_trans
  by (metis(no_types))

corollary lm073:
  assumes "a \<in> allAllocations N G"
  shows "pseudoAllocation a \<subseteq> N \<times> finestpart G"
proof -
  let ?p = pseudoAllocation
  let ?aa = "?p a"
  let ?d = Domain
  let ?r = Range
  have "?d ?aa \<subseteq> N" using assms lm072 by (metis (lifting, mono_tags))
  moreover have "?r ?aa \<subseteq> finestpart G" using assms lm072 by (metis (lifting, mono_tags) equalityE)
  ultimately have "?d ?aa \<times> (?r ?aa) \<subseteq> N \<times> finestpart G" by auto
  then show "?aa \<subseteq> N \<times> finestpart G" by auto
qed

subsection \<open>From Pseudo-allocations to allocations\<close>

(* pseudoAllocationInv inverts pseudoAllocation *)
abbreviation "pseudoAllocationInv pseudo == {(x, \<Union> (pseudo `` {x}))| x. x \<in> Domain pseudo}"

lemma lm074:
  assumes "runiq a" "{} \<notin> Range a"
  shows "a = pseudoAllocationInv (pseudoAllocation a)"
proof -
  let ?p="{(x, Y)| Y x. Y \<in> finestpart (a,,x) & x \<in> Domain a}"
  let ?a="{(x, \<Union> (?p `` {x}))| x. x \<in> Domain ?p}"
  have "\<forall>x \<in> Domain a. a,,x \<noteq> {}" by (metis assms eval_runiq_in_Range)
  then have "\<forall>x \<in> Domain a. finestpart (a,,x) \<noteq> {}" by (metis notEmptyFinestpart)
  then have "Domain a \<subseteq> Domain ?p" by force
  moreover have "Domain a \<supseteq> Domain ?p" by fast
  ultimately have
  1: "Domain a = Domain ?p" by fast
  {
    fix z assume "z \<in> ?a"
    then obtain x where
    "x \<in> Domain ?p & z=(x , \<Union> (?p `` {x}))" by blast
    then have "x \<in> Domain a & z=(x , \<Union> (?p `` {x}))" by fast
    then moreover have "?p``{x} = finestpart (a,,x)" using assms by fastforce
    moreover have "\<Union> (finestpart (a,,x))= a,,x" by (metis finestPartUnion)
    ultimately have "z \<in> a" by (metis assms(1) eval_runiq_rel)
  }
  then have
  2: "?a \<subseteq> a" by fast
  {
    fix z assume 0: "z \<in> a" let ?x="fst z" let ?Y="a,,?x" let ?YY="finestpart ?Y"
    have "z \<in> a & ?x \<in> Domain a" using 0 by (metis fst_eq_Domain rev_image_eqI)
    then have
    3: "z \<in> a & ?x \<in> Domain ?p" using 1 by presburger
    then have "?p `` {?x} = ?YY" by fastforce
    then have "\<Union> (?p `` {?x}) = ?Y" by (metis finestPartUnion)
    moreover have "z = (?x, ?Y)" using assms by (metis "0" functionOnFirstEqualsSecond
                                                           surjective_pairing)
    ultimately have "z \<in> ?a" using 3 by (metis (lifting, mono_tags) mem_Collect_eq)
  }
  then have "a = ?a" using 2 by blast
  moreover have "?p = pseudoAllocation a" using lm048 assms by (metis (lifting, mono_tags))
  ultimately show ?thesis by auto
qed

corollary lm075:
  assumes "a \<in> runiqs \<inter> Pow (UNIV \<times> (UNIV - {{}}))"
  shows "(pseudoAllocationInv \<circ> pseudoAllocation) a = id a"
proof -
  have "runiq a" using runiqs_def assms by fast
  moreover have "{} \<notin> Range a" using assms by blast
  ultimately show ?thesis using lm074 by fastforce
qed

lemma lm076:
  "inj_on (pseudoAllocationInv \<circ> pseudoAllocation) (runiqs \<inter> Pow (UNIV \<times> (UNIV - {{}})))"
proof -
  let ?ne="Pow (UNIV \<times> (UNIV - {{}}))"
  let ?X="runiqs \<inter> ?ne"
  let ?f="pseudoAllocationInv \<circ> pseudoAllocation"
  have "\<forall>a1 \<in> ?X. \<forall> a2 \<in> ?X. ?f a1 = ?f a2 \<longrightarrow> id a1 = id a2" using lm075 by blast
  then have "\<forall>a1 \<in> ?X. \<forall> a2 \<in> ?X. ?f a1 = ?f a2 \<longrightarrow> a1 = a2" by auto
  thus ?thesis unfolding inj_on_def by blast
qed

corollary lm077:
  "inj_on pseudoAllocation (runiqs \<inter> Pow (UNIV \<times> (UNIV - {{}})))"
  using lm076 inj_on_imageI2 by blast

lemma lm078:
  "injectionsUniverse \<subseteq> runiqs"
  using runiqs_def Collect_conj_eq Int_lower1 by metis

lemma lm079:
  "partitionValuedUniverse \<subseteq> Pow (UNIV \<times> (UNIV - {{}}))"
  using is_non_overlapping_def by force

corollary lm080:
  "allocationsUniverse \<subseteq> runiqs \<inter> Pow (UNIV \<times> (UNIV - {{}}))"
  using lm078 lm079 by auto

corollary lm081:
  "inj_on pseudoAllocation allocationsUniverse"
  using lm077 lm080 subset_inj_on by blast

corollary lm082:
  "inj_on pseudoAllocation (allAllocations N G)"
proof -
  have "allAllocations N G \<subseteq> allocationsUniverse"
    by (metis (no_types) allAllocationsUniverse)
  thus "inj_on pseudoAllocation (allAllocations N G)" using lm081 subset_inj_on by blast
qed

lemma lm083:
  assumes "card N > 0" "distinct G"
  shows "winningAllocationsRel N (set G) bids \<subseteq> set (allAllocationsAlg N G)"
  using assms winningAllocationPossible allAllocationsBridgingLemma by (metis(no_types))

corollary lm084:
  assumes "N \<noteq> {}" "finite N" "distinct G" "set G \<noteq> {}"
  shows "winningAllocationsRel N (set G) bids \<inter> set (allAllocationsAlg N G) \<noteq> {}"
proof -
  let ?w = winningAllocationsRel
  let ?a = allAllocationsAlg
  let ?G = "set G"
  have "card N > 0" using assms by (metis card_gt_0_iff)
  then have "?w N ?G bids \<subseteq> set (?a N G)" using lm083 by (metis assms(3))
  then show ?thesis using assms lm011 by (metis List.finite_set le_iff_inf)
qed

(* -` is the reverse image *)
lemma lm085:
  "X = (%x. x \<in> X) -`{True}"
  by blast

corollary lm086:
  assumes  "N \<noteq> {}" "finite N" "distinct G" "set G \<noteq> {}"
  shows "(%x. x\<in>winningAllocationsRel N (set G) bids)-`{True} \<inter>
         set (allAllocationsAlg N G) \<noteq> {}"
  using assms lm084 lm085 by metis

lemma lm087:
  assumes "P -` {True} \<inter> set l \<noteq> {}"
  shows "takeAll P l \<noteq> []"
  using assms nonEmptyListFiltered filterpositions2_def by (metis Nil_is_map_conv)

corollary lm088:
  assumes "N \<noteq> {}" "finite N" "distinct G" "set G \<noteq> {}"
  shows "takeAll (%x. x \<in> winningAllocationsRel N (set G) bids) (allAllocationsAlg N G) \<noteq> []"
  using assms lm087 lm086 by metis

corollary lm089:
  assumes "N \<noteq> {}" "finite N" "distinct G" "set G \<noteq> {}"
  shows "perm2 (takeAll (%x. x \<in> winningAllocationsRel N (set G) bids)
                        (allAllocationsAlg N G))
               n \<noteq> []"
  using assms permutationNotEmpty lm088 by metis

(* The chosen allocation is in the set of possible winning allocations *)

corollary lm090:
  assumes "N \<noteq> {}" "finite N" "distinct G" "set G \<noteq> {}"
  shows "chosenAllocation N G bids random \<in> winningAllocationsRel N (set G) bids"
proof -
  have "\<And>x\<^sub>1 b_x x. set x\<^sub>1 = {}
        \<or> (randomEl x\<^sub>1 b_x::('a \<times> 'b set) set) \<in> x
        \<or> \<not> set x\<^sub>1 \<subseteq> x" by (metis (no_types) randomElLemma subsetCE)
  thus "winningAllocationRel N (set G)
          ((\<in>) (randomEl (takeAll (\<lambda>x. winningAllocationRel N (set G) ((\<in>) x) bids)
                (allAllocationsAlg N G)) random)) bids"
       by (metis lm088 assms(1) assms(2) assms(3) assms(4) takeAllSubset set_empty)
qed

(* The following lemma proves a property of maxbid, which in the following will be proved to maximize the revenue. a and aa are allocations. *)

lemma lm092:
  "summedBidVectorRel bids N G = graph (N \<times> (Pow G-{{}})) (summedBidSecond bids)"
  unfolding graph_def using lm016 by blast

lemma lm093:
  assumes "x\<in>X"
  shows "toFunction (graph X f) x = f x"
  using assms by (metis graphEqImage toFunction_def)

corollary lm094:
  assumes "pair \<in> N \<times> (Pow G-{{}})"
  shows "summedBidVector bids N G pair = summedBidSecond bids pair"
  using assms lm093 lm092 by (metis(mono_tags))

(* type conversion to real commutes *)
lemma lm095:
  "summedBidSecond (real \<circ> ((bids:: _ => nat))) pair = real (summedBidSecond bids pair)"
  by simp

lemma lm096:
  assumes "pair \<in> N \<times> (Pow G-{{}})"
  shows  "summedBidVector (real\<circ>(bids:: _ => nat)) N G pair =
          real (summedBidVector bids N G pair)"
  using assms lm094 lm095 by (metis(no_types))

(* TPTP?*)
corollary lm097:
  assumes "X \<subseteq> N \<times> (Pow G - {{}})"
  shows "\<forall>pair \<in> X. summedBidVector (real \<circ> (bids::_=>nat)) N G pair =
         (real \<circ> (summedBidVector bids N G)) pair"
proof -
  { fix esk48\<^sub>0 :: "'a \<times> 'b set"
    { assume "esk48\<^sub>0 \<in> N \<times> (Pow G - {{}})"
      hence "summedBidVector (real \<circ> bids) N G esk48\<^sub>0 = real (summedBidVector bids N G esk48\<^sub>0)" using lm096 by blast
      hence "esk48\<^sub>0 \<notin> X \<or> summedBidVector (real \<circ> bids) N G esk48\<^sub>0 = (real \<circ> summedBidVector bids N G) esk48\<^sub>0" by simp }
    hence "esk48\<^sub>0 \<notin> X \<or> summedBidVector (real \<circ> bids) N G esk48\<^sub>0 = (real \<circ> summedBidVector bids N G) esk48\<^sub>0" using assms by blast }
  thus "\<forall>pair\<in>X. summedBidVector (real \<circ> bids) N G pair = (real \<circ> summedBidVector bids N G) pair" by blast
qed

corollary lm098:
  assumes "aa \<subseteq> N \<times> (Pow G-{{}})"
  shows "sum ((summedBidVector (real \<circ> (bids::_=>nat)) N G)) aa =
         real (sum ((summedBidVector bids N G)) aa)"
  (is "?L=?R")
proof -
  have "\<forall> pair \<in> aa. summedBidVector (real \<circ> bids) N G pair =
                     (real \<circ> (summedBidVector bids N G)) pair"
  using assms by (rule lm097)
  then have "?L = sum (real\<circ>(summedBidVector bids N G)) aa" using sum.cong by force
  then show ?thesis by simp
qed

corollary lm099:
  assumes "aa \<in> allAllocations N G"
  shows "sum ((summedBidVector (real \<circ> (bids::_=>nat)) N G)) aa =
         real (sum ((summedBidVector bids N G)) aa)"
  using assms lm098 allocationPowerset by (metis(lifting,mono_tags))

corollary lm100:
  assumes "finite G" "a \<in> allAllocations N G" "aa \<in> allAllocations N G"
  shows "real (sum (tiebids a N G) a) - sum (tiebids a N G) aa =
         real (card G) - card (pseudoAllocation aa \<inter> (pseudoAllocation a))"
  (is "?L=?R")
proof -
  let ?l=summedBidVector
  let ?m=maxbid
  let ?s=sum
  let ?p=pseudoAllocation
  let ?bb="?m a N G"
  let ?b="real \<circ> (?m a N G)"
  have "real (?s ?bb (?p a)) - (?s ?bb (?p aa)) = ?R" using assms lm091 by blast
  then have
  1: "?R = real (?s ?bb (?p a)) - (?s ?bb (?p aa))" by simp
  have " ?s (?l ?b N G) aa = ?s ?b (?p aa)" using assms lm070 by blast moreover have
  "... = ?s ?bb (?p aa)" by fastforce
  moreover have "(?s (?l ?b N G) aa) = real (?s (?l ?bb N G) aa)" using assms(3) by (rule lm099)
  ultimately have
  2: "?R = real (?s ?bb (?p a)) - (?s (?l ?bb N G) aa)" by (metis 1)
  have "?s (?l ?b N G) a=(?s ?b (?p a))" using assms lm070 by blast
  moreover have "... = ?s ?bb (?p a)" by force
  moreover have "... = real (?s ?bb (?p a))" by fast
  moreover have "?s (?l ?b N G) a = real (?s (?l ?bb N G) a)" using assms(2) by (rule lm099)
  ultimately have "?s (?l ?bb N G) a = real (?s ?bb (?p a))" by simp
  thus ?thesis using 2 by simp
qed

corollary lm101:
  assumes "finite G" "a \<in> allAllocations N G" "aa \<in> allAllocations N G"
          "x = real (sum (tiebids a N G) a) - sum (tiebids a N G) aa"
  shows "x <= card G &
         x \<ge> 0 &
        (x=0 \<longleftrightarrow> a = aa) &
        (aa \<noteq> a \<longrightarrow> sum (tiebids a N G) aa < sum (tiebids a N G) a)"
proof -
  let ?p = pseudoAllocation
  have "real (card G) >= real (card G) - card (?p aa \<inter> (?p a))" by force
  moreover have "real (sum (tiebids a N G) a) - sum (tiebids a N G) aa =
                 real (card G) - card (pseudoAllocation aa \<inter> (pseudoAllocation a))"
           using assms lm100 by blast
  ultimately have
  1: "x=real(card G)-card(pseudoAllocation aa\<inter>(pseudoAllocation a))" using assms by force
  then have
  2: "x \<le> real (card G)" using assms by linarith
  have
  3: "card (?p aa) = card G & card (?p a) = card G" using assms lm034 by blast
  moreover have "finite (?p aa) & finite (?p a)" using assms lm040 by blast
  ultimately have "card (?p aa \<inter> ?p a) \<le> card G" using Int_lower2 card_mono by fastforce
  then have
  4: "x \<ge> 0" using assms lm100 1 by linarith
  have "card (?p aa \<inter> (?p a)) = card G \<longleftrightarrow> (?p aa = ?p a)"
       using 3 lm041 4 assms by (metis (lifting, mono_tags))
  moreover have "?p aa = ?p a \<longrightarrow> a = aa" using assms lm082 inj_on_def
       by (metis (lifting, mono_tags))
  ultimately have "card (?p aa \<inter> (?p a)) = card G \<longleftrightarrow> (a=aa)" by blast
  moreover have "x = real (card G) - card (?p aa \<inter> (?p a))" using assms lm100 by blast
  ultimately have
  5: "x = 0 \<longleftrightarrow> (a=aa)" by linarith
  then have
  "aa \<noteq> a \<longrightarrow> sum (tiebids a N G) aa < real (sum (tiebids a N G) a)"
        using 1 4 assms by auto
  thus ?thesis using 2 4 5
    unfolding of_nat_less_iff by force
qed

(* If for an arbitrary allocation a we compute tiebids for it then the corresponding revenue is strictly maximal. *)
corollary lm102:
  assumes "finite G" "a \<in> allAllocations N G"
          "aa \<in> allAllocations N G" "aa \<noteq> a"
  shows "sum (tiebids a N G) aa < sum (tiebids a N G) a"
  using assms lm101 by blast

lemma lm103:
  assumes "N \<noteq> {}" "finite N" "distinct G" "set G \<noteq> {}"
          "aa \<in> (allAllocations N (set G))-{chosenAllocation N G bids random}"
  shows "sum (resolvingBid N G bids random) aa <
         sum (resolvingBid N G bids random) (chosenAllocation N G bids random)"
proof -
  let ?a="chosenAllocation N G bids random"
  let ?p=allAllocations
  let ?G="set G"
  have "?a \<in> winningAllocationsRel N (set G) bids" using assms lm090 by blast
  moreover have "winningAllocationsRel N (set G) bids \<subseteq> ?p N ?G" using assms winningAllocationPossible by metis
  ultimately have "?a \<in> ?p N ?G" using lm090 assms winningAllocationPossible rev_subsetD by blast
  then show ?thesis using assms lm102 by blast
qed

(* putting together the two rounds in the auction, first using the bids, then the random values. *)
abbreviation "terminatingAuctionRel N G bids random ==
              argmax (sum (resolvingBid N G bids random))
                     (argmax (sum bids) (allAllocations N (set G)))"

text\<open>Termination theorem: it assures that the number of winning allocations is exactly one\<close>
theorem winningAllocationUniqueness:
  assumes "N \<noteq> {}" "distinct G" "set G \<noteq> {}" "finite N"
  shows "terminatingAuctionRel N G (bids) random = {chosenAllocation N G bids random}"
proof -
  let ?p = allAllocations
  let ?G = "set G"
  let ?X = "argmax (sum bids) (?p N ?G)"
  let ?a = "chosenAllocation N G bids random"
  let ?b = "resolvingBid N G bids random"
  let ?f = "sum ?b"
  let ?t=terminatingAuctionRel
  have "\<forall>aa \<in> (allAllocations N ?G)-{?a}. ?f aa < ?f ?a"
    using assms lm103 by blast
  then have "\<forall>aa \<in> ?X-{?a}. ?f aa < ?f ?a" using assms lm103 by auto
  moreover have "finite N" using assms by simp
  then have "finite (?p N ?G)" using assms allAllocationsFinite by (metis List.finite_set)
  then have "finite ?X" using assms by (metis finite_subset winningAllocationPossible)
  moreover have "?a \<in> ?X" using lm090 assms by blast
  ultimately have "finite ?X & ?a \<in> ?X & (\<forall>aa \<in> ?X-{?a}. ?f aa < ?f ?a)" by force
  moreover have "(finite ?X & ?a \<in> ?X & (\<forall>aa \<in> ?X-{?a}. ?f aa < ?f ?a)) \<longrightarrow> argmax ?f ?X = {?a}"
    by (rule argmaxProperty)
  ultimately have "{?a} = argmax ?f ?X" using injectionsFromEmptyIsEmpty by presburger
  moreover have "... = ?t N G bids random" by simp
  ultimately show ?thesis by simp
qed

text \<open>The computable variant of Else is defined next as Elsee.\<close>
definition "toFunctionWithFallbackAlg R fallback ==
            (% x. if (x \<in> Domain R) then (R,,x) else fallback)"
notation toFunctionWithFallbackAlg (infix "Elsee" 75)

end


(*<*)
theory Examples
  imports Monitor_Code
begin
(*>*)

section \<open>Examples\<close>

abbreviation "TT \<equiv> MFOTL.Eq (MFOTL.Const ''_'') (MFOTL.Const ''_'')"
abbreviation "Eventually I \<psi> \<equiv> MFOTL.Until TT I \<psi>"

definition "\<phi>\<^sub>e\<^sub>x = MFOTL.And_Not (MFOTL.Pred ''A'' [MFOTL.Var 0])
  (Eventually (interval 1 2) (MFOTL.Exists (MFOTL.Pred ''B'' [MFOTL.Var 1, MFOTL.Var 0])))"

lemma "mmonitorable \<phi>\<^sub>e\<^sub>x" by eval

text \<open>Offline monitoring:\<close>

lift_definition \<pi>\<^sub>e\<^sub>x :: "string MFOTL.prefix" is
  "[ ({(''A'', [''d'']), (''A'', [''e''])}, 1)
   , ({(''B'', [''d'', ''f''])}, 2)
   , ({(''B'', [''e'', ''f''])}, 5)
  ]"
  by simp

lemma "monitor \<phi>\<^sub>e\<^sub>x \<pi>\<^sub>e\<^sub>x = {(0, [Some ''e''])}" by eval

text \<open>Online monitoring:\<close>

definition "m1 = mstep ({(''A'', [''d'']), (''A'', [''e''])}, 1) (minit \<phi>\<^sub>e\<^sub>x)"
definition "m2 = mstep ({(''B'', [''d'', ''f''])}, 2) (snd m1)"
definition "m3 = mstep ({(''B'', [''e'', ''f''])}, 5) (snd m2)"

lemma "fst m1 = {}" by eval
lemma "fst m2 = {}" by eval
lemma "fst m3 = {(0, [Some ''e''])}" by eval

text \<open>Operation of the monitor:\<close>

lemma "minit \<phi>\<^sub>e\<^sub>x = \<lparr>
  mstate_i = 0,
  mstate_m =
    MAnd (MPred ''A'' [MFOTL.Var 0]) False
     (MUntil True (MRel {[None]}) (interval 1 2) (MExists (MPred ''B'' [MFOTL.Var 1, MFOTL.Var 0]))
       ([], []) [] [])
     ([], []),
  mstate_n = 1\<rparr>"
  by eval

lemma "mstate_m (snd m1) = MAnd (MPred ''A'' [MFOTL.Var 0]) False
  (MUntil True (MRel {[None]}) (interval 1 2) (MExists (MPred ''B'' [MFOTL.Var 1, MFOTL.Var 0]))
    ([], []) [] [(1, {[None]}, {})])
  ([{[Some ''d''], [Some ''e'']}], [])"
  by eval

lemma "mstate_m (snd m2) = MAnd (MPred ''A'' [MFOTL.Var 0]) False
  (MUntil True (MRel {[None]}) (interval 1 2) (MExists (MPred ''B'' [MFOTL.Var 1, MFOTL.Var 0]))
   ([], []) [] [(1, {[None]}, {[Some ''d'']}), (2, {[None]}, {})])
  ([{[Some ''d''], [Some ''e'']}, {}], [])"
  by eval

lemma "mstate_m (snd m3) = MAnd (MPred ''A'' [MFOTL.Var 0]) False
  (MUntil True (MRel {[None]}) (interval 1 2) (MExists (MPred ''B'' [MFOTL.Var 1, MFOTL.Var 0]))
    ([], []) [] [(5, {[None]}, {})])
  ([{}], [])"
  by eval

(*<*)
end
(*>*)


theory OrdRec_locale
  imports "../GZF/GZF_Base" Ordinal
begin

context OrdRec begin

lemmas predset_set = funE[OF predset_typ]

lemma predset_iff : assumes "\<beta> : Ord"
  shows "\<alpha> \<in> predSet \<beta> \<longleftrightarrow> \<alpha> < \<beta>"
  using predset_def assms by auto

lemma predsetI :
  shows "\<alpha> < \<beta> \<Longrightarrow> \<alpha> \<in> predSet \<beta>"
  using predset_iff lt_ord by auto

lemma predsetE : assumes "Ord \<beta>"
  shows "\<alpha> \<in> predSet \<beta> \<Longrightarrow> \<alpha> < \<beta>"
  using predset_iff[OF assms] by simp

lemma predset_mem_ord : assumes "Ord \<beta>"
  shows "\<alpha> \<in> predSet \<beta> \<Longrightarrow> Ord \<alpha>"
  using predset_iff[OF \<open>Ord \<beta>\<close>] lt_ord1 by auto

lemma ordrec_succ : assumes "Ord b"
  shows "OrdRec G F A (succ b) = F (succ b) (OrdRec G F A b)"
  using ordrec_succ_ax assms by auto

lemma ordrec_lim : assumes "Limit u"
  shows "OrdRec G F A u = G u (\<lambda>\<beta>. if \<beta> < u then OrdRec G F A \<beta> else 0)"
  using ordrec_lim_ax assms by auto

definition if_ord3 :: "('d \<Rightarrow> 'd \<Rightarrow> 'd) \<Rightarrow> ('d \<Rightarrow> 'd \<Rightarrow> 'd) \<Rightarrow> 'd \<Rightarrow> 'd \<Rightarrow> 'd \<Rightarrow> 'd" where
  "if_ord3 G F A \<beta> x \<equiv>
      if \<beta> = 0 then A else if \<exists>\<beta>'. \<beta> = succ \<beta>' then F \<beta> x else if Limit \<beta> then G \<beta> x else \<emptyset>"

lemma if_ord_0 : "if_ord3 G F A 0 x = A" unfolding if_ord3_def by auto
lemma if_ord_succ : assumes "Ord \<beta>" shows "if_ord3 G F A (succ \<beta>) = F (succ \<beta>)" unfolding if_ord3_def
  using exI[of \<open>(\<lambda>\<beta>'. succ \<beta> = succ \<beta>')\<close> \<open>\<beta>\<close>, OF refl] succ_nonzero[OF assms] by auto
lemma if_ord_lim : assumes "Limit \<mu>" shows "if_ord3 G F A \<mu> = G \<mu>"
  unfolding if_ord3_def using Limit_nonzero not_succ_Limit assms by auto

lemma if_set : assumes "Set x" "Set y" shows "Set (if P then x else y)" using assms by simp

lemma if_ord3_set : assumes "Set A" "\<And>\<beta>. Ord \<beta> \<Longrightarrow> Set x \<Longrightarrow> Set (F (succ \<beta>) x)"
                                    "\<And>\<mu>. Limit \<mu> \<Longrightarrow> Set x \<Longrightarrow> Set (G \<mu> x)"
                    shows "Ord \<beta> \<Longrightarrow> Set x \<Longrightarrow> Set (if_ord3 G F A \<beta> x)"
  unfolding if_ord3_def using assms by auto

thm if_True if_False Eq_TrueI Eq_FalseI
thm if_P if_not_P
thm refl succ_nonzero
thm not_sym[OF lt_neq]
thm succ_lt[OF zero_ord]
thm lt_trans_pure[OF lt_trans_pure[OF lt_trans_pure],
                  of \<open>0\<close> \<open>succ 0\<close> \<open>succ (succ 0)\<close> \<open>succ (succ (succ 0))\<close> \<open>succ (succ (succ (succ 0)))\<close>,
                  OF le_refl[OF zero_ord] le_refl[OF succ_ord[OF zero_ord]]
                     le_refl[OF succ_ord[OF succ_ord[OF zero_ord]]]
                     le_refl[OF succ_ord[OF succ_ord[OF succ_ord[OF zero_ord]]]]]

thm lt_trans_pure[OF le_refl[of 0] lt_trans_pure[OF le_refl]]
ML \<open>fun mk_ord_thm z _ 0 = z
      | mk_ord_thm z s n = s OF [mk_ord_thm z s (n-1)]\<close>

ML \<open>fun le_trans r t 0 = r
      | le_trans r t j = t OF [le_trans r t (j-1)]\<close>

ML \<open>fun ord_le (z,s,r,t) i j = le_trans r t (j-i) OF (map (fn n => if n = i then mk_ord_thm z s n else r OF [mk_ord_thm z s n]) (i upto j))\<close>
ML \<open>fun ord_neq thms neq i j = @{thm not_sym} OF [neq] OF [ord_le thms i (j-1)]\<close>

ML \<open>fun ops_alpha thms neq i j =
      if i = j then @{thm if_P} OF [@{thm refl}]
      else @{thm trans} OF [@{thm if_not_P} OF [ord_neq thms neq i j],
                            ops_alpha thms neq (i+1) j]\<close>

(*Ops 0*)
thm if_P[OF refl[of 0]]
(*Ops 1*)
thm trans[OF if_not_P[OF succ_neq[OF zero_ord]] if_P[OF refl[of \<open>succ 0\<close>]]]
(*Ops 2*)
thm trans[OF if_not_P[OF succ_neq[OF zero_ord]] if_P[OF refl[of \<open>succ (succ 0)\<close>]]]

end
end


theory ETCS_Choice
  imports ETCS_Nat
begin

section \<open>Axiom 11: Axiom of Choice\<close>

definition section_of :: "cfunc \<Rightarrow> cfunc \<Rightarrow> bool" (infix "sectionof" 90)
  where "s sectionof f \<longleftrightarrow> s : codomain(f) \<rightarrow> domain(f) \<and> f \<circ>\<^sub>c s = id (codomain(f))"

(*Definition 2.7.1*)
definition split_epimorphism :: "cfunc \<Rightarrow> bool"
  where "split_epimorphism(f)\<longleftrightarrow>(\<exists> s. f \<circ>\<^sub>c s = id (codomain f))"

axiomatization
  where
  axiom_of_choice :"epimorphism(f) \<longrightarrow> (\<exists> g . g sectionof f)"

lemma epis_give_monos:
  assumes f_type: "f : X \<rightarrow> Y"
  assumes f_epi: "epimorphism(f)"
  shows "\<exists>g. g: Y \<rightarrow> X \<and> monomorphism(g) \<and> f \<circ>\<^sub>c g = id Y"
  using assms
  by (typecheck_cfuncs_prems, metis axiom_of_choice cfunc_type_def comp_monic_imp_monic f_epi id_isomorphism iso_imp_epi_and_monic section_of_def)

(* Proposition 2.6.8 *)
lemma monos_give_epis:
  assumes f_type: "f : X \<rightarrow> Y"
  assumes f_mono: "monomorphism(f)"
  assumes X_nonempty: "nonempty X"
  shows "\<exists>g. g: Y \<rightarrow> X \<and> epimorphism(g) \<and> g \<circ>\<^sub>c f = id X"
proof -
  obtain g m E where g_type[type_rule]: "g : X \<rightarrow> E" and m_type[type_rule]: "m : E \<rightarrow> Y" and
      g_epi: "epimorphism g" and m_mono[type_rule]: "monomorphism m" and f_eq: "f = m \<circ>\<^sub>c g"
    using epi_monic_factorization2 f_type by blast

  have g_mono: "monomorphism g"
  proof (typecheck_cfuncs, unfold monomorphism_def3, auto)
    fix x y A
    assume x_type[type_rule]: "x : A \<rightarrow> X" and y_type[type_rule]: "y : A \<rightarrow> X"

    assume "g \<circ>\<^sub>c x = g \<circ>\<^sub>c y"
    then have "(m \<circ>\<^sub>c g) \<circ>\<^sub>c x = (m \<circ>\<^sub>c g) \<circ>\<^sub>c y"
      by (typecheck_cfuncs, smt comp_associative2)
    then have "f \<circ>\<^sub>c x = f \<circ>\<^sub>c y"
      unfolding f_eq by auto
    then show "x = y"
      using f_mono f_type monomorphism_def2 x_type y_type by blast
  qed

  have g_iso: "isomorphism g"
    by (simp add: epi_mon_is_iso g_epi g_mono)
  then obtain g_inv where g_inv_type[type_rule]: "g_inv : E \<rightarrow> X" and
      g_g_inv: "g \<circ>\<^sub>c g_inv = id E" and g_inv_g: "g_inv \<circ>\<^sub>c g = id X"
    using cfunc_type_def g_type isomorphism_def by auto

  obtain x where x_type[type_rule]: "x \<in>\<^sub>c X"
    using X_nonempty nonempty_def by blast

  show "\<exists>g. g: Y \<rightarrow> X \<and> epimorphism(g) \<and> g \<circ>\<^sub>c f = id\<^sub>c X"
  proof (rule_tac x="(g_inv \<amalg> (x \<circ>\<^sub>c \<beta>\<^bsub>Y \<setminus> (E, m)\<^esub>)) \<circ>\<^sub>c try_cast m" in exI, auto)

    show "g_inv \<amalg> (x \<circ>\<^sub>c \<beta>\<^bsub>Y \<setminus> (E, m)\<^esub>) \<circ>\<^sub>c try_cast m : Y \<rightarrow> X"
      by typecheck_cfuncs

    have func_f_elem_eq: "\<And> y. y \<in>\<^sub>c X \<Longrightarrow> (g_inv \<amalg> (x \<circ>\<^sub>c \<beta>\<^bsub>Y \<setminus> (E, m)\<^esub>) \<circ>\<^sub>c try_cast m) \<circ>\<^sub>c f \<circ>\<^sub>c y = y"
    proof -
      fix y
      assume y_type[type_rule]: "y \<in>\<^sub>c X"

      have "(g_inv \<amalg> (x \<circ>\<^sub>c \<beta>\<^bsub>Y \<setminus> (E, m)\<^esub>) \<circ>\<^sub>c try_cast m) \<circ>\<^sub>c f \<circ>\<^sub>c y
          = g_inv \<amalg> (x \<circ>\<^sub>c \<beta>\<^bsub>Y \<setminus> (E, m)\<^esub>) \<circ>\<^sub>c (try_cast m \<circ>\<^sub>c m) \<circ>\<^sub>c g \<circ>\<^sub>c y"
        unfolding f_eq by (typecheck_cfuncs, smt comp_associative2)
      also have "... = (g_inv \<amalg> (x \<circ>\<^sub>c \<beta>\<^bsub>Y \<setminus> (E, m)\<^esub>) \<circ>\<^sub>c left_coproj E (Y \<setminus> (E,m))) \<circ>\<^sub>c g \<circ>\<^sub>c y"
        by (typecheck_cfuncs, smt comp_associative2 m_mono try_cast_m_m)
      also have "... = (g_inv \<circ>\<^sub>c g) \<circ>\<^sub>c y"
        by (typecheck_cfuncs, simp add: comp_associative2 left_coproj_cfunc_coprod)
      also have "... = y"
        by (typecheck_cfuncs, simp add: g_inv_g id_left_unit2)
      then show "(g_inv \<amalg> (x \<circ>\<^sub>c \<beta>\<^bsub>Y \<setminus> (E, m)\<^esub>) \<circ>\<^sub>c try_cast m) \<circ>\<^sub>c f \<circ>\<^sub>c y = y"
        using calculation by auto
    qed

    show "epimorphism (g_inv \<amalg> (x \<circ>\<^sub>c \<beta>\<^bsub>Y \<setminus> (E, m)\<^esub>) \<circ>\<^sub>c try_cast m)"
    proof (rule surjective_is_epimorphism, typecheck_cfuncs, unfold surjective_def2, auto)
      fix y
      assume y_type[type_rule]: "y \<in>\<^sub>c X"

      show "\<exists>xa. xa \<in>\<^sub>c Y \<and> (g_inv \<amalg> (x \<circ>\<^sub>c \<beta>\<^bsub>Y \<setminus> (E, m)\<^esub>) \<circ>\<^sub>c try_cast m) \<circ>\<^sub>c xa = y"
      proof (rule_tac x="f \<circ>\<^sub>c y" in exI, auto)

        show "f \<circ>\<^sub>c y \<in>\<^sub>c Y"
          using f_type by typecheck_cfuncs

        show "(g_inv \<amalg> (x \<circ>\<^sub>c \<beta>\<^bsub>Y \<setminus> (E, m)\<^esub>) \<circ>\<^sub>c try_cast m) \<circ>\<^sub>c f \<circ>\<^sub>c y = y"
          by (simp add: func_f_elem_eq y_type)
      qed
    qed

    show "(g_inv \<amalg> (x \<circ>\<^sub>c \<beta>\<^bsub>Y \<setminus> (E, m)\<^esub>) \<circ>\<^sub>c try_cast m) \<circ>\<^sub>c f = id\<^sub>c X"
      by (insert comp_associative2 func_f_elem_eq id_left_unit2 f_type, typecheck_cfuncs, rule one_separator, auto)
  qed
qed

end


(*
    Title:      Echelon_Form_Det.thy
    Author:     Jose Divasón <jose.divasonm at unirioja.es>
    Author:     Jesús Aransay <jesus-maria.aransay at unirioja.es>
*)

section\<open>Determinant of matrices over principal ideal rings\<close>

theory Echelon_Form_Det
  imports Echelon_Form
begin

subsection\<open>Definitions\<close>

text\<open>The following definition can be improved in terms of performance, because it checks if
  there exists an element different from zero twice.\<close>

definition
  echelon_form_of_column_k_det :: "('b \<Rightarrow> 'b \<Rightarrow> 'b \<times> 'b \<times> 'b \<times> 'b \<times> 'b)
      \<Rightarrow> 'b::{bezout_domain}
      \<times> (('b, 'c::{mod_type}) vec, 'd::{mod_type}) vec
      \<times> nat
     \<Rightarrow>  nat \<Rightarrow> 'b
      \<times> (('b, 'c) vec, 'd) vec
      \<times> nat"
  where
  "echelon_form_of_column_k_det bezout A' k =
    (let (det_P, A, i) =  A';
      from_nat_i = from_nat i;
      from_nat_k = from_nat k
     in
      if ( (i \<noteq> nrows A) \<and>
           (A $ from_nat_i $ from_nat_k = 0) \<and>
           (\<exists>m>from_nat i. A $ m $ from_nat k \<noteq> 0))
         then (-1 * det_P, (echelon_form_of_column_k bezout) (A, i) k)
         else (     det_P, (echelon_form_of_column_k bezout) (A, i) k))"

definition
  "echelon_form_of_upt_k_det bezout A' k =
    (let A = (snd A');
         f = (foldl (echelon_form_of_column_k_det bezout) (1, A, 0) [0..<Suc k])
     in (fst f, fst (snd f)))"

definition
  echelon_form_of_det :: "'a::{bezout_domain}^'n::{mod_type}^'n::{mod_type}
      \<Rightarrow> ('a \<Rightarrow> 'a \<Rightarrow> 'a \<times> 'a \<times> 'a \<times> 'a \<times> 'a)
      \<Rightarrow> ('a \<times> ('a::{bezout_domain}^'n::{mod_type}^'n::{mod_type}))"
  where
  "echelon_form_of_det A bezout = echelon_form_of_upt_k_det bezout (1::'a,A) (ncols A - 1)"

subsection\<open>Properties\<close>

subsubsection\<open>Bezout Iterate\<close>

lemma det_bezout_iterate:
  fixes A::"'a::{bezout_domain}^'n::{mod_type}^'n::{mod_type}"
  assumes ib: "is_bezout_ext bezout"
  and Aik: "A $ i $ from_nat k \<noteq> 0"
  and n: "n<ncols A"
  shows "det (bezout_iterate A n i (from_nat k) bezout) = det A"
  using Aik n
proof (induct n arbitrary: A)
  case 0
  show ?case unfolding bezout_iterate.simps ..
next
  case (Suc n)
  show ?case
  proof (cases "Suc n \<le> to_nat i")
    case True thus ?thesis unfolding bezout_iterate.simps by simp
  next
    let ?B = "bezout_matrix A i (from_nat (Suc n)) (from_nat k) bezout"
    let ?A="(?B ** A)"
    case False
    hence "(bezout_iterate A (Suc n) i (mod_type_class.from_nat k) bezout)
      = bezout_iterate ?A n i (mod_type_class.from_nat k) bezout"
      unfolding bezout_iterate.simps by auto
    also have "det (...) = det ?A"
    proof (rule Suc.hyps, rule bezout_matrix_not_zero[OF ib _ Suc.prems(1)])
      show "n < ncols ?A" using Suc.prems(2) unfolding ncols_def by simp
      show "i \<noteq> from_nat (Suc n)" using False
        by (metis Suc.prems(2) eq_imp_le ncols_def to_nat_from_nat_id)
    qed
    also have "... = det A"
    proof -
      have "det ?B = 1"
      proof (rule det_bezout_matrix[OF ib _  Suc.prems(1)])
        have "from_nat (to_nat i) < (from_nat (Suc n)::'n)"
        proof (rule from_nat_mono)
          show "to_nat i < Suc n" using False by simp
          show "Suc n < CARD('n)" using Suc.prems(2) unfolding ncols_def .
        qed
        thus "i < mod_type_class.from_nat (Suc n)" unfolding from_nat_to_nat_id .
      qed
      thus ?thesis unfolding  det_mul by auto
    qed
    finally show ?thesis .
  qed
qed

subsubsection\<open>Echelon Form of column k\<close>

lemma det_echelon_form_of_column_k_det:
  fixes A::"'a::{bezout_domain}^'n::{mod_type}^'n::{mod_type}"
  assumes ib: "is_bezout_ext bezout"
  and det: "det_P * det B = det A"
  shows "fst ((echelon_form_of_column_k_det bezout) (det_P,A,i) k) * det B
  = det (fst (snd ((echelon_form_of_column_k_det bezout) (det_P,A,i) k)))"
proof -
  let ?interchange="(interchange_rows A (from_nat i)
    (LEAST n. A $ n $ from_nat k \<noteq> 0 \<and> from_nat i \<le> n))"
  let ?B="(bezout_iterate ?interchange (nrows A - Suc 0) (from_nat i) (from_nat k) bezout)"
  show ?thesis
  proof (unfold echelon_form_of_column_k_det_def Let_def echelon_form_of_column_k_def,
      auto simp add: assms)
    fix m
    assume i: "from_nat i < m"
      and Amk: "A $ m $ from_nat k \<noteq> 0"
      and i_not_nrows: "i \<noteq> nrows A "
      and Aik: "A $ from_nat i $ from_nat k = 0"
    have "det ?B = det ?interchange"
    proof (rule det_bezout_iterate[OF ib])
      show "?interchange $ from_nat i $ from_nat k \<noteq> 0"
        by (metis (mono_tags, lifting) Amk LeastI_ex
          dual_order.strict_iff_order i interchange_rows_i)
      show "nrows A - Suc 0 < ncols ?interchange"  unfolding nrows_def ncols_def by simp
    qed
    also have "... = - det A"
    proof (rule det_interchange_different_rows, rule ccontr, simp)
      assume i_least: "from_nat i = (LEAST n. A $ n $ from_nat k \<noteq> 0 \<and> from_nat i \<le> n)"
      have "A $ from_nat i $ from_nat k \<noteq> 0"
        by (metis (poly_guards_query, lifting) Amk LeastI_ex
          linear i i_least leD)
      thus "False" using Aik by contradiction
    qed
    finally show "- det A = det ?B" by simp
  next
    assume i: "i \<noteq> nrows A"
      and Aik: "A $ from_nat i $ from_nat k \<noteq> 0"
    have "det ?B = det ?interchange"
    proof (rule det_bezout_iterate[OF ib])
      show "?interchange $ from_nat i $ from_nat k \<noteq> 0"
        by (metis (mono_tags, lifting) Aik LeastI order_refl interchange_rows_i)
      show "nrows A - Suc 0 < ncols ?interchange"  unfolding nrows_def ncols_def by simp
    qed
    also have "... = det A"
      by (rule det_interchange_same_rows, rule Least_equality[symmetric], auto simp add: Aik)
    finally show "det A = det ?B" ..
  qed
qed

lemma snd_echelon_form_of_column_k_det_eq:
  shows "snd ((echelon_form_of_column_k_det bezout) (n, A, i) k)
  = (echelon_form_of_column_k bezout) (A,i) k"
  unfolding echelon_form_of_column_k_det_def echelon_form_of_column_k_def Let_def snd_conv fst_conv
  by auto

subsubsection\<open>Echelon form up to column k\<close>

lemma snd_foldl_ef_det_eq: "snd (foldl (echelon_form_of_column_k_det bezout) (n, A, 0) [0..<k])
  = foldl (echelon_form_of_column_k bezout) (A, 0) [0..<k]"
proof (induct k)
  case 0
  show ?case
    by (simp add: echelon_form_of_column_k_det_def Let_def)
next
  case (Suc k)
  have Suc_rw: "[0..<(Suc k)] = [0..<k] @ [k]" by simp
  show ?case
    unfolding Suc_rw foldl_append List.foldl.simps fst_conv snd_conv
    using Suc.hyps[unfolded echelon_form_of_upt_k_det_def Let_def snd_conv, simplified]
    by (metis prod.collapse snd_echelon_form_of_column_k_det_eq)
qed

lemma snd_echelon_form_of_upt_k_det_eq:
  shows "snd ((echelon_form_of_upt_k_det bezout) (n, A) k) = echelon_form_of_upt_k A k bezout"
  unfolding echelon_form_of_upt_k_det_def echelon_form_of_upt_k_def Let_def fst_conv snd_conv
  unfolding snd_foldl_ef_det_eq by auto

lemma det_echelon_form_of_upt_k_det:
  fixes A::"'a::{bezout_domain}^'n::{mod_type}^'n::{mod_type}"
  assumes ib: "is_bezout_ext bezout"
  shows "fst ((echelon_form_of_upt_k_det bezout) (1::'a,A) k) *  det A
  = det (snd ((echelon_form_of_upt_k_det bezout) (1::'a,A) k))"
proof (induct k)
  case 0
  show ?case
    unfolding echelon_form_of_upt_k_det_def Let_def
    by (auto, rule det_echelon_form_of_column_k_det[OF ib], simp)
next
  case (Suc k)
  let ?f = "foldl (echelon_form_of_column_k_det bezout) (1,A,0) [0..<Suc k]"
  have Suc_rw: "[0..<Suc (Suc k)] = [0..<(Suc k)] @ [Suc k]" by simp
  have fold_expand: "?f = (fst ?f, fst (snd ?f), snd (snd ?f))" by simp
  show ?case unfolding echelon_form_of_upt_k_det_def Let_def
    unfolding Suc_rw foldl_append List.foldl.simps fst_conv snd_conv
    apply (subst (1 2) fold_expand)
    apply (rule det_echelon_form_of_column_k_det)
    apply (rule ib)
    apply (subst (1) snd_foldl_ef_det_eq)
    by (metis Suc.hyps echelon_form_of_upt_k_det_def fst_conv snd_conv snd_foldl_ef_det_eq)
qed

subsubsection\<open>Echelon form\<close>

lemma det_echelon_form_of_det:
  fixes A::"'a::{bezout_domain}^'n::{mod_type}^'n::{mod_type}"
  assumes ib: "is_bezout_ext bezout"
  shows "(fst (echelon_form_of_det A bezout)) * det A = det (snd (echelon_form_of_det A bezout))"
  using det_echelon_form_of_upt_k_det ib unfolding echelon_form_of_det_def by simp

subsubsection\<open>Proving that the first component is a unit\<close>

lemma echelon_form_of_column_k_det_unit:
  fixes A::"'a::{bezout_domain_div}^'n::{mod_type}^'n::{mod_type}"
  assumes det: "is_unit (det_P)"
  shows "is_unit (fst ((echelon_form_of_column_k_det bezout) (det_P,A,i) k))"
  unfolding echelon_form_of_column_k_det_def Let_def fst_conv snd_conv using det by auto

lemma echelon_form_of_upt_k_det_unit:
  fixes A::"'a::{bezout_domain_div}^'n::{mod_type}^'n::{mod_type}"
  shows "is_unit (fst ((echelon_form_of_upt_k_det bezout) (1::'a,A) k))"
proof (induct k)
  case 0
  show ?case unfolding echelon_form_of_upt_k_det_def Let_def fst_conv
    using echelon_form_of_column_k_det_unit[of 1] by auto
next
  case (Suc k)
  let ?f = "foldl (echelon_form_of_column_k_det bezout) (1,A,0) [0..<Suc k]"
  have Suc_rw: "[0..<Suc (Suc k)] = [0..<(Suc k)] @ [Suc k]" by simp
  have fold_expand: "?f = (fst ?f, fst (snd ?f), snd (snd ?f))"
    by simp
  show ?case
    unfolding echelon_form_of_upt_k_det_def Let_def
    unfolding Suc_rw foldl_append List.foldl.simps fst_conv snd_conv
    by (subst fold_expand, rule echelon_form_of_column_k_det_unit
    [OF Suc.hyps[unfolded echelon_form_of_upt_k_det_def Let_def fst_conv snd_conv]])
qed

lemma echelon_form_of_unit:
  fixes A::"'a::{bezout_domain_div}^'n::{mod_type}^'n::{mod_type}"
  shows "is_unit (fst (echelon_form_of_det A k))"
  unfolding echelon_form_of_det_def
  by (rule echelon_form_of_upt_k_det_unit)

subsubsection\<open>Final lemmas\<close>

corollary det_echelon_form_of_det':
  fixes A::"'a::{bezout_domain_div}^'n::{mod_type}^'n::{mod_type}"
  assumes ib: "is_bezout_ext bezout"
  shows "det A = 1 div (fst (echelon_form_of_det A bezout))
  * det (snd (echelon_form_of_det A bezout))"
proof -
  have "(fst (echelon_form_of_det A bezout)) * det A = det (snd (echelon_form_of_det A bezout))"
    by (rule det_echelon_form_of_det[OF ib])
  thus "det A = 1 div (fst (echelon_form_of_det A bezout))
    * det (snd (echelon_form_of_det A bezout))"
    by (auto simp add: echelon_form_of_unit dest: sym)
qed

lemma ef_echelon_form_of_det:
  fixes A::"'a::{bezout_domain}^'n::{mod_type}^'n::{mod_type}"
  assumes ib: "is_bezout_ext bezout"
  shows "echelon_form (snd (echelon_form_of_det A bezout))"
  unfolding echelon_form_of_det_def
  unfolding snd_echelon_form_of_upt_k_det_eq
  unfolding echelon_form_of_def[symmetric]
  by (rule echelon_form_echelon_form_of[OF ib])

lemma det_echelon_form:
  fixes A::"'a::{bezout_domain}^'n::{mod_type}^'n::{mod_type}"
  assumes ef: "echelon_form A"
  shows "det A = prod (\<lambda>i. A $ i $ i) (UNIV:: 'n set)"
  using det_upperdiagonal echelon_form_imp_upper_triagular[OF ef]
  unfolding upper_triangular_def by blast

corollary det_echelon_form_of_det_prod:
  fixes A::"'a::{bezout_domain_div}^'n::{mod_type}^'n::{mod_type}"
  assumes ib: "is_bezout_ext bezout"
  shows "det A = 1 div (fst (echelon_form_of_det A bezout))
  * prod (\<lambda>i. snd (echelon_form_of_det A bezout) $ i $ i) (UNIV:: 'n set)"
  using det_echelon_form_of_det'[OF ib]
  unfolding det_echelon_form[OF ef_echelon_form_of_det[OF ib]] by auto

corollary det_echelon_form_of_euclidean[code]:
  fixes A::"'a::{euclidean_ring_gcd}^'n::{mod_type}^'n::{mod_type}"
  shows "det A = 1 div (fst (echelon_form_of_det A euclid_ext2))
  * prod (\<lambda>i. snd (echelon_form_of_det A euclid_ext2) $ i $ i) (UNIV:: 'n set)"
  by (rule det_echelon_form_of_det_prod[OF is_bezout_ext_euclid_ext2])

end