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

section\<open>Inverse of a matrix using the Gauss Jordan algorithm\<close>

theory Inverse
imports
  Gauss_Jordan_PA
begin

subsection\<open>Several properties\<close>

text\<open>Properties about Gauss Jordan algorithm, reduced row echelon form, rank, identity matrix and invertibility\<close>

lemma rref_id_implies_invertible:
fixes A::"'a::{field}^'n::{mod_type}^'n::{mod_type}"
assumes Gauss_mat_1: "Gauss_Jordan A = mat 1"
shows "invertible A"
proof -
obtain P where P: "invertible P" and PA: "Gauss_Jordan A = P ** A" using invertible_Gauss_Jordan[of A] by blast
have "A = mat 1 ** A" unfolding matrix_mul_lid ..
also have "... = (matrix_inv P ** P) ** A" using P invertible_def matrix_inv_unique by metis
also have "... = (matrix_inv P) ** (P ** A)" by (metis PA assms calculation matrix_eq matrix_vector_mul_assoc matrix_vector_mul_lid)
also have "... = (matrix_inv P) ** mat 1" unfolding PA[symmetric] Gauss_mat_1 ..
also have "... = (matrix_inv P)" unfolding matrix_mul_rid ..
finally have "A = (matrix_inv P)" .
thus ?thesis using P unfolding invertible_def using matrix_inv_unique by blast
qed

text\<open>In the following case, nrows is equivalent to ncols due to we are working with a square matrix\<close>
lemma full_rank_implies_invertible:
fixes A::"'a::{field}^'n::{mod_type}^'n::{mod_type}"
assumes rank_n: "rank A = nrows A"
shows "invertible A"
proof (unfold invertible_left_inverse[of A] matrix_left_invertible_ker, clarify)
fix x
assume Ax: "A *v x = 0"
have rank_eq_card_n: "rank A = CARD('n)" using rank_n unfolding nrows_def .
have "vec.dim (null_space A)=0" unfolding dim_null_space unfolding rank_eq_card_n dimension_vector by simp
hence "null_space A = {0}" using vec.dim_zero_eq using Ax null_space_def by auto
thus "x = 0" unfolding null_space_def using Ax by blast
qed

lemma invertible_implies_full_rank:
  fixes A::"'a::{field}^'n::{mod_type}^'n::{mod_type}"
  assumes inv_A: "invertible A"
  shows "rank A = nrows A"
