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

header{*Solving systems of equations using the Gauss Jordan algorithm*}

theory System_Of_Equations
imports
 Gauss_Jordan_PA
 Bases_Of_Fundamental_Subspaces
begin

subsection{*Definitions*}

text{*Given a system of equations @{term "A *v x = b"}, the following function returns the pair @{term "(P ** A,P *v b)"}, where P is the matrix
      which states @{term "Gauss_Jordan A = P ** A"}. That matrix is computed by means of @{term "Gauss_Jordan_PA"}.*}

definition solve_system :: "('a::{field}^'cols::{mod_type}^'rows::{mod_type}) \<Rightarrow> ('a^'rows::{mod_type})
  \<Rightarrow> (('a^'cols::{mod_type}^'rows::{mod_type}) \<times> ('a^'rows::{mod_type}))"
  where "solve_system A b = (let A' = Gauss_Jordan_PA A in (snd A', (fst A') *v b))"

definition is_solution where "is_solution x A b = (A *v x = b)"

subsection{*Relationship between @{term "is_solution_def"} and @{term "solve_system_def"}*}

lemma is_solution_imp_solve_system:
fixes A::"'a::{field}^'cols::{mod_type}^'rows::{mod_type}"
assumes xAb:"is_solution x A b"
shows "is_solution x (fst (solve_system A b)) (snd (solve_system A b))"
proof -
have "(fst (Gauss_Jordan_PA A)*v(A *v x) = fst (Gauss_Jordan_PA A) *v b)"
using xAb unfolding is_solution_def by fast
hence "(snd (Gauss_Jordan_PA A) *v x = fst (Gauss_Jordan_PA A) *v b)"
  unfolding matrix_vector_mul_assoc
  unfolding fst_Gauss_Jordan_PA[of A] .
thus "is_solution x (fst (solve_system A b)) (snd (solve_system A b))"
unfolding is_solution_def solve_system_def Let_def by simp
qed

lemma solve_system_imp_is_solution:
fixes A::"'a::{field}^'cols::{mod_type}^'rows::{mod_type}"
assumes xAb: "is_solution x (fst (solve_system A b)) (snd (solve_system A b))"
shows "is_solution x A b"
proof -
have "fst (solve_system A b) *v x = snd (solve_system A b)"
  using xAb unfolding is_solution_def .
hence "snd (Gauss_Jordan_PA A) *v x = fst (Gauss_Jordan_PA A) *v b"
  unfolding solve_system_def Let_def fst_conv snd_conv .
hence "(fst (Gauss_Jordan_PA A) ** A) *v x = fst (Gauss_Jordan_PA A) *v b"
  unfolding fst_Gauss_Jordan_PA .
hence "fst (Gauss_Jordan_PA A) *v (A *v x) = fst (Gauss_Jordan_PA A) *v b"
  unfolding matrix_vector_mul_assoc .
hence "matrix_inv (fst (Gauss_Jordan_PA A)) *v (fst (Gauss_Jordan_PA A) *v (A *v x))
  = matrix_inv (fst (Gauss_Jordan_PA A)) *v (fst (Gauss_Jordan_PA A) *v b)" by simp
hence "(A *v x) = b"
unfolding matrix_vector_mul_assoc[of "matrix_inv (fst (Gauss_Jordan_PA A))"]
unfolding matrix_inv_left[OF invertible_fst_Gauss_Jordan_PA]
unfolding matrix_vector_mul_lid .
thus ?thesis unfolding is_solution_def .
qed

lemma is_solution_solve_system:
fixes A::"'a::{field}^'cols::{mod_type}^'rows::{mod_type}"
shows "is_solution x A b = is_solution x (fst (solve_system A b)) (snd (solve_system A b))"
using solve_system_imp_is_solution is_solution_imp_solve_system by blast

subsection{*Consistent and inconsistent systems of equations*}

definition consistent :: "'a::{field}^'cols::{mod_type}^'rows::{mod_type} \<Rightarrow> 'a::{field}^'rows::{mod_type} \<Rightarrow> bool"
where "consistent A b = (\<exists>x. is_solution x A b)"

definition inconsistent where "inconsistent A b =  (\<not> (consistent A b))"

lemma inconsistent: "inconsistent A b = (\<not> (\<exists>x. is_solution x A b))"
unfolding inconsistent_def consistent_def by simp

text{*The following function will be use to solve consistent systems which are already in the reduced row echelon form.*}

definition solve_consistent_rref :: "'a::{field}^'cols::{mod_type}^'rows::{mod_type} \<Rightarrow> 'a::{field}^'rows::{mod_type} \<Rightarrow> 'a::{field}^'cols::{mod_type}"
where "solve_consistent_rref A b = (\<chi> j. if (\<exists>i. A $ i $ j = 1 \<and> j=(LEAST n. A $ i $ n \<noteq> 0)) then b $ (THE i. A $ i $ j = 1) else 0)"

lemma solve_consistent_rref_code[code abstract]:
shows "vec_nth (solve_consistent_rref A b) = (% j. if (\<exists>i. A $ i $ j = 1 \<and> j=(LEAST n. A $ i $ n \<noteq> 0)) then b $ (THE i. A $ i $ j = 1) else 0)"
unfolding solve_consistent_rref_def by auto

lemma rank_ge_imp_is_solution:
fixes A::"'a::{field}^'cols::{mod_type}^'rows::{mod_type}"
assumes con: "rank A \<ge> (if (\<exists>a. (P_Gauss_Jordan A *v b) $ a \<noteq> 0)
                                            then (to_nat (GREATEST' a. (P_Gauss_Jordan A *v b) $ a \<noteq> 0) + 1) else 0)"
shows "is_solution (solve_consistent_rref (Gauss_Jordan A) (P_Gauss_Jordan A *v b)) A b"
proof -
have "is_solution (solve_consistent_rref (Gauss_Jordan A) (P_Gauss_Jordan A *v b)) (Gauss_Jordan A) (P_Gauss_Jordan A *v b)"
proof (unfold is_solution_def solve_consistent_rref_def, subst matrix_vector_mult_def, vector, auto)
fix a
let ?f="\<lambda>j. Gauss_Jordan A $ a $ j *
      (if \<exists>i. Gauss_Jordan A $ i $ j = 1 \<and> j = (LEAST n. Gauss_Jordan A $ i $ n \<noteq> 0)
        then (P_Gauss_Jordan A *v b) $ (THE i. Gauss_Jordan A $ i $ j = 1) else 0)"
show "setsum ?f UNIV = (P_Gauss_Jordan A *v b) $ a"
proof (cases "A=0")
case True
hence rank_A_eq_0:"rank A = 0" using rank_0 by simp
have "(P_Gauss_Jordan A *v b) = 0"
  proof (rule ccontr)
   assume not_zero: "P_Gauss_Jordan A *v b \<noteq> 0"
   hence ex_a: "\<exists>a. (P_Gauss_Jordan A *v b) $ a \<noteq> 0" by (metis vec_eq_iff zero_index)
   show False using con unfolding if_P[OF ex_a] unfolding rank_A_eq_0 by auto
 qed

thus ?thesis unfolding A_0_imp_Gauss_Jordan_0[OF True] by force
next
case False note A_not_zero=False
def not_zero_positions_row_a\<equiv>"{j. Gauss_Jordan A $ a $ j \<noteq> 0}"
def zero_positions_row_a\<equiv>"{j. Gauss_Jordan A $ a $ j = 0}"
have UNIV_rw: "UNIV = not_zero_positions_row_a \<union> zero_positions_row_a"
  unfolding zero_positions_row_a_def not_zero_positions_row_a_def by auto
have disj: "not_zero_positions_row_a \<inter> zero_positions_row_a = {}"
  unfolding zero_positions_row_a_def not_zero_positions_row_a_def by fastforce
have setsum_zero: "(setsum ?f zero_positions_row_a) = 0"
  by (unfold zero_positions_row_a_def, rule setsum.neutral, fastforce)
have "setsum ?f (UNIV::'cols set)=setsum ?f (not_zero_positions_row_a \<union> zero_positions_row_a)"
  unfolding UNIV_rw ..
also have "... = setsum ?f (not_zero_positions_row_a) + (setsum ?f zero_positions_row_a)"
  by (rule setsum.union_disjoint[OF _ _ disj], simp+)
also have "... = setsum ?f (not_zero_positions_row_a)" unfolding setsum_zero by simp
also have "... = (P_Gauss_Jordan A *v b) $ a"
  proof (cases "not_zero_positions_row_a = {}")
    case True note zero_row_a=True
    show ?thesis
    proof (cases "\<exists>a. (P_Gauss_Jordan A *v b) $ a \<noteq> 0")
      case False hence "(P_Gauss_Jordan A *v b) $ a = 0" by simp
      thus ?thesis unfolding True by auto
      next
      case True
      have rank_not_0: "rank A \<noteq> 0" by (metis A_not_zero less_not_refl3 rank_Gauss_Jordan rank_greater_zero)
      have greatest_less_a: "(GREATEST' a. \<not> is_zero_row a (Gauss_Jordan A)) < a"
        proof (unfold is_zero_row_def, rule greatest_less_zero_row)
        show " reduced_row_echelon_form_upt_k (Gauss_Jordan A) (ncols (Gauss_Jordan A))"
          using rref_Gauss_Jordan unfolding reduced_row_echelon_form_def .
        show "is_zero_row_upt_k a (ncols (Gauss_Jordan A)) (Gauss_Jordan A)"
          by (metis (mono_tags) Collect_empty_eq is_zero_row_upt_ncols not_zero_positions_row_a_def zero_row_a)
        show "\<not> (\<forall>a. is_zero_row_upt_k a (ncols (Gauss_Jordan A)) (Gauss_Jordan A))"
          by (metis False Gauss_Jordan_not_0 is_zero_row_upt_ncols vec_eq_iff zero_index)
        qed
    hence "to_nat (GREATEST' a. \<not> is_zero_row a (Gauss_Jordan A)) < to_nat a" using to_nat_mono by fast
    hence rank_le_to_nat_a: "rank A \<le> to_nat a" unfolding rank_eq_suc_to_nat_greatest[OF A_not_zero] by simp
    have "to_nat (GREATEST' a. (P_Gauss_Jordan A *v b) $ a \<noteq> 0) < to_nat a"
      using con unfolding consistent_def unfolding if_P[OF True] using rank_le_to_nat_a by simp
    hence "(GREATEST' a. (P_Gauss_Jordan A *v b) $ a \<noteq> 0) < a" by (metis not_le to_nat_mono')
    hence "(P_Gauss_Jordan A *v b) $ a = 0" using not_greater_Greatest' by blast
    thus ?thesis unfolding zero_row_a by simp
    qed
    next
    case False note not_empty=False
    have not_zero_positions_row_a_rw: "not_zero_positions_row_a = {LEAST j. (Gauss_Jordan A) $ a $ j \<noteq> 0} \<union> (not_zero_positions_row_a - {LEAST j. (Gauss_Jordan A) $ a $ j \<noteq> 0})"
    unfolding not_zero_positions_row_a_def
    by (metis (mono_tags) Collect_cong False LeastI_ex bot_set_def empty_iff insert_Diff_single insert_absorb insert_is_Un mem_Collect_eq not_zero_positions_row_a_def)
    have setsum_zero': "setsum ?f (not_zero_positions_row_a - {LEAST j. (Gauss_Jordan A) $ a $ j \<noteq> 0}) = 0"
      by (rule setsum.neutral, auto, metis is_zero_row_def' rref_Gauss_Jordan rref_condition4_explicit zero_neq_one)
    have "setsum ?f (not_zero_positions_row_a) = setsum ?f {LEAST j. (Gauss_Jordan A) $ a $ j \<noteq> 0} + setsum ?f (not_zero_positions_row_a - {LEAST j. (Gauss_Jordan A) $ a $ j \<noteq> 0})"
    by (subst not_zero_positions_row_a_rw, rule setsum.union_disjoint[OF _ _ _], simp+)
    also have "... = ?f (LEAST j. (Gauss_Jordan A) $ a $ j \<noteq> 0)" using setsum_zero' by force
    also have "... = (P_Gauss_Jordan A *v b) $ a"
      proof (cases "\<exists>i. (Gauss_Jordan A) $ i $ (LEAST j. (Gauss_Jordan A) $ a $ j \<noteq> 0) = 1 \<and> (LEAST j. (Gauss_Jordan A) $ a $ j \<noteq> 0) = (LEAST n. (Gauss_Jordan A) $ i $ n \<noteq> 0)")
      case True
      have A_least_eq_1: "(Gauss_Jordan A) $ a $ (LEAST j. (Gauss_Jordan A) $ a $ j \<noteq> 0) = 1"
        by (metis (mono_tags) empty_Collect_eq is_zero_row_def' not_empty not_zero_positions_row_a_def rref_Gauss_Jordan rref_condition2_explicit)
      moreover have "(THE i. (Gauss_Jordan A) $ i $ (LEAST j. (Gauss_Jordan A) $ a $ j \<noteq> 0) = 1) = a"
        proof (rule the_equality)
          show "(Gauss_Jordan A) $ a $ (LEAST j. (Gauss_Jordan A) $ a $ j \<noteq> 0) = 1" using A_least_eq_1 .
          show "\<And>i. (Gauss_Jordan A) $ i $ (LEAST j. (Gauss_Jordan A) $ a $ j \<noteq> 0) = 1 \<Longrightarrow> i = a"
            by (metis calculation is_zero_row_def' rref_Gauss_Jordan rref_condition4_explicit zero_neq_one)
      qed
      ultimately show ?thesis unfolding if_P[OF True] by simp
      next
      case False
      have "is_zero_row a (Gauss_Jordan A)" using False rref_Gauss_Jordan rref_condition2 by blast
      hence "(P_Gauss_Jordan A *v b) $ a = 0"
        by (metis (mono_tags) IntI disj empty_iff insert_compr insert_is_Un is_zero_row_def' mem_Collect_eq not_zero_positions_row_a_rw zero_positions_row_a_def)
      thus ?thesis unfolding if_not_P[OF False] by fastforce
      qed
     finally show ?thesis .
qed
finally show "setsum ?f UNIV = (P_Gauss_Jordan A *v b) $ a" .
qed
qed
thus ?thesis apply (subst is_solution_solve_system)
unfolding solve_system_def Let_def snd_conv fst_conv unfolding Gauss_Jordan_PA_eq P_Gauss_Jordan_def .
qed

corollary rank_ge_imp_consistent:
fixes A::"'a::{field}^'cols::{mod_type}^'rows::{mod_type}"
assumes "rank A \<ge> (if (\<exists>a. (P_Gauss_Jordan A *v b) $ a \<noteq> 0) then (to_nat (GREATEST' a. (P_Gauss_Jordan A *v b) $ a \<noteq> 0) + 1) else 0)"
shows "consistent A b"
using rank_ge_imp_is_solution assms unfolding consistent_def by auto

lemma inconsistent_imp_rank_less:
fixes A::"'a::{field}^'cols::{mod_type}^'rows::{mod_type}"
assumes inc: "inconsistent A b"
shows "rank A < (if (\<exists>a. (P_Gauss_Jordan A *v b) $ a \<noteq> 0) then (to_nat (GREATEST' a. (P_Gauss_Jordan A *v b) $ a \<noteq> 0) + 1) else 0)"
proof (rule ccontr)
assume "\<not> rank A < (if \<exists>a. (P_Gauss_Jordan A *v b) $ a \<noteq> 0 then to_nat (GREATEST' a. (P_Gauss_Jordan A *v b) $ a \<noteq> 0) + 1 else 0)"
hence "(if \<exists>a. (P_Gauss_Jordan A *v b) $ a \<noteq> 0 then to_nat (GREATEST' a. (P_Gauss_Jordan A *v b) $ a \<noteq> 0) + 1 else 0) \<le> rank A" by simp
hence "consistent A b" using rank_ge_imp_consistent by auto
thus False using inc unfolding inconsistent_def by contradiction
qed

lemma rank_less_imp_inconsistent:
fixes A::"'a::{field}^'cols::{mod_type}^'rows::{mod_type}"
assumes inc: "rank A < (if (\<exists>a. (P_Gauss_Jordan A *v b) $ a \<noteq> 0) then (to_nat (GREATEST' a. (P_Gauss_Jordan A *v b) $ a \<noteq> 0) + 1) else 0)"
shows "inconsistent A b"
proof (rule ccontr)
def i\<equiv>"(GREATEST' a. (P_Gauss_Jordan A *v b) $ a \<noteq> 0)"
def j\<equiv>"(GREATEST' a. \<not> is_zero_row a (Gauss_Jordan A))"
assume "\<not> inconsistent A b"
hence ex_solution: "\<exists>x. is_solution x A b" unfolding inconsistent_def consistent_def by auto
from this obtain x where "is_solution x A b"  by auto
hence is_solution_solve: "is_solution x (Gauss_Jordan A) (P_Gauss_Jordan A *v b)"
  using is_solution_solve_system
  by (metis Gauss_Jordan_PA_eq P_Gauss_Jordan_def fst_conv snd_conv solve_system_def)
show False
  proof (cases "A=0")
  case True
  hence rank_eq_0: "rank A = 0" using rank_0 by simp
  hence exists_not_0:"(\<exists>a. (P_Gauss_Jordan A *v b) $ a \<noteq> 0)"
  using inc unfolding inconsistent
  using to_nat_plus_1_set[of "(GREATEST' a. (P_Gauss_Jordan A *v b) $ a \<noteq> 0)"]
  by presburger
  show False
    by (metis True exists_not_0 is_solution_def A_0_imp_Gauss_Jordan_0 transpose_vector
        transpose_zero vector_matrix_zero' is_solution_solve vec_0 vec_component)
  next
  case False
have j_less_i: "j<i"
proof -
have rank_less_greatest_i: "rank A < to_nat i + 1"
  using inc unfolding i_def inconsistent by presburger
moreover have rank_eq_greatest_A: "rank A = to_nat j + 1" unfolding j_def by (rule rank_eq_suc_to_nat_greatest[OF False])
ultimately have "to_nat j + 1 < to_nat i + 1" by simp
hence "to_nat j < to_nat i" by auto
thus "j<i" by (metis (full_types) not_le to_nat_mono')
qed
have is_zero_i: "is_zero_row i (Gauss_Jordan A)" by (metis (full_types) j_def j_less_i not_greater_Greatest')
have "(Gauss_Jordan A *v x) $ i = 0"
  proof (unfold matrix_vector_mult_def, auto, rule setsum.neutral,clarify)
    fix a::'cols
    show "Gauss_Jordan A $ i $ a * x $ a = 0" using is_zero_i unfolding is_zero_row_def' by simp
    qed
moreover have "(Gauss_Jordan A *v x) $ i \<noteq> 0"
  proof -
    have "Gauss_Jordan A *v x = P_Gauss_Jordan A *v b" using is_solution_def is_solution_solve by blast
    also have "... $ i \<noteq> 0"
    unfolding i_def
      proof (rule Greatest'I_ex)
        show "\<exists>x. (P_Gauss_Jordan A *v b) $ x \<noteq> 0" using inc unfolding i_def inconsistent by presburger
       qed
     finally show ?thesis .
qed
ultimately show "False" by contradiction
qed
qed

corollary consistent_imp_rank_ge:
fixes A::"'a::{field}^'cols::{mod_type}^'rows::{mod_type}"
assumes "consistent A b"
shows "rank A \<ge> (if (\<exists>a. (P_Gauss_Jordan A *v b) $ a \<noteq> 0) then (to_nat (GREATEST' a. (P_Gauss_Jordan A *v b) $ a \<noteq> 0) + 1) else 0)"
using rank_less_imp_inconsistent by (metis assms inconsistent_def not_less)

lemma inconsistent_eq_rank_less:
fixes A::"'a::{field}^'cols::{mod_type}^'rows::{mod_type}"
shows "inconsistent A b = (rank A < (if (\<exists>a. (P_Gauss_Jordan A *v b) $ a \<noteq> 0)
                                            then (to_nat (GREATEST' a. (P_Gauss_Jordan A *v b) $ a \<noteq> 0) + 1) else 0))"
using inconsistent_imp_rank_less rank_less_imp_inconsistent by blast

lemma consistent_eq_rank_ge:
fixes A::"'a::{field}^'cols::{mod_type}^'rows::{mod_type}"
shows "consistent A b = (rank A \<ge> (if (\<exists>a. (P_Gauss_Jordan A *v b) $ a \<noteq> 0)
                                            then (to_nat (GREATEST' a. (P_Gauss_Jordan A *v b) $ a \<noteq> 0) + 1) else 0))"
using consistent_imp_rank_ge rank_ge_imp_consistent by blast

corollary consistent_imp_is_solution:
fixes A::"'a::{field}^'cols::{mod_type}^'rows::{mod_type}"
assumes "consistent A b"
shows "is_solution (solve_consistent_rref (Gauss_Jordan A) (P_Gauss_Jordan A *v b)) A b"
by (rule rank_ge_imp_is_solution[OF assms[unfolded consistent_eq_rank_ge]])

corollary consistent_imp_is_solution':
fixes A::"'a::{field}^'cols::{mod_type}^'rows::{mod_type}"
assumes "consistent A b"
shows "is_solution (solve_consistent_rref (fst (solve_system A b)) (snd (solve_system A b))) A b"
using consistent_imp_is_solution[OF assms] unfolding solve_system_def Let_def snd_conv fst_conv
unfolding Gauss_Jordan_PA_eq P_Gauss_Jordan_def .

text{*Code equations optimized using Lets*}

lemma inconsistent_eq_rank_less_code[code]:
fixes A::"'a::{field}^'cols::{mod_type}^'rows::{mod_type}"
shows "inconsistent A b = (let GJ_P=Gauss_Jordan_PA A;
                                P_mult_b = (fst(GJ_P) *v b);
                                rank_A = (if A = 0 then 0 else to_nat (GREATEST' a. row a (snd GJ_P) \<noteq> 0) + 1)  in (rank_A < (if (\<exists>a. P_mult_b $ a \<noteq> 0)
                                            then (to_nat (GREATEST' a. P_mult_b $ a \<noteq> 0) + 1) else 0)))"
unfolding inconsistent_eq_rank_less Let_def rank_Gauss_Jordan_code
unfolding Gauss_Jordan_PA_eq P_Gauss_Jordan_def ..

lemma consistent_eq_rank_ge_code[code]:
fixes A::"'a::{field}^'cols::{mod_type}^'rows::{mod_type}"
shows "consistent A b = (let GJ_P=Gauss_Jordan_PA A;
                              P_mult_b = (fst(GJ_P) *v b);
                              rank_A = (if A = 0 then 0 else to_nat (GREATEST' a. row a (snd GJ_P) \<noteq> 0) + 1) in (rank_A \<ge> (if (\<exists>a. P_mult_b $ a \<noteq> 0)
                                            then (to_nat (GREATEST' a. P_mult_b $ a \<noteq> 0) + 1) else 0)))"
unfolding consistent_eq_rank_ge Let_def rank_Gauss_Jordan_code
unfolding Gauss_Jordan_PA_eq P_Gauss_Jordan_def ..

subsection{*Solution set of a system of equations. Dependent and independent systems.*}

definition solution_set where "solution_set A b = {x. is_solution x A b}"

lemma null_space_eq_solution_set:
shows "null_space A = solution_set A 0" unfolding null_space_def solution_set_def is_solution_def ..

corollary dim_solution_set_homogeneous_eq_dim_null_space[code_unfold]:
shows "vec.dim (solution_set A 0) = vec.dim (null_space A)" using null_space_eq_solution_set[of A] by simp

lemma zero_is_solution_homogeneous_system:
shows "0 \<in> (solution_set A 0)"
unfolding solution_set_def is_solution_def
using matrix_vector_zero by fast

lemma homogeneous_solution_set_subspace:
fixes A::"'a::{field}^'n^'rows"
shows "vec.subspace (solution_set A 0)"
using subspace_null_space[of A] unfolding null_space_eq_solution_set .

lemma solution_set_rel:
fixes A::"'a::{field}^'n^'rows"
assumes p: "is_solution p A b"
shows "solution_set A b = {p} + (solution_set A 0)"
proof (unfold set_plus_def, auto)
fix ba
assume ba: "ba \<in> solution_set A 0"
have "A *v (p + ba) = (A *v p) + (A *v ba)" unfolding matrix_vector_right_distrib ..
also have "... = b" using p ba unfolding solution_set_def is_solution_def by simp
finally show "p + ba \<in> solution_set A b" unfolding solution_set_def is_solution_def by simp
next
fix x
assume x: "x \<in> solution_set A b"
show "\<exists>b\<in>solution_set A 0. x = p + b"
proof (rule bexI[of _ "x-p"], simp)
have "A *v (x - p) = (A *v x) - (A *v p)" by (metis (no_types) add_diff_cancel diff_add_cancel matrix_vector_right_distrib)
also have "... = 0" using x p unfolding solution_set_def is_solution_def by simp
finally show  "x - p \<in> solution_set A 0"  unfolding solution_set_def is_solution_def by simp
qed
qed

lemma independent_and_consistent_imp_uniqueness_solution:
fixes A::"'a::{field}^'n::{mod_type}^'rows::{mod_type}"
assumes dim_0: "vec.dim (solution_set A 0) = 0"
and con: "consistent A b"
shows "\<exists>!x. is_solution x A b"
proof -
obtain p where p: "is_solution p A b" using con unfolding consistent_def by blast
have solution_set_0: "solution_set A 0 = {0}"
  using vec.dim_zero_eq[OF dim_0] zero_is_solution_homogeneous_system by blast
show "\<exists>!x. is_solution x A b"
  proof (rule ex_ex1I)
    show "\<exists>x. is_solution x A b" using p by auto
    fix x y assume x: "is_solution x A b" and y: "is_solution y A b"
    have "solution_set A b = {p} + (solution_set A 0)" unfolding solution_set_rel[OF p] ..
    also have "... = {p}" unfolding solution_set_0 set_plus_def by force
    finally show "x = y" using x y unfolding solution_set_def by (metis (full_types) mem_Collect_eq singleton_iff)
qed
qed

(*TODO: Maybe move. Until Isabelle2013-2 this lemma was part of the library.*)
lemma card_1_exists: "card s = 1 \<longleftrightarrow> (\<exists>!x. x \<in> s)"
  unfolding One_nat_def
  apply rule apply(drule card_eq_SucD) defer apply(erule ex1E)
proof-
 fix x assume as:"x \<in> s" "\<forall>y. y \<in> s \<longrightarrow> y = x"
 have *:"s = insert x {}" apply - apply(rule,rule) unfolding singleton_iff
 apply(rule as(2)[rule_format]) using as(1) by auto
 show "card s = Suc 0" unfolding * using card_insert by auto
qed auto

corollary independent_and_consistent_imp_card_1:
fixes A::"'a::{field}^'n::{mod_type}^'rows::{mod_type}"
assumes dim_0: "vec.dim (solution_set A 0) = 0"
and con: "consistent A b"
shows "card (solution_set A b) = 1"
using independent_and_consistent_imp_uniqueness_solution[OF assms] unfolding solution_set_def
using card_1_exists by auto

lemma uniqueness_solution_imp_independent:
fixes A::"'a::{field}^'n^'rows"
assumes ex1_sol: "\<exists>!x. is_solution x A b"
shows "vec.dim (solution_set A 0) = 0"
proof -
obtain x where x: "is_solution x A b" using ex1_sol by blast
have solution_set_homogeneous_zero: "solution_set A 0 = {0}"
    proof (rule ccontr)
    assume not_zero_set: "solution_set A 0 \<noteq> {0}"
    have homogeneous_not_empty: "solution_set A 0 \<noteq> {}" by (metis empty_iff zero_is_solution_homogeneous_system)
    obtain y where y: "y \<in> solution_set A 0" and y_not_0: "y \<noteq> 0" using not_zero_set homogeneous_not_empty by blast
   have "{x} = solution_set A b" unfolding solution_set_def using x ex1_sol by blast
   also have "... = {x} + solution_set A 0" unfolding solution_set_rel[OF x] ..
   finally show False
    by (metis (hide_lams, mono_tags) add_left_cancel comm_monoid_add_class.add.right_neutral empty_iff insert_iff set_plus_intro y y_not_0)
   qed
thus ?thesis using vec.dim_zero_eq' by blast
qed

corollary uniqueness_solution_eq_independent_and_consistent:
fixes A::"'a::{field}^'n::{mod_type}^'rows::{mod_type}"
shows "(\<exists>!x. is_solution x A b) = (consistent A b \<and> vec.dim (solution_set A 0) = 0)"
using independent_and_consistent_imp_uniqueness_solution uniqueness_solution_imp_independent consistent_def
by metis

lemma consistent_homogeneous:
shows "consistent A 0" unfolding consistent_def is_solution_def using matrix_vector_zero by fast

lemma dim_solution_set_0:
fixes A::"'a::{field}^'n::{mod_type}^'rows::{mod_type}"
shows "(vec.dim (solution_set A 0) = 0) = (solution_set A 0 = {0})"
proof (auto)
show "vec.dim {0::'a^'n::{mod_type}} = 0" using vec.dim_zero_eq'[of "{0::'a^'n::{mod_type}}"] by fast
fix x assume dim0: "vec.dim (solution_set A 0) = 0"
show "0 \<in> solution_set A 0" using zero_is_solution_homogeneous_system .
assume x: "x \<in> solution_set A 0"
show "x = 0"
 using independent_and_consistent_imp_uniqueness_solution[OF dim0 consistent_homogeneous] zero_is_solution_homogeneous_system x unfolding solution_set_def by blast
qed

text{*We have to impose the restriction @{text "semiring_char_0"} in the following lemma,
because it may not hold over a general field (for instance, in Z2 there is a finite number of elements, so the solution
set can't be infinite.*}

lemma dim_solution_set_not_zero_imp_infinite_solutions_homogeneous:
fixes A::"'a::{field, semiring_char_0}^'n::{mod_type}^'rows::{mod_type}"
assumes dim_not_zero: "vec.dim (solution_set A 0) > 0"
shows "infinite (solution_set A 0)"
proof -
have "solution_set A 0 \<noteq> {0}" using vec.dim_zero_subspace_eq[of "solution_set A 0"] dim_not_zero
  by (metis less_numeral_extra(3) vec.dim_zero_eq')
from this obtain x where x: "x \<in> solution_set A 0" and x_not_0: "x \<noteq> 0" using vec.subspace_0[OF homogeneous_solution_set_subspace, of A] by auto
def f\<equiv>"\<lambda>n::nat. (of_nat n) *s x"
show ?thesis
  proof (unfold infinite_iff_countable_subset, rule exI[of _ f], rule conjI)
    show "inj f" unfolding inj_on_def unfolding f_def using x_not_0 by auto
    show "range f \<subseteq> solution_set A 0" using homogeneous_solution_set_subspace using x unfolding vec.subspace_def image_def f_def by fast
  qed
qed

lemma infinite_solutions_homogeneous_imp_dim_solution_set_not_zero:
fixes A::"'a::{field}^'n::{mod_type}^'rows::{mod_type}"
assumes i: "infinite (solution_set A 0)"
shows "vec.dim (solution_set A 0) > 0"
proof (rule ccontr, simp)
assume "vec.dim (solution_set A 0) = 0"
hence "solution_set A 0 = {0}" using dim_solution_set_0 by auto
hence "finite (solution_set A 0)" by simp
thus False using i by contradiction
qed

corollary infinite_solution_set_homogeneous_eq:
fixes A::"'a::{field,semiring_char_0}^'n::{mod_type}^'rows::{mod_type}"
shows "infinite (solution_set A 0) = (vec.dim (solution_set A 0) > 0)"
using infinite_solutions_homogeneous_imp_dim_solution_set_not_zero
using dim_solution_set_not_zero_imp_infinite_solutions_homogeneous by metis

corollary infinite_solution_set_homogeneous_eq':
fixes A::"'a::{field,semiring_char_0}^'n::{mod_type}^'rows::{mod_type}"
shows "(\<exists>\<^sub>\<infinity>x. is_solution x A 0) = (vec.dim (solution_set A 0) > 0)"
unfolding infinite_solution_set_homogeneous_eq[symmetric] INFM_iff_infinite unfolding solution_set_def ..

lemma infinite_solution_set_imp_consistent:
fixes A::"'a::{field}^'n::{mod_type}^'rows::{mod_type}"
assumes i: "infinite (solution_set A b)"
shows "consistent A b"
proof -
have "(\<exists>\<^sub>\<infinity>x. is_solution x A b)" using i unfolding solution_set_def INFM_iff_infinite .
thus ?thesis unfolding consistent_def by (metis (full_types) INFM_MOST_simps(1) INFM_mono)
qed

lemma infinite_solutions_no_homogeneous_imp_dim_solution_set_not_zero_imp:
fixes A::"'a::{field}^'n::{mod_type}^'rows::{mod_type}"
assumes i: "infinite (solution_set A b)"
shows "vec.dim (solution_set A 0) > 0"
proof (rule ccontr, simp)
have "(\<exists>\<^sub>\<infinity>x. is_solution x A b)" using i unfolding solution_set_def INFM_iff_infinite .
from this obtain x where x: "is_solution x A b" by (metis (full_types) INFM_MOST_simps(1) INFM_mono)
assume "vec.dim (solution_set A 0) = 0"
hence "solution_set A 0 = {0}" using dim_solution_set_0 by auto
hence "solution_set A b = {x} + {0}"  unfolding solution_set_rel[OF x] by simp
also have "... = {x}" unfolding set_plus_def by force
finally show False using i by simp
qed

corollary infinite_solution_set_no_homogeneous_eq:
fixes A::"'a::{field, semiring_char_0}^'n::{mod_type}^'rows::{mod_type}"
shows "infinite (solution_set A b) = (consistent A b \<and> vec.dim (solution_set A 0) > 0)"
using dim_solution_set_not_zero_imp_infinite_solutions_no_homogeneous
using infinite_solutions_no_homogeneous_imp_dim_solution_set_not_zero_imp
using infinite_solution_set_imp_consistent by blast

corollary infinite_solution_set_no_homogeneous_eq':
fixes A::"'a::{field, semiring_char_0}^'n::{mod_type}^'rows::{mod_type}"
shows "(\<exists>\<^sub>\<infinity>x. is_solution x A b) = (consistent A b \<and> vec.dim (solution_set A 0) > 0)"
unfolding infinite_solution_set_no_homogeneous_eq[symmetric] INFM_iff_infinite unfolding solution_set_def ..

definition "independent_and_consistent A b = (consistent A b \<and> vec.dim (solution_set A 0) = 0)"
definition "dependent_and_consistent A b = (consistent A b \<and> vec.dim (solution_set A 0) > 0)"

subsection{*Solving systems of linear equations*}

text{*The following function will solve any system of linear equations. Given a matrix @{text "A"} and a vector @{text "b"},
Firstly it makes use of the funcion @{term "solve_system"} to transform the original matrix @{text "A"} and the vector @{text "b"}
into another ones in reduced row echelon form. Then, that system will have the same solution than the original one but it is easier to be solved.
So we make use of the function @{term "solve_consistent_rref"} to obtain one solution of the system.

We will prove that any solution of the system can be rewritten as a linear combination of elements of a basis of the null space plus a particular solution of the system.
So the function @{term "solve"} will return an option type, depending on the consistency of the system:
\begin{itemize}
\item If the system is consistent (so there exists at least one solution), the function will return the @{text "Some"} of a pair.
      In the first component of that pair will be one solution of the system and the second one will be a basis of the null space of the matrix. Hence:
    \begin{enumerate}
        \item If the system is consistent and independent (so there exists one and only one solution), the pair will consist of the solution and the empty set (this empty set is
              the basis of the null space).
        \item If the system is consistent and dependent (so there exists more than one solution, maybe an infinite number),
              the pair will consist of one particular solution and a basis of the null space (which will not be the empty set).
    \end{enumerate}
\item If the system is inconsistent (so there exists no solution), the function will return @{text "None"}.
\end{itemize}
*}

definition "solve A b = (if consistent A b then
    Some (solve_consistent_rref (fst (solve_system A b)) (snd (solve_system A b)), basis_null_space A)
    else None)"

lemma solve_code[code]:
shows "solve A b = (let GJ_P=Gauss_Jordan_PA A;
                        P_times_b=fst(GJ_P) *v b;
                        rank_A = (if A = 0 then 0 else to_nat (GREATEST' a. row a (snd GJ_P) \<noteq> 0) + 1);
                        consistent_Ab = (rank_A \<ge> (if (\<exists>a. (P_times_b) $ a \<noteq> 0) then (to_nat (GREATEST' a. (P_times_b) $ a \<noteq> 0) + 1) else 0));
                        GJ_transpose = Gauss_Jordan_PA (transpose A);
                        basis = {row i (fst GJ_transpose) | i. to_nat i \<ge> rank_A}
                        in (if consistent_Ab then Some (solve_consistent_rref (snd GJ_P) P_times_b,basis) else None))"
unfolding Let_def solve_def
unfolding consistent_eq_rank_ge_code[unfolded Let_def,symmetric]
unfolding basis_null_space_def Let_def
unfolding P_Gauss_Jordan_def
unfolding rank_Gauss_Jordan_code Let_def Gauss_Jordan_PA_eq
unfolding solve_system_def Let_def fst_conv snd_conv
unfolding Gauss_Jordan_PA_eq ..

lemma consistent_imp_is_solution_solve:
fixes A::"'a::{field}^'cols::{mod_type}^'rows::{mod_type}"
assumes con: "consistent A b"
shows "is_solution (fst (the (solve A b))) A b"
unfolding solve_def unfolding if_P[OF con] fst_conv using consistent_imp_is_solution'[OF con]
by simp

corollary consistent_eq_solution_solve:
fixes A::"'a::{field}^'cols::{mod_type}^'rows::{mod_type}"
shows "consistent A b = is_solution (fst (the (solve A b))) A b"
by (metis consistent_def consistent_imp_is_solution_solve)

lemma inconsistent_imp_solve_eq_none:
fixes A::"'a::{field}^'cols::{mod_type}^'rows::{mod_type}"
assumes con: "inconsistent A b"
shows "solve A b = None" unfolding solve_def unfolding if_not_P[OF con[unfolded inconsistent_def]] ..

corollary inconsistent_eq_solve_eq_none:
fixes A::"'a::{field}^'cols::{mod_type}^'rows::{mod_type}"
shows "inconsistent A b = (solve A b = None)"
unfolding solve_def unfolding inconsistent_def by force

text{*We demonstrate that all solutions of a system of linear equations can be expressed as a linear combination of the basis of the null space plus a particular solution
obtained. The basis and the particular solution are obtained by means of the function @{term "solve A b"}*}

lemma solution_set_rel_solve:
fixes A::"'a::{field}^'cols::{mod_type}^'rows::{mod_type}"
assumes con: "consistent A b"
shows "solution_set A b = {fst (the (solve A b))} + vec.span (snd (the (solve A b)))"
proof -
have s: "is_solution (fst (the (solve A b))) A b" using consistent_imp_is_solution_solve[OF con] by simp
have "solution_set A b = {fst (the (solve A b))} + solution_set A 0" using solution_set_rel[OF s] .
also have "... = {fst (the (solve A b))} + vec.span (snd (the (solve A b)))"
  unfolding set_plus_def solve_def unfolding if_P[OF con] snd_conv fst_conv
  proof (auto)
    fix b assume "b \<in> solution_set A 0"
    thus "b \<in> vec.span (basis_null_space A)" unfolding null_space_eq_solution_set[symmetric] using basis_null_space[of A] by fast
    next
    fix b
    assume b: "b \<in> vec.span (basis_null_space A)"
    thus "b \<in> solution_set A 0" unfolding null_space_eq_solution_set[symmetric] using basis_null_space by blast
   qed
finally show "solution_set A b = {fst (the (solve A b))} + vec.span (snd (the (solve A b)))" .
qed

lemma is_solution_eq_in_span_solve:
fixes A::"'a::{field}^'cols::{mod_type}^'rows::{mod_type}"
assumes con: "consistent A b"
shows "(is_solution x A b) = (x \<in> {fst (the (solve A b))} + vec.span (snd (the (solve A b))))"
using solution_set_rel_solve[OF con] unfolding solution_set_def by auto

end


(*  Title:      Fun With Functions
    Author:     Tobias Nipkow
*)

theory FunWithFunctions imports Complex_Main begin

text\<open>See \<^cite>\<open>"Tao2006"\<close>. Was first brought to our attention by Herbert
Ehler who provided a similar proof.\<close>

theorem identity1: fixes f :: "nat \<Rightarrow> nat"
assumes fff: "\<And>n. f(f(n)) < f(Suc(n))"
shows "f(n) = n"
proof -
  { fix m n have key: "n \<le> m \<Longrightarrow> n \<le> f(m)"
    proof(induct n arbitrary: m)
      case 0 show ?case by simp
    next
      case (Suc n)
      hence "m \<noteq> 0" by simp
      then obtain k where [simp]: "m = Suc k" by (metis not0_implies_Suc)
      have "n \<le> f(k)" using Suc by simp
      hence "n \<le> f(f(k))" using Suc by simp
      also have "\<dots> < f(m)" using fff by simp
      finally show ?case by simp
    qed }
  hence "\<And>n. n \<le> f(n)" by simp
  hence "\<And>n. f(n) < f(Suc n)" by(metis fff order_le_less_trans)
  hence "f(n) < n+1" by (metis fff lift_Suc_mono_less_iff[of f] Suc_eq_plus1)
  with \<open>n \<le> f(n)\<close> show "f n = n" by arith
qed

text\<open>See \<^cite>\<open>"Tao2006"\<close>. Possible extension:
Should also hold if the range of \<open>f\<close> is the reals!
\<close>

lemma identity2: fixes f :: "nat \<Rightarrow> nat"
assumes "f(k) = k" and "k \<ge> 2"
and f_times: "\<And>m n. f(m*n) = f(m)*f(n)"
and f_mono: "\<And>m n. m<n \<Longrightarrow> f m < f n"
shows "f(n) = n"
proof -
  have 0: "f(0) = 0"
    by (metis f_mono f_times mult_1_right mult_is_0 nat_less_le nat_mult_eq_cancel_disj not_less_eq)
  have 1: "f(1) = 1"
    by (metis f_mono f_times gr_implies_not0 mult_eq_self_implies_10 nat_mult_1_right zero_less_one)
  have 2: "f 2 = 2"
  proof -
    have "2 + (k - 2) = k" using \<open>k \<ge> 2\<close> by arith
    hence "f(2) \<le> 2"
      using mono_nat_linear_lb[of f 2 "k - 2",OF f_mono] \<open>f k = k\<close>
      by simp
    thus "f 2 = 2" using 1 f_mono[of 1 2] by arith
  qed
  show ?thesis
  proof(induct rule:less_induct)
    case (less i)
    show ?case
    proof cases
      assume "i\<le>1" thus ?case using 0 1 by (auto simp add:le_Suc_eq)
    next
      assume "~i\<le>1"
      show ?case
      proof cases
        assume "i mod 2 = 0"
        hence "\<exists>k. i=2*k" by arith
        then obtain k where "i = 2*k" ..
        hence "0 < k" and "k<i" using \<open>~i\<le>1\<close> by arith+
        hence "f(k) = k" using less(1) by blast
        thus "f(i) = i" using \<open>i = 2*k\<close> by(simp add:f_times 2)
      next
        assume "i mod 2 \<noteq> 0"
        hence "\<exists>k. i=2*k+1" by arith
        then obtain k where "i = 2*k+1" ..
        hence "0<k" and "k+1<i" using \<open>~i\<le>1\<close> by arith+
        have "2*k < f(2*k+1)"
        proof -
          have "2*k = 2*f(k)" using less(1) \<open>i=2*k+1\<close> by simp
          also have "\<dots> = f(2*k)" by(simp add:f_times 2)
          also have "\<dots> < f(2*k+1)" using f_mono[of "2*k" "2*k+1"] by simp
          finally show ?thesis .
        qed
        moreover
        have "f(2*k+1) < 2*(k+1)"
        proof -
          have "f(2*k+1) < f(2*k+2)" using f_mono[of "2*k+1" "2*k+2"] by simp
          also have "\<dots> = f(2*(k+1))" by simp
          also have "\<dots> = 2*f(k+1)" by(simp only:f_times 2)
          also have "f(k+1) = k+1" using less(1) \<open>i=2*k+1\<close> \<open>~i\<le>1\<close> by simp
          finally show ?thesis .
        qed
        ultimately show "f(i) = i" using \<open>i = 2*k+1\<close> by arith
      qed
    qed
  qed
qed

text\<open>One more from Tao's booklet. If \<open>f\<close> is also assumed to be
continuous, @{term"f(x::real) = x+1"} holds for all reals, not only
rationals. Extend the proof!\<close>

theorem plus1:
fixes f :: "real \<Rightarrow> real"
assumes 0: "f 0 = 1" and f_add: "\<And>x y. f(x+y+1) = f x + f y"

assumes "r : \<rat>" shows "f(r) = r + 1"
proof -
  { fix i have "f(of_int i) = of_int i + 1"
    proof (induct i rule: int_induct [where k=0])
      case base show ?case using 0 by simp
    next
      case (step1 i)
      have "f(of_int (i+1)) = f(of_int i + 0 + 1)" by simp
      also have "\<dots> = f(of_int i) + f 0" by(rule f_add)
      also have "\<dots> = of_int (i+1) + 1" using step1 0 by simp
      finally show ?case .
    next
      case (step2 i)
      have "f(of_int i) = f(of_int (i - 1) + 0 + 1)" by simp
      also have "\<dots> = f(of_int (i - 1)) + f 0" by(rule f_add)
      also have "\<dots> = f(of_int (i - 1)) + 1 " using 0 by simp
      finally show ?case using step2 by simp
    qed }
  note f_int = this
  { fix n r have "f(of_int (Suc n)*r + of_int n) = of_int (Suc n) * f r"
    proof(induct n)
      case 0 show ?case by simp
    next
      case (Suc n)
      have "of_int (Suc(Suc n))*r + of_int (Suc n) =
            r + (of_int (Suc n)*r + of_int n) + 1" (is "?a = ?b")
        by(simp add: field_simps)
      hence "f ?a = f ?b"
        by presburger
      also have "\<dots> = f r + f(of_int (Suc n)*r + of_int n)" by(rule f_add)
      also have "\<dots> = f r + of_int (Suc n) * f r" by(simp only:Suc)
      finally show ?case by(simp add: field_simps)
    qed }
  note 1 = this
  { fix n::nat and r assume "n\<noteq>0"
    have "f(of_int (n)*r + of_int (n - 1)) = of_int (n) * f r"
    proof(cases n)
      case 0 thus ?thesis using \<open>n\<noteq>0\<close> by simp
    next
      case Suc thus ?thesis using \<open>n\<noteq>0\<close> using "1" by auto
    qed }
  note f_mult = this
  from \<open>r:\<rat>\<close> obtain i::int and n::nat where r: "r = of_int i/of_int n" and "n\<noteq>0"
    by(fastforce simp:Rats_eq_int_div_nat)
  have "of_int (n) * f(of_int i / of_int n) = f(of_int i + of_int (n - 1))"
    using \<open>n\<noteq>0\<close>
    by (metis (no_types, opaque_lifting) f_mult mult.commute nonzero_divide_eq_eq of_int_of_nat_eq of_nat_0_eq_iff)
  also have "\<dots> = f(of_int (i + int n - 1))" using \<open>n\<noteq>0\<close>[simplified]
    by (metis One_nat_def Suc_leI of_nat_1 add_diff_eq of_int_add of_nat_diff)
  also have "\<dots> = of_int (i + int n - 1) + 1" by(rule f_int)
  also have "\<dots> = of_int i + of_int n" by arith
  finally show ?thesis using \<open>n\<noteq>0\<close> unfolding r by (simp add:field_simps)
qed

text\<open>The only total model of a naive recursion equation of factorial on
integers is 0 for all negative arguments. Probably folklore.\<close>

theorem ifac_neg0: fixes ifac :: "int \<Rightarrow> int"
assumes ifac_rec: "\<And>i. ifac i = (if i=0 then 1 else i*ifac(i - 1))"
shows "i<0 \<Longrightarrow> ifac i = 0"
proof(rule ccontr)
  assume 0: "i<0" "ifac i \<noteq> 0"
  { fix j assume "j \<le> i"
    have "ifac j \<noteq> 0"
      apply(rule int_le_induct[OF \<open>j\<le>i\<close>])
       apply(rule \<open>ifac i \<noteq> 0\<close>)
      apply (metis \<open>i<0\<close> ifac_rec linorder_not_le mult_eq_0_iff)
      done
  } note below0 = this
  { fix j assume "j<i"
    have "1 < -j" using \<open>j<i\<close> \<open>i<0\<close> by arith
    have "ifac(j - 1) \<noteq> 0" using \<open>j<i\<close> by(simp add: below0)
    then have "\<bar>ifac (j - 1)\<bar> < (-j) * \<bar>ifac (j - 1)\<bar>" using \<open>j<i\<close>
      mult_le_less_imp_less[OF order_refl[of "abs(ifac(j - 1))"] \<open>1 < -j\<close>]
      by(simp add:mult.commute)
    hence "abs(ifac(j - 1)) < abs(ifac j)"
      using \<open>1 < -j\<close> by(simp add: ifac_rec[of "j"] abs_mult)
  } note not_wf = this
  let ?f = "%j. nat(abs(ifac(i - int(j+1))))"
  obtain k where "\<not> ?f (Suc k) < ?f k"
    using wf_no_infinite_down_chainE[OF wf_less, of "?f"] by blast
  moreover have "i - int (k + 1) - 1 = i - int (Suc k + 1)" by arith
  ultimately show False using not_wf[of "i - int(k+1)"]
    by (simp only:) arith
qed

end


(*
  File:    Linear_Homogenous_Recurrences.thy
  Author:  Manuel Eberl, TU München
*)
section \<open>Homogenous linear recurrences\<close>
theory Linear_Homogenous_Recurrences
imports
  Complex_Main
  RatFPS
  Rational_FPS_Solver
  Linear_Recurrences_Common
begin

text \<open>
  The following is the numerator of the rational generating function of a
  linear homogenous recurrence.
\<close>
definition lhr_fps_numerator where
  "lhr_fps_numerator m cs f = (let N = length cs - 1 in
      Poly [(\<Sum>i\<le>min N k. cs ! (N - i) * f (k - i)). k \<leftarrow> [0..<N+m]])"

lemma lhr_fps_numerator_code [code abstract]:
  "coeffs (lhr_fps_numerator m cs f) = (let N = length cs - 1 in
     strip_while ((=) 0) [(\<Sum>i\<le>min N k. cs ! (N - i) * f (k - i)). k \<leftarrow> [0..<N+m]])"
  by (simp add: lhr_fps_numerator_def Let_def)

lemma lhr_fps_aux:
  fixes f :: "nat \<Rightarrow> 'a :: field"
  assumes "\<And>n. n \<ge> m \<Longrightarrow> (\<Sum>k\<le>N. c k * f (n + k)) = 0"
  assumes cN: "c N \<noteq> 0"
  defines "p \<equiv> Poly [c (N - k). k \<leftarrow> [0..<Suc N]]"
  defines "q \<equiv> Poly [(\<Sum>i\<le>min N k. c (N - i) * f (k - i)). k \<leftarrow> [0..<N+m]]"
  shows   "Abs_fps f = fps_of_poly q / fps_of_poly p"
proof -
  include fps_notation
  define F where "F = Abs_fps f"
  have [simp]: "F $ n = f n" for n by (simp add: F_def)
  have [simp]: "coeff p 0 = c N"
    by (simp add: p_def nth_default_def del: upt_Suc)

  have "(fps_of_poly p * F) $ n = coeff q n" for n
  proof (cases "n \<ge> N + m")
    case True
    let ?f = "\<lambda>i. N - i"
    have "(fps_of_poly p * F) $ n = (\<Sum>i\<le>n. coeff p i * f (n - i))"
      by (simp add: fps_mult_nth atLeast0AtMost)
    also from True have "\<dots> = (\<Sum>i\<le>N. coeff p i * f (n - i))"
      by (intro sum.mono_neutral_right) (auto simp: nth_default_def p_def)
    also have "\<dots> = (\<Sum>i\<le>N. c (N - i) * f (n - i))"
      by (intro sum.cong) (auto simp: nth_default_def p_def simp del: upt_Suc)
    also from True have "\<dots> = (\<Sum>i\<le>N. c i * f (n - N + i))"
      by (intro sum.reindex_bij_witness[of _ ?f ?f]) auto
    also from True have "\<dots> = 0" by (intro assms) simp_all
    also from True have "\<dots> = coeff q n"
      by (simp add: q_def nth_default_def del: upt_Suc)
    finally show ?thesis .
  next
    case False
    hence "(fps_of_poly p * F) $ n = (\<Sum>i\<le>n. coeff p i * f (n - i))"
      by (simp add: fps_mult_nth atLeast0AtMost)
    also have "\<dots> = (\<Sum>i\<le>min N n. coeff p i * f (n - i))"
      by (intro sum.mono_neutral_right)
         (auto simp: p_def nth_default_def simp del: upt_Suc)
    also have "\<dots> = (\<Sum>i\<le>min N n. c (N - i) * f (n - i))"
      by (intro sum.cong) (simp_all add: p_def nth_default_def del: upt_Suc)
    also from False have "\<dots> = coeff q n" by (simp add: q_def nth_default_def)
    finally show ?thesis .
  qed
  hence "fps_of_poly p * F = fps_of_poly q"
    by (intro fps_ext) simp
  with cN show "F = fps_of_poly q / fps_of_poly p"
    by (subst unit_eq_div2) (simp_all add: mult_ac)
qed

lemma lhr_fps:
  fixes f :: "nat \<Rightarrow> 'a :: field" and cs :: "'a list"
  defines "N \<equiv> length cs - 1"
  assumes cs: "cs \<noteq> []"
  assumes "\<And>n. n \<ge> m \<Longrightarrow> (\<Sum>k\<le>N. cs ! k * f (n + k)) = 0"
  assumes cN: "last cs \<noteq> 0"
  shows   "Abs_fps f = fps_of_poly (lhr_fps_numerator m cs f) /
              fps_of_poly (lr_fps_denominator cs)"
proof -
  define p and q
    where "p = Poly (map (\<lambda>k. \<Sum>i\<le>min N k. cs ! (N - i) * f (k - i)) [0..<N + m])"
      and "q = Poly (map (\<lambda>k. cs ! (N - k)) [0..<Suc N])"

  from assms have "Abs_fps f = fps_of_poly p / fps_of_poly q" unfolding p_def q_def
    by (intro lhr_fps_aux) (simp_all add: last_conv_nth)
  also have "p = lhr_fps_numerator m cs f"
    unfolding p_def lhr_fps_numerator_def by (auto simp: Let_def N_def)
  also from cN have "q = lr_fps_denominator cs"
    unfolding q_def lr_fps_denominator_def
    by (intro poly_eqI)
       (auto simp add: nth_default_def rev_nth N_def not_less cs simp del: upt_Suc)
  finally show ?thesis .
qed

(* TODO: Do I even need this? *)
fun lhr where
  "lhr cs fs n =
     (if (cs :: 'a :: field list) = [] \<or> last cs = 0 \<or> length fs < length cs - 1 then undefined else
     (if n < length fs then fs ! n else
          (\<Sum>k<length cs - 1. cs ! k * lhr cs fs (n + 1 - length cs + k)) / -last cs))"

declare lhr.simps [simp del]

lemma lhr_rec:
  assumes "cs \<noteq> []" "last cs \<noteq> 0" "length fs \<ge> length cs - 1" "n \<ge> length fs"
  shows   "(\<Sum>k<length cs. cs ! k * lhr cs fs (n + 1 - length cs + k)) = 0"
proof -
  from assms have "{..<length cs} = insert (length cs - 1) {..<length cs - 1}" by auto
  also have "(\<Sum>k\<in>\<dots> . cs ! k * lhr cs fs (n + 1 - length cs + k)) =
               (\<Sum>k<length cs - 1. cs ! k * lhr cs fs (n + 1 - length cs + k)) +
                    last cs * lhr cs fs n" using assms
    by (cases cs) (simp_all add: algebra_simps last_conv_nth)
  also from assms have "\<dots> = 0" by (subst (2) lhr.simps) (simp_all add: field_simps)
  finally show ?thesis .
qed

lemma lhrI:
  assumes "cs \<noteq> []" "last cs \<noteq> 0" "length fs \<ge> length cs - 1"
  assumes "\<And>n. n < length fs \<Longrightarrow> f n = fs ! n"
  assumes "\<And>n. n \<ge> length fs \<Longrightarrow> (\<Sum>k<length cs. cs ! k * f (n + 1 - length cs + k)) = 0"
  shows   "f n = lhr cs fs n"
using assms
proof (induction cs fs n rule: lhr.induct)
  case (1 cs fs n)
  show ?case
  proof (cases "n < length fs")
    case False
    with 1 have "0 = (\<Sum>k<length cs. cs ! k * f (n + 1 - length cs + k))" by simp
    also from 1 have "{..<length cs} = insert (length cs - 1) {..<length cs - 1}" by auto
    also have "(\<Sum>k\<in>\<dots> . cs ! k * f (n + 1 - length cs + k)) =
                 (\<Sum>k<length cs - 1. cs ! k * f (n + 1 - length cs + k)) +
                      last cs * f n" using 1 False
      by (cases cs) (simp_all add: algebra_simps last_conv_nth)
    also have "(\<Sum>k<length cs - 1. cs ! k * f (n + 1 - length cs + k)) =
                   (\<Sum>k<length cs - 1. cs ! k * lhr cs fs (n + 1 - length cs + k))"
      using False 1 by (intro sum.cong refl) simp
    finally have "f n = (\<Sum>k<length cs - 1. cs ! k * lhr cs fs (n + 1 - length cs + k)) / -last cs"
      using \<open>last cs \<noteq> 0\<close> by (simp add: field_simps eq_neg_iff_add_eq_0)
  also from 1(2-4) False have "\<dots> = lhr cs fs n" by (subst lhr.simps) simp
    finally show ?thesis .
  qed (insert 1(2-5), simp add: lhr.simps)
qed
(* END TODO *)

locale linear_homogenous_recurrence =
  fixes f :: "nat \<Rightarrow> 'a :: comm_semiring_0" and cs fs :: "'a list"
  assumes base: "n < length fs \<Longrightarrow> f n = fs ! n"
  assumes cs_not_null [simp]: "cs \<noteq> []" and last_cs [simp]: "last cs \<noteq> 0"
      and hd_cs [simp]: "hd cs \<noteq> 0" and enough_base: "length fs + 1 \<ge> length cs"
  assumes rec:  "n \<ge> length fs - length cs \<Longrightarrow> (\<Sum>k<length cs. cs ! k * f (n + k)) = 0"
begin

lemma lhr_fps_numerator_altdef:
  "lhr_fps_numerator (length fs + 1 - length cs) cs f =
     lhr_fps_numerator (length fs + 1 - length cs) cs ((!) fs)"
proof -
  define N where "N = length cs - 1"
  define m where "m = length fs + 1 - length cs"
  have "lhr_fps_numerator m cs f =
          Poly (map (\<lambda>k. (\<Sum>i\<le>min N k. cs ! (N - i) * f (k - i))) [0..<N + m])"
    by (simp add: lhr_fps_numerator_def Let_def N_def)
  also from enough_base have "N + m = length fs"
    by (cases cs) (simp_all add: N_def m_def algebra_simps)
  also {
    fix k assume k: "k \<in> {0..<length fs}"
    hence "f (k - i) = fs ! (k - i)" if "i \<le> min N k" for i
      using enough_base that by (intro base) (auto simp: Suc_le_eq N_def m_def algebra_simps)
    hence "(\<Sum>i\<le>min N k. cs ! (N - i) * f (k - i)) = (\<Sum>i\<le>min N k. cs ! (N - i) * fs ! (k - i))"
      by simp
  }
  hence "map (\<lambda>k. (\<Sum>i\<le>min N k. cs ! (N - i) * f (k - i))) [0..<length fs] =
           map (\<lambda>k. (\<Sum>i\<le>min N k. cs ! (N - i) * fs ! (k - i))) [0..<length fs]"
    by (intro map_cong) simp_all
  also have "Poly \<dots> = lhr_fps_numerator m cs ((!) fs)" using enough_base
    by (cases cs) (simp_all add: lhr_fps_numerator_def Let_def m_def N_def)
  finally show ?thesis unfolding m_def .
qed

end

(* TODO Duplication *)
lemma solve_lhr_aux:
  assumes "linear_homogenous_recurrence f cs fs"
  assumes "is_factorization_of fctrs (lr_fps_denominator' cs)"
  shows   "f = interp_ratfps_solution (solve_factored_ratfps' (lhr_fps_numerator
                  (length fs + 1 - length cs) cs ((!) fs)) fctrs)"
proof -
  interpret linear_homogenous_recurrence f cs fs by fact

  note assms(2)
  hence "is_alt_factorization_of fctrs (reflect_poly (lr_fps_denominator' cs))"
    by (intro reflect_factorization)
       (simp_all add: lr_fps_denominator'_def
                      nth_default_def hd_conv_nth [symmetric])
  also have "reflect_poly (lr_fps_denominator' cs) = lr_fps_denominator cs"
    unfolding lr_fps_denominator_def lr_fps_denominator'_def
    by (subst coeffs_eq_iff) (simp add: coeffs_reflect_poly strip_while_rev [symmetric]
                                 no_trailing_unfold last_rev del: strip_while_rev)
  finally have factorization: "is_alt_factorization_of fctrs (lr_fps_denominator cs)" .

  define m where "m = length fs + 1 - length cs"
  obtain a ds where fctrs: "fctrs = (a, ds)" by (cases fctrs) simp_all
  define p and p' where "p = lhr_fps_numerator m cs ((!) fs)" and "p' = smult (inverse a) p"
  obtain b es where sol: "solve_factored_ratfps' p fctrs = (b, es)"
    by (cases "solve_factored_ratfps' p fctrs") simp_all
  have sol': "(b, es) = solve_factored_ratfps p' ds"
    by (subst sol [symmetric]) (simp add: fctrs p'_def solve_factored_ratfps_def
                                          solve_factored_ratfps'_def case_prod_unfold)
  have factorization': "lr_fps_denominator cs = interp_alt_factorization fctrs"
    using factorization by (simp add: is_alt_factorization_of_def)
  from assms(2) have distinct: "distinct (map fst ds)"
    by (simp add: fctrs is_factorization_of_def)
  have coeff_0_denom: "coeff (lr_fps_denominator cs) 0 \<noteq> 0"
    by (simp add: lr_fps_denominator_def nth_default_def
                  hd_conv_nth [symmetric] hd_rev)
  have "coeff (lr_fps_denominator' cs) 0 \<noteq> 0"
    by (simp add: lr_fps_denominator'_def nth_default_def hd_conv_nth [symmetric])
  with assms(2) have no_zero: "0 \<notin> fst ` set ds" by (simp add: zero_in_factorization_iff fctrs)

  from assms(2) have a_nz [simp]: "a \<noteq> 0"
    by (auto simp: fctrs interp_factorization_def is_factorization_of_def lr_fps_denominator'_nz)
  hence unit1: "is_unit (fps_const a)" by simp
  moreover have "is_unit (fps_of_poly (interp_alt_factorization fctrs))"
    by (simp add: coeff_0_denom factorization' [symmetric])
  ultimately have unit2: "is_unit (fps_of_poly (\<Prod>p\<leftarrow>ds. [:1, - fst p:] ^ Suc (snd p)))"
    by (simp add: fctrs case_prod_unfold interp_alt_factorization_def del: power_Suc)

  have "Abs_fps f = fps_of_poly (lhr_fps_numerator m cs f) /
                        fps_of_poly (lr_fps_denominator cs)"
  proof (intro lhr_fps)
    fix n assume n: "n \<ge> m"
    have "{..length cs - 1} = {..<length cs}" by (cases cs) auto
    also from n have "(\<Sum>k\<in>\<dots> . cs ! k * f (n + k)) = 0"
      by (intro rec) (simp_all add: m_def algebra_simps)
    finally show "(\<Sum>k\<le>length cs - 1. cs ! k * f (n + k)) = 0" .
  qed (simp_all add: m_def)
  also have "lhr_fps_numerator m cs f = lhr_fps_numerator m cs ((!) fs)"
    unfolding lhr_fps_numerator_def using enough_base
    by (auto simp: Let_def poly_eq_iff nth_default_def base
                   m_def Suc_le_eq intro!: sum.cong)
  also have "fps_of_poly \<dots> / fps_of_poly (lr_fps_denominator cs) =
               fps_of_poly (lhr_fps_numerator m cs ((!) fs)) /
                 (fps_const (fst fctrs) *
                   fps_of_poly (\<Prod>p\<leftarrow>snd fctrs. [:1, - fst p:] ^ Suc (snd p)))"
    unfolding assms factorization' interp_alt_factorization_def
    by (simp add: case_prod_unfold Let_def fps_of_poly_smult)
  also from unit1 unit2 have "\<dots> = fps_of_poly p / fps_const a /
                                     fps_of_poly (\<Prod>(c,n)\<leftarrow>ds. [:1, -c:]^Suc n)"
    by (subst is_unit_div_mult2_eq) (simp_all add: fctrs case_prod_unfold p_def)
  also from unit1 have "fps_of_poly p / fps_const a = fps_of_poly p'"
    by (simp add: fps_divide_unit fps_of_poly_smult fps_const_inverse p'_def)
  also from distinct no_zero have "\<dots> / fps_of_poly (\<Prod>(c,n)\<leftarrow>ds. [:1, -c:]^Suc n) =
      Abs_fps (interp_ratfps_solution (solve_factored_ratfps' p fctrs))"
    by (subst solve_factored_ratfps) (simp_all add: case_prod_unfold sol' sol)
  finally show ?thesis unfolding p_def m_def
    by (intro ext) (simp add: fps_eq_iff)
qed

definition
  "lhr_fps as fs = (
     let m = length fs + 1 - length as;
         p = lhr_fps_numerator m as (\<lambda>n. fs ! n);
         q = lr_fps_denominator as
     in  ratfps_of_poly p / ratfps_of_poly q)"

lemma lhr_fps_correct:
  fixes   f :: "nat \<Rightarrow> 'a :: {field_char_0,field_gcd}"
  assumes "linear_homogenous_recurrence f cs fs"
  shows   "fps_of_ratfps (lhr_fps cs fs) = Abs_fps f"
proof -
  interpret linear_homogenous_recurrence f cs fs by fact
  define m where "m = length fs + 1 - length cs"
  let ?num = "lhr_fps_numerator m cs f"
  let ?num' = "lhr_fps_numerator m cs ((!) fs)"
  let ?denom = "lr_fps_denominator cs"

  have "{..length cs - 1} = {..<length cs}" by (cases cs) auto
  moreover have "length cs \<ge> 1" by (cases cs) auto
  ultimately have "Abs_fps f = fps_of_poly ?num / fps_of_poly ?denom"
    by (intro lhr_fps) (insert rec, simp_all add: m_def)
  also have "?num = ?num'"
    by (rule lhr_fps_numerator_altdef [folded m_def])
  also have "fps_of_poly ?num' / fps_of_poly ?denom =
                fps_of_ratfps (ratfps_of_poly ?num' / ratfps_of_poly ?denom)"
    by simp
  also from enough_base have "\<dots> = fps_of_ratfps (lhr_fps cs fs)"
    by (cases cs)  (simp_all add: base fps_of_ratfps_def case_prod_unfold lhr_fps_def m_def)
  finally show ?thesis ..
qed

end


section \<open>Quantales\<close>

theory Quantale_iso
  imports Main
  "HOL-Library.Lattice_Syntax"

begin

notation times (infixl "\<cdot>" 70)

class quantale = complete_lattice + monoid_mult +
  assumes Sup_distl: "x \<cdot> \<Squnion>Y = (\<Squnion>y \<in> Y. x \<cdot> y)"
  assumes Sup_distr: "\<Squnion>X \<cdot> y = (\<Squnion>x \<in> X. x \<cdot> y)"

subsection \<open>Relational Model of Kleene algebra\<close>

notation relcomp (infixl ";" 70)

interpretation rel_quantale: quantale Inf Sup inf "(\<subseteq>)" "(\<subset>)" sup "{}" "UNIV" Id "(;)"
  by (unfold_locales, auto)

subsection \<open>State Transformer Model of Kleene Algebra\<close>

type_synonym 'a sta = "'a \<Rightarrow> 'a set"

definition eta :: "'a sta" ("\<eta>") where
  "\<eta> x = {x}"

definition nsta :: "'a sta" ("\<nu>") where
  "\<nu> x = {}"

definition tsta :: "'a sta" ("\<tau>") where
  "\<tau> x = UNIV"

definition kcomp :: "'a sta \<Rightarrow> 'a sta \<Rightarrow> 'a sta" (infixl "\<circ>\<^sub>K" 75) where
  "(f \<circ>\<^sub>K g) x = \<Union>{g y |y. y \<in> f x}"

definition kSup :: "'a sta set \<Rightarrow> 'a sta" where
  "(kSup F) x = \<Union>{f x |f. f \<in> F}"

definition kInf :: "'a sta set \<Rightarrow> 'a sta" where
  "(kInf F) x = \<Inter>{f x |f. f \<in> F}"

definition ksup :: "'a sta \<Rightarrow> 'a sta \<Rightarrow> 'a sta" where
  "(ksup f g) x = f x \<union> g x"

definition kinf :: "'a sta \<Rightarrow> 'a sta \<Rightarrow> 'a sta" where
  "(kinf f g) x = f x \<inter> g x"

definition kleq :: "'a sta \<Rightarrow> 'a sta \<Rightarrow> bool" (infix "\<sqsubseteq>" 50) where
  "f \<sqsubseteq> g = (\<forall>x. f x \<subseteq> g x)"

definition kle :: "'a sta \<Rightarrow> 'a sta \<Rightarrow> bool" (infix "\<sqsubset>" 50) where
  "f \<sqsubset> g = (f \<sqsubseteq> g \<and> f \<noteq> g)"

subsection \<open>Bijections between the relations and state transformers\<close>

definition r2s :: "'a rel \<Rightarrow> 'a sta" ("\<S>") where
  "\<S> R = Image R \<circ> \<eta>"

definition s2r :: "'a sta \<Rightarrow> 'a rel" ("\<R>") where
  "\<R> f = {(x,y). y \<in> f x}"

lemma r2s2r_galois: "(\<R> f = R) = (\<S> R = f)"
  by (force simp: s2r_def eta_def r2s_def)

lemma r2s_bij: "bij \<S>"
  by (metis bij_def inj_def r2s2r_galois surj_def)

lemma s2r_bij: "bij \<R>"
  by (metis bij_def inj_def r2s2r_galois surj_def)

subsection \<open>Type definition and lifting for bijections\<close>

lemma type_definition_s2r_r2s: "type_definition \<R> \<S> UNIV"
  unfolding type_definition_def by (meson iso_tuple_UNIV_I r2s2r_galois)

definition "rel_s2r R f = (R = \<R> f)"

lemma bi_unique_rel_s2r [transfer_rule]: "bi_unique rel_s2r"
  by (metis rel_s2r_def type_definition_s2r_r2s typedef_bi_unique)

lemma bi_total_rel_s2r [transfer_rule]: "bi_total rel_s2r"
  by (metis bi_total_def r2s2r_galois rel_s2r_def)

subsection \<open>Transfer functions\<close>

lemma r2s_id: "\<R> \<eta> = Id"
  unfolding s2r_def Id_def eta_def by force

lemma Id_eta_transfer [transfer_rule]: "rel_s2r Id \<eta>"
  unfolding rel_s2r_def
  by (simp add: r2s_id rel_s2r_def)

lemma r2s_zero: "\<R> \<nu> = {}"
  by (simp add: s2r_def nsta_def)

lemma emp_nsta_transfer [transfer_rule]: "rel_s2r {} \<nu>"
  by (simp add: r2s_zero rel_s2r_def)

lemma r2s_tau: "\<R> \<tau> = UNIV"
  unfolding s2r_def tsta_def by simp

lemma UNIV_tsta_transfer [transfer_rule]: "rel_s2r UNIV \<tau>"
  by (simp add: r2s_tau rel_s2r_def)

lemma r2s_comp: "\<R> (f \<circ>\<^sub>K g) = \<R> f ; \<R> g"
  unfolding s2r_def kcomp_def by force

lemma relcomp_kcomp_transfer [transfer_rule]: "rel_fun rel_s2r (rel_fun rel_s2r rel_s2r) (;) (\<circ>\<^sub>K)"
  by (metis r2s_comp rel_funI rel_s2r_def)

lemma s2r_kSup: "\<R> (kSup F) = \<Union>(image \<R> F)"
  unfolding s2r_def kSup_def by force

lemma Un_kSup_transfer [transfer_rule]: "rel_fun (rel_set rel_s2r) rel_s2r Union kSup"
  unfolding rel_s2r_def rel_fun_def rel_set_def s2r_kSup by fastforce

lemma s2r_kInf: "\<R> (kInf F) = \<Inter>(image \<R> F)"
  unfolding s2r_def kInf_def by force

lemma Un_kInf_transfer [transfer_rule]: "rel_fun (rel_set rel_s2r) rel_s2r Inter kInf"
  unfolding rel_s2r_def rel_fun_def rel_set_def s2r_kInf by fastforce

lemma s2r_ksup: "\<R> (ksup f g) = \<R> f \<union> \<R> g"
  unfolding s2r_def ksup_def by force

lemma un_ksup_transfer [transfer_rule]: "rel_fun rel_s2r (rel_fun rel_s2r rel_s2r) (\<union>) (ksup)"
  by (metis rel_funI rel_s2r_def s2r_ksup)

lemma s2r_kinf: "\<R> (kinf f g) = \<R> f \<inter> \<R> g"
  unfolding s2r_def kinf_def by force

lemma in_kinf_transfer [transfer_rule]: "rel_fun rel_s2r (rel_fun rel_s2r rel_s2r) (\<inter>) (kinf)"
  by (metis rel_funI rel_s2r_def s2r_kinf)

lemma leq_kleq_transfer [transfer_rule]: "rel_fun rel_s2r (rel_fun rel_s2r (=)) (\<subseteq>) (\<sqsubseteq>)"
  unfolding kleq_def s2r_def rel_s2r_def by force

lemma le_kle_transfer [transfer_rule]: "rel_fun rel_s2r (rel_fun rel_s2r (=)) (\<subset>) (\<sqsubset>)"
  unfolding kle_def kleq_def s2r_def rel_s2r_def by blast

text \<open>State transformer model of Kleene algebra\<close>

interpretation sta_quantale: quantale kInf kSup kinf "(\<sqsubseteq>)" "(\<sqsubset>)" ksup "\<nu>" tsta "\<eta>" "(\<circ>\<^sub>K)"
  by unfold_locales (transfer, force)+

end


text\<open>
Formal Languages and Automata Theory (FLAT)
according to the book with same name (2nd version) by Zongli Jiang
created by Yongwang Zhao (zhaoyw@buaa.edu.cn)
School of Computer Science and Engineering, Beihang University, Beijing, China
\<close>

section\<open>3. Finite Automaton\<close>

subsection\<open>3.3: nondeterministic finite automaton\<close>

theory NFA
imports AutoProj
begin

subsubsection\<open>definition 3-7: nondeterministic finite automaton\<close>

text\<open>
M = <Q,\<Sigma>,\<delta>,q0,F>
Q: states, represented as 's
\<Sigma>: input alphabet, represented as 'a
\<delta>: transition function
q0: initial state
F: final states
nfa defined as below is a triple <q0,\<delta>,F>
\<close>
type_synonym ('a,'s) nfa = "'s * ('a \<Rightarrow> 's \<Rightarrow> 's set) * ('s set)"

abbreviation "q0 \<equiv> start"
abbreviation "\<delta> \<equiv> next"
abbreviation "F \<equiv> fin"

primrec \<delta>' :: "('a,'s)nfa \<Rightarrow> 'a list \<Rightarrow> 's \<Rightarrow> 's set" where
"\<delta>' A []    p = {p}" |
"\<delta>' A (a#w) p = \<Union>(\<delta>' A w ` \<delta> A a p)"

subsubsection\<open>definition 3-8: accepted language\<close>
definition
 accepts :: "('a,'s)nfa \<Rightarrow> 'a list \<Rightarrow> bool" where
"accepts A w = (\<exists>q \<in> \<delta>' A w (q0 A). q \<in> F A)"

type_synonym 'a lang = "'a list set"

definition NFALang :: "('a,'s)nfa \<Rightarrow> 'a lang"
  where "NFALang m \<equiv> {x. accepts m x}"

definition
 step :: "('a,'s)nfa \<Rightarrow> 'a \<Rightarrow> ('s * 's)set" where
"step A a = {(p,q) . q \<in> \<delta> A a p}"

primrec steps :: "('a,'s)nfa \<Rightarrow> 'a list \<Rightarrow> ('s * 's)set" where
"steps A [] = Id" |
"steps A (a#w) = step A a O steps A w"

lemma steps_append[simp]:
 "steps A (v@w) = steps A v  O  steps A w"
by(induct v, simp_all add:O_assoc)

lemma in_steps_append[iff]:
  "(p,r) : steps A (v@w) = ((p,r) : (steps A v O steps A w))"
apply(rule steps_append[THEN equalityE])
apply blast
done

lemma delta_conv_steps: "\<And>p. \<delta>' A w p = {q. (p,q) \<in> steps A w}"
by(induct w)(auto simp:step_def)

lemma accepts_conv_steps:
 "accepts A w = (\<exists>q. (q0 A,q) \<in> steps A w \<and> q \<in> F A)"
by(simp add: delta_conv_steps accepts_def)

abbreviation
  Cons_syn :: "'a \<Rightarrow> 'a list set \<Rightarrow> 'a list set" (infixr "##" 65) where
  "x ## S \<equiv> Cons x ` S"

end


(* Author: Tobias Nipkow *)

section \<open>Function \textit{lookup} for Tree2\<close>

theory Lookup2
imports
  Tree2
  Cmp
  Map_by_Ordered
begin

fun lookup :: "('a::linorder * 'b, 'c) tree \<Rightarrow> 'a \<Rightarrow> 'b option" where
"lookup Leaf x = None" |
"lookup (Node _ l (a,b) r) x =
  (case cmp x a of LT \<Rightarrow> lookup l x | GT \<Rightarrow> lookup r x | EQ \<Rightarrow> Some b)"

lemma lookup_map_of:
  "sorted1(inorder t) \<Longrightarrow> lookup t x = map_of (inorder t) x"
by(induction t) (auto simp: map_of_simps split: option.split)

end


(*  Title:      HOL/Induct/ABexp.thy
    Author:     Stefan Berghofer, TU Muenchen
*)

section \<open>Arithmetic and boolean expressions\<close>

theory ABexp
imports Main
begin

datatype 'a aexp =
    IF "'a bexp"  "'a aexp"  "'a aexp"
  | Sum "'a aexp"  "'a aexp"
  | Diff "'a aexp"  "'a aexp"
  | Var 'a
  | Num nat
and 'a bexp =
    Less "'a aexp"  "'a aexp"
  | And "'a bexp"  "'a bexp"
  | Neg "'a bexp"

text \<open>\medskip Evaluation of arithmetic and boolean expressions\<close>

primrec evala :: "('a \<Rightarrow> nat) \<Rightarrow> 'a aexp \<Rightarrow> nat"
  and evalb :: "('a \<Rightarrow> nat) \<Rightarrow> 'a bexp \<Rightarrow> bool"
where
  "evala env (IF b a1 a2) = (if evalb env b then evala env a1 else evala env a2)"
| "evala env (Sum a1 a2) = evala env a1 + evala env a2"
| "evala env (Diff a1 a2) = evala env a1 - evala env a2"
| "evala env (Var v) = env v"
| "evala env (Num n) = n"

| "evalb env (Less a1 a2) = (evala env a1 < evala env a2)"
| "evalb env (And b1 b2) = (evalb env b1 \<and> evalb env b2)"
| "evalb env (Neg b) = (\<not> evalb env b)"

text \<open>\medskip Substitution on arithmetic and boolean expressions\<close>

primrec substa :: "('a \<Rightarrow> 'b aexp) \<Rightarrow> 'a aexp \<Rightarrow> 'b aexp"
  and substb :: "('a \<Rightarrow> 'b aexp) \<Rightarrow> 'a bexp \<Rightarrow> 'b bexp"
where
  "substa f (IF b a1 a2) = IF (substb f b) (substa f a1) (substa f a2)"
| "substa f (Sum a1 a2) = Sum (substa f a1) (substa f a2)"
| "substa f (Diff a1 a2) = Diff (substa f a1) (substa f a2)"
| "substa f (Var v) = f v"
| "substa f (Num n) = Num n"

| "substb f (Less a1 a2) = Less (substa f a1) (substa f a2)"
| "substb f (And b1 b2) = And (substb f b1) (substb f b2)"
| "substb f (Neg b) = Neg (substb f b)"

lemma subst1_aexp:
  "evala env (substa (Var (v := a')) a) = evala (env (v := evala env a')) a"
and subst1_bexp:
  "evalb env (substb (Var (v := a')) b) = evalb (env (v := evala env a')) b"
    \<comment>  \<open>one variable\<close>
  by (induct a and b) simp_all

lemma subst_all_aexp:
  "evala env (substa s a) = evala (\<lambda>x. evala env (s x)) a"
and subst_all_bexp:
  "evalb env (substb s b) = evalb (\<lambda>x. evala env (s x)) b"
  by (induct a and b) auto

end


theory Scratch
  imports Main
begin

datatype mybool = MTrue | MFalse

fun myconj :: "mybool \<Rightarrow> mybool \<Rightarrow> mybool" where
  "myconj MTrue MTrue = MTrue" |
  "myconj _    _    = MFalse"

value "myconj MTrue MFalse"

datatype mynat = MZero | MSuc mynat

fun myadd :: "mynat \<Rightarrow> mynat \<Rightarrow> mynat" where
  "myadd MZero    r = r" |
  "myadd (MSuc l) r = MSuc(myadd l r)"
  (* "myadd (MSuc l) r = myadd l (MSuc r)" *)

lemma add_02: "myadd l MZero = l"
  apply(induction l)
   apply(auto)
  done

value "myadd (MSuc MZero) MZero"

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)"

value "rev(Cons True (Cons False Nil))"
value "rev(Cons a (Cons b Nil))"

end


(*  Title:      HOL/Power.thy
    Author:     Lawrence C Paulson, Cambridge University Computer Laboratory
    Copyright   1997  University of Cambridge
*)

section \<open>Exponentiation\<close>

theory Power
  imports Num
begin

subsection \<open>Powers for Arbitrary Monoids\<close>

class power = one + times
begin

primrec power :: "'a \<Rightarrow> nat \<Rightarrow> 'a"  (infixr "^" 80)
  where
    power_0: "a ^ 0 = 1"
  | power_Suc: "a ^ Suc n = a * a ^ n"

notation (latex output)
  power ("(_\<^bsup>_\<^esup>)" [1000] 1000)

text \<open>Special syntax for squares.\<close>
abbreviation power2 :: "'a \<Rightarrow> 'a"  ("(_\<^sup>2)" [1000] 999)
  where "x\<^sup>2 \<equiv> x ^ 2"

end

context monoid_mult
begin

subclass power .

lemma power_one [simp]: "1 ^ n = 1"
  by (induct n) simp_all

lemma power_one_right [simp]: "a ^ 1 = a"
  by simp

lemma power_Suc0_right [simp]: "a ^ Suc 0 = a"
  by simp

lemma power_commutes: "a ^ n * a = a * a ^ n"
  by (induct n) (simp_all add: mult.assoc)

lemma power_Suc2: "a ^ Suc n = a ^ n * a"
  by (simp add: power_commutes)

lemma power_add: "a ^ (m + n) = a ^ m * a ^ n"
  by (induct m) (simp_all add: algebra_simps)

lemma power_mult: "a ^ (m * n) = (a ^ m) ^ n"
  by (induct n) (simp_all add: power_add)

lemma power2_eq_square: "a\<^sup>2 = a * a"
  by (simp add: numeral_2_eq_2)

lemma power3_eq_cube: "a ^ 3 = a * a * a"
  by (simp add: numeral_3_eq_3 mult.assoc)

lemma power_even_eq: "a ^ (2 * n) = (a ^ n)\<^sup>2"
  by (subst mult.commute) (simp add: power_mult)

lemma power_odd_eq: "a ^ Suc (2*n) = a * (a ^ n)\<^sup>2"
  by (simp add: power_even_eq)

lemma power_numeral_even: "z ^ numeral (Num.Bit0 w) = (let w = z ^ (numeral w) in w * w)"
  by (simp only: numeral_Bit0 power_add Let_def)

lemma power_numeral_odd: "z ^ numeral (Num.Bit1 w) = (let w = z ^ (numeral w) in z * w * w)"
  by (simp only: numeral_Bit1 One_nat_def add_Suc_right add_0_right
      power_Suc power_add Let_def mult.assoc)

lemma funpow_times_power: "(times x ^^ f x) = times (x ^ f x)"
proof (induct "f x" arbitrary: f)
  case 0
  then show ?case by (simp add: fun_eq_iff)
next
  case (Suc n)
  define g where "g x = f x - 1" for x
  with Suc have "n = g x" by simp
  with Suc have "times x ^^ g x = times (x ^ g x)" by simp
  moreover from Suc g_def have "f x = g x + 1" by simp
  ultimately show ?case
    by (simp add: power_add funpow_add fun_eq_iff mult.assoc)
qed

lemma power_commuting_commutes:
  assumes "x * y = y * x"
  shows "x ^ n * y = y * x ^n"
proof (induct n)
  case 0
  then show ?case by simp
next
  case (Suc n)
  have "x ^ Suc n * y = x ^ n * y * x"
    by (subst power_Suc2) (simp add: assms ac_simps)
  also have "\<dots> = y * x ^ Suc n"
    by (simp only: Suc power_Suc2) (simp add: ac_simps)
  finally show ?case .
qed

lemma power_minus_mult: "0 < n \<Longrightarrow> a ^ (n - 1) * a = a ^ n"
  by (simp add: power_commutes split: nat_diff_split)

end

context comm_monoid_mult
begin

lemma power_mult_distrib [field_simps]: "(a * b) ^ n = (a ^ n) * (b ^ n)"
  by (induct n) (simp_all add: ac_simps)

end

text \<open>Extract constant factors from powers.\<close>
declare power_mult_distrib [where a = "numeral w" for w, simp]
declare power_mult_distrib [where b = "numeral w" for w, simp]

lemma power_add_numeral [simp]: "a^numeral m * a^numeral n = a^numeral (m + n)"
  for a :: "'a::monoid_mult"
  by (simp add: power_add [symmetric])

lemma power_add_numeral2 [simp]: "a^numeral m * (a^numeral n * b) = a^numeral (m + n) * b"
  for a :: "'a::monoid_mult"
  by (simp add: mult.assoc [symmetric])

lemma power_mult_numeral [simp]: "(a^numeral m)^numeral n = a^numeral (m * n)"
  for a :: "'a::monoid_mult"
  by (simp only: numeral_mult power_mult)

context semiring_numeral
begin

lemma numeral_sqr: "numeral (Num.sqr k) = numeral k * numeral k"
  by (simp only: sqr_conv_mult numeral_mult)

lemma numeral_pow: "numeral (Num.pow k l) = numeral k ^ numeral l"
  by (induct l)
    (simp_all only: numeral_class.numeral.simps pow.simps
      numeral_sqr numeral_mult power_add power_one_right)

lemma power_numeral [simp]: "numeral k ^ numeral l = numeral (Num.pow k l)"
  by (rule numeral_pow [symmetric])

end

context semiring_1
begin

lemma of_nat_power [simp]: "of_nat (m ^ n) = of_nat m ^ n"
  by (induct n) simp_all

lemma zero_power: "0 < n \<Longrightarrow> 0 ^ n = 0"
  by (cases n) simp_all

lemma power_zero_numeral [simp]: "0 ^ numeral k = 0"
  by (simp add: numeral_eq_Suc)

lemma zero_power2: "0\<^sup>2 = 0" (* delete? *)
  by (rule power_zero_numeral)

lemma one_power2: "1\<^sup>2 = 1" (* delete? *)
  by (rule power_one)

lemma power_0_Suc [simp]: "0 ^ Suc n = 0"
  by simp

text \<open>It looks plausible as a simprule, but its effect can be strange.\<close>
lemma power_0_left: "0 ^ n = (if n = 0 then 1 else 0)"
  by (cases n) simp_all

end

context comm_semiring_1
begin

text \<open>The divides relation.\<close>

lemma le_imp_power_dvd:
  assumes "m \<le> n"
  shows "a ^ m dvd a ^ n"
proof
  from assms have "a ^ n = a ^ (m + (n - m))" by simp
  also have "\<dots> = a ^ m * a ^ (n - m)" by (rule power_add)
  finally show "a ^ n = a ^ m * a ^ (n - m)" .
qed

lemma power_le_dvd: "a ^ n dvd b \<Longrightarrow> m \<le> n \<Longrightarrow> a ^ m dvd b"
  by (rule dvd_trans [OF le_imp_power_dvd])

lemma dvd_power_same: "x dvd y \<Longrightarrow> x ^ n dvd y ^ n"
  by (induct n) (auto simp add: mult_dvd_mono)

lemma dvd_power_le: "x dvd y \<Longrightarrow> m \<ge> n \<Longrightarrow> x ^ n dvd y ^ m"
  by (rule power_le_dvd [OF dvd_power_same])

lemma dvd_power [simp]:
  fixes n :: nat
  assumes "n > 0 \<or> x = 1"
  shows "x dvd (x ^ n)"
  using assms
proof
  assume "0 < n"
  then have "x ^ n = x ^ Suc (n - 1)" by simp
  then show "x dvd (x ^ n)" by simp
next
  assume "x = 1"
  then show "x dvd (x ^ n)" by simp
qed

end

context semiring_1_no_zero_divisors
begin

subclass power .

lemma power_eq_0_iff [simp]: "a ^ n = 0 \<longleftrightarrow> a = 0 \<and> n > 0"
  by (induct n) auto

lemma power_not_zero: "a \<noteq> 0 \<Longrightarrow> a ^ n \<noteq> 0"
  by (induct n) auto

lemma zero_eq_power2 [simp]: "a\<^sup>2 = 0 \<longleftrightarrow> a = 0"
  unfolding power2_eq_square by simp

end

context ring_1
begin

lemma power_minus: "(- a) ^ n = (- 1) ^ n * a ^ n"
proof (induct n)
  case 0
  show ?case by simp
next
  case (Suc n)
  then show ?case
    by (simp del: power_Suc add: power_Suc2 mult.assoc)
qed

lemma power_minus': "NO_MATCH 1 x \<Longrightarrow> (-x) ^ n = (-1)^n * x ^ n"
  by (rule power_minus)

lemma power_minus_Bit0: "(- x) ^ numeral (Num.Bit0 k) = x ^ numeral (Num.Bit0 k)"
  by (induct k, simp_all only: numeral_class.numeral.simps power_add
    power_one_right mult_minus_left mult_minus_right minus_minus)

lemma power_minus_Bit1: "(- x) ^ numeral (Num.Bit1 k) = - (x ^ numeral (Num.Bit1 k))"
  by (simp only: eval_nat_numeral(3) power_Suc power_minus_Bit0 mult_minus_left)

lemma power2_minus [simp]: "(- a)\<^sup>2 = a\<^sup>2"
  by (fact power_minus_Bit0)

lemma power_minus1_even [simp]: "(- 1) ^ (2*n) = 1"
proof (induct n)
  case 0
  show ?case by simp
next
  case (Suc n)
  then show ?case by (simp add: power_add power2_eq_square)
qed

lemma power_minus1_odd: "(- 1) ^ Suc (2*n) = -1"
  by simp

lemma power_minus_even [simp]: "(-a) ^ (2*n) = a ^ (2*n)"
  by (simp add: power_minus [of a])

end

context ring_1_no_zero_divisors
begin

lemma power2_eq_1_iff: "a\<^sup>2 = 1 \<longleftrightarrow> a = 1 \<or> a = - 1"
  using square_eq_1_iff [of a] by (simp add: power2_eq_square)

end

context idom
begin

lemma power2_eq_iff: "x\<^sup>2 = y\<^sup>2 \<longleftrightarrow> x = y \<or> x = - y"
  unfolding power2_eq_square by (rule square_eq_iff)

end

context algebraic_semidom
begin

lemma div_power: "b dvd a \<Longrightarrow> (a div b) ^ n = a ^ n div b ^ n"
  by (induct n) (simp_all add: div_mult_div_if_dvd dvd_power_same)

lemma is_unit_power_iff: "is_unit (a ^ n) \<longleftrightarrow> is_unit a \<or> n = 0"
  by (induct n) (auto simp add: is_unit_mult_iff)

lemma dvd_power_iff:
  assumes "x \<noteq> 0"
  shows   "x ^ m dvd x ^ n \<longleftrightarrow> is_unit x \<or> m \<le> n"
proof
  assume *: "x ^ m dvd x ^ n"
  {
    assume "m > n"
    note *
    also have "x ^ n = x ^ n * 1" by simp
    also from \<open>m > n\<close> have "m = n + (m - n)" by simp
    also have "x ^ \<dots> = x ^ n * x ^ (m - n)" by (rule power_add)
    finally have "x ^ (m - n) dvd 1"
      by (subst (asm) dvd_times_left_cancel_iff) (insert assms, simp_all)
    with \<open>m > n\<close> have "is_unit x" by (simp add: is_unit_power_iff)
  }
  thus "is_unit x \<or> m \<le> n" by force
qed (auto intro: unit_imp_dvd simp: is_unit_power_iff le_imp_power_dvd)

end

context normalization_semidom
begin

lemma normalize_power: "normalize (a ^ n) = normalize a ^ n"
  by (induct n) (simp_all add: normalize_mult)

lemma unit_factor_power: "unit_factor (a ^ n) = unit_factor a ^ n"
  by (induct n) (simp_all add: unit_factor_mult)

end

context division_ring
begin

text \<open>Perhaps these should be simprules.\<close>
lemma power_inverse [field_simps, divide_simps]: "inverse a ^ n = inverse (a ^ n)"
proof (cases "a = 0")
  case True
  then show ?thesis by (simp add: power_0_left)
next
  case False
  then have "inverse (a ^ n) = inverse a ^ n"
    by (induct n) (simp_all add: nonzero_inverse_mult_distrib power_commutes)
  then show ?thesis by simp
qed

lemma power_one_over [field_simps, divide_simps]: "(1 / a) ^ n = 1 / a ^ n"
  using power_inverse [of a] by (simp add: divide_inverse)

end

context field
begin

lemma power_diff:
  assumes "a \<noteq> 0"
  shows "n \<le> m \<Longrightarrow> a ^ (m - n) = a ^ m / a ^ n"
  by (induct m n rule: diff_induct) (simp_all add: assms power_not_zero)

lemma power_divide [field_simps, divide_simps]: "(a / b) ^ n = a ^ n / b ^ n"
  by (induct n) simp_all

end

subsection \<open>Exponentiation on ordered types\<close>

context linordered_semidom
begin

lemma zero_less_power [simp]: "0 < a \<Longrightarrow> 0 < a ^ n"
  by (induct n) simp_all

lemma zero_le_power [simp]: "0 \<le> a \<Longrightarrow> 0 \<le> a ^ n"
  by (induct n) simp_all

lemma power_mono: "a \<le> b \<Longrightarrow> 0 \<le> a \<Longrightarrow> a ^ n \<le> b ^ n"
  by (induct n) (auto intro: mult_mono order_trans [of 0 a b])

lemma one_le_power [simp]: "1 \<le> a \<Longrightarrow> 1 \<le> a ^ n"
  using power_mono [of 1 a n] by simp

lemma power_le_one: "0 \<le> a \<Longrightarrow> a \<le> 1 \<Longrightarrow> a ^ n \<le> 1"
  using power_mono [of a 1 n] by simp

lemma power_gt1_lemma:
  assumes gt1: "1 < a"
  shows "1 < a * a ^ n"
proof -
  from gt1 have "0 \<le> a"
    by (fact order_trans [OF zero_le_one less_imp_le])
  from gt1 have "1 * 1 < a * 1" by simp
  also from gt1 have "\<dots> \<le> a * a ^ n"
    by (simp only: mult_mono \<open>0 \<le> a\<close> one_le_power order_less_imp_le zero_le_one order_refl)
  finally show ?thesis by simp
qed

lemma power_gt1: "1 < a \<Longrightarrow> 1 < a ^ Suc n"
  by (simp add: power_gt1_lemma)

lemma one_less_power [simp]: "1 < a \<Longrightarrow> 0 < n \<Longrightarrow> 1 < a ^ n"
  by (cases n) (simp_all add: power_gt1_lemma)

lemma power_le_imp_le_exp:
  assumes gt1: "1 < a"
  shows "a ^ m \<le> a ^ n \<Longrightarrow> m \<le> n"
proof (induct m arbitrary: n)
  case 0
  show ?case by simp
next
  case (Suc m)
  show ?case
  proof (cases n)
    case 0
    with Suc have "a * a ^ m \<le> 1" by simp
    with gt1 show ?thesis
      by (force simp only: power_gt1_lemma not_less [symmetric])
  next
    case (Suc n)
    with Suc.prems Suc.hyps show ?thesis
      by (force dest: mult_left_le_imp_le simp add: less_trans [OF zero_less_one gt1])
  qed
qed

lemma of_nat_zero_less_power_iff [simp]: "of_nat x ^ n > 0 \<longleftrightarrow> x > 0 \<or> n = 0"
  by (induct n) auto

text \<open>Surely we can strengthen this? It holds for \<open>0<a<1\<close> too.\<close>
lemma power_inject_exp [simp]: "1 < a \<Longrightarrow> a ^ m = a ^ n \<longleftrightarrow> m = n"
  by (force simp add: order_antisym power_le_imp_le_exp)

text \<open>
  Can relax the first premise to @{term "0<a"} in the case of the
  natural numbers.
\<close>
lemma power_less_imp_less_exp: "1 < a \<Longrightarrow> a ^ m < a ^ n \<Longrightarrow> m < n"
  by (simp add: order_less_le [of m n] less_le [of "a^m" "a^n"] power_le_imp_le_exp)

lemma power_strict_mono [rule_format]: "a < b \<Longrightarrow> 0 \<le> a \<Longrightarrow> 0 < n \<longrightarrow> a ^ n < b ^ n"
  by (induct n) (auto simp: mult_strict_mono le_less_trans [of 0 a b])

text\<open>Lemma for \<open>power_strict_decreasing\<close>\<close>
lemma power_Suc_less: "0 < a \<Longrightarrow> a < 1 \<Longrightarrow> a * a ^ n < a ^ n"
  by (induct n) (auto simp: mult_strict_left_mono)

lemma power_strict_decreasing [rule_format]: "n < N \<Longrightarrow> 0 < a \<Longrightarrow> a < 1 \<longrightarrow> a ^ N < a ^ n"
proof (induct N)
  case 0
  then show ?case by simp
next
  case (Suc N)
  then show ?case
    apply (auto simp add: power_Suc_less less_Suc_eq)
    apply (subgoal_tac "a * a^N < 1 * a^n")
     apply simp
    apply (rule mult_strict_mono)
       apply auto
    done
qed

text \<open>Proof resembles that of \<open>power_strict_decreasing\<close>.\<close>
lemma power_decreasing: "n \<le> N \<Longrightarrow> 0 \<le> a \<Longrightarrow> a \<le> 1 \<Longrightarrow> a ^ N \<le> a ^ n"
proof (induct N)
  case 0
  then show ?case by simp
next
  case (Suc N)
  then show ?case
    apply (auto simp add: le_Suc_eq)
    apply (subgoal_tac "a * a^N \<le> 1 * a^n")
     apply simp
    apply (rule mult_mono)
       apply auto
    done
qed

lemma power_Suc_less_one: "0 < a \<Longrightarrow> a < 1 \<Longrightarrow> a ^ Suc n < 1"
  using power_strict_decreasing [of 0 "Suc n" a] by simp

text \<open>Proof again resembles that of \<open>power_strict_decreasing\<close>.\<close>
lemma power_increasing: "n \<le> N \<Longrightarrow> 1 \<le> a \<Longrightarrow> a ^ n \<le> a ^ N"
proof (induct N)
  case 0
  then show ?case by simp
next
  case (Suc N)
  then show ?case
    apply (auto simp add: le_Suc_eq)
    apply (subgoal_tac "1 * a^n \<le> a * a^N")
     apply simp
    apply (rule mult_mono)
       apply (auto simp add: order_trans [OF zero_le_one])
    done
qed

text \<open>Lemma for \<open>power_strict_increasing\<close>.\<close>
lemma power_less_power_Suc: "1 < a \<Longrightarrow> a ^ n < a * a ^ n"
  by (induct n) (auto simp: mult_strict_left_mono less_trans [OF zero_less_one])

lemma power_strict_increasing: "n < N \<Longrightarrow> 1 < a \<Longrightarrow> a ^ n < a ^ N"
proof (induct N)
  case 0
  then show ?case by simp
next
  case (Suc N)
  then show ?case
    apply (auto simp add: power_less_power_Suc less_Suc_eq)
    apply (subgoal_tac "1 * a^n < a * a^N")
     apply simp
    apply (rule mult_strict_mono)
    apply (auto simp add: less_trans [OF zero_less_one] less_imp_le)
    done
qed

lemma power_increasing_iff [simp]: "1 < b \<Longrightarrow> b ^ x \<le> b ^ y \<longleftrightarrow> x \<le> y"
  by (blast intro: power_le_imp_le_exp power_increasing less_imp_le)

lemma power_strict_increasing_iff [simp]: "1 < b \<Longrightarrow> b ^ x < b ^ y \<longleftrightarrow> x < y"
  by (blast intro: power_less_imp_less_exp power_strict_increasing)

lemma power_le_imp_le_base:
  assumes le: "a ^ Suc n \<le> b ^ Suc n"
    and "0 \<le> b"
  shows "a \<le> b"
proof (rule ccontr)
  assume "\<not> ?thesis"
  then have "b < a" by (simp only: linorder_not_le)
  then have "b ^ Suc n < a ^ Suc n"
    by (simp only: assms(2) power_strict_mono)
  with le show False
    by (simp add: linorder_not_less [symmetric])
qed

lemma power_less_imp_less_base:
  assumes less: "a ^ n < b ^ n"
  assumes nonneg: "0 \<le> b"
  shows "a < b"
proof (rule contrapos_pp [OF less])
  assume "\<not> ?thesis"
  then have "b \<le> a" by (simp only: linorder_not_less)
  from this nonneg have "b ^ n \<le> a ^ n" by (rule power_mono)
  then show "\<not> a ^ n < b ^ n" by (simp only: linorder_not_less)
qed

lemma power_inject_base: "a ^ Suc n = b ^ Suc n \<Longrightarrow> 0 \<le> a \<Longrightarrow> 0 \<le> b \<Longrightarrow> a = b"
  by (blast intro: power_le_imp_le_base antisym eq_refl sym)

lemma power_eq_imp_eq_base: "a ^ n = b ^ n \<Longrightarrow> 0 \<le> a \<Longrightarrow> 0 \<le> b \<Longrightarrow> 0 < n \<Longrightarrow> a = b"
  by (cases n) (simp_all del: power_Suc, rule power_inject_base)

lemma power_eq_iff_eq_base: "0 < n \<Longrightarrow> 0 \<le> a \<Longrightarrow> 0 \<le> b \<Longrightarrow> a ^ n = b ^ n \<longleftrightarrow> a = b"
  using power_eq_imp_eq_base [of a n b] by auto

lemma power2_le_imp_le: "x\<^sup>2 \<le> y\<^sup>2 \<Longrightarrow> 0 \<le> y \<Longrightarrow> x \<le> y"
  unfolding numeral_2_eq_2 by (rule power_le_imp_le_base)

lemma power2_less_imp_less: "x\<^sup>2 < y\<^sup>2 \<Longrightarrow> 0 \<le> y \<Longrightarrow> x < y"
  by (rule power_less_imp_less_base)

lemma power2_eq_imp_eq: "x\<^sup>2 = y\<^sup>2 \<Longrightarrow> 0 \<le> x \<Longrightarrow> 0 \<le> y \<Longrightarrow> x = y"
  unfolding numeral_2_eq_2 by (erule (2) power_eq_imp_eq_base) simp

lemma power_Suc_le_self: "0 \<le> a \<Longrightarrow> a \<le> 1 \<Longrightarrow> a ^ Suc n \<le> a"
  using power_decreasing [of 1 "Suc n" a] by simp

end

context linordered_ring_strict
begin

lemma sum_squares_eq_zero_iff: "x * x + y * y = 0 \<longleftrightarrow> x = 0 \<and> y = 0"
  by (simp add: add_nonneg_eq_0_iff)

lemma sum_squares_le_zero_iff: "x * x + y * y \<le> 0 \<longleftrightarrow> x = 0 \<and> y = 0"
  by (simp add: le_less not_sum_squares_lt_zero sum_squares_eq_zero_iff)

lemma sum_squares_gt_zero_iff: "0 < x * x + y * y \<longleftrightarrow> x \<noteq> 0 \<or> y \<noteq> 0"
  by (simp add: not_le [symmetric] sum_squares_le_zero_iff)

end

context linordered_idom
begin

lemma power_abs: "\<bar>a ^ n\<bar> = \<bar>a\<bar> ^ n"
  by (induct n) (auto simp add: abs_mult)

lemma abs_power_minus [simp]: "\<bar>(-a) ^ n\<bar> = \<bar>a ^ n\<bar>"
  by (simp add: power_abs)

lemma zero_less_power_abs_iff [simp]: "0 < \<bar>a\<bar> ^ n \<longleftrightarrow> a \<noteq> 0 \<or> n = 0"
proof (induct n)
  case 0
  show ?case by simp
next
  case Suc
  then show ?case by (auto simp: zero_less_mult_iff)
qed

lemma zero_le_power_abs [simp]: "0 \<le> \<bar>a\<bar> ^ n"
  by (rule zero_le_power [OF abs_ge_zero])

lemma zero_le_power2 [simp]: "0 \<le> a\<^sup>2"
  by (simp add: power2_eq_square)

lemma zero_less_power2 [simp]: "0 < a\<^sup>2 \<longleftrightarrow> a \<noteq> 0"
  by (force simp add: power2_eq_square zero_less_mult_iff linorder_neq_iff)

lemma power2_less_0 [simp]: "\<not> a\<^sup>2 < 0"
  by (force simp add: power2_eq_square mult_less_0_iff)

lemma power2_less_eq_zero_iff [simp]: "a\<^sup>2 \<le> 0 \<longleftrightarrow> a = 0"
  by (simp add: le_less)

lemma abs_power2 [simp]: "\<bar>a\<^sup>2\<bar> = a\<^sup>2"
  by (simp add: power2_eq_square)

lemma power2_abs [simp]: "\<bar>a\<bar>\<^sup>2 = a\<^sup>2"
  by (simp add: power2_eq_square)

lemma odd_power_less_zero: "a < 0 \<Longrightarrow> a ^ Suc (2*n) < 0"
proof (induct n)
  case 0
  then show ?case by simp
next
  case (Suc n)
  have "a ^ Suc (2 * Suc n) = (a*a) * a ^ Suc(2*n)"
    by (simp add: ac_simps power_add power2_eq_square)
  then show ?case
    by (simp del: power_Suc add: Suc mult_less_0_iff mult_neg_neg)
qed

lemma odd_0_le_power_imp_0_le: "0 \<le> a ^ Suc (2*n) \<Longrightarrow> 0 \<le> a"
  using odd_power_less_zero [of a n]
  by (force simp add: linorder_not_less [symmetric])

lemma zero_le_even_power'[simp]: "0 \<le> a ^ (2*n)"
proof (induct n)
  case 0
  show ?case by simp
next
  case (Suc n)
  have "a ^ (2 * Suc n) = (a*a) * a ^ (2*n)"
    by (simp add: ac_simps power_add power2_eq_square)
  then show ?case
    by (simp add: Suc zero_le_mult_iff)
qed

lemma sum_power2_ge_zero: "0 \<le> x\<^sup>2 + y\<^sup>2"
  by (intro add_nonneg_nonneg zero_le_power2)

lemma not_sum_power2_lt_zero: "\<not> x\<^sup>2 + y\<^sup>2 < 0"
  unfolding not_less by (rule sum_power2_ge_zero)

lemma sum_power2_eq_zero_iff: "x\<^sup>2 + y\<^sup>2 = 0 \<longleftrightarrow> x = 0 \<and> y = 0"
  unfolding power2_eq_square by (simp add: add_nonneg_eq_0_iff)

lemma sum_power2_le_zero_iff: "x\<^sup>2 + y\<^sup>2 \<le> 0 \<longleftrightarrow> x = 0 \<and> y = 0"
  by (simp add: le_less sum_power2_eq_zero_iff not_sum_power2_lt_zero)

lemma sum_power2_gt_zero_iff: "0 < x\<^sup>2 + y\<^sup>2 \<longleftrightarrow> x \<noteq> 0 \<or> y \<noteq> 0"
  unfolding not_le [symmetric] by (simp add: sum_power2_le_zero_iff)

lemma abs_le_square_iff: "\<bar>x\<bar> \<le> \<bar>y\<bar> \<longleftrightarrow> x\<^sup>2 \<le> y\<^sup>2"
  (is "?lhs \<longleftrightarrow> ?rhs")
proof
  assume ?lhs
  then have "\<bar>x\<bar>\<^sup>2 \<le> \<bar>y\<bar>\<^sup>2" by (rule power_mono) simp
  then show ?rhs by simp
next
  assume ?rhs
  then show ?lhs
    by (auto intro!: power2_le_imp_le [OF _ abs_ge_zero])
qed

lemma abs_square_le_1:"x\<^sup>2 \<le> 1 \<longleftrightarrow> \<bar>x\<bar> \<le> 1"
  using abs_le_square_iff [of x 1] by simp

lemma abs_square_eq_1: "x\<^sup>2 = 1 \<longleftrightarrow> \<bar>x\<bar> = 1"
  by (auto simp add: abs_if power2_eq_1_iff)

lemma abs_square_less_1: "x\<^sup>2 < 1 \<longleftrightarrow> \<bar>x\<bar> < 1"
  using  abs_square_eq_1 [of x] abs_square_le_1 [of x] by (auto simp add: le_less)

end

subsection \<open>Miscellaneous rules\<close>

lemma (in linordered_semidom) self_le_power: "1 \<le> a \<Longrightarrow> 0 < n \<Longrightarrow> a \<le> a ^ n"
  using power_increasing [of 1 n a] power_one_right [of a] by auto

lemma (in power) power_eq_if: "p ^ m = (if m=0 then 1 else p * (p ^ (m - 1)))"
  unfolding One_nat_def by (cases m) simp_all

lemma (in comm_semiring_1) power2_sum: "(x + y)\<^sup>2 = x\<^sup>2 + y\<^sup>2 + 2 * x * y"
  by (simp add: algebra_simps power2_eq_square mult_2_right)

context comm_ring_1
begin

lemma power2_diff: "(x - y)\<^sup>2 = x\<^sup>2 + y\<^sup>2 - 2 * x * y"
  by (simp add: algebra_simps power2_eq_square mult_2_right)

lemma power2_commute: "(x - y)\<^sup>2 = (y - x)\<^sup>2"
  by (simp add: algebra_simps power2_eq_square)

lemma minus_power_mult_self: "(- a) ^ n * (- a) ^ n = a ^ (2 * n)"
  by (simp add: power_mult_distrib [symmetric])
    (simp add: power2_eq_square [symmetric] power_mult [symmetric])

lemma minus_one_mult_self [simp]: "(- 1) ^ n * (- 1) ^ n = 1"
  using minus_power_mult_self [of 1 n] by simp

lemma left_minus_one_mult_self [simp]: "(- 1) ^ n * ((- 1) ^ n * a) = a"
  by (simp add: mult.assoc [symmetric])

end

text \<open>Simprules for comparisons where common factors can be cancelled.\<close>

lemmas zero_compare_simps =
  add_strict_increasing add_strict_increasing2 add_increasing
  zero_le_mult_iff zero_le_divide_iff
  zero_less_mult_iff zero_less_divide_iff
  mult_le_0_iff divide_le_0_iff
  mult_less_0_iff divide_less_0_iff
  zero_le_power2 power2_less_0

subsection \<open>Exponentiation for the Natural Numbers\<close>

lemma nat_one_le_power [simp]: "Suc 0 \<le> i \<Longrightarrow> Suc 0 \<le> i ^ n"
  by (rule one_le_power [of i n, unfolded One_nat_def])

lemma nat_zero_less_power_iff [simp]: "x ^ n > 0 \<longleftrightarrow> x > 0 \<or> n = 0"
  for x :: nat
  by (induct n) auto

lemma nat_power_eq_Suc_0_iff [simp]: "x ^ m = Suc 0 \<longleftrightarrow> m = 0 \<or> x = Suc 0"
  by (induct m) auto

lemma power_Suc_0 [simp]: "Suc 0 ^ n = Suc 0"
  by simp

text \<open>
  Valid for the naturals, but what if \<open>0 < i < 1\<close>? Premises cannot be
  weakened: consider the case where \<open>i = 0\<close>, \<open>m = 1\<close> and \<open>n = 0\<close>.
\<close>

lemma nat_power_less_imp_less:
  fixes i :: nat
  assumes nonneg: "0 < i"
  assumes less: "i ^ m < i ^ n"
  shows "m < n"
proof (cases "i = 1")
  case True
  with less power_one [where 'a = nat] show ?thesis by simp
next
  case False
  with nonneg have "1 < i" by auto
  from power_strict_increasing_iff [OF this] less show ?thesis ..
qed

lemma power_dvd_imp_le: "i ^ m dvd i ^ n \<Longrightarrow> 1 < i \<Longrightarrow> m \<le> n"
  for i m n :: nat
  apply (rule power_le_imp_le_exp)
   apply assumption
  apply (erule dvd_imp_le)
  apply simp
  done

lemma power2_nat_le_eq_le: "m\<^sup>2 \<le> n\<^sup>2 \<longleftrightarrow> m \<le> n"
  for m n :: nat
  by (auto intro: power2_le_imp_le power_mono)

lemma power2_nat_le_imp_le:
  fixes m n :: nat
  assumes "m\<^sup>2 \<le> n"
  shows "m \<le> n"
proof (cases m)
  case 0
  then show ?thesis by simp
next
  case (Suc k)
  show ?thesis
  proof (rule ccontr)
    assume "\<not> ?thesis"
    then have "n < m" by simp
    with assms Suc show False
      by (simp add: power2_eq_square)
  qed
qed

lemma ex_power_ivl1: fixes b k :: nat assumes "b \<ge> 2"
shows "k \<ge> 1 \<Longrightarrow> \<exists>n. b^n \<le> k \<and> k < b^(n+1)" (is "_ \<Longrightarrow> \<exists>n. ?P k n")
proof(induction k)
  case 0 thus ?case by simp
next
  case (Suc k)
  show ?case
  proof cases
    assume "k=0"
    hence "?P (Suc k) 0" using assms by simp
    thus ?case ..
  next
    assume "k\<noteq>0"
    with Suc obtain n where IH: "?P k n" by auto
    show ?case
    proof (cases "k = b^(n+1) - 1")
      case True
      hence "?P (Suc k) (n+1)" using assms
        by (simp add: power_less_power_Suc)
      thus ?thesis ..
    next
      case False
      hence "?P (Suc k) n" using IH by auto
      thus ?thesis ..
    qed
  qed
qed

lemma ex_power_ivl2: fixes b k :: nat assumes "b \<ge> 2" "k \<ge> 2"
shows "\<exists>n. b^n < k \<and> k \<le> b^(n+1)"
proof -
  have "1 \<le> k - 1" using assms(2) by arith
  from ex_power_ivl1[OF assms(1) this]
  obtain n where "b ^ n \<le> k - 1 \<and> k - 1 < b ^ (n + 1)" ..
  hence "b^n < k \<and> k \<le> b^(n+1)" using assms by auto
  thus ?thesis ..
qed

subsubsection \<open>Cardinality of the Powerset\<close>

lemma card_UNIV_bool [simp]: "card (UNIV :: bool set) = 2"
  unfolding UNIV_bool by simp

lemma card_Pow: "finite A \<Longrightarrow> card (Pow A) = 2 ^ card A"
proof (induct rule: finite_induct)
  case empty
  show ?case by auto
next
  case (insert x A)
  then have "inj_on (insert x) (Pow A)"
    unfolding inj_on_def by (blast elim!: equalityE)
  then have "card (Pow A) + card (insert x ` Pow A) = 2 * 2 ^ card A"
    by (simp add: mult_2 card_image Pow_insert insert.hyps)
  with insert show ?case
    apply (simp add: Pow_insert)
    apply (subst card_Un_disjoint)
       apply auto
    done
qed

subsection \<open>Code generator tweak\<close>

code_identifier
  code_module Power \<rightharpoonup> (SML) Arith and (OCaml) Arith and (Haskell) Arith

end