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

header{*Computing determinants of matrices using the Gauss Jordan algorithm over nested IArrays*}

theory Determinants_IArrays
imports
    Determinants2
    Gauss_Jordan_IArrays
begin

subsection{*Definitions*}

definition "Gauss_Jordan_in_ij_det_P_iarrays A i j = (let n = least_non_zero_position_of_vector_from_index (column_iarray j A) i
  in (if i = n then 1 / A !! i !! j else - 1 / A !! n !! j, Gauss_Jordan_in_ij_iarrays A i j))"

definition "Gauss_Jordan_column_k_det_P_iarrays A' k = (let det_P = fst A'; i = fst (snd A'); A = snd (snd A')
 in if vector_all_zero_from_index (i, column_iarray k A) \<or> i = nrows_iarray A then (det_P, i, A)
    else let gauss = Gauss_Jordan_in_ij_det_P_iarrays A i k in (fst gauss * det_P, i + 1, snd gauss))"

definition "Gauss_Jordan_upt_k_det_P_iarrays A k = (let foldl = foldl Gauss_Jordan_column_k_det_P_iarrays (1, 0, A) [0..<Suc k] in (fst foldl, snd (snd foldl)))"
definition "Gauss_Jordan_det_P_iarrays A = Gauss_Jordan_upt_k_det_P_iarrays A (ncols_iarray A - 1)"

subsection{*Proofs*}

text{*A more efficient equation for @{term "Gauss_Jordan_in_ij_det_P_iarrays A i j"}.*}

lemma Gauss_Jordan_in_ij_det_P_iarrays_code[code]: "Gauss_Jordan_in_ij_det_P_iarrays A i j
    = (let n = least_non_zero_position_of_vector_from_index (column_iarray j A) i;
           interchange_A = interchange_rows_iarray A i n;
           A' = mult_row_iarray interchange_A i (1 / interchange_A !! i !! j)
       in (if i = n then 1 / A !! i !! j else - 1 / A !! n !! j, IArray.of_fun (\<lambda>s. if s = i then A' !! s else row_add_iarray A' s i (- interchange_A !! s !! j) !! s) (nrows_iarray A)))"
unfolding Gauss_Jordan_in_ij_det_P_iarrays_def Gauss_Jordan_in_ij_iarrays_def Let_def ..