proof -
  have "(\<forall>x. A *v x = 0 \<longrightarrow> x = 0)" using inv_A unfolding  invertible_left_inverse[unfolded matrix_left_invertible_ker] .
  hence null_space_eq_0: "(null_space A) = {0}" unfolding null_space_def using matrix_vector_mult_0_right by fast
  have dim_null_space: "vec.dim (null_space A) = 0" unfolding vec.dim_def
    by (metis (no_types) null_space_eq_0 vec.dim_def vec.dim_zero_eq')
  show ?thesis using rank_nullity_theorem_matrices[of A] unfolding dim_null_space rank_eq_dim_col_space nrows_def
    unfolding col_space_eq unfolding ncols_def by simp
qed

definition id_upt_k :: "'a::{zero, one}^'n::{mod_type}^'n::{mod_type} \<Rightarrow> nat => bool"
where "id_upt_k A k = (\<forall>i j. to_nat i < k \<and> to_nat j < k \<longrightarrow> ((i = j \<longrightarrow> A $ i $ j = 1) \<and> (i \<noteq> j \<longrightarrow> A $ i $ j = 0)))"

lemma id_upt_nrows_mat_1:
assumes "id_upt_k A (nrows A)"
shows "A = mat 1"
unfolding mat_def apply vector using assms unfolding id_upt_k_def nrows_def
using to_nat_less_card[where ?'a='b]
by presburger

subsection\<open>Computing the inverse of a matrix using the Gauss Jordan algorithm\<close>

text\<open>This lemma is essential to demonstrate that the Gauss Jordan form of an invertible matrix is the identity.
  The proof is made by induction and it is explained in
  @{url "http://www.unirioja.es/cu/jodivaso/Isabelle/Gauss-Jordan-2013-2-Generalized/Demonstration_invertible.pdf"}\<close>

lemma id_upt_k_Gauss_Jordan:
fixes A::"'a::{field}^'n::{mod_type}^'n::{mod_type}"
assumes inv_A: "invertible A"
shows "id_upt_k (Gauss_Jordan A) k"
proof (induct k)
case 0
show ?case unfolding id_upt_k_def by fast
next
case (Suc k)
note id_k=Suc.hyps
have rref_k: "reduced_row_echelon_form_upt_k (Gauss_Jordan A) k"  using rref_implies_rref_upt[OF rref_Gauss_Jordan] .
have rref_suc_k: "reduced_row_echelon_form_upt_k (Gauss_Jordan A) (Suc k)"  using rref_implies_rref_upt[OF rref_Gauss_Jordan] .
have inv_gj: "invertible (Gauss_Jordan A)" by (metis inv_A invertible_Gauss_Jordan invertible_mult)
show "id_upt_k (Gauss_Jordan A) (Suc k)"
proof (unfold id_upt_k_def, auto)
fix j::'n
assume j_less_suc: "to_nat j < Suc k"
\<comment> \<open>First of all we prove a property which will be useful later\<close>
have greatest_prop: "j \<noteq> 0 \<Longrightarrow> to_nat j = k \<Longrightarrow> (GREATEST m. \<not> is_zero_row_upt_k m k (Gauss_Jordan A)) = j - 1"
proof (rule Greatest_equality)
assume j_not_zero: "j \<noteq> 0" and j_eq_k: "to_nat j = k"
 have j_minus_1: "to_nat (j - 1) < k" by (metis (full_types) Suc_le' diff_add_cancel j_eq_k j_not_zero to_nat_mono)
          show "\<not> is_zero_row_upt_k (j - 1) k (Gauss_Jordan A)"
            unfolding is_zero_row_upt_k_def
            proof (auto, rule exI[of _ "j - 1"], rule conjI)
               show "to_nat (j - 1) < k" using j_minus_1 .
               show "Gauss_Jordan A $ (j - 1) $ (j - 1) \<noteq> 0" using id_k unfolding id_upt_k_def using j_minus_1 by simp
            qed
            fix a::'n
            assume not_zero_a: "\<not> is_zero_row_upt_k a k (Gauss_Jordan A)"
            show "a \<le> j - 1"
              proof (rule ccontr)
                assume " \<not> a \<le> j - 1"
                hence a_greater_i_minus_1: "a > j - 1" by simp
                have "is_zero_row_upt_k a k (Gauss_Jordan A)"
                  unfolding is_zero_row_upt_k_def
                    proof (clarify)
                    fix b::'n assume a: "to_nat b < k"
                    have Least_eq: "(LEAST n. Gauss_Jordan A $ b $ n \<noteq> 0) = b"
                      proof (rule Least_equality)
                        show "Gauss_Jordan A $ b $ b \<noteq> 0" by (metis a id_k id_upt_k_def zero_neq_one)
                        show "\<And>y. Gauss_Jordan A $ b $ y \<noteq> 0 \<Longrightarrow> b \<le> y"
                          by (metis (hide_lams, no_types) a not_less_iff_gr_or_eq id_k id_upt_k_def less_trans not_less to_nat_mono)
                      qed
                    moreover have "\<not> is_zero_row_upt_k b k (Gauss_Jordan A)"
                      unfolding is_zero_row_upt_k_def apply auto apply (rule exI[of _ b]) using a id_k unfolding id_upt_k_def by simp
                    moreover have "a \<noteq> b"
                      proof -
                       have "b < from_nat k" by (metis a from_nat_to_nat_id j_eq_k not_less_iff_gr_or_eq to_nat_le)
                       also have "... = j" using j_eq_k to_nat_from_nat by auto
                       also have "... \<le> a" using a_greater_i_minus_1 by (metis diff_add_cancel le_Suc)
                       finally show ?thesis by simp
                      qed
                    ultimately show "Gauss_Jordan A $ a $ b = 0" using rref_upt_condition4[OF rref_k] by auto
                    qed
                thus "False" using not_zero_a by contradiction
              qed
              qed

show Gauss_jj_1: "Gauss_Jordan A $ j $ j = 1"
proof (cases "j=0")
\<comment> \<open>In case that j be zero, the result is trivial\<close>
case True show ?thesis
  proof (unfold True, rule rref_first_element)
     show "reduced_row_echelon_form (Gauss_Jordan A)" by (rule rref_Gauss_Jordan)
     show "column 0 (Gauss_Jordan A) \<noteq> 0" by (metis det_zero_column inv_gj invertible_det_nz)
  qed
next
case False note j_not_zero = False
show ?thesis
proof (cases "to_nat j < k")
  case True thus ?thesis using id_k unfolding id_upt_k_def by presburger  \<comment> \<open>Easy due to the inductive hypothesis\<close>
  next
  case False
  hence j_eq_k: "to_nat j = k" using j_less_suc by auto
  have j_minus_1: "to_nat (j - 1) < k" by (metis (full_types) Suc_le' diff_add_cancel j_eq_k j_not_zero to_nat_mono)
  have "(GREATEST m. \<not> is_zero_row_upt_k m k (Gauss_Jordan A)) = j - 1" by (rule greatest_prop[OF j_not_zero j_eq_k])
        hence zero_j_k: "is_zero_row_upt_k j k (Gauss_Jordan A)"
                by (metis not_le greatest_ge_nonzero_row j_eq_k j_minus_1 to_nat_mono')
              show ?thesis
                proof (rule ccontr, cases "Gauss_Jordan A $ j $ j = 0")
                case False
                note gauss_jj_not_0 = False
                assume gauss_jj_not_1: "Gauss_Jordan A $ j $ j \<noteq> 1"
                have "(LEAST n. Gauss_Jordan A $ j $ n \<noteq> 0) = j"
                  proof (rule Least_equality)
                     show "Gauss_Jordan A $ j $ j \<noteq> 0" using gauss_jj_not_0 .
                     show "\<And>y. Gauss_Jordan A $ j $ y \<noteq> 0 \<Longrightarrow> j \<le> y" by (metis le_less_linear is_zero_row_upt_k_def j_eq_k to_nat_mono zero_j_k)
                  qed
                hence "Gauss_Jordan A $ j $ (LEAST n. Gauss_Jordan A $ j $ n \<noteq> 0) \<noteq> 1" using gauss_jj_not_1 by auto \<comment> \<open>Contradiction with the second condition of rref\<close>
                thus False by (metis gauss_jj_not_0 is_zero_row_upt_k_def j_eq_k lessI rref_suc_k rref_upt_condition2)
                next
                  case True
                  note gauss_jj_0 = True
                  have zero_j_suc_k: "is_zero_row_upt_k j (Suc k) (Gauss_Jordan A)"
                    by (rule is_zero_row_upt_k_suc[OF zero_j_k], metis gauss_jj_0 j_eq_k to_nat_from_nat)
                    have "\<not> (\<exists>B. B ** (Gauss_Jordan A) = mat 1)" \<comment> \<open>This will be a contradiction\<close>
                    proof (unfold matrix_left_invertible_independent_columns, simp,
                        rule exI[of _ "\<lambda>i. (if i < j then column j (Gauss_Jordan A) $ i else if i=j then -1 else 0)"], rule conjI)
                      show "(\<Sum>i\<in>UNIV. (if i < j then column j (Gauss_Jordan A) $ i else if i=j then -1 else 0) *s column i (Gauss_Jordan A)) = 0"
                        proof (unfold vec_eq_iff sum_component, auto)
                          \<comment> \<open>We write the column j in a linear combination of the previous ones, which is a contradiction (the matrix wouldn't be invertible)\<close>
                            let ?f="\<lambda>i. (if i < j then column j (Gauss_Jordan A) $ i else if i=j then -1 else 0)"
                            fix i
                            let ?g="(\<lambda>x. ?f x * column x (Gauss_Jordan A) $ i)"
                            show "sum ?g UNIV = 0"
                              proof (cases "i<j")
                              case True note i_less_j = True
                              have sum_rw: "sum ?g (UNIV - {i}) = ?g j + sum ?g ((UNIV - {i}) - {j})"
                                proof (rule sum.remove)
                                   show "finite (UNIV - {i})" using finite_code by simp
                                   show "j \<in> UNIV - {i}" using True by blast
                                qed
                              have sum_g0: "sum ?g (UNIV - {i} - {j}) = 0"
                                proof (rule sum.neutral, auto)
                                fix a
                                assume a_not_j: "a \<noteq> j" and a_not_i: "a \<noteq> i" and a_less_j: "a < j" and column_a_not_zero: "column a (Gauss_Jordan A) $ i \<noteq> 0"
                                have "Gauss_Jordan A $ i $ a = 0" using id_k unfolding id_upt_k_def using a_less_j j_eq_k using i_less_j a_not_i to_nat_mono by blast
                                thus "column j (Gauss_Jordan A) $ a = 0" using column_a_not_zero unfolding column_def by simp \<comment> \<open>Contradiction\<close>
                                qed
                              have "sum ?g UNIV = ?g i + sum ?g (UNIV - {i})" by (rule sum.remove, simp_all)
                              also have "... = ?g i + ?g j + sum ?g (UNIV - {i} - {j})" unfolding sum_rw by auto
                              also have "... = ?g i + ?g j" unfolding sum_g0 by simp
                              also have "... = 0" using True unfolding column_def
                                by (simp, metis id_k id_upt_k_def j_eq_k to_nat_mono)
                              finally show ?thesis .
                              next
                              case False
                              have zero_i_suc_k: "is_zero_row_upt_k i (Suc k) (Gauss_Jordan A)"
                                    by (metis False zero_j_suc_k linorder_cases rref_suc_k rref_upt_condition1)
                              show ?thesis
                                proof (rule sum.neutral, auto)
                                  show "column j (Gauss_Jordan A) $ i = 0"
                                    using zero_i_suc_k unfolding column_def is_zero_row_upt_k_def
                                    by (metis j_eq_k lessI vec_lambda_beta)
                                  next
                                  fix a
                                  assume a_not_j: "a \<noteq> j" and a_less_j: "a < j" and column_a_i: "column a (Gauss_Jordan A) $ i \<noteq> 0"
                                  have "Gauss_Jordan A $ i $ a = 0" using zero_i_suc_k unfolding is_zero_row_upt_k_def
                                    by (metis (full_types) a_less_j j_eq_k less_SucI to_nat_mono)
                                  thus "column j (Gauss_Jordan A) $ a = 0" using column_a_i unfolding column_def by simp
                        qed
                    qed
                    qed
                    next
                    show "\<exists>i. (if i < j then column j (Gauss_Jordan A) $ i else if i = j then -1 else 0) \<noteq> 0"
                      by (metis False j_eq_k neg_equal_0_iff_equal to_nat_mono zero_neq_one)
                    qed
                    thus False using inv_gj unfolding invertible_def by simp
                    qed
                    qed
                   qed
                    fix i::'n
                    assume i_less_suc: "to_nat i < Suc k" and i_not_j: "i \<noteq> j"
                    show "Gauss_Jordan A $ i $ j = 0" \<comment> \<open>This result is proved making use of the 4th condition of rref\<close>
                      proof (cases "to_nat i < k \<and> to_nat j < k")
                        case True thus ?thesis using id_k i_not_j unfolding id_upt_k_def by blast \<comment> \<open>Easy due to the inductive hypothesis\<close>
                        next
                        case False note i_or_j_ge_k = False
                        show ?thesis
                        proof (cases "to_nat i < k")
                          case True
                          hence j_eq_k: "to_nat j = k" using i_or_j_ge_k j_less_suc by simp
                          have j_noteq_0: "j \<noteq> 0" by (metis True j_eq_k less_nat_zero_code to_nat_0)
                          have j_minus_1: "to_nat (j - 1) < k" by (metis (full_types) Suc_le' diff_add_cancel j_eq_k j_noteq_0 to_nat_mono)
                          have "(GREATEST m. \<not> is_zero_row_upt_k m k (Gauss_Jordan A)) = j - 1" by (rule greatest_prop[OF j_noteq_0 j_eq_k])
                          hence zero_j_k: "is_zero_row_upt_k j k (Gauss_Jordan A)"
                            by (metis (lifting, mono_tags) less_linear less_asym j_eq_k j_minus_1 not_greater_Greatest to_nat_mono)
                          have Least_eq_j: "(LEAST n. Gauss_Jordan A $ j $ n \<noteq> 0) = j"
                            proof (rule Least_equality)
                               show "Gauss_Jordan A $ j $ j \<noteq> 0" using Gauss_jj_1 by simp
                               show "\<And>y. Gauss_Jordan A $ j $ y \<noteq> 0 \<Longrightarrow> j \<le> y"
                               by (metis True le_cases from_nat_to_nat_id i_or_j_ge_k is_zero_row_upt_k_def j_less_suc less_Suc_eq_le less_le to_nat_le zero_j_k)
                            qed
                          moreover have "\<not> is_zero_row_upt_k j (Suc k) (Gauss_Jordan A)" unfolding is_zero_row_upt_k_def by (metis Gauss_jj_1 j_less_suc zero_neq_one)
                          ultimately show ?thesis using rref_upt_condition4[OF rref_suc_k] i_not_j by fastforce
                          next
                          case False
                          hence i_eq_k: "to_nat i = k" by (metis \<open>to_nat i < Suc k\<close> less_SucE)
                          hence j_less_k: "to_nat j < k" by (metis i_not_j j_less_suc less_SucE to_nat_from_nat)
                          have "(LEAST n. Gauss_Jordan A $ j $ n \<noteq> 0) = j"
                            proof (rule Least_equality)
                               show "Gauss_Jordan A $ j $ j \<noteq> 0" by (metis Gauss_jj_1 zero_neq_one)
                               show "\<And>y. Gauss_Jordan A $ j $ y \<noteq> 0 \<Longrightarrow> j \<le> y"
                                  by (metis le_cases id_k id_upt_k_def j_less_k less_trans not_less to_nat_mono)
                            qed
                          moreover have "\<not> is_zero_row_upt_k j k (Gauss_Jordan A)" by (metis (full_types) Gauss_jj_1 is_zero_row_upt_k_def j_less_k zero_neq_one)
                          ultimately show ?thesis  using rref_upt_condition4[OF rref_k] i_not_j by fastforce
                         qed
                         qed
qed
qed

lemma invertible_implies_rref_id:
  fixes A::"'a::{field}^'n::{mod_type}^'n::{mod_type}"
  assumes inv_A: "invertible A"
  shows "Gauss_Jordan A = mat 1"
  using id_upt_k_Gauss_Jordan[OF inv_A, of "nrows (Gauss_Jordan A)"]
  using id_upt_nrows_mat_1
  by fast

lemma matrix_inv_Gauss:
fixes A::"'a::{field}^'n::{mod_type}^'n::{mod_type}"
assumes inv_A: "invertible A" and Gauss_eq: "Gauss_Jordan A = P ** A"
shows "matrix_inv A = P"
proof (unfold matrix_inv_def, rule some1_equality)
 show "\<exists>!A'. A ** A' = mat 1 \<and> A' ** A = mat 1" by (metis inv_A invertible_def matrix_inv_unique matrix_left_right_inverse)
 show "A ** P = mat 1 \<and> P ** A = mat 1" by (metis Gauss_eq inv_A invertible_implies_rref_id matrix_left_right_inverse)
qed

lemma matrix_inv_Gauss_Jordan_PA:
fixes A::"'a::{field}^'n::{mod_type}^'n::{mod_type}"
assumes inv_A: "invertible A"
shows "matrix_inv A = fst (Gauss_Jordan_PA A)"
by (metis Gauss_Jordan_PA_eq fst_Gauss_Jordan_PA inv_A matrix_inv_Gauss)

lemma invertible_eq_full_rank[code_unfold]:
fixes A::"'a::{field}^'n::{mod_type}^'n::{mod_type}"
shows "invertible A = (rank A = nrows A)"
by (metis full_rank_implies_invertible invertible_implies_full_rank)

definition "inverse_matrix A = (if invertible A then Some (matrix_inv A) else None)"

lemma the_inverse_matrix:
fixes A::"'a::{field}^'n::{mod_type}^'n::{mod_type}"
assumes "invertible A"
shows "the (inverse_matrix A) = P_Gauss_Jordan A"
  by (metis P_Gauss_Jordan_def assms inverse_matrix_def matrix_inv_Gauss_Jordan_PA option.sel)

lemma inverse_matrix:
fixes A::"'a::{field}^'n::{mod_type}^'n::{mod_type}"
shows "inverse_matrix A = (if invertible A then Some (P_Gauss_Jordan A) else None)"
  by (metis inverse_matrix_def option.sel the_inverse_matrix)

lemma inverse_matrix_code[code_unfold]:
fixes A::"'a::{field}^'n::{mod_type}^'n::{mod_type}"
shows "inverse_matrix A = (let GJ = Gauss_Jordan_PA A;
                                rank_A = (if A = 0 then 0 else to_nat (GREATEST a. row a (snd GJ) \<noteq> 0) + 1) in
                                if nrows A = rank_A then Some (fst(GJ)) else None)"
unfolding inverse_matrix
unfolding invertible_eq_full_rank
unfolding rank_Gauss_Jordan_code
unfolding P_Gauss_Jordan_def
unfolding Let_def Gauss_Jordan_PA_eq by presburger

end


(*  Authors:    Jeremy Avigad, David Gray, and Adam Kramer

Ported by lcp but unfinished
*)

section {* Gauss' Lemma *}

theory Gauss
imports Residues
begin

lemma cong_prime_prod_zero_nat:
  fixes a::nat
  shows "\<lbrakk>[a * b = 0] (mod p); prime p\<rbrakk> \<Longrightarrow> [a = 0] (mod p) | [b = 0] (mod p)"
  by (auto simp add: cong_altdef_nat)

lemma cong_prime_prod_zero_int:
  fixes a::int
  shows "\<lbrakk>[a * b = 0] (mod p); prime p\<rbrakk> \<Longrightarrow> [a = 0] (mod p) | [b = 0] (mod p)"
  by (auto simp add: cong_altdef_int)

locale GAUSS =
  fixes p :: "nat"
  fixes a :: "int"

  assumes p_prime: "prime p"
  assumes p_ge_2: "2 < p"
  assumes p_a_relprime: "[a \<noteq> 0](mod p)"
  assumes a_nonzero:    "0 < a"
begin

definition "A = {0::int <.. ((int p - 1) div 2)}"
definition "B = (\<lambda>x. x * a) ` A"
definition "C = (\<lambda>x. x mod p) ` B"
definition "D = C \<inter> {.. (int p - 1) div 2}"
definition "E = C \<inter> {(int p - 1) div 2 <..}"
definition "F = (\<lambda>x. (int p - x)) ` E"

subsection {* Basic properties of p *}

lemma odd_p: "odd p"
by (metis p_prime p_ge_2 prime_odd_nat)

lemma p_minus_one_l: "(int p - 1) div 2 < p"
proof -
  have "(p - 1) div 2 \<le> (p - 1) div 1"
    by (metis div_by_1 div_le_dividend)
  also have "\<dots> = p - 1" by simp
  finally show ?thesis using p_ge_2 by arith
qed

lemma p_eq2: "int p = (2 * ((int p - 1) div 2)) + 1"
  using odd_p p_ge_2 div_mult_self1_is_id [of 2 "p - 1"]
  by simp

lemma p_odd_int: obtains z::int where "int p = 2*z+1" "0<z"
  using odd_p p_ge_2
  by (auto simp add: even_iff_mod_2_eq_zero) (metis p_eq2)

subsection {* Basic Properties of the Gauss Sets *}

lemma finite_A: "finite (A)"
by (auto simp add: A_def)

lemma finite_B: "finite (B)"
by (auto simp add: B_def finite_A)

lemma finite_C: "finite (C)"
by (auto simp add: C_def finite_B)

lemma finite_D: "finite (D)"
by (auto simp add: D_def finite_C)

lemma finite_E: "finite (E)"
by (auto simp add: E_def finite_C)

lemma finite_F: "finite (F)"
by (auto simp add: F_def finite_E)

lemma C_eq: "C = D \<union> E"
by (auto simp add: C_def D_def E_def)

lemma A_card_eq: "card A = nat ((int p - 1) div 2)"
  by (auto simp add: A_def)

lemma inj_on_xa_A: "inj_on (\<lambda>x. x * a) A"
  using a_nonzero by (simp add: A_def inj_on_def)

definition ResSet :: "int => int set => bool"
  where "ResSet m X = (\<forall>y1 y2. (y1 \<in> X & y2 \<in> X & [y1 = y2] (mod m) --> y1 = y2))"

lemma ResSet_image:
  "\<lbrakk> 0 < m; ResSet m A; \<forall>x \<in> A. \<forall>y \<in> A. ([f x = f y](mod m) --> x = y) \<rbrakk> \<Longrightarrow>
    ResSet m (f ` A)"
  by (auto simp add: ResSet_def)

lemma A_res: "ResSet p A"
  using p_ge_2
  by (auto simp add: A_def ResSet_def intro!: cong_less_imp_eq_int)

lemma B_res: "ResSet p B"
proof -
  {fix x fix y
    assume a: "[x * a = y * a] (mod p)"
    assume b: "0 < x"
    assume c: "x \<le> (int p - 1) div 2"
    assume d: "0 < y"
    assume e: "y \<le> (int p - 1) div 2"
    from a p_a_relprime p_prime a_nonzero cong_mult_rcancel_int [of _ a x y]
    have "[x = y](mod p)"
      by (metis comm_monoid_mult_class.mult.left_neutral cong_dvd_modulus_int cong_mult_rcancel_int
                cong_mult_self_int gcd_int.commute prime_imp_coprime_int)
    with cong_less_imp_eq_int [of x y p] p_minus_one_l
        order_le_less_trans [of x "(int p - 1) div 2" p]
        order_le_less_trans [of y "(int p - 1) div 2" p]
    have "x = y"
      by (metis b c cong_less_imp_eq_int d e zero_less_imp_eq_int zero_zle_int)
    } note xy = this
  show ?thesis
    apply (insert p_ge_2 p_a_relprime p_minus_one_l)
    apply (auto simp add: B_def)
    apply (rule ResSet_image)
    apply (auto simp add: A_res)
    apply (auto simp add: A_def xy)
    done
  qed

lemma SR_B_inj: "inj_on (\<lambda>x. x mod p) B"
proof -
{ fix x fix y
  assume a: "x * a mod p = y * a mod p"
  assume b: "0 < x"
  assume c: "x \<le> (int p - 1) div 2"
  assume d: "0 < y"
  assume e: "y \<le> (int p - 1) div 2"
  assume f: "x \<noteq> y"
  from a have "[x * a = y * a](mod p)"
    by (metis cong_int_def)
  with p_a_relprime p_prime cong_mult_rcancel_int [of a p x y]
  have "[x = y](mod p)"
    by (metis cong_mult_self_int dvd_div_mult_self gcd_commute_int prime_imp_coprime_int)
  with cong_less_imp_eq_int [of x y p] p_minus_one_l
    order_le_less_trans [of x "(int p - 1) div 2" p]
    order_le_less_trans [of y "(int p - 1) div 2" p]
  have "x = y"
    by (metis b c cong_less_imp_eq_int d e zero_less_imp_eq_int zero_zle_int)
  then have False
    by (simp add: f)}
  then show ?thesis
    by (auto simp add: B_def inj_on_def A_def) metis
qed

lemma inj_on_pminusx_E: "inj_on (\<lambda>x. p - x) E"
  apply (auto simp add: E_def C_def B_def A_def)
  apply (rule_tac g = "(op - (int p))" in inj_on_inverseI)
  apply auto
  done

lemma nonzero_mod_p:
  fixes x::int shows "\<lbrakk>0 < x; x < int p\<rbrakk> \<Longrightarrow> [x \<noteq> 0](mod p)"
by (metis Nat_Transfer.transfer_nat_int_function_closures(9) cong_less_imp_eq_int
     inf.semilattice_strict_iff_order int_less_0_conv le_numeral_extra(3) zero_less_imp_eq_int)

lemma A_ncong_p: "x \<in> A \<Longrightarrow> [x \<noteq> 0](mod p)"
  by (rule nonzero_mod_p) (auto simp add: A_def)

lemma A_greater_zero: "x \<in> A \<Longrightarrow> 0 < x"
  by (auto simp add: A_def)

lemma B_ncong_p: "x \<in> B \<Longrightarrow> [x \<noteq> 0](mod p)"
  by (auto simp add: B_def) (metis cong_prime_prod_zero_int A_ncong_p p_a_relprime p_prime)

lemma B_greater_zero: "x \<in> B \<Longrightarrow> 0 < x"
  using a_nonzero by (auto simp add: B_def A_greater_zero)

lemma C_greater_zero: "y \<in> C \<Longrightarrow> 0 < y"
proof (auto simp add: C_def)
  fix x :: int
  assume a1: "x \<in> B"
  have f2: "\<And>x\<^sub>1. int x\<^sub>1 = 0 \<or> 0 < int x\<^sub>1" by linarith
  have "x mod int p \<noteq> 0" using a1 B_ncong_p cong_int_def by simp
  thus "0 < x mod int p" using a1 f2
    by (metis (no_types) B_greater_zero Divides.transfer_int_nat_functions(2) zero_less_imp_eq_int)
qed

lemma F_subset: "F \<subseteq> {x. 0 < x & x \<le> ((int p - 1) div 2)}"
  apply (auto simp add: F_def E_def C_def)
  apply (metis p_ge_2 Divides.pos_mod_bound less_diff_eq nat_int plus_int_code(2) zless_nat_conj)
  apply (auto intro: p_odd_int)
  done

lemma D_subset: "D \<subseteq> {x. 0 < x & x \<le> ((p - 1) div 2)}"
  by (auto simp add: D_def C_greater_zero)

lemma F_eq: "F = {x. \<exists>y \<in> A. ( x = p - ((y*a) mod p) & (int p - 1) div 2 < (y*a) mod p)}"
  by (auto simp add: F_def E_def D_def C_def B_def A_def)

lemma D_eq: "D = {x. \<exists>y \<in> A. ( x = (y*a) mod p & (y*a) mod p \<le> (int p - 1) div 2)}"
  by (auto simp add: D_def C_def B_def A_def)

lemma all_A_relprime: assumes "x \<in> A" shows "gcd x p = 1"
  using p_prime A_ncong_p [OF assms]
  by (simp add: cong_altdef_int) (metis gcd_int.commute prime_imp_coprime_int)

lemma A_prod_relprime: "gcd (setprod id A) p = 1"
  by (metis id_def all_A_relprime setprod_coprime_int)

subsection {* Relationships Between Gauss Sets *}

lemma StandardRes_inj_on_ResSet: "ResSet m X \<Longrightarrow> (inj_on (\<lambda>b. b mod m) X)"
  by (auto simp add: ResSet_def inj_on_def cong_int_def)

lemma B_card_eq_A: "card B = card A"
  using finite_A by (simp add: finite_A B_def inj_on_xa_A card_image)

lemma B_card_eq: "card B = nat ((int p - 1) div 2)"
  by (simp add: B_card_eq_A A_card_eq)

lemma F_card_eq_E: "card F = card E"
  using finite_E
  by (simp add: F_def inj_on_pminusx_E card_image)

lemma C_card_eq_B: "card C = card B"
proof -
  have "inj_on (\<lambda>x. x mod p) B"
    by (metis SR_B_inj)
  then show ?thesis
    by (metis C_def card_image)
qed

lemma D_E_disj: "D \<inter> E = {}"
  by (auto simp add: D_def E_def)

lemma C_card_eq_D_plus_E: "card C = card D + card E"
  by (auto simp add: C_eq card_Un_disjoint D_E_disj finite_D finite_E)

lemma C_prod_eq_D_times_E: "setprod id E * setprod id D = setprod id C"
  by (metis C_eq D_E_disj finite_D finite_E inf_commute setprod.union_disjoint sup_commute)

lemma C_B_zcong_prod: "[setprod id C = setprod id B] (mod p)"
  apply (auto simp add: C_def)
  apply (insert finite_B SR_B_inj)
  apply (drule setprod.reindex [of "\<lambda>x. x mod int p" B id])
  apply auto
  apply (rule cong_setprod_int)
  apply (auto simp add: cong_int_def)
  done

lemma F_Un_D_subset: "(F \<union> D) \<subseteq> A"
  apply (intro Un_least subset_trans [OF F_subset] subset_trans [OF D_subset])
  apply (auto simp add: A_def)
  done

lemma F_D_disj: "(F \<inter> D) = {}"
proof (auto simp add: F_eq D_eq)
  fix y::int and z::int
  assume "p - (y*a) mod p = (z*a) mod p"
  then have "[(y*a) mod p + (z*a) mod p = 0] (mod p)"
    by (metis add.commute diff_eq_eq dvd_refl cong_int_def dvd_eq_mod_eq_0 mod_0)
  moreover have "[y * a = (y*a) mod p] (mod p)"
    by (metis cong_int_def mod_mod_trivial)
  ultimately have "[a * (y + z) = 0] (mod p)"
    by (metis cong_int_def mod_add_left_eq mod_add_right_eq mult.commute ring_class.ring_distribs(1))
  with p_prime a_nonzero p_a_relprime
  have a: "[y + z = 0] (mod p)"
    by (metis cong_prime_prod_zero_int)
  assume b: "y \<in> A" and c: "z \<in> A"
  with A_def have "0 < y + z"
    by auto
  moreover from b c p_eq2 A_def have "y + z < p"
    by auto
  ultimately show False
    by (metis a nonzero_mod_p)
qed

lemma F_Un_D_card: "card (F \<union> D) = nat ((p - 1) div 2)"
proof -
  have "card (F \<union> D) = card E + card D"
    by (auto simp add: finite_F finite_D F_D_disj card_Un_disjoint F_card_eq_E)
  then have "card (F \<union> D) = card C"
    by (simp add: C_card_eq_D_plus_E)
  then show "card (F \<union> D) = nat ((p - 1) div 2)"
    by (simp add: C_card_eq_B B_card_eq)
qed

lemma F_Un_D_eq_A: "F \<union> D = A"
  using finite_A F_Un_D_subset A_card_eq F_Un_D_card
  by (auto simp add: card_seteq)

lemma prod_D_F_eq_prod_A: "(setprod id D) * (setprod id F) = setprod id A"
  by (metis F_D_disj F_Un_D_eq_A Int_commute Un_commute finite_D finite_F setprod.union_disjoint)

lemma prod_F_zcong: "[setprod id F = ((-1) ^ (card E)) * (setprod id E)] (mod p)"
proof -
  have FE: "setprod id F = setprod (op - p) E"
    apply (auto simp add: F_def)
    apply (insert finite_E inj_on_pminusx_E)
    apply (drule setprod.reindex, auto)
    done
  then have "\<forall>x \<in> E. [(p-x) mod p = - x](mod p)"
    by (metis cong_int_def minus_mod_self1 mod_mod_trivial)
  then have "[setprod ((\<lambda>x. x mod p) o (op - p)) E = setprod (uminus) E](mod p)"
    using finite_E p_ge_2
          cong_setprod_int [of E "(\<lambda>x. x mod p) o (op - p)" uminus p]
    by auto
  then have two: "[setprod id F = setprod (uminus) E](mod p)"
    by (metis FE cong_cong_mod_int cong_refl_int cong_setprod_int minus_mod_self1)
  have "setprod uminus E = (-1) ^ (card E) * (setprod id E)"
    using finite_E by (induct set: finite) auto
  with two show ?thesis
    by simp
qed

subsection {* Gauss' Lemma *}

lemma aux: "setprod id A * (- 1) ^ card E * a ^ card A * (- 1) ^ card E = setprod id A * a ^ card A"
by (metis (no_types) minus_minus mult.commute mult.left_commute power_minus power_one)

theorem pre_gauss_lemma:
  "[a ^ nat((int p - 1) div 2) = (-1) ^ (card E)] (mod p)"
proof -
  have "[setprod id A = setprod id F * setprod id D](mod p)"
    by (auto simp add: prod_D_F_eq_prod_A mult.commute cong del:setprod.cong)
  then have "[setprod id A = ((-1)^(card E) * setprod id E) * setprod id D] (mod p)"
    apply (rule cong_trans_int)
    apply (metis cong_scalar_int prod_F_zcong)
    done
  then have "[setprod id A = ((-1)^(card E) * setprod id C)] (mod p)"
    by (metis C_prod_eq_D_times_E mult.commute mult.left_commute)
  then have "[setprod id A = ((-1)^(card E) * setprod id B)] (mod p)"
    by (rule cong_trans_int) (metis C_B_zcong_prod cong_scalar2_int)
  then have "[setprod id A = ((-1)^(card E) *
    (setprod id ((\<lambda>x. x * a) ` A)))] (mod p)"
    by (simp add: B_def)
  then have "[setprod id A = ((-1)^(card E) * (setprod (\<lambda>x. x * a) A))]
    (mod p)"
    by (simp add: inj_on_xa_A setprod.reindex)
  moreover have "setprod (\<lambda>x. x * a) A =
    setprod (\<lambda>x. a) A * setprod id A"
    using finite_A by (induct set: finite) auto
  ultimately have "[setprod id A = ((-1)^(card E) * (setprod (\<lambda>x. a) A *
    setprod id A))] (mod p)"
    by simp
  then have "[setprod id A = ((-1)^(card E) * a^(card A) *
      setprod id A)](mod p)"
    apply (rule cong_trans_int)
    apply (simp add: cong_scalar2_int cong_scalar_int finite_A setprod_constant mult.assoc)
    done
  then have a: "[setprod id A * (-1)^(card E) =
      ((-1)^(card E) * a^(card A) * setprod id A * (-1)^(card E))](mod p)"
    by (rule cong_scalar_int)
  then have "[setprod id A * (-1)^(card E) = setprod id A *
      (-1)^(card E) * a^(card A) * (-1)^(card E)](mod p)"
    apply (rule cong_trans_int)
    apply (simp add: a mult.commute mult.left_commute)
    done
  then have "[setprod id A * (-1)^(card E) = setprod id A * a^(card A)](mod p)"
    apply (rule cong_trans_int)
    apply (simp add: aux cong del:setprod.cong)
    done
  with A_prod_relprime have "[(- 1) ^ card E = a ^ card A](mod p)"
    by (metis cong_mult_lcancel_int)
  then show ?thesis
    by (simp add: A_card_eq cong_sym_int)