lemma matrix_to_iarray_fst_Gauss_Jordan_in_ij_det_P:
assumes ex_n: "\<exists>n. A $ n $ j \<noteq> 0 \<and> i \<le> n"
shows "fst (Gauss_Jordan_in_ij_det_P A i j) = fst (Gauss_Jordan_in_ij_det_P_iarrays (matrix_to_iarray A) (to_nat i) (to_nat j))"
proof -
have least_n_eq: "least_non_zero_position_of_vector_from_index (vec_to_iarray (column j A)) (to_nat i) = to_nat (LEAST n. A $ n $ j \<noteq> 0 \<and> i \<le> n)"
by (rule vec_to_iarray_least_non_zero_position_of_vector_from_index'[unfolded matrix_vector_all_zero_from_index[symmetric]], metis ex_n)
show ?thesis
unfolding Gauss_Jordan_in_ij_det_P_def Gauss_Jordan_in_ij_det_P_iarrays_def Let_def fst_conv
 unfolding  least_n_eq[unfolded vec_to_iarray_column] unfolding matrix_to_iarray_nth by auto
qed

corollary matrix_to_iarray_fst_Gauss_Jordan_in_ij_det_P':
assumes "\<not> (vector_all_zero_from_index (to_nat i, vec_to_iarray (column j A)))"
shows "fst (Gauss_Jordan_in_ij_det_P A i j) = fst (Gauss_Jordan_in_ij_det_P_iarrays (matrix_to_iarray A) (to_nat i) (to_nat j))"
using matrix_to_iarray_fst_Gauss_Jordan_in_ij_det_P assms unfolding matrix_vector_all_zero_from_index[symmetric]
by auto

lemma matrix_to_iarray_snd_Gauss_Jordan_in_ij_det_P:
assumes ex_n: "\<exists>n. A $ n $ j \<noteq> 0 \<and> i \<le> n"
shows "matrix_to_iarray (snd (Gauss_Jordan_in_ij_det_P A i j)) = snd (Gauss_Jordan_in_ij_det_P_iarrays (matrix_to_iarray A) (to_nat i) (to_nat j))"
unfolding Gauss_Jordan_in_ij_det_P_def Gauss_Jordan_in_ij_det_P_iarrays_def Let_def snd_conv
by (rule matrix_to_iarray_Gauss_Jordan_in_ij, simp add: matrix_vector_all_zero_from_index[symmetric], metis ex_n)

lemma matrix_to_iarray_fst_Gauss_Jordan_column_k_det_P:
assumes i: "i\<le>nrows A" and k: "k<ncols A"
shows "fst (Gauss_Jordan_column_k_det_P (n, i, A) k) = fst (Gauss_Jordan_column_k_det_P_iarrays (n, i, matrix_to_iarray A) k)"
proof (cases "i<nrows A")
case True
show ?thesis
unfolding Gauss_Jordan_column_k_det_P_def Gauss_Jordan_column_k_det_P_iarrays_def Let_def snd_conv fst_conv
unfolding matrix_to_iarray_nrows matrix_vector_all_zero_from_index
using matrix_to_iarray_fst_Gauss_Jordan_in_ij_det_P'[of "from_nat i" "from_nat k" A]
unfolding vec_to_iarray_column
unfolding to_nat_from_nat_id[OF True[unfolded nrows_def]]
unfolding to_nat_from_nat_id[OF k[unfolded ncols_def]]
by auto
next
case False
hence "i=nrows A" using i by simp
thus ?thesis
unfolding Gauss_Jordan_column_k_det_P_def Gauss_Jordan_column_k_det_P_iarrays_def Let_def snd_conv fst_conv unfolding matrix_to_iarray_nrows by force
qed

lemma matrix_to_iarray_fst_snd_Gauss_Jordan_column_k_det_P:
assumes i: "i\<le>nrows A" and k: "k<ncols A"
shows "fst (snd (Gauss_Jordan_column_k_det_P (n, i, A) k)) = fst (snd (Gauss_Jordan_column_k_det_P_iarrays (n, i, matrix_to_iarray A) k))"
proof (cases "i<nrows A")
case True
show ?thesis
unfolding Gauss_Jordan_column_k_det_P_def Gauss_Jordan_column_k_det_P_iarrays_def Let_def snd_conv fst_conv
unfolding matrix_to_iarray_nrows matrix_vector_all_zero_from_index
unfolding vec_to_iarray_column
unfolding to_nat_from_nat_id[OF True[unfolded nrows_def]]
unfolding to_nat_from_nat_id[OF k[unfolded ncols_def]] by auto
next
case False
thus ?thesis
using assms
unfolding Gauss_Jordan_column_k_det_P_def Gauss_Jordan_column_k_det_P_iarrays_def Let_def snd_conv fst_conv
unfolding matrix_to_iarray_nrows matrix_vector_all_zero_from_index by auto
qed

lemma matrix_to_iarray_snd_snd_Gauss_Jordan_column_k_det_P:
assumes i: "i\<le>nrows A" and k: "k<ncols A"
shows "matrix_to_iarray (snd (snd (Gauss_Jordan_column_k_det_P (n, i, A) k))) = snd (snd (Gauss_Jordan_column_k_det_P_iarrays (n, i, matrix_to_iarray A) k))"
proof (cases "i<nrows A")
case True
show ?thesis
unfolding Gauss_Jordan_column_k_det_P_def Gauss_Jordan_column_k_det_P_iarrays_def Let_def fst_conv snd_conv
unfolding matrix_to_iarray_nrows matrix_vector_all_zero_from_index
using matrix_to_iarray_snd_Gauss_Jordan_in_ij_det_P[of A "from_nat k" "from_nat i"]
using matrix_vector_all_zero_from_index[of "from_nat i" A "from_nat k"]
unfolding vec_to_iarray_column
unfolding to_nat_from_nat_id[OF True[unfolded nrows_def]]
unfolding to_nat_from_nat_id[OF k[unfolded ncols_def]]
by auto
next
case False
thus ?thesis
using assms
unfolding Gauss_Jordan_column_k_det_P_def Gauss_Jordan_column_k_det_P_iarrays_def Let_def fst_conv snd_conv
unfolding matrix_to_iarray_nrows matrix_vector_all_zero_from_index by auto
qed

lemma fst_snd_Gauss_Jordan_column_k_det_P_le_nrows:
assumes i: "i\<le>nrows A"
shows "fst (snd (Gauss_Jordan_column_k_det_P (n, i, A) k)) \<le> nrows A"
unfolding fst_snd_Gauss_Jordan_column_k_det_P_eq_fst_snd_Gauss_Jordan_column_k_PA[unfolded fst_snd_Gauss_Jordan_column_k_PA_eq]
by (rule fst_Gauss_Jordan_column_k[OF i])

text{*The proof of the following theorem is very similar to the ones of @{text "foldl_Gauss_Jordan_column_k_eq"},
      @{text "rref_and_index_Gauss_Jordan_upt_k"} and @{text "foldl_Gauss_Jordan_column_k_det_P"}.*}

lemma
assumes "k<ncols A"
shows matrix_to_iarray_fst_Gauss_Jordan_upt_k_det_P: "fst (Gauss_Jordan_upt_k_det_P A k) = fst (Gauss_Jordan_upt_k_det_P_iarrays (matrix_to_iarray A) k)"
and matrix_to_iarray_snd_Gauss_Jordan_upt_k_det_P: "matrix_to_iarray (snd (Gauss_Jordan_upt_k_det_P A k)) = snd (Gauss_Jordan_upt_k_det_P_iarrays (matrix_to_iarray A) k)"
and "fst (snd (foldl Gauss_Jordan_column_k_det_P (1, 0, A) [0..<Suc k])) \<le> nrows A"
and "fst (snd (foldl Gauss_Jordan_column_k_det_P_iarrays (1, 0, matrix_to_iarray A) [0..<Suc k])) = fst (snd (foldl Gauss_Jordan_column_k_det_P (1, 0, A) [0..<Suc k]))"
using assms
proof (induct k)
show "fst (Gauss_Jordan_upt_k_det_P A 0) = fst (Gauss_Jordan_upt_k_det_P_iarrays (matrix_to_iarray A) 0)"
unfolding Gauss_Jordan_upt_k_det_P_def Gauss_Jordan_upt_k_det_P_iarrays_def Let_def fst_conv
by (simp, rule matrix_to_iarray_fst_Gauss_Jordan_column_k_det_P, simp_all add: ncols_def)
show "matrix_to_iarray (snd (Gauss_Jordan_upt_k_det_P A 0)) = snd (Gauss_Jordan_upt_k_det_P_iarrays (matrix_to_iarray A) 0)"
unfolding Gauss_Jordan_upt_k_det_P_def Gauss_Jordan_upt_k_det_P_iarrays_def Let_def fst_conv snd_conv
by (simp, rule matrix_to_iarray_snd_snd_Gauss_Jordan_column_k_det_P, simp_all add: ncols_def)
show "fst (snd (foldl Gauss_Jordan_column_k_det_P (1, 0, A) [0..<Suc 0])) \<le> nrows A"
unfolding Gauss_Jordan_upt_k_det_P_def Gauss_Jordan_upt_k_det_P_iarrays_def Let_def fst_conv snd_conv
by (simp, rule fst_snd_Gauss_Jordan_column_k_det_P_le_nrows, simp add: nrows_def)
show "fst (snd (foldl Gauss_Jordan_column_k_det_P_iarrays (1, 0, matrix_to_iarray A) [0..<Suc 0])) = fst (snd (foldl Gauss_Jordan_column_k_det_P (1, 0, A) [0..<Suc 0]))"
unfolding Gauss_Jordan_upt_k_det_P_def Gauss_Jordan_upt_k_det_P_iarrays_def Let_def fst_conv snd_conv
by (simp, rule matrix_to_iarray_fst_snd_Gauss_Jordan_column_k_det_P[symmetric], simp_all add: ncols_def)
next
fix k
assume "(k < ncols A \<Longrightarrow> fst (Gauss_Jordan_upt_k_det_P A k) = fst (Gauss_Jordan_upt_k_det_P_iarrays (matrix_to_iarray A) k))"
        and "(k < ncols A \<Longrightarrow> matrix_to_iarray (snd (Gauss_Jordan_upt_k_det_P A k)) = snd (Gauss_Jordan_upt_k_det_P_iarrays (matrix_to_iarray A) k))"
        and "(k < ncols A \<Longrightarrow> fst (snd (foldl Gauss_Jordan_column_k_det_P (1, 0, A) [0..<Suc k])) \<le> nrows A)"
        and "(k < ncols A \<Longrightarrow> fst (snd (foldl Gauss_Jordan_column_k_det_P_iarrays (1, 0, matrix_to_iarray A) [0..<Suc k])) = fst (snd (foldl Gauss_Jordan_column_k_det_P (1, 0, A) [0..<Suc k])))"
        and Suc_k_less_ncols: "Suc k < ncols A"
hence hyp1: "fst (Gauss_Jordan_upt_k_det_P A k) = fst (Gauss_Jordan_upt_k_det_P_iarrays (matrix_to_iarray A) k)"
and hyp2: "matrix_to_iarray (snd (Gauss_Jordan_upt_k_det_P A k)) = snd (Gauss_Jordan_upt_k_det_P_iarrays (matrix_to_iarray A) k)"
and hyp3: "fst (snd (foldl Gauss_Jordan_column_k_det_P (1, 0, A) [0..<Suc k])) \<le> nrows A"
and hyp4: "(fst (snd (foldl Gauss_Jordan_column_k_det_P_iarrays (1, 0, matrix_to_iarray A) [0..<Suc k])) = fst (snd (foldl Gauss_Jordan_column_k_det_P (1, 0, A) [0..<Suc k])))"
  by auto
have list_rw: "[0..<Suc (Suc k)] = [0..<(Suc k)] @ [Suc k]" by simp
def f\<equiv>"(foldl Gauss_Jordan_column_k_det_P (1, 0, A) [0..<Suc k])"
def g\<equiv>"(foldl Gauss_Jordan_column_k_det_P_iarrays (1, 0, matrix_to_iarray A) [0..<Suc k])"
have f_rw: "f = (fst f, fst (snd f), snd (snd f))" by simp
have g_rw: "g = (fst g, fst (snd g), snd (snd g))" by simp
have fst_rw: "fst g = fst f" unfolding f_def g_def using hyp1[unfolded Gauss_Jordan_upt_k_det_P_def Gauss_Jordan_upt_k_det_P_iarrays_def Let_def fst_conv] ..
have fst_snd_rw: "fst (snd g) = fst (snd f)" unfolding f_def g_def using hyp4 .
have snd_snd_rw: "snd (snd g) = matrix_to_iarray (snd (snd f))"
  unfolding f_def g_def using hyp2[unfolded Gauss_Jordan_upt_k_det_P_def Gauss_Jordan_upt_k_det_P_iarrays_def Let_def snd_conv] ..
have fst_snd_f_le_nrows: "fst (snd f) \<le> nrows (snd (snd f))"  unfolding f_def g_def using hyp3 unfolding nrows_def .
have Suc_k_less_ncols': "Suc k < ncols (snd (snd f))"  using Suc_k_less_ncols unfolding ncols_def .
show "fst (Gauss_Jordan_upt_k_det_P A (Suc k)) = fst (Gauss_Jordan_upt_k_det_P_iarrays (matrix_to_iarray A) (Suc k))"
unfolding Gauss_Jordan_upt_k_det_P_def Gauss_Jordan_upt_k_det_P_iarrays_def Let_def fst_conv
unfolding list_rw foldl_append
unfolding List.foldl.simps
unfolding f_def[symmetric] g_def[symmetric]
by (subst f_rw, subst g_rw, unfold fst_rw fst_snd_rw snd_snd_rw, rule matrix_to_iarray_fst_Gauss_Jordan_column_k_det_P[OF fst_snd_f_le_nrows Suc_k_less_ncols'])
show "matrix_to_iarray (snd (Gauss_Jordan_upt_k_det_P A (Suc k))) = snd (Gauss_Jordan_upt_k_det_P_iarrays (matrix_to_iarray A) (Suc k))"
unfolding Gauss_Jordan_upt_k_det_P_def Gauss_Jordan_upt_k_det_P_iarrays_def Let_def snd_conv
unfolding list_rw foldl_append
unfolding List.foldl.simps
unfolding f_def[symmetric] g_def[symmetric]
by (subst f_rw, subst g_rw, unfold fst_rw fst_snd_rw snd_snd_rw, rule matrix_to_iarray_snd_snd_Gauss_Jordan_column_k_det_P[OF fst_snd_f_le_nrows Suc_k_less_ncols'])
show "fst (snd (foldl Gauss_Jordan_column_k_det_P (1, 0, A) [0..<Suc (Suc k)])) \<le> nrows A"
unfolding list_rw foldl_append List.foldl.simps
unfolding f_def[symmetric] g_def[symmetric]
apply (subst f_rw)
using fst_snd_Gauss_Jordan_column_k_det_P_le_nrows[OF fst_snd_f_le_nrows]
unfolding nrows_def .
show "fst (snd (foldl Gauss_Jordan_column_k_det_P_iarrays (1, 0, matrix_to_iarray A) [0..<Suc (Suc k)])) = fst (snd (foldl Gauss_Jordan_column_k_det_P (1, 0, A) [0..<Suc (Suc k)]))"
unfolding list_rw foldl_append List.foldl.simps
unfolding f_def[symmetric] g_def[symmetric]
by (subst f_rw, subst g_rw, unfold fst_rw fst_snd_rw snd_snd_rw,rule matrix_to_iarray_fst_snd_Gauss_Jordan_column_k_det_P[symmetric, OF fst_snd_f_le_nrows Suc_k_less_ncols'])
qed

lemma matrix_to_iarray_fst_Gauss_Jordan_det_P:
shows "fst (Gauss_Jordan_det_P A) = fst (Gauss_Jordan_det_P_iarrays (matrix_to_iarray A))"
unfolding Gauss_Jordan_det_P_def Gauss_Jordan_det_P_iarrays_def
using matrix_to_iarray_fst_Gauss_Jordan_upt_k_det_P
by (metis diff_less matrix_to_iarray_ncols ncols_not_0 neq0_conv zero_less_one)

lemma matrix_to_iarray_snd_Gauss_Jordan_det_P:
shows "matrix_to_iarray (snd (Gauss_Jordan_det_P A)) = snd (Gauss_Jordan_det_P_iarrays (matrix_to_iarray A))"
unfolding Gauss_Jordan_det_P_def Gauss_Jordan_det_P_iarrays_def
using matrix_to_iarray_snd_Gauss_Jordan_upt_k_det_P
by (metis diff_less matrix_to_iarray_ncols ncols_not_0 neq0_conv zero_less_one)

subsection{*Code equations*}
definition "det_iarrays A = (let A' = Gauss_Jordan_det_P_iarrays A in listprod (map (\<lambda>i. (snd A') !! i !! i) [0..<nrows_iarray A]) / fst A')"

lemma matrix_to_iarray_det[code_unfold]:
fixes A::"'a::{field,linordered_idom}^'n::{mod_type}^'n::{mod_type}"
shows "det A = det_iarrays (matrix_to_iarray A)"
proof -
let ?f="(\<lambda>i. snd (Gauss_Jordan_det_P_iarrays (matrix_to_iarray A)) !! i !! i)"
have *: "fst (Gauss_Jordan_det_P A) = fst (Gauss_Jordan_det_P_iarrays (matrix_to_iarray A))"
  unfolding matrix_to_iarray_fst_Gauss_Jordan_det_P ..
have "listprod (map ?f [0..<nrows_iarray (matrix_to_iarray A)]) = setprod ?f (set [0..<nrows_iarray (matrix_to_iarray A)])"
  proof (rule listprod_distinct_conv_setprod_set)
    show "distinct [0..<nrows_iarray (matrix_to_iarray A)]" unfolding nrows_iarray_def by auto
   qed
also have "... = (\<Prod>i\<in>UNIV. snd (Gauss_Jordan_det_P A) $ i $ i)"
  proof (rule setprod.reindex_cong[of "to_nat::('n=>nat)"])
    show "inj (to_nat::('n=>nat))" by (metis strict_mono_imp_inj_on strict_mono_to_nat)
    show "set [0..<nrows_iarray (matrix_to_iarray A)] = range (to_nat::'n=>nat)"
    unfolding nrows_eq_card_rows using bij_to_nat[where ?'a='n]
    unfolding bij_betw_def
    unfolding atLeast0LessThan atLeast_upt by auto
    fix x
    show "snd (Gauss_Jordan_det_P_iarrays (matrix_to_iarray A)) !! to_nat x !! to_nat x = snd (Gauss_Jordan_det_P A) $ x $ x"
    unfolding matrix_to_iarray_snd_Gauss_Jordan_det_P[symmetric]
    unfolding matrix_to_iarray_nth ..
    qed
  finally have "(\<Prod>i\<in>UNIV. snd (Gauss_Jordan_det_P A) $ i $ i)
  = listprod (map (\<lambda>i. snd (Gauss_Jordan_det_P_iarrays (matrix_to_iarray A)) !! i !! i) [0..<nrows_iarray (matrix_to_iarray A)])" ..
  thus ?thesis using * unfolding det_code_equation det_iarrays_def Let_def  by presburger
qed

end


(*  Title:      HOL/Hoare/Arith2.thy
    Author:     Norbert Galm
    Copyright   1995 TUM

More arithmetic.  Much of this duplicates ex/Primes.
*)

theory Arith2
imports Main
begin

definition cd :: "[nat, nat, nat] \<Rightarrow> bool"
  where "cd x m n \<longleftrightarrow> x dvd m \<and> x dvd n"

definition gcd :: "[nat, nat] \<Rightarrow> nat"
  where "gcd m n = (SOME x. cd x m n & (\<forall>y.(cd y m n) \<longrightarrow> y\<le>x))"

primrec fac :: "nat \<Rightarrow> nat"
where
  "fac 0 = Suc 0"
| "fac (Suc n) = Suc n * fac n"

subsubsection \<open>cd\<close>

lemma cd_nnn: "0<n \<Longrightarrow> cd n n n"
  apply (simp add: cd_def)
  done

lemma cd_le: "[| cd x m n; 0<m; 0<n |] ==> x<=m & x<=n"
  apply (unfold cd_def)
  apply (blast intro: dvd_imp_le)
  done

lemma cd_swap: "cd x m n = cd x n m"
  apply (unfold cd_def)
  apply blast
  done

lemma cd_diff_l: "n\<le>m \<Longrightarrow> cd x m n = cd x (m-n) n"
  apply (unfold cd_def)
  apply (fastforce dest: dvd_diffD)
  done

lemma cd_diff_r: "m\<le>n \<Longrightarrow> cd x m n = cd x m (n-m)"
  apply (unfold cd_def)
  apply (fastforce dest: dvd_diffD)
  done

subsubsection \<open>gcd\<close>

lemma gcd_nnn: "0<n \<Longrightarrow> n = gcd n n"
  apply (unfold gcd_def)
  apply (frule cd_nnn)
  apply (rule some_equality [symmetric])
  apply (blast dest: cd_le)
  apply (blast intro: le_antisym dest: cd_le)
  done

lemma gcd_swap: "gcd m n = gcd n m"
  apply (simp add: gcd_def cd_swap)
  done

lemma gcd_diff_l: "n\<le>m \<Longrightarrow> gcd m n = gcd (m-n) n"
  apply (unfold gcd_def)
  apply (subgoal_tac "n\<le>m \<Longrightarrow> \<forall>x. cd x m n = cd x (m-n) n")
  apply simp
  apply (rule allI)
  apply (erule cd_diff_l)
  done

lemma gcd_diff_r: "m\<le>n \<Longrightarrow> gcd m n = gcd m (n-m)"
  apply (unfold gcd_def)
  apply (subgoal_tac "m\<le>n \<Longrightarrow> \<forall>x. cd x m n = cd x m (n-m) ")
  apply simp
  apply (rule allI)
  apply (erule cd_diff_r)
  done

subsubsection \<open>pow\<close>

lemma sq_pow_div2 [simp]:
    "m mod 2 = 0 \<Longrightarrow> ((n::nat)*n)^(m div 2) = n^m"
  apply (simp add: power2_eq_square [symmetric] power_mult [symmetric] minus_mod_eq_mult_div [symmetric])
  done

end


(*  Title:      RSAPSS/Crypt.thy

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

header "Definition of rsacrypt"

theory Crypt
imports Main Mod
begin

text {*
  This theory defines the rsacrypt function which implements RSA using fast
  exponentiation. An proof, that this function calculates RSA is also given
*}

definition rsa_crypt :: "nat \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> nat"
where
  cryptcorrect: "rsa_crypt M e n = M ^ e mod n"

lemma rsa_crypt_code [code]:
  "rsa_crypt M e n = (if e = 0 then 1 mod n
    else if even e then rsa_crypt M (e div 2) n ^ 2 mod n
    else (M * rsa_crypt M (e div 2) n ^ 2 mod n) mod n)"
proof -
  { fix m
    have "(M ^ m mod n)\<^sup>2 mod n = (M ^ m)\<^sup>2 mod n"
      by (simp add: power_mod)
    then have "(M mod n) * ((M ^ m mod n)\<^sup>2 mod n) = (M mod n) * ((M ^ m)\<^sup>2 mod n)"
      by simp
    have "M * (M ^ m mod n)\<^sup>2 mod n = M * (M ^ m)\<^sup>2 mod n"
      by (metis mod_mult_right_eq power_mod)
  }
  then show ?thesis
    by (auto simp add: cryptcorrect power_even_eq remainderexp elim!: evenE oddE)
qed

end


(*  Title:      HOL/Old_Number_Theory/WilsonRuss.thy
    Author:     Thomas M. Rasmussen
    Copyright   2000  University of Cambridge
*)

section {* Wilson's Theorem according to Russinoff *}

theory WilsonRuss
imports EulerFermat
begin

text {*
  Wilson's Theorem following quite closely Russinoff's approach
  using Boyer-Moore (using finite sets instead of lists, though).
*}

subsection {* Definitions and lemmas *}

definition inv :: "int => int => int"
  where "inv p a = (a^(nat (p - 2))) mod p"

fun wset :: "int \<Rightarrow> int => int set" where
  "wset a p =
    (if 1 < a then
      let ws = wset (a - 1) p
      in (if a \<in> ws then ws else insert a (insert (inv p a) ws)) else {})"

text {* \medskip @{term [source] inv} *}

lemma inv_is_inv_aux: "1 < m ==> Suc (nat (m - 2)) = nat (m - 1)"
  by (subst int_int_eq [symmetric]) auto

lemma inv_is_inv:
    "zprime p \<Longrightarrow> 0 < a \<Longrightarrow> a < p ==> [a * inv p a = 1] (mod p)"
  apply (unfold inv_def)
  apply (subst zcong_zmod)
  apply (subst mod_mult_right_eq [symmetric])
  apply (subst zcong_zmod [symmetric])
  apply (subst power_Suc [symmetric])
  apply (subst inv_is_inv_aux)
   apply (erule_tac [2] Little_Fermat)
   apply (erule_tac [2] zdvd_not_zless)
   apply (unfold zprime_def, auto)
  done

lemma inv_distinct:
    "zprime p \<Longrightarrow> 1 < a \<Longrightarrow> a < p - 1 ==> a \<noteq> inv p a"
  apply safe
  apply (cut_tac a = a and p = p in zcong_square)
     apply (cut_tac [3] a = a and p = p in inv_is_inv, auto)
   apply (subgoal_tac "a = 1")
    apply (rule_tac [2] m = p in zcong_zless_imp_eq)
        apply (subgoal_tac [7] "a = p - 1")
         apply (rule_tac [8] m = p in zcong_zless_imp_eq, auto)
  done

lemma inv_not_0:
    "zprime p \<Longrightarrow> 1 < a \<Longrightarrow> a < p - 1 ==> inv p a \<noteq> 0"
  apply safe
  apply (cut_tac a = a and p = p in inv_is_inv)
     apply (unfold zcong_def, auto)
  done

lemma inv_not_1:
    "zprime p \<Longrightarrow> 1 < a \<Longrightarrow> a < p - 1 ==> inv p a \<noteq> 1"
  apply safe
  apply (cut_tac a = a and p = p in inv_is_inv)
     prefer 4
     apply simp
     apply (subgoal_tac "a = 1")
      apply (rule_tac [2] zcong_zless_imp_eq, auto)
  done

lemma inv_not_p_minus_1_aux:
    "[a * (p - 1) = 1] (mod p) = [a = p - 1] (mod p)"
  apply (unfold zcong_def)
  apply (simp add: diff_diff_eq diff_diff_eq2 right_diff_distrib)
  apply (rule_tac s = "p dvd -((a + 1) + (p * -a))" in trans)
   apply (simp add: algebra_simps)
  apply (subst dvd_minus_iff)
  apply (subst zdvd_reduce)
  apply (rule_tac s = "p dvd (a + 1) + (p * -1)" in trans)
   apply (subst zdvd_reduce, auto)
  done

lemma inv_not_p_minus_1:
    "zprime p \<Longrightarrow> 1 < a \<Longrightarrow> a < p - 1 ==> inv p a \<noteq> p - 1"
  apply safe
  apply (cut_tac a = a and p = p in inv_is_inv, auto)
  apply (simp add: inv_not_p_minus_1_aux)
  apply (subgoal_tac "a = p - 1")
   apply (rule_tac [2] zcong_zless_imp_eq, auto)
  done

lemma inv_g_1:
    "zprime p \<Longrightarrow> 1 < a \<Longrightarrow> a < p - 1 ==> 1 < inv p a"
  apply (case_tac "0\<le> inv p a")
   apply (subgoal_tac "inv p a \<noteq> 1")
    apply (subgoal_tac "inv p a \<noteq> 0")
     apply (subst order_less_le)
     apply (subst zle_add1_eq_le [symmetric])
     apply (subst order_less_le)
     apply (rule_tac [2] inv_not_0)
       apply (rule_tac [5] inv_not_1, auto)
  apply (unfold inv_def zprime_def, simp)
  done

lemma inv_less_p_minus_1:
    "zprime p \<Longrightarrow> 1 < a \<Longrightarrow> a < p - 1 ==> inv p a < p - 1"
  apply (case_tac "inv p a < p")
   apply (subst order_less_le)
   apply (simp add: inv_not_p_minus_1, auto)
  apply (unfold inv_def zprime_def, simp)
  done

lemma inv_inv_aux: "5 \<le> p ==>
    nat (p - 2) * nat (p - 2) = Suc (nat (p - 1) * nat (p - 3))"
  apply (subst int_int_eq [symmetric])
  apply (simp add: of_nat_mult)
  apply (simp add: left_diff_distrib right_diff_distrib)
  done

lemma zcong_zpower_zmult:
    "[x^y = 1] (mod p) \<Longrightarrow> [x^(y * z) = 1] (mod p)"
  apply (induct z)
   apply (auto simp add: power_add)
  apply (subgoal_tac "zcong (x^y * x^(y * z)) (1 * 1) p")
   apply (rule_tac [2] zcong_zmult, simp_all)
  done

lemma inv_inv: "zprime p \<Longrightarrow>
    5 \<le> p \<Longrightarrow> 0 < a \<Longrightarrow> a < p ==> inv p (inv p a) = a"
  apply (unfold inv_def)
  apply (subst power_mod)
  apply (subst zpower_zpower)
  apply (rule zcong_zless_imp_eq)
      prefer 5
      apply (subst zcong_zmod)
      apply (subst mod_mod_trivial)
      apply (subst zcong_zmod [symmetric])
      apply (subst inv_inv_aux)
       apply (subgoal_tac [2]
         "zcong (a * a^(nat (p - 1) * nat (p - 3))) (a * 1) p")
        apply (rule_tac [3] zcong_zmult)
         apply (rule_tac [4] zcong_zpower_zmult)
         apply (erule_tac [4] Little_Fermat)
         apply (rule_tac [4] zdvd_not_zless, simp_all)
  done

text {* \medskip @{term wset} *}

declare wset.simps [simp del]

lemma wset_induct:
  assumes "!!a p. P {} a p"
    and "!!a p. 1 < (a::int) \<Longrightarrow>
      P (wset (a - 1) p) (a - 1) p ==> P (wset a p) a p"
  shows "P (wset u v) u v"
  apply (rule wset.induct)
  apply (case_tac "1 < a")
   apply (rule assms)
    apply (simp_all add: wset.simps assms)
  done

lemma wset_mem_imp_or [rule_format]:
  "1 < a \<Longrightarrow> b \<notin> wset (a - 1) p
    ==> b \<in> wset a p --> b = a \<or> b = inv p a"
  apply (subst wset.simps)
  apply (unfold Let_def, simp)
  done

lemma wset_mem_mem [simp]: "1 < a ==> a \<in> wset a p"
  apply (subst wset.simps)
  apply (unfold Let_def, simp)
  done

lemma wset_subset: "1 < a \<Longrightarrow> b \<in> wset (a - 1) p ==> b \<in> wset a p"
  apply (subst wset.simps)
  apply (unfold Let_def, auto)
  done

lemma wset_g_1 [rule_format]:
    "zprime p --> a < p - 1 --> b \<in> wset a p --> 1 < b"
  apply (induct a p rule: wset_induct, auto)
  apply (case_tac "b = a")
   apply (case_tac [2] "b = inv p a")
    apply (subgoal_tac [3] "b = a \<or> b = inv p a")
     apply (rule_tac [4] wset_mem_imp_or)
       prefer 2
       apply simp
       apply (rule inv_g_1, auto)
  done

lemma wset_less [rule_format]:
    "zprime p --> a < p - 1 --> b \<in> wset a p --> b < p - 1"
  apply (induct a p rule: wset_induct, auto)
  apply (case_tac "b = a")
   apply (case_tac [2] "b = inv p a")
    apply (subgoal_tac [3] "b = a \<or> b = inv p a")
     apply (rule_tac [4] wset_mem_imp_or)
       prefer 2
       apply simp
       apply (rule inv_less_p_minus_1, auto)
  done

lemma wset_mem [rule_format]:
  "zprime p -->
    a < p - 1 --> 1 < b --> b \<le> a --> b \<in> wset a p"
  apply (induct a p rule: wset.induct, auto)
  apply (rule_tac wset_subset)
  apply (simp (no_asm_simp))
  apply auto
  done

lemma wset_mem_inv_mem [rule_format]:
  "zprime p --> 5 \<le> p --> a < p - 1 --> b \<in> wset a p
    --> inv p b \<in> wset a p"
  apply (induct a p rule: wset_induct, auto)
   apply (case_tac "b = a")
    apply (subst wset.simps)
    apply (unfold Let_def)
    apply (rule_tac [3] wset_subset, auto)
  apply (case_tac "b = inv p a")
   apply (simp (no_asm_simp))
   apply (subst inv_inv)
       apply (subgoal_tac [6] "b = a \<or> b = inv p a")
        apply (rule_tac [7] wset_mem_imp_or, auto)
  done

lemma wset_inv_mem_mem:
  "zprime p \<Longrightarrow> 5 \<le> p \<Longrightarrow> a < p - 1 \<Longrightarrow> 1 < b \<Longrightarrow> b < p - 1
    \<Longrightarrow> inv p b \<in> wset a p \<Longrightarrow> b \<in> wset a p"
  apply (rule_tac s = "inv p (inv p b)" and t = b in subst)
   apply (rule_tac [2] wset_mem_inv_mem)
      apply (rule inv_inv, simp_all)
  done

lemma wset_fin: "finite (wset a p)"
  apply (induct a p rule: wset_induct)
   prefer 2
   apply (subst wset.simps)
   apply (unfold Let_def, auto)
  done

lemma wset_zcong_prod_1 [rule_format]:
  "zprime p -->
    5 \<le> p --> a < p - 1 --> [(\<Prod>x\<in>wset a p. x) = 1] (mod p)"
  apply (induct a p rule: wset_induct)
   prefer 2
   apply (subst wset.simps)
   apply (auto, unfold Let_def, auto)
  apply (subst setprod.insert)
    apply (tactic {* stac @{thm setprod.insert} 3 *})
      apply (subgoal_tac [5]
        "zcong (a * inv p a * (\<Prod>x\<in>wset (a - 1) p. x)) (1 * 1) p")
       prefer 5
       apply (simp add: mult.assoc)
      apply (rule_tac [5] zcong_zmult)
       apply (rule_tac [5] inv_is_inv)
         apply (tactic "clarify_tac @{context} 4")
         apply (subgoal_tac [4] "a \<in> wset (a - 1) p")
          apply (rule_tac [5] wset_inv_mem_mem)
               apply (simp_all add: wset_fin)
  apply (rule inv_distinct, auto)
  done

lemma d22set_eq_wset: "zprime p ==> d22set (p - 2) = wset (p - 2) p"
  apply safe
   apply (erule wset_mem)
     apply (rule_tac [2] d22set_g_1)
     apply (rule_tac [3] d22set_le)
     apply (rule_tac [4] d22set_mem)
      apply (erule_tac [4] wset_g_1)
       prefer 6
       apply (subst zle_add1_eq_le [symmetric])
       apply (subgoal_tac "p - 2 + 1 = p - 1")
        apply (simp (no_asm_simp))
        apply (erule wset_less, auto)
  done

subsection {* Wilson *}

lemma prime_g_5: "zprime p \<Longrightarrow> p \<noteq> 2 \<Longrightarrow> p \<noteq> 3 ==> 5 \<le> p"
  apply (unfold zprime_def dvd_def)
  apply (case_tac "p = 4", auto)
   apply (rule notE)
    prefer 2
    apply assumption
   apply (simp (no_asm))
   apply (rule_tac x = 2 in exI)
   apply (safe, arith)
     apply (rule_tac x = 2 in exI, auto)
  done

theorem Wilson_Russ:
    "zprime p ==> [zfact (p - 1) = -1] (mod p)"
  apply (subgoal_tac "[(p - 1) * zfact (p - 2) = -1 * 1] (mod p)")
   apply (rule_tac [2] zcong_zmult)
    apply (simp only: zprime_def)
    apply (subst zfact.simps)
    apply (rule_tac t = "p - 1 - 1" and s = "p - 2" in subst, auto)
   apply (simp only: zcong_def)
   apply (simp (no_asm_simp))
  apply (case_tac "p = 2")
   apply (simp add: zfact.simps)
  apply (case_tac "p = 3")
   apply (simp add: zfact.simps)
  apply (subgoal_tac "5 \<le> p")
   apply (erule_tac [2] prime_g_5)
    apply (subst d22set_prod_zfact [symmetric])
    apply (subst d22set_eq_wset)
     apply (rule_tac [2] wset_zcong_prod_1, auto)
  done

end


theory Unused
  imports Main
begin

lemma max_image_mono:
  assumes "finite S"
  assumes "S \<noteq> {}"
  assumes "\<And>i. i \<in> S \<Longrightarrow> f i \<le> g i"
  shows "Max (f ` S) \<le> Max (g ` S)"
  using assms
proof (induct rule:finite_ne_induct)
  case (singleton x)
  then show ?case by simp
next
  case (insert x F)
  have "Max (f ` insert x F) = max (f x) (Max (f ` F))"
    using insert by auto
  also have "... \<le> max (g x) (Max (g ` F))"
    using insert by (intro max.mono, auto)
  also have "... = Max (g ` insert x F)"
    using insert by auto
  finally show ?case by simp
qed

end


text\<open>
  Author: Julius Michaelis
\<close>

theory MkIfex
  imports "ROBDD.BDT"
begin

section\<open>Converting boolean functions to BDTs\<close>
text\<open>The following function builds an @{typ "'a ifex"}
  (a binary decision tree)
  from a boolean function and its list of variables
  (note that in this development we will be using
  boolean functions over sets of the natural numbers
  of the form @{term "{..<n::nat}"}).\<close>

fun mk_ifex :: "('a :: linorder) boolfunc \<Rightarrow> 'a list \<Rightarrow> 'a ifex" where
"mk_ifex f [] = (if f (const False) then Trueif else Falseif)" |
"mk_ifex f (v#vs) = ifex_ite
                      (IF v Trueif Falseif)
                      (mk_ifex (bf_restrict v True f) vs)
                      (mk_ifex (bf_restrict v False f) vs)"

text\<open>The result of @{term "mk_ifex"} is @{const ifex_ordered}
  and @{const ifex_minimal}.\<close>

lemma mk_ifex_ro: "ro_ifex (mk_ifex f vs)"
  by(induction vs arbitrary: f; fastforce
      intro: order_ifex_ite_invar minimal_ifex_ite_invar
      simp del: ifex_ite.simps)

text\<open>To prove that @{const mk_ifex} has correctly captured a boolean function @{term f},
we need know that all variables that @{term f} depends on were considered by @{const mk_ifex}.
In that regard, one troublesome aspect of @{type boolfunc} from @{theory "ROBDD.Bool_Func"} is that it is too general:
Boolean functions' assignments assign a Boolean value to any natural number,
and functions are not limited to ``reading'' only from a finite set of variables.
This for example allows for the boolean function that asks ``Is the assignment true in a finite number of variables:
@{term "\<lambda>as. finite {x. as x}"}.''
This function does not depend on any single variable, but on the set of all of them.
A definition that proved to work despite such subtleties is that
a function @{term f} only depends on the variables in set @{term x} iff
for any pair of assignments that agree in @{term x} (but are arbitrary otherwise),
the values of @{term f} agree:\<close>
definition "reads_inside_set f x \<equiv>
  (\<forall>assmt1 assmt2. (\<forall>p. p \<in> x \<longrightarrow> assmt1 p = assmt2 p) \<longrightarrow> f assmt1 = f assmt2)"

lemma reads_inside_set_subset: "reads_inside_set f a \<Longrightarrow> a \<subseteq> b \<Longrightarrow> reads_inside_set f b"
  unfolding reads_inside_set_def by blast

lemma reads_inside_set_restrict: "reads_inside_set f s \<Longrightarrow> reads_inside_set (bf_restrict i v f) (Set.remove i s)"
  unfolding reads_inside_set_def bf_restrict_def by force (* wow *)

lemma collect_upd_true: "Collect (x(y:= True)) = insert y (Collect x)" by auto
lemma collect_upd_false: "Collect (x(y:= False)) = Set.remove y (Collect x)" by auto metis

lemma reads_none: "reads_inside_set f {} \<Longrightarrow> f = bf_True \<or> f = bf_False"
  unfolding reads_inside_set_def by fast (* wow *)

lemma val_ifex_ite_subst: "\<lbrakk>ro_ifex i; ro_ifex t; ro_ifex e\<rbrakk> \<Longrightarrow> val_ifex (ifex_ite i t e) = bf_ite (val_ifex i) (val_ifex t) (val_ifex e)"
  using val_ifex_ite by blast

theorem
  val_ifex_mk_ifex_equal:
  "reads_inside_set f (set vs) \<Longrightarrow> val_ifex (mk_ifex f vs) assmt = f assmt"
proof(induction vs arbitrary: f assmt)
  case Nil
  then show ?case using reads_none by auto
next
  case (Cons v vs)
  have "reads_inside_set (bf_restrict v x f) (set vs)" for x
    using reads_inside_set_restrict[OF Cons.prems] reads_inside_set_subset by fastforce
  from Cons.IH[OF this] show ?case
    unfolding mk_ifex.simps val_ifex.simps bf_restrict_def
    by(subst val_ifex_ite_subst; simp add: bf_ite_def fun_upd_idem mk_ifex_ro)
qed

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_list_perm_elem
imports "../../Test_Base"
begin

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

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

fun deleteBy :: "('a => ('a => bool)) => 'a => 'a list =>
                 'a list" where
"deleteBy x y (nil2) = nil2"
| "deleteBy x y (cons2 y2 ys) =
     (if (x y) y2 then ys else cons2 y2 (deleteBy x y ys))"

fun isPermutation :: "'a list => 'a list => bool" where
"isPermutation (nil2) (nil2) = True"
| "isPermutation (nil2) (cons2 z x2) = False"
| "isPermutation (cons2 x3 xs) y =
     ((elem x3 y) &
        (isPermutation
           xs (deleteBy (% (x4 :: 'a) => % (x5 :: 'a) => (x4 = x5)) x3 y)))"

theorem property0 :
  "((elem x xs) ==> ((isPermutation xs ys) ==> (elem x ys)))"
  oops

end


theory XList
imports Main
begin

declare [[names_short]]

datatype 'a list = Nil | Cons 'a "'a list"

fun app :: "'a list \<Rightarrow> 'a list \<Rightarrow> 'a list" where
"app Nil ys = ys" |
"app (Cons x xs) ys = Cons x (app xs ys)"

fun rev :: "'a list \<Rightarrow> 'a list" where
"rev Nil = Nil" |
"rev (Cons x xs) = app (rev xs) (Cons x Nil)"

lemma app_nil [simp] : "app xs Nil = xs"
apply(induction xs)
apply simp
apply simp
done

lemma app_assoc [simp] : "app (app xs ys) zs = app xs (app ys zs)"
apply(induction xs arbitrary: ys zs)
apply simp
apply simp
done

lemma rev_app [simp] : "rev (app xs ys) = app (rev ys) (rev xs)"
apply(induction xs arbitrary: ys)
apply simp
apply simp
done

theorem rev_rev: "rev (rev xs) = xs"
apply(induction xs)
apply(simp)
apply(simp)
done

fun itrev :: "'a list \<Rightarrow> 'a list \<Rightarrow> 'a list" where
"itrev Nil ys = ys" |
"itrev (Cons x xs) ys = itrev xs (Cons x ys)"

lemma itrev_rev0 [simp] : "itrev xs ys = app (rev xs) ys"
apply (induction xs arbitrary: ys)
apply simp
apply simp
done

theorem itrev_rev : "itrev xs Nil = rev xs"
apply simp
done

end


theory prop_74
imports Main
        "$HIPSTER_HOME/IsaHipster"
begin
  datatype 'a list = Nil2 | Cons2 "'a" "'a list"
  datatype Nat = Z | S "Nat"
  fun take :: "Nat => 'a list => 'a list" where
  "take (Z) y = Nil2"
  | "take (S z) (Nil2) = Nil2"
  | "take (S z) (Cons2 x2 x3) = Cons2 x2 (take z x3)"
  fun minus :: "Nat => Nat => Nat" where
  "minus (Z) y = Z"
  | "minus (S z) (Z) = S z"
  | "minus (S z) (S x2) = minus z x2"
  fun len :: "'a list => Nat" where
  "len (Nil2) = Z"
  | "len (Cons2 y xs) = S (len xs)"
  fun drop :: "Nat => 'a list => 'a list" where
  "drop (Z) y = y"
  | "drop (S z) (Nil2) = Nil2"
  | "drop (S z) (Cons2 x2 x3) = drop z x3"
  fun append :: "'a list => 'a list => 'a list" where
  "append (Nil2) y = y"
  | "append (Cons2 z xs) y = Cons2 z (append xs y)"
  fun rev :: "'a list => 'a list" where
  "rev (Nil2) = Nil2"
  | "rev (Cons2 y xs) = append (rev xs) (Cons2 y (Nil2))"
  (*hipster take minus len drop append rev *)

lemma lemma_a [thy_expl]: "minus x2 x2 = Z"
by (hipster_induct_schemes minus.simps)

lemma lemma_aa [thy_expl]: "minus x3 Z = x3"
by (hipster_induct_schemes minus.simps)

lemma lemma_ab [thy_expl]: "minus x2 (S x2) = Z"
by (hipster_induct_schemes)

lemma lemma_ac [thy_expl]: "minus (S x2) x2 = S Z"
by (hipster_induct_schemes)

lemma lemma_ad [thy_expl]: "minus (minus x3 y3) (minus y3 x3) =
minus x3 y3"
by (hipster_induct_schemes minus.simps)

lemma lemma_ae [thy_expl]: "minus (minus x3 y3) (S Z) = minus x3 (S y3)"
by (hipster_induct_schemes minus.simps)

lemma lemma_af [thy_expl]: "minus (minus x4 y4) x4 = Z"
by (hipster_induct_schemes minus.simps)

lemma lemma_da [thy_expl]: "drop x3 Nil2 = Nil2"
by (hipster_induct_schemes drop.simps)

lemma lemma_daa [thy_expl]: "drop (S Z) (drop x3 y3) = drop (S x3) y3"
by (hipster_induct_schemes drop.simps)

lemma lemma_ai [thy_expl]: "take x3 Nil2 = Nil2"
by (hipster_induct_schemes take.simps)

lemma lemma_aj [thy_expl]: "take x3 (take x3 y3) = take x3 y3"
by (hipster_induct_schemes take.simps)

lemma lemma_ak [thy_expl]: "take (S x3) (take x3 y3) = take x3 y3"
by (hipster_induct_schemes take.simps)

(*hipster take drop len*)
lemma lemma_ag [thy_expl]: "drop x2 (take x2 y2) = Nil2"
by (hipster_induct_schemes take.simps drop.simps len.simps)

lemma lemma_ah [thy_expl]: "drop (len x2) x2 = Nil2"
by (hipster_induct_schemes take.simps drop.simps len.simps)

lemma lemma_al [thy_expl]: "take (len x2) x2 = x2"
by (hipster_induct_schemes take.simps drop.simps len.simps)

lemma lemma_am [thy_expl]: "drop (len x4) (drop y4 x4) = Nil2"
by (hipster_induct_schemes take.simps drop.simps len.simps)

lemma lemma_an [thy_expl]: "drop (len x3) (take y3 x3) = Nil2"
by (hipster_induct_schemes take.simps drop.simps len.simps)

lemma lemma_ao [thy_expl]: "take (len x4) (drop y4 x4) = drop y4 x4"
by (hipster_induct_schemes take.simps drop.simps len.simps)

lemma lemma_ap [thy_expl]: "take (len x3) (take y3 x3) = take y3 x3"
by (hipster_induct_schemes take.simps drop.simps len.simps)

(*hipster rev append take drop len minus*)
lemma lemma_aq [thy_expl]: "append x2 Nil2 = x2"
by (hipster_induct_schemes rev.simps append.simps take.simps drop.simps len.simps minus.simps)

lemma lemma_ar [thy_expl]: "append (append x1 y1) z1 = append x1 (append y1 z1)"
by (hipster_induct_schemes rev.simps append.simps take.simps drop.simps len.simps minus.simps)

lemma lemma_as [thy_expl]: "minus (len x3) y3 = len (drop y3 x3)"
by (hipster_induct_schemes rev.simps append.simps take.simps drop.simps len.simps minus.simps)

lemma lemma_at [thy_expl]: "append (take x2 y2) (drop x2 y2) = y2"
by (hipster_induct_schemes rev.simps append.simps take.simps drop.simps len.simps minus.simps)

lemma lemma_au [thy_expl]: "append (rev x4) (rev y4) = rev (append y4 x4)"
by (hipster_induct_schemes rev.simps append.simps take.simps drop.simps len.simps minus.simps)

lemma lemma_av [thy_expl]: "take (len x2) (append x2 y2) = x2"
by (hipster_induct_schemes rev.simps append.simps take.simps drop.simps len.simps minus.simps)

lemma lemma_aw [thy_expl]: "drop (len x2) (append x2 y2) = y2"
by (hipster_induct_schemes rev.simps append.simps take.simps drop.simps len.simps minus.simps)

lemma lemma_ax [thy_expl]: "take (S Z) (append x1 x1) = take (S Z) x1"
by (hipster_induct_schemes rev.simps append.simps take.simps drop.simps len.simps minus.simps)

lemma lemma_ay [thy_expl]: "rev (rev x3) = x3"
by (hipster_induct_schemes rev.simps append.simps take.simps drop.simps len.simps minus.simps)

lemma unknown []: "take x (take y z) = take y (take x z)"
oops

lemma unknown []: "drop x (drop y z) = drop y (drop x z)"
oops

lemma unknown []: "minus (minus x y) z = minus (minus x z) y"
oops

lemma unknown []: "minus x (minus x y) = minus y (minus y x)"
oops

lemma lemma_applen [thy_expl]: "len (append x y) = len (append y x)"
apply(induction x)
apply(simp_all)
apply(metis thy_expl append.simps len.simps)
by (hipster_induct_schemes)

lemma lemma_revlen [thy_expl]: "len (rev x) = len x"
by (hipster_induct_schemes len.simps rev.simps)

lemma unknown []: "take (minus x y) (take x z) = take (minus x y) z"
oops

lemma unknown []: "take (minus x y) (drop y z) = drop y (take x z)"
oops

lemma unknown []: "drop (minus x y) (drop y z) = drop (minus y x) (drop x z)"
oops

lemma unknown []: "minus (minus x y) (minus z y) = minus (minus x z) (minus y z)"
oops

lemma unknown []: "minus (minus x y) (S z) = minus (minus x z) (S y)"
oops

lemma unknown []: "minus (minus x y) (minus x z) = minus (minus z y) (minus z x)"
oops

lemma unknown []: "drop (S x) (drop y z) = drop (S y) (drop x z)"
oops

lemma unknown []: "minus (S x) (minus x y) = minus (S y) (minus y x)"
oops

lemma lemma_takerev [thy_expl]: "take (len x) (rev x) = rev x"
by (hipster_induct_schemes take.simps rev.simps len.simps)

lemma lemma_droprev [thy_expl]: "drop (len x) (rev x) = Nil2"
by (hipster_induct_schemes drop.simps len.simps rev.simps)

  theorem x0 :
    "(rev (take i xs)) = (drop (minus (len xs) i) (rev xs))"
    by (hipster_induct_schemes take.simps minus.simps rev.simps take.simps len.simps)

end


theory BarberParadox
imports
  HOL
begin
declare [[show_types]]

text{*
This forward proof of the barber paradox relies only on lemmas from HOL and immediate proof
steps (".").
*}
lemma barber_paradox:
fixes
  --"The barber is a man."
  barber::"'man" and
  --"Men shave men."
  shaves::"'man \<Rightarrow> 'man \<Rightarrow> bool" (infix "<shaves>" 40)
assumes
  --"The barber shaves every man who does not shave himself."
  1: "\<forall>man. barber <shaves> man \<longleftrightarrow> \<not> man <shaves> man"
shows
  False   -- "I.e. this shaving constellation cannot work."
proof -
  from spec 1
    have 2: "barber <shaves> barber \<longleftrightarrow> \<not> barber <shaves> barber" .
    --"A special instance of the assumption says that the barber shaves himself iff he doesn't..."
  from 2
    have 3: "\<not>(barber <shaves> barber \<longleftrightarrow> barber <shaves> barber)"
    unfolding not_iff .
    --"When we drift the negation up the syntax tree, this looks even more paradoxical."
  from impE 3
    have 4: "(barber <shaves> barber \<longleftrightarrow> barber <shaves> barber) \<Longrightarrow> False"
    unfolding not_def .
    --"...Just unfolding the definition of negation and lifting it to the mata logic..."
  from 4 refl
    show "False" .
    --"...Shows the idea that the barber shaves every man who does not shave himself
      clashes with the axiom that '\<longleftrightarrow>' is reflexive."
qed

end


section \<open> Predicate Laws \<close>

theory utp_pred_laws
  imports utp_pred
begin

lemma impl_neg_disj: "((P::'s pred) \<longrightarrow> (Q::'s pred)) = (\<not>P \<or> Q)"
  by (simp add: impl_pred_def fun_eq_iff conj_pred_def disj_pred_def not_pred_def)

lemma top_false: "\<top> = false"
  using ref_lattice.ccInf_empty by auto

lemma bot_true: "\<bottom> = true"
  using ref_lattice.Inf_UNIV by auto

lemma pred_impl_laws [simp]:
  "(true \<longrightarrow> P) = P" "(P \<longrightarrow> true) = true" "(false \<longrightarrow> P) = true" "(P \<longrightarrow> false) = (\<not> P)" "(P \<longrightarrow> P) = true"
  by pred_simp+

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.*)
  theory TIP_sort_nat_HSortPermutes
  imports "../../Test_Base"
begin

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

datatype Nat = Z | S "Nat"

datatype Heap = Node "Heap" "Nat" "Heap" | Nil

fun toHeap :: "Nat list => Heap list" where
  "toHeap (nil2) = nil2"
| "toHeap (cons2 y z) = cons2 (Node Nil y Nil) (toHeap z)"

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

fun hmerge :: "Heap => Heap => Heap" where
  "hmerge (Node z x2 x3) (Node x4 x5 x6) =
   (if le x2 x5 then Node (hmerge x3 (Node x4 x5 x6)) x2 z else
      Node (hmerge (Node z x2 x3) x6) x5 x4)"
| "hmerge (Node z x2 x3) (Nil) = Node z x2 x3"
| "hmerge (Nil) y = y"

fun hpairwise :: "Heap list => Heap list" where
  "hpairwise (nil2) = nil2"
| "hpairwise (cons2 q (nil2)) = cons2 q (nil2)"
| "hpairwise (cons2 q (cons2 r qs)) =
     cons2 (hmerge q r) (hpairwise qs)"

(*fun did not finish the proof*)
function hmerging :: "Heap list => Heap" where
  "hmerging (nil2) = Nil"
| "hmerging (cons2 q (nil2)) = q"
| "hmerging (cons2 q (cons2 z x2)) =
     hmerging (hpairwise (cons2 q (cons2 z x2)))"
  by pat_completeness auto

fun toHeap2 :: "Nat list => Heap" where
  "toHeap2 x = hmerging (toHeap x)"

(*fun did not finish the proof*)
function toList :: "Heap => Nat list" where
  "toList (Node q y r) = cons2 y (toList (hmerge q r))"
| "toList (Nil) = nil2"
  by pat_completeness auto

fun hsort :: "Nat list => Nat list" where
  "hsort x = toList (toHeap2 x)"

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

fun deleteBy :: "('a => ('a => bool)) => 'a => 'a list =>
                 'a list" where
  "deleteBy x y (nil2) = nil2"
| "deleteBy x y (cons2 y2 ys) =
     (if (x y) y2 then ys else cons2 y2 (deleteBy x y ys))"

fun isPermutation :: "'a list => 'a list => bool" where
  "isPermutation (nil2) (nil2) = True"
| "isPermutation (nil2) (cons2 z x2) = False"
| "isPermutation (cons2 x3 xs) y =
     ((elem x3 y) &
        (isPermutation
           xs (deleteBy (% (x4 :: 'a) => % (x5 :: 'a) => (x4 = x5)) x3 y)))"

theorem property0 :
  "isPermutation (hsort xs) xs"
  oops

end


(* This Isabelle theory is produced using the TIP tool offered at the following website:
     https://github.com/tip-org/tools
   This file was originally provided as part of TIP benchmark at the following website:
     https://github.com/tip-org/benchmarks
   Yutaka Nagashima at CIIRC, CTU changed the TIP output theory file slightly
   to make it compatible with Isabelle2017.
\:w
   Some proofs were added by Yutaka Nagashima.*)
  theory TIP_bin_distrib
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 (plus y z)) = (plus (times x y) (times x z)))"apply(induction x, auto)apply(induction y, auto)
  oops

end


(* Title:      Kleene algebra with tests
   Author:     Alasdair Armstrong, Victor B. F. Gomes, Georg Struth
   Maintainer: Georg Struth <g.struth at sheffield.ac.uk>
*)

header {* Hoare Logic *}

theory HoareLogic
  imports KAT
begin

context kat
begin

text {*
  We encode validity of Hoare triples and derive the inference rules of propositional Hoare logic,
  that is, Hoare logic without the assignement rule, in Kleene algebra with tests.
*}

definition hoare_triple :: "'a \<Rightarrow> 'a \<Rightarrow> 'a \<Rightarrow> bool" ("\<lbrace>_\<rbrace>_\<lbrace>_\<rbrace>") where
  "\<lbrace>p\<rbrace> x \<lbrace>q\<rbrace> \<equiv> p\<cdot>x = p\<cdot>x\<cdot>q \<and> test p \<and> test q"

lemma hoare_triple_def_var: "\<lbrace>p\<rbrace> x \<lbrace>q\<rbrace> = (p\<cdot>x \<le> x\<cdot>q \<and> test p \<and> test q)"
  by (metis hoare_triple_def kat_eq1 kat_eq2)

lemma skip_rule: "test p \<Longrightarrow> \<lbrace>p\<rbrace>1\<lbrace>p\<rbrace>"
  by (simp add: hoare_triple_def)

lemma sequence_rule: "\<lbrace>p\<rbrace>x\<lbrace>q'\<rbrace> \<Longrightarrow> \<lbrace>q'\<rbrace>x'\<lbrace>q\<rbrace> \<Longrightarrow> \<lbrace>p\<rbrace>x\<cdot>x'\<lbrace>q\<rbrace>"
  by (simp add: hoare_triple_def, metis mult.assoc)

lemma conditional_rule: "\<lbrakk>\<lbrace>p\<cdot>b\<rbrace>x\<lbrace>q\<rbrace>; \<lbrace>p\<cdot>!b\<rbrace>x'\<lbrace>q\<rbrace>; test p; test b\<rbrakk> \<Longrightarrow> \<lbrace>p\<rbrace>b\<cdot>x + !b\<cdot>x'\<lbrace>q\<rbrace>"
  by (simp add: hoare_triple_def, metis mult.assoc distrib_left distrib_right)

lemma consequence_rule: "\<lbrakk>test p; p \<le> p'; \<lbrace>p'\<rbrace>x\<lbrace>q'\<rbrace>; q' \<le> q; test q\<rbrakk> \<Longrightarrow> \<lbrace>p\<rbrace>x\<lbrace>q\<rbrace>"
  by (unfold hoare_triple_def, metis (full_types) mult.assoc test_leq_mult_def_var)

lemma while_rule_var: "\<lbrace>p\<rbrace>x\<lbrace>p\<rbrace> \<Longrightarrow> \<lbrace>p\<rbrace>x\<^sup>\<star>\<lbrace>p\<rbrace>"
  by (metis hoare_triple_def_var star_sim2)

lemma while_rule: "\<lbrakk>test q; \<lbrace>p\<cdot>q\<rbrace>x\<lbrace>p\<rbrace>\<rbrakk> \<Longrightarrow> \<lbrace>p\<rbrace>(q\<cdot>x)\<^sup>\<star>\<cdot>!q\<lbrace>p\<cdot>!q\<rbrace>"
proof (unfold hoare_triple_def_var, auto)
  assume assms: "test p" "test q" "p\<cdot>q\<cdot>x \<le> x\<cdot>p"
  hence "q\<cdot>p\<cdot>q\<cdot>x \<le> q\<cdot>x\<cdot>p"
    by (metis mult.assoc mult_isol)
  thus "p\<cdot>((q\<cdot>x)\<^sup>\<star>\<cdot>!q) \<le> (q\<cdot>x)\<^sup>\<star>\<cdot>!q\<cdot>(p\<cdot>!q)"
    by (metis assms(1,2) test_mult_comm_var star_sim2 mult_isor kat_eq3 mult.assoc test2)
qed (metis test_comp_closed_var test_mult_closed)

definition (in kat) while_inv :: "'a \<Rightarrow> 'b \<Rightarrow> 'a \<Rightarrow> 'a" ("while _ inv _ do _" [64,64,64] 63) where
  "while b inv i do p = (b\<cdot>p)\<^sup>\<star> \<cdot> !b"

lemma hoare_while_inv:
  assumes tb: "test b" and tp: "test p" and tq: "test q"
  and pi: "p \<le> i" and iq: "i \<cdot> !b \<le> q"
  and inv_loop: "\<lbrace>i \<cdot> b\<rbrace> c \<lbrace>i\<rbrace>"
  shows "\<lbrace>p\<rbrace> while b inv i do c \<lbrace>q\<rbrace>"
  by (metis assms while_inv_def while_rule consequence_rule)

end
end


theory Left_Coset
imports Coset

(*This instance of Coset.thy but for left cosets is due to Jonas Rädle and has been imported
  from the AFP entry Orbit_Stabiliser. *)

begin

definition
  LCOSETS  :: "[_, 'a set] \<Rightarrow> ('a set)set"   ("lcosets\<index> _" [81] 80)
  where "lcosets\<^bsub>G\<^esub> H = (\<Union>a\<in>carrier G. {a <#\<^bsub>G\<^esub> H})"

definition
  LFactGroup :: "[('a,'b) monoid_scheme, 'a set] \<Rightarrow> ('a set) monoid" (infixl "LMod" 65)
    \<comment> \<open>Actually defined for groups rather than monoids\<close>
   where "LFactGroup G H = \<lparr>carrier = lcosets\<^bsub>G\<^esub> H, mult = set_mult G, one = H\<rparr>"

lemma (in group) lcos_self: "[| x \<in> carrier G; subgroup H G |] ==> x \<in> x <# H"
  by (simp add: group_l_invI subgroup.lcos_module_rev subgroup.one_closed)

text \<open>Elements of a left coset are in the carrier\<close>
lemma (in subgroup) elemlcos_carrier:
  assumes "group G" "a \<in> carrier G" "a' \<in> a <# H"
  shows "a' \<in> carrier G"
  by (meson assms group.l_coset_carrier subgroup_axioms)

text \<open>Step one for lemma \<open>rcos_module\<close>\<close>
lemma (in subgroup) lcos_module_imp:
  assumes "group G"
  assumes xcarr: "x \<in> carrier G"
      and x'cos: "x' \<in> x <# H"
  shows "(inv x \<otimes> x') \<in> H"
proof -
  interpret group G by fact
  obtain h
    where hH: "h \<in> H" and x': "x' = x \<otimes> h" and hcarr: "h \<in> carrier G"
    using assms by (auto simp: l_coset_def)
  have "(inv x) \<otimes> x' = (inv x) \<otimes> (x \<otimes> h)"
    by (simp add: x')
  have "\<dots> = (x \<otimes> inv x) \<otimes> h"
    by (metis hcarr inv_closed inv_inv l_inv m_assoc xcarr)
  also have "\<dots> = h"
    by (simp add: hcarr xcarr)
  finally have "(inv x) \<otimes> x' = h"
    using x' by metis
  then show "(inv x) \<otimes> x' \<in> H"
    using hH by force
qed

text \<open>Left cosets are subsets of the carrier.\<close>
lemma (in subgroup) lcosets_carrier:
  assumes "group G"
  assumes XH: "X \<in> lcosets H"
  shows "X \<subseteq> carrier G"
proof -
  interpret group G by fact
  show "X \<subseteq> carrier G"
    using XH l_coset_subset_G subset by (auto simp: LCOSETS_def)
qed

lemma (in group) lcosets_part_G:
  assumes "subgroup H G"
  shows "\<Union>(lcosets H) = carrier G"
proof -
  interpret subgroup H G by fact
  show ?thesis
  proof
    show "\<Union> (lcosets H) \<subseteq> carrier G"
      by (force simp add: LCOSETS_def l_coset_def)
    show "carrier G \<subseteq> \<Union> (lcosets H)"
      by (auto simp add: LCOSETS_def intro: lcos_self assms)
  qed
qed

lemma (in group) lcosets_subset_PowG:
     "subgroup H G  \<Longrightarrow> lcosets H \<subseteq> Pow(carrier G)"
  using lcosets_part_G subset_Pow_Union by blast

lemma (in group) lcos_disjoint:
  assumes "subgroup H G"
  assumes p: "a \<in> lcosets H" "b \<in> lcosets H" "a\<noteq>b"
  shows "a \<inter> b = {}"
proof -
  interpret subgroup H G by fact
  show ?thesis
    using p l_repr_independence subgroup_axioms unfolding LCOSETS_def disjoint_iff
    by blast
qed

text\<open>The next two lemmas support the proof of \<open>card_cosets_equal\<close>.\<close>
lemma (in group) inj_on_f':
    "\<lbrakk>H \<subseteq> carrier G;  a \<in> carrier G\<rbrakk> \<Longrightarrow> inj_on (\<lambda>y. y \<otimes> inv a) (a <# H)"
  by (simp add: inj_on_g l_coset_subset_G)

lemma (in group) inj_on_f'':
    "\<lbrakk>H \<subseteq> carrier G;  a \<in> carrier G\<rbrakk> \<Longrightarrow> inj_on (\<lambda>y. inv a \<otimes> y) (a <# H)"
  by (meson inj_on_cmult inv_closed l_coset_subset_G subset_inj_on)

lemma (in group) inj_on_g':
    "\<lbrakk>H \<subseteq> carrier G;  a \<in> carrier G\<rbrakk> \<Longrightarrow> inj_on (\<lambda>y. a \<otimes> y) H"
  using inj_on_cmult inj_on_subset by blast

lemma (in group) l_card_cosets_equal:
  assumes "c \<in> lcosets H" and H: "H \<subseteq> carrier G" and fin: "finite(carrier G)"
  shows "card H = card c"
proof -
  obtain x where x: "x \<in> carrier G" and c: "c = x <# H"
    using assms by (auto simp add: LCOSETS_def)
  have "inj_on ((\<otimes>) x) H"
    by (simp add: H group.inj_on_g' x)
  moreover
  have "(\<otimes>) x ` H \<subseteq> x <# H"
    by (force simp add: m_assoc subsetD l_coset_def)
  moreover
  have "inj_on ((\<otimes>) (inv x)) (x <# H)"
    by (simp add: H group.inj_on_f'' x)
  moreover
  have "\<And>h. h \<in> H \<Longrightarrow> inv x \<otimes> (x \<otimes> h) \<in> H"
    by (metis H in_mono inv_solve_left m_closed x)
  then have "(\<otimes>) (inv x) ` (x <# H) \<subseteq> H"
    by (auto simp: l_coset_def)
  ultimately show ?thesis
    by (metis H fin c card_bij_eq finite_imageD finite_subset)
qed

theorem (in group) l_lagrange:
  assumes "finite(carrier G)" "subgroup H G"
  shows "card(lcosets H) * card(H) = order(G)"
proof -
  have "card H * card (lcosets H) = card (\<Union> (lcosets H))"
    using card_partition
    by (metis (no_types, lifting) assms finite_UnionD l_card_cosets_equal lcos_disjoint lcosets_part_G subgroup.subset)
  then show ?thesis
    by (simp add: assms(2) lcosets_part_G mult.commute order_def)
qed

end