qed

(*NOT WORKING. Old_Number_Theory/Euler.thy needs to be translated, but it's
quite a mess and should better be completely redone.

theorem gauss_lemma: "(Legendre a p) = (-1) ^ (card E)"
proof -
  from Euler_Criterion p_prime p_ge_2 have
      "[(Legendre a p) = a^(nat (((p) - 1) div 2))] (mod p)"
    by auto
  moreover note pre_gauss_lemma
  ultimately have "[(Legendre a p) = (-1) ^ (card E)] (mod p)"
    by (rule cong_trans_int)
  moreover from p_a_relprime have "(Legendre a p) = 1 | (Legendre a p) = (-1)"
    by (auto simp add: Legendre_def)
  moreover have "(-1::int) ^ (card E) = 1 | (-1::int) ^ (card E) = -1"
    by (rule neg_one_power)
  ultimately show ?thesis
    by (auto simp add: p_ge_2 one_not_neg_one_mod_m zcong_sym)
qed
*)

end

end


section \<open> Summing a List \<close>

theory sum_list
  imports "UTP.utp"
begin

text \<open> We first create a state space with the variables the program needs. \<close>

alphabet st_sum_list =
  i   :: nat
  xs  :: "int list"
  ans :: int

text \<open> Next, we define the program as by a homogeneous relation over the state-space type. \<close>

abbreviation Sum_List :: "st_sum_list hrel" where
  "Sum_List \<equiv>
  i := 0 ;;
  ans := 0 ;;
  while (i < length xs) invr (ans = list_sum(take i xs))
  do
    ans := ans + xs ! i ;;
    i := i + 1
  od"

text \<open> Next, we symbolically evaluate some examples. \<close>

lemma "TRY([&xs \<mapsto>\<^sub>s \<guillemotleft>[4,3,7,1,12,8]\<guillemotright>] \<Turnstile> Sum_List)"
  apply (sym_eval) oops

text \<open> Finally, we verify the program. \<close>

theorem Sum_List_sums:
  "\<lbrace>xs = \<guillemotleft>XS\<guillemotright>\<rbrace> Sum_List \<lbrace>ans = list_sum(xs)\<rbrace>\<^sub>u"
  by (hoare_auto, metis add.foldr_snoc take_Suc_conv_app_nth)

end


theory MultiplicationRusse
imports Main
begin

record 's algorithm =
  init :: 's
  trans :: "('s \<times> 's) set"

inductive
  reachable :: "'s algorithm \<Rightarrow> 's \<Rightarrow> bool"
  for A :: "'s algorithm"
  where
    reachable_0:  "reachable A (init A)"
  | reachable_n:  "\<lbrakk> reachable A s; (s,t) \<in> (trans A) \<rbrakk>
    \<Longrightarrow> reachable A t"

definition invariant where
  "invariant A P \<equiv> (\<forall> s . reachable A s \<longrightarrow> P s)"

theorem invariantI:
  fixes A P
  assumes "P (init A)"
  and "\<And> s t . \<lbrakk>reachable A s; P s; (s,t) \<in> trans A\<rbrakk>
    \<Longrightarrow> P t"
  shows "invariant A P"
proof (auto simp add:invariant_def)
  fix s
  assume "reachable A s"
  thus "P s"
  proof (induct rule:reachable.induct)
    show "P (init A)" using assms by auto
  next
    fix s t
    assume "reachable A s" and "P s"
      and "(s, t) \<in> trans A"
    thus "P t" using assms(2) by simp
  qed
qed

theorem invariant_imp:
  fixes A P Q
  assumes "invariant A P"
  and "\<And> s . P s \<Longrightarrow> Q s"
  shows "invariant A Q"
using assms
by (auto simp add:invariant_def)

datatype ligne = l1 | l2 | l3 | l4 | l5

record MultVars =
  ligne :: ligne
  x :: nat
  y :: nat
  r :: nat

sledgehammer_params[timeout=600]

locale Mult =
  fixes a b :: nat
begin

definition MultRusse where
  "MultRusse \<equiv> \<lparr>
    init = \<lparr>ligne = l1, x = a, y = b, r = 0\<rparr>,
    trans = { (s,t) .
      ligne s = l1
        \<and> (if (x s \<noteq> 0)
          then t = s\<lparr>ligne := l2\<rparr>
          else t = s\<lparr>ligne := l5\<rparr>)
      \<or> ligne s = l2
        \<and> (if (x s mod 2 = 1)
          then t = s\<lparr>ligne := l3, r := (r s) + (y s)\<rparr>
          else t = s\<lparr>ligne := l3\<rparr>)
      \<or> ligne s = l3 \<and> t = s\<lparr>ligne := l4, x := (x s) div 2\<rparr>
      \<or> ligne s = l4 \<and> t = s\<lparr>ligne := l1, y := (y s) * 2\<rparr>
    }
  \<rparr>"

definition valide :: "MultVars \<Rightarrow> bool" where
  "valide s \<equiv>
    ligne s = l5 \<longrightarrow> r s = a*b"

definition ind :: "MultVars \<Rightarrow> bool" where
  "ind s \<equiv>
    (ligne s \<in> {l1,l2,l5} \<longrightarrow> r s + (x s)*(y s) = a*b)
    \<and> (ligne s = l3 \<longrightarrow> r s + (x s)*(y s) =
        (if ((x s) mod 2 = 0) then a*b else a*b + (y s)))
    \<and> (ligne s = l4 \<longrightarrow> r s + 2*(x s)*(y s) = a*b)
    \<and> (ligne s = l5 \<longrightarrow> x s = 0)"

declare
  MultRusse_def [simp]
  valide_def [simp]
  ind_def [simp]
  split_if [split]
  split_if_asm [split]

lemma "ind s \<Longrightarrow> valide s"
by auto

lemma ind_inv:
  "invariant MultRusse ind"
proof (rule invariantI)
  show "ind (init MultRusse)" by auto
next
  fix s t
  assume 1:"ind s"
  and 2:"(s,t) \<in> trans MultRusse"
  show "ind t"
  proof (cases "ligne s")
    case l1
    hence 3:"if (x s \<noteq> 0)
             then t = s\<lparr>ligne := l2\<rparr>
             else t = s\<lparr>ligne := l5\<rparr>"
      using 2 by force
    show ?thesis
    proof (cases "x s \<noteq> 0")
      case True
      with 3 have "t = s\<lparr>ligne := l2\<rparr>" by auto
      with 1 l1 show ?thesis by auto
    next
      case False
      with 3 have "t = s\<lparr>ligne := l5\<rparr>" by auto
      with 1 l1 False show ?thesis by auto
    qed
  next
    case l2
    hence 3:
      "if (x s mod 2 = 1)
        then t = s\<lparr>ligne := l3, r := (r s) + (y s)\<rparr>
        else t = s\<lparr>ligne := l3\<rparr>"
      using 2 by force
    show ?thesis
    proof (cases "x s mod 2 = 1")
      case True
      have "t = s\<lparr>ligne := l3, r := (r s) + (y s)\<rparr>"
        using True 3 by auto
      thus ?thesis using 1 l2 True by auto
    next
      case False
      have "t = s\<lparr>ligne := l3\<rparr>"
        using False 3 by auto
      thus ?thesis using 1 l2 False by auto
    qed
  next
    case l3
    hence 3:"t = s\<lparr>ligne := l4, x := (x s) div 2\<rparr>"
      using 2 by force
    show ?thesis
    proof (cases "x s mod 2 = 0")
      case True
      thus ?thesis using 1 3 l3 by auto
    next
      case False
      have "x s \<noteq> 0" using False by linarith
      hence 4:"2*(x s div 2)*(y s) = (x s)*(y s) - (y s)"
        by (metis False diff_mult_distrib2 mult.commute mult_numeral_1_right numeral_One parity semiring_numeral_div_class.mult_div_cancel)
      hence "r s + (2*(x s div 2)*(y s)) = r s + ((x s)*(y s) - (y s))" by metis
      hence "r s + 2*(x s div 2)*(y s) = r s + ((x s)*(y s) - (y s))" by metis
      also have "... = r s + (x s)*(y s) - (y s)" using `x s \<noteq> 0` by fastforce
      finally have "r s + 2*(x s div 2)*(y s) = r s + (x s)*(y s) - (y s)" .
      moreover have "r s + (x s)*(y s) = a*b + y s" using 1 l3 False by auto
      ultimately have "r s + 2*(x s div 2)*(y s) = a*b" by auto
      thus ?thesis using 1 3 l3 False by auto
    qed
  next
    case l4
    hence 3:"t = s\<lparr>ligne := l1, y := (y s) * 2\<rparr>"
      using 2 by force
    thus ?thesis using 1 l4 by auto
  next
    case l5
    thus ?thesis using 2 by force
  qed
qed

end

end


theory Preliminaries
  imports "HOL-Analysis.Analysis"
begin

notation powr (infixr ".^" 80)

section \<open>Preliminary Definitions and Lemmas\<close>

lemma seq_part_multiple: fixes m n :: nat assumes "m \<noteq> 0" defines "A \<equiv> \<lambda>i::nat. {i*m ..< (i+1)*m}"
  shows "\<forall>i j. i \<noteq> j \<longrightarrow> A i \<inter> A j = {}" and "(\<Union>i<n. A i) = {..< n*m}"
proof -
  { fix i j :: nat
    have "i \<noteq> j \<Longrightarrow> A i \<inter> A j = {}"
    proof (erule contrapos_np)
      assume "A i \<inter> A j \<noteq> {}"
      then obtain k where "k \<in> A i \<inter> A j" by blast
      hence "i*m < (j+1)*m \<and> j*m < (i+1)*m" unfolding A_def by force
      hence "i < j+1 \<and> j < i+1" using mult_less_cancel2 by blast
      thus "i = j" by force
    qed }
  thus "\<forall>i j. i \<noteq> j \<longrightarrow> A i \<inter> A j = {}" by blast
next
  show "(\<Union>i<n. A i) = {..< n*m}"
  proof
    show "(\<Union>i<n. A i) \<subseteq> {..< n*m}"
    proof
      fix x::nat
      assume "x \<in> (\<Union>i<n. A i)"
      then obtain i where i_n: "i < n" and i_x: "x < (i+1)*m" unfolding A_def by force
      hence "i+1 \<le> n" by linarith
      hence "x < n*m" by (meson less_le_trans mult_le_cancel2 i_x)
      thus "x \<in> {..< n*m}"
        using diff_mult_distrib mult_1 i_n by auto
    qed
  next
    show "{..< n*m} \<subseteq> (\<Union>i<n. A i)"
    proof
      fix x::nat
      let ?i = "x div m"
      assume "x \<in> {..< n*m}"
      hence "?i < n" by (simp add: less_mult_imp_div_less)
      moreover have "?i*m \<le> x \<and> x < (?i+1)*m"
        using assms div_times_less_eq_dividend dividend_less_div_times by auto
      ultimately show "x \<in> (\<Union>i<n. A i)" unfolding A_def by force
    qed
  qed
qed

lemma(in field) divide_mult_cancel[simp]: fixes a b assumes "b \<noteq> 0"
  shows "a / b * b = a"
  by (simp add: assms)

lemma inverse_powr: "(1/a).^b = a.^-b" if "a > 0" for a b :: real
  by (smt that powr_divide powr_minus_divide powr_one_eq_one)

lemma powr_eq_one_iff_gen[simp]: "a.^x = 1 \<longleftrightarrow> x = 0" if "a > 0" "a \<noteq> 1" for a x :: real
  by (metis powr_eq_0_iff powr_inj powr_zero_eq_one that)

lemma powr_less_cancel2: "0 < a \<Longrightarrow> 0 < x \<Longrightarrow> 0 < y \<Longrightarrow> x.^a < y.^a \<Longrightarrow> x < y"
  for a x y ::real
proof -
  assume a_pos: "0 < a" and x_pos: "0 < x" and y_pos: "0 < y"
  show "x.^a < y.^a \<Longrightarrow> x < y"
  proof (erule contrapos_pp)
    assume "\<not> x < y"
    hence "x \<ge> y" by fastforce
    hence "x.^a \<ge> y.^a"
    proof (cases "x = y")
      case True
      thus ?thesis by simp
    next
      case False
      hence "x.^a > y.^a"
        using \<open>x \<ge> y\<close> powr_less_mono2 a_pos y_pos by auto
      thus ?thesis by auto
    qed
    thus "\<not> x.^a < y.^a" by fastforce
  qed
qed

lemma geometric_increasing_sum_aux: "(1-r)^2 * (\<Sum>k<n. (k+1)*r^k) = 1 - (n+1)*r^n + n*r^(n+1)"
  for n::nat and r::real
proof (induct n)
  case 0
  thus ?case by simp
next
  case (Suc n)
  thus ?case
    by (simp add: distrib_left power2_diff field_simps power2_eq_square)
qed

lemma geometric_increasing_sum: "(\<Sum>k<n. (k+1)*r^k) = (1 - (n+1)*r^n + n*r^(n+1)) / (1-r)^2"
  if "r \<noteq> 1" for n::nat and r::real
  by (subst geometric_increasing_sum_aux[THEN sym], simp add: that)

lemma Reals_UNIV[simp]: "\<real> = {x::real. True}"
  unfolding Reals_def by auto

lemma DERIV_fun_powr2:
  fixes a::real
  assumes a_pos: "a > 0"
    and f: "DERIV f x :> r"
  shows "DERIV (\<lambda>x. a.^(f x)) x :> a.^(f x) * r * ln a"
proof -
  let ?g = "(\<lambda>x. a)"
  have g: "DERIV ?g x :> 0" by simp
  have pos: "?g x > 0" by (simp add: a_pos)
  show ?thesis
    using DERIV_powr[OF g pos f] a_pos by (auto simp add: field_simps)
qed

lemma has_real_derivative_powr2:
  assumes a_pos: "a > 0"
  shows "((\<lambda>x. a.^x) has_real_derivative a.^x * ln a) (at x)"
proof -
  let ?f = "(\<lambda>x. x::real)"
  have f: "DERIV ?f x :> 1" by simp
  thus ?thesis using DERIV_fun_powr2[OF a_pos f] by simp
qed

lemma has_integral_powr2_from_0:
  fixes a c :: real
  assumes a_pos: "a > 0" and a_neq_1: "a \<noteq> 1" and c_nneg: "c \<ge> 0"
  shows "((\<lambda>x. a.^x) has_integral ((a.^c - 1) / (ln a))) {0..c}"
proof -
  have "((\<lambda>x. a.^x) has_integral ((a.^c)/(ln a) - (a.^0)/(ln a))) {0..c}"
  proof (rule fundamental_theorem_of_calculus[OF c_nneg])
    fix x::real
    assume "x \<in> {0..c}"
    show "((\<lambda>y. a.^y / ln a) has_vector_derivative a.^x) (at x within {0..c})"
      using has_real_derivative_powr2[OF a_pos, of x]
      apply -
      apply (drule DERIV_cdivide[where c = "ln a"], simp add: assms)
      apply (rule has_vector_derivative_within_subset[where S=UNIV and T="{0..c}"], auto)
      by (rule iffD1[OF has_real_derivative_iff_has_vector_derivative])
  qed
  thus ?thesis
    using assms powr_zero_eq_one by (simp add: field_simps)
qed

lemma integrable_on_powr2_from_0:
  fixes a c :: real
  assumes a_pos: "a > 0" and a_neq_1: "a \<noteq> 1" and c_nneg: "c \<ge> 0"
  shows "(\<lambda>x. a.^x) integrable_on {0..c}"
  using has_integral_powr2_from_0[OF assms] unfolding integrable_on_def by blast

lemma integrable_on_powr2_from_0_general:
  fixes a c :: real
  assumes a_pos: "a > 0" and c_nneg: "c \<ge> 0"
  shows "(\<lambda>x. a.^x) integrable_on {0..c}"
proof (cases "a = 1")
  case True
  thus ?thesis
    using has_integral_const_real by auto
next
  case False
  thus ?thesis
    using has_integral_powr2_from_0 False assms by auto
qed

lemma has_integral_null_interval: fixes a b :: real and f::"real \<Rightarrow> real" assumes "a \<ge> b"
  shows "(f has_integral 0) {a..b}"
  using assms content_real_eq_0 by blast

lemma has_integral_interval_reverse: fixes f :: "real \<Rightarrow> real" and a b :: real
  assumes "a \<le> b"
    and "continuous_on {a..b} f"
  shows "((\<lambda>x. f (a+b-x)) has_integral (integral {a..b} f)) {a..b}"
proof -
  let ?g = "\<lambda>x. a + b - x"
  let ?g' = "\<lambda>x. -1"
  have g_C0: "continuous_on {a..b} ?g" using continuous_on_op_minus by simp
  have Dg_g': "\<And>x. x\<in>{a..b} \<Longrightarrow> (?g has_field_derivative ?g' x) (at x within {a..b})"
    by (auto intro!: derivative_eq_intros)
  show ?thesis
    using has_integral_substitution_general
      [of "{}" a b ?g a b f, simplified, OF assms g_C0 Dg_g', simplified]
    apply (simp add: has_integral_null_interval[OF assms(1), THEN integral_unique])
    by (simp add: has_integral_neg_iff)
qed

end


theory prop_69
imports Main
        "$HIPSTER_HOME/IsaHipster"
begin
  datatype Nat = Z | S "Nat"
  fun plus :: "Nat => Nat => Nat" where
  "plus (Z) y = y"
  | "plus (S z) y = S (plus z y)"
  fun le :: "Nat => Nat => bool" where
  "le (Z) y = True"
  | "le (S z) (Z) = False"
  | "le (S z) (S x2) = le z x2"
  (*hipster plus le *)

lemma lemma_ab [thy_expl]: "le x2 x2 = True"
by (hipster_induct_schemes le.simps)

lemma lemma_ac [thy_expl]: "le x2 (S x2) = True"
by (hipster_induct_schemes le.simps)

lemma lemma_ad [thy_expl]: "le (S x2) x2 = False"
by (hipster_induct_schemes le.simps)

lemma lemma_ag [thy_expl]: "plus x2 Z = x2"
by (hipster_induct_schemes plus.simps)

lemma lemma_ah [thy_expl]: "plus (plus x2 y2) z2 = plus x2 (plus y2 z2)"
by (hipster_induct_schemes plus.simps)

lemma lemma_ai [thy_expl]: "plus x2 (S y2) = S (plus x2 y2)"
by (hipster_induct_schemes plus.simps)

lemma lemma_aj [thy_expl]: "plus x2 (plus y2 x2) = plus y2 (plus x2 x2)"
by (hipster_induct_schemes plus.simps)

lemma lemma_ak [thy_expl]: "plus x2 (plus y2 y2) = plus y2 (plus y2 x2)"
by (hipster_induct_schemes plus.simps)

lemma lemma_al [thy_expl]: "plus x2 (S y2) = S (plus y2 x2)"
by (hipster_induct_schemes plus.simps)

lemma lemma_am [thy_expl]: "plus (plus x2 y2) x2 = plus x2 (plus x2 y2)"
by (hipster_induct_schemes plus.simps)

lemma lemma_an [thy_expl]: "plus (S x2) y2 = S (plus y2 x2)"
by (hipster_induct_schemes plus.simps)

lemma lemma_ao [thy_expl]: "plus (plus x3 y3) (plus x3 z3) = plus (plus x3 z3) (plus x3 y3)"
by (hipster_induct_schemes )

lemma lemma_ap [thy_expl]: "plus (plus x2 y2) (plus z2 y2) = plus (plus x2 z2) (plus y2 y2)"
by (hipster_induct_schemes plus.simps)

lemma lemma_aq [thy_expl]: "plus (plus x3 y3) (plus z3 z3) = plus (plus x3 z3) (plus z3 y3)"
by (hipster_induct_schemes plus.simps)

lemma lemma_ar [thy_expl]: "plus (plus x2 y2) (S z2) = plus (plus x2 z2) (S y2)"
by (hipster_induct_schemes plus.simps)
(*
lemma lemma_as [thy_expl]: "plus (plus x2 y2) (plus z2 x2) =
plus (plus z2 x2) (plus x2 y2)"
by (hipster_induct_schemes plus.simps)

lemma lemma_at [thy_expl]: "plus (plus x2 y2) (plus z2 y2) =
plus (plus z2 x2) (plus y2 y2)"
by (hipster_induct_schemes plus.simps)

lemma lemma_au [thy_expl]: "plus (plus x3 y3) (plus z3 z3) =
plus (plus z3 x3) (plus z3 y3)"
by (hipster_induct_schemes plus.simps)

lemma lemma_av [thy_expl]: "plus (plus x2 y2) (S z2) =
plus (plus z2 x2) (S y2)"
by (hipster_induct_schemes plus.simps)

lemma lemma_aw [thy_expl]: "plus (plus x2 x2) (plus y2 z2) =
plus (plus x2 y2) (plus x2 z2)"
by (hipster_induct_schemes plus.simps)

lemma lemma_ax [thy_expl]: "plus (plus x2 x2) (plus y2 z2) =
plus (plus y2 x2) (plus x2 z2)"
by (hipster_induct_schemes plus.simps)

lemma lemma_ay [thy_expl]: "plus (S x2) (plus y2 z2) =
plus (plus y2 x2) (S z2)"
by (hipster_induct_schemes plus.simps)

lemma lemma_az [thy_expl]: "plus (S x2) (plus y2 z2) =
plus (plus y2 z2) (S x2)"
by (hipster_induct_schemes plus.simps)

lemma lemma_ba [thy_expl]: "plus (plus x2 x2) (plus y2 y2) =
plus (plus x2 y2) (plus x2 y2)"
by (hipster_induct_schemes plus.simps)

lemma lemma_bb [thy_expl]: "plus (plus x2 x2) (S y2) =
plus (plus x2 y2) (S x2)"
by (hipster_induct_schemes plus.simps)

lemma lemma_bc [thy_expl]: "plus (plus x2 x2) (plus y2 y2) =
plus (plus y2 x2) (plus y2 x2)"
by (hipster_induct_schemes plus.simps)

lemma lemma_bd [thy_expl]: "plus (S x2) (plus x2 y2) =
plus (plus x2 y2) (S x2)"
by (hipster_induct_schemes plus.simps)

lemma lemma_be [thy_expl]: "plus (S x2) (plus y2 x2) =
plus (plus y2 x2) (S x2)"
by (hipster_induct_schemes plus.simps)
*)
lemma lemma_bf [thy_expl]: "plus (S x2) (S y2) = plus (S y2) (S x2)"
by (hipster_induct_schemes plus.simps)

lemma lemma_bg [thy_expl]: "plus x2 y2 = plus y2 x2"
by (hipster_induct_schemes plus.simps)

lemma lemma_bh [thy_expl]: "plus x2 (plus y2 z2) = plus y2 (plus x2 z2)"
by (hipster_induct_schemes plus.simps)

  theorem x0 :
    "le n (plus m n)"
    by (hipster_induct_schemes le.simps)
end


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

datatype Bin = One | ZeroAnd "Bin" | OneAnd "Bin"

fun s :: "Bin => Bin" where
"s (One) = ZeroAnd One"
| "s (ZeroAnd xs) = OneAnd xs"
| "s (OneAnd ys) = ZeroAnd (s ys)"

fun plus :: "Bin => Bin => Bin" where
"plus (One) y = s y"
| "plus (ZeroAnd z) (One) = s (ZeroAnd z)"
| "plus (ZeroAnd z) (ZeroAnd ys) = ZeroAnd (plus z ys)"
| "plus (ZeroAnd z) (OneAnd xs) = OneAnd (plus z xs)"
| "plus (OneAnd x2) (One) = s (OneAnd x2)"
| "plus (OneAnd x2) (ZeroAnd zs) = OneAnd (plus x2 zs)"
| "plus (OneAnd x2) (OneAnd ys2) = ZeroAnd (s (plus x2 ys2))"

fun times :: "Bin => Bin => Bin" where
"times (One) y = y"
| "times (ZeroAnd xs1) y = ZeroAnd (times xs1 y)"
| "times (OneAnd xs12) y = plus (ZeroAnd (times xs12 y)) y"

theorem property0 :
  "((times x y) = (times y x))"
  oops

end