theory Function
  imports HOL.Fun Main HOL.Real "~~/src/HOL/ex/Sqrt"
begin

subsection \<open>function and relation\<close>

type_synonym ('a, 'b) rel = "('a \<times> 'b) set"

definition func :: "('a, 'b) rel \<Rightarrow> 'a set \<Rightarrow> 'b set \<Rightarrow> bool" ("_ : _ \<rightarrow> _" [80,80,80] 81)
  where "func f X Y \<equiv> f \<subseteq> X \<times> Y \<and> X \<noteq> {} \<and> Y \<noteq> {} \<and> Domain f = X
                        \<and> (\<forall>x y1 y2. (x, y1)\<in>f \<and> (x, y2)\<in>f \<longrightarrow> y1 = y2)"

subsection \<open>total and partial function\<close>

definition sqrt :: "real \<rightharpoonup> real"
  where "sqrt r \<equiv> (if r \<ge> 0 then Some (root 2 r) else None)"

definition Pred :: "nat \<rightharpoonup> nat"
  where "Pred n \<equiv> (if n > 0 then Some (n - 1) else None)"

value "Pred 9"
value "Pred 0"

definition minus_nat :: "nat \<Rightarrow> nat \<rightharpoonup> nat"
  where "minus_nat a b \<equiv> (if a \<ge> b then Some (a - b) else None)"

value "minus_nat 6 3"

value "minus_nat 3 8"

subsection \<open>injective, surjective, bijective\<close>

definition add1 :: "nat \<Rightarrow> nat"
  where "add1 n \<equiv> n + 1"

lemma "inj add1 = True"
  unfolding add1_def by auto

lemma "surj add1 = False"
  apply(simp add:add1_def surj_def)
  apply(rule_tac x = 0 in exI)
  by auto

definition add2 :: "real \<Rightarrow> real"
  where "add2 r \<equiv> r + 1"

lemma add2_lm1: "inj add2 = True"
  by (simp add:add2_def inj_def)

lemma add2_lm2: "surj add2 = True"
  apply (simp add:add2_def surj_def)
  apply(rule allI)
  by (metis add_diff_cancel_left' diff_minus_eq_add)

lemma "bij add2 = True"
  using add2_lm1 add2_lm2 by (simp add:bij_def)

lemma "f = g \<longleftrightarrow> (\<forall>x. f x = g x)"
  by auto

lemma "f = g \<longleftrightarrow> {(x,y). y = f x} = {(x,y). y = g x}"
  by auto

subsection \<open>function operation\<close>

definition fun1 :: "int \<Rightarrow> int"
  where "fun1 x \<equiv> x + 1"

value "fun_upd f a b"
value "f(a := b)"

value "fun1 2"

term "fun1(2 := 2)"

value "(fun1(2 := 2)) 2"

value "(fun1(1 := 1, 2 := 2, 3 := 3)) 2"
value "(fun1(1 := 1, 2 := 2, 3 := 3)) 1"
value "(fun1(1 := 1, 2 := 2, 3 := 3)) 3"

value "(fun1(x := y)) x"

lemma "(f(x := y)) x = y"
  by auto

lemma "z \<noteq> x \<Longrightarrow> (f(x := y)) z = f z"
  by auto

lemma "f(x := y, x := z) = f(x := z)"
  by auto

value "(fun1(x := y, x := z)) x"

definition "fun2 x \<equiv> fun1 x * 2"
value "fun2 3"

definition "fun3 \<equiv> (\<lambda>x. (fun1(x := fun1 x * 2)) x)"
value "fun3 3"

definition fun4 :: "int \<Rightarrow> int"
  where "fun4 x \<equiv> x * 2"
value "fun4 ` {1,2,3}"

value "fun4 ` {1..10}"

lemma "fun4 ` {x. x > 5 \<and> x < 12} = {12,14,16,18,20,22}"
  using fun4_def by auto

thm fun4_def
thm swap_def

definition "fun5 \<equiv> Fun.swap 2 3 fun4"

value "fun4 2"
value "fun4 3"
value "fun5 2"
value "fun5 3"

lemma "(Fun.swap a b f) a = f b"
  by auto

lemma "(Fun.swap a b f) b = f a"
  by auto

lemma "c \<noteq> a \<and> c \<noteq> b \<Longrightarrow> Fun.swap a b f c = f c"
  by auto

definition suc :: "int \<Rightarrow> int"
  where "suc n \<equiv> n + 1"

lemma bij_suc: "bij suc"
  unfolding suc_def bij_def inj_def surj_def
  apply(rule conjI)
  apply auto apply(rule_tac x = "y - 1" in exI) by simp

definition "suc_inv \<equiv> the_inv suc"

definition pred :: "int \<Rightarrow> int"
  where "pred n \<equiv> n - 1"

value "pred 1"
value "pred 0"

lemma "suc_inv x = pred x"
  unfolding suc_inv_def pred_def the_inv_into_def suc_def using bij_suc by force

definition suc2 :: "nat \<Rightarrow> nat"
  where "suc2 n \<equiv> n + 2"

lemma "inj suc2"
  unfolding suc2_def inj_def by simp

definition "suc2_inv = the_inv suc2"

lemma "suc2_inv 3 = 1"
  unfolding suc2_inv_def the_inv_into_def suc2_def by simp

lemma "suc2_inv 1 = 0" (* its wrong *)
   sorry

definition pred2 :: "nat \<Rightarrow> nat"
  where "pred2 n \<equiv> n - 2"

value "pred2 1"
value "pred2 0"

definition f6 :: "int \<Rightarrow> int"
  where "f6 x \<equiv> (if x < 0 then x + 1 else 10)"

value "f6 (-2)"
value "f6 2"
value "f6 3"

lemma "\<not>(\<exists>x. f6 x = 5)"
  unfolding f6_def by simp

definition "f6_inv \<equiv> the_inv f6"

lemma "f6_inv (-1) = -2"
  unfolding f6_inv_def the_inv_into_def f6_def by auto

definition f7 :: "int \<Rightarrow> int"
  where "f7 n \<equiv> n + 2"

definition g7 :: "int \<Rightarrow> int"
  where "g7 n \<equiv> n * 2"

value "(f7 \<circ> g7) 3"
value "(g7 \<circ> f7) 3"

lemma "(f7 \<circ> g7) x = x * 2 + 2"
  unfolding f7_def g7_def comp_def by simp

lemma "(g7 \<circ> f7) x = (x + 2) * 2"
  unfolding f7_def g7_def comp_def by simp

lemma "(f \<circ> g) x = f (g x)"
  by auto

lemma "(g \<circ> f) x = g (f x)"
  by auto

lemma "(f \<circ> g) \<circ> h = f \<circ> (g \<circ> h)"
  by auto

value "id (2::int)"
value "id ''hello''"
value "id (0::nat)"
value "id (2.0 :: real)"

lemma "f \<circ> id = f"
  by auto

lemma "id \<circ> f = f"
  by auto

subsection \<open>polymorphism\<close>

definition addi :: "int \<Rightarrow> int \<Rightarrow> int"
  where "addi x y \<equiv> x + y"

definition first :: "('a \<times> 'b) \<Rightarrow> 'a"
  where "first p \<equiv> case p of (a,b) \<Rightarrow> a"

definition second :: "('a \<times> 'b) \<Rightarrow> 'b"
  where "second p \<equiv> case p of (a,b) \<Rightarrow> b"

value "first (2::int, 3::nat)"
value "second (2::int, 3::nat)"
value "first (2.0::real, ''hello'')"
value "second (2.0::real, ''hello'')"

type_synonym 'a array = "'a list"

primrec array_assn :: "'a array \<Rightarrow> nat \<Rightarrow> 'a \<Rightarrow> 'a array" ("_[_] := _")
  where "array_assn [] i v = []" |
        "array_assn (x # xs) i v =
            (case i of 0 \<Rightarrow> v # xs |
                  Suc j \<Rightarrow> x # list_update xs j v)"

definition query :: "'a array \<Rightarrow> nat \<Rightarrow> 'a" ("_[_]")
  where "arr[i] \<equiv> arr ! i"

definition arr1 :: "int array"
  where "arr1 \<equiv> [1,2,3]"
definition "arr2 \<equiv> arr1[1] := 8"
value "arr2[1]"

definition arr3 :: "string array"
  where "arr3 \<equiv> [''aaaa'',''bbbb'',''cccc'']"
definition "arr4 \<equiv> arr3[1] := ''eeee''"
value "arr4[1]"

type_synonym ('k,'v) kvstore = "'k \<rightharpoonup> 'v"

definition getv :: "('k,'v) kvstore \<Rightarrow> 'k \<Rightarrow> 'v option"
  where "getv m k \<equiv> m k"

definition update :: "('k,'v) kvstore \<Rightarrow> 'k \<Rightarrow> 'v \<Rightarrow> ('k,'v) kvstore" ("_ [_ :\<rightarrow> _]")
  where "update m k v \<equiv> m(k:= Some v)"

datatype 'v valT = I int | S string | L "'v list" | T "'v set"

record info = name :: string
              addr :: string
              val  :: int

type_synonym imap = "(int, info valT) kvstore"
type_synonym smap = "(string, info valT) kvstore"

definition kvs1 :: "imap"
  where "kvs1 \<equiv> (\<lambda>i. None)"

value "kvs1 1"

definition "kvs2 \<equiv> kvs1[1 :\<rightarrow> (S ''hello'')]"
value "kvs2 1"
definition "kvs3 \<equiv> kvs2[2 :\<rightarrow> (T {\<lparr>name = ''david'',addr = ''beijing'', val = 1\<rparr>})]"
value "kvs3 1"
value "kvs3 2"

definition kvs4 :: "imap"
  where "kvs4 \<equiv> \<lambda>x::int. if x > 5 \<and> x < 10 then Some (I x) else kvs3 x"

value "kvs4 1"
value "kvs4 2"
value "kvs4 4"
value "kvs4 6"

value "(2::int) + (3::int)"
value "(2.5::real) + (3::int)"
value "(2.5::real) + (3.4::real)"

end


theory Ex1_9
  imports Main
begin

primrec zip1 :: "'a list \<Rightarrow> 'a list \<Rightarrow> 'a list" where
  "zip1 [] rest  = rest"|
  "zip1 (x#xs) rest = (case rest of  [] \<Rightarrow> (x#xs) | (y#ys) \<Rightarrow> x # y # zip1 xs ys)"

primrec zip2 :: "'a list \<Rightarrow> 'a list \<Rightarrow> 'a list" where
  "zip2 rest [] = rest"|
  "zip2 rest (x#xs) = (case rest of [] \<Rightarrow> (x#xs) | (y#ys) \<Rightarrow> y # x # zip2 ys xs)"

fun zipr :: "'a list \<Rightarrow> 'a list \<Rightarrow> 'a list" where
  "zipr [] ys = ys"|
  "zipr xs [] = xs"|
  "zipr (x#xs) (y#ys) = x # y # zipr xs ys"

lemma "zip1 xs ys = zip2 xs ys"
proof (induct xs ys rule : list_induct2')
  case 1
  then show ?case by simp
next
  case (2 x xs)
  then show ?case by simp
next
  case (3 y ys)
  then show ?case by simp
next
  case (4 x xs y ys)
  then show ?case by simp
qed

lemma "zip1 xs ys = zipr xs ys" by (induct xs ys rule : list_induct2', simp_all)

lemma "zip2 xs ys = zipr xs ys" by (induct xs ys rule : list_induct2', simp_all)

lemma "\<lbrakk> length p = length u ; length q = length v\<rbrakk> \<Longrightarrow> zipr (p@q) (u@v) = zipr p u @ zipr q v"
proof (induct p u rule : list_induct2)
  case Nil
  then show ?case  by simp
next
  case (Cons x xs y ys)
  assume hyp1:"length xs = length ys"
  assume hyp2:" length q = length v \<Longrightarrow> zipr (xs @ q) (ys @ v) = zipr xs ys @ zipr q v"
  assume hyp3:"length q = length v"
  show ?case using hyp3 hyp2 by simp
qed


(*  Title:      HOL/Proofs/Extraction/Euclid.thy
    Author:     Markus Wenzel, TU Muenchen
    Author:     Freek Wiedijk, Radboud University Nijmegen
    Author:     Stefan Berghofer, TU Muenchen
*)

section \<open>Euclid's theorem\<close>

theory Euclid
imports
  "~~/src/HOL/Number_Theory/Primes"
  Util
  "~~/src/HOL/Library/Code_Target_Numeral"
begin

text \<open>
  A constructive version of the proof of Euclid's theorem by
  Markus Wenzel and Freek Wiedijk @{cite "Wenzel-Wiedijk-JAR2002"}.
\<close>

lemma factor_greater_one1: "n = m * k \<Longrightarrow> m < n \<Longrightarrow> k < n \<Longrightarrow> Suc 0 < m"
  by (induct m) auto

lemma factor_greater_one2: "n = m * k \<Longrightarrow> m < n \<Longrightarrow> k < n \<Longrightarrow> Suc 0 < k"
  by (induct k) auto

lemma prod_mn_less_k: "0 < n \<Longrightarrow> 0 < k \<Longrightarrow> Suc 0 < m \<Longrightarrow> m * n = k \<Longrightarrow> n < k"
  by (induct m) auto

lemma prime_eq: "prime (p::nat) \<longleftrightarrow> 1 < p \<and> (\<forall>m. m dvd p \<longrightarrow> 1 < m \<longrightarrow> m = p)"
  apply (simp add: prime_nat_iff)
  apply (rule iffI)
  apply blast
  apply (erule conjE)
  apply (rule conjI)
  apply assumption
  apply (rule allI impI)+
  apply (erule allE)
  apply (erule impE)
  apply assumption
  apply (case_tac "m = 0")
  apply simp
  apply (case_tac "m = Suc 0")
  apply simp
  apply simp
  done

lemma prime_eq': "prime (p::nat) \<longleftrightarrow> 1 < p \<and> (\<forall>m k. p = m * k \<longrightarrow> 1 < m \<longrightarrow> m = p)"
  by (simp add: prime_eq dvd_def HOL.all_simps [symmetric] del: HOL.all_simps)

lemma not_prime_ex_mk:
  assumes n: "Suc 0 < n"
  shows "(\<exists>m k. Suc 0 < m \<and> Suc 0 < k \<and> m < n \<and> k < n \<and> n = m * k) \<or> prime n"
proof -
  from nat_eq_dec have "(\<exists>m<n. n = m * k) \<or> \<not> (\<exists>m<n. n = m * k)" for k
    by (rule search)
  then have "(\<exists>k<n. \<exists>m<n. n = m * k) \<or> \<not> (\<exists>k<n. \<exists>m<n. n = m * k)"
    by (rule search)
  then show ?thesis
  proof
    assume "\<exists>k<n. \<exists>m<n. n = m * k"
    then obtain k m where k: "k<n" and m: "m<n" and nmk: "n = m * k"
      by iprover
    from nmk m k have "Suc 0 < m" by (rule factor_greater_one1)
    moreover from nmk m k have "Suc 0 < k" by (rule factor_greater_one2)
    ultimately show ?thesis using k m nmk by iprover
  next
    assume "\<not> (\<exists>k<n. \<exists>m<n. n = m * k)"
    then have A: "\<forall>k<n. \<forall>m<n. n \<noteq> m * k" by iprover
    have "\<forall>m k. n = m * k \<longrightarrow> Suc 0 < m \<longrightarrow> m = n"
    proof (intro allI impI)
      fix m k
      assume nmk: "n = m * k"
      assume m: "Suc 0 < m"
      from n m nmk have k: "0 < k"
        by (cases k) auto
      moreover from n have n: "0 < n" by simp
      moreover note m
      moreover from nmk have "m * k = n" by simp
      ultimately have kn: "k < n" by (rule prod_mn_less_k)
      show "m = n"
      proof (cases "k = Suc 0")
        case True
        with nmk show ?thesis by (simp only: mult_Suc_right)
      next
        case False
        from m have "0 < m" by simp
        moreover note n
        moreover from False n nmk k have "Suc 0 < k" by auto
        moreover from nmk have "k * m = n" by (simp only: ac_simps)
        ultimately have mn: "m < n" by (rule prod_mn_less_k)
        with kn A nmk show ?thesis by iprover
      qed
    qed
    with n have "prime n"
      by (simp only: prime_eq' One_nat_def simp_thms)
    then show ?thesis ..
  qed
qed

lemma dvd_factorial: "0 < m \<Longrightarrow> m \<le> n \<Longrightarrow> m dvd fact n"
proof (induct n rule: nat_induct)
  case 0
  then show ?case by simp
next
  case (Suc n)
  from \<open>m \<le> Suc n\<close> show ?case
  proof (rule le_SucE)
    assume "m \<le> n"
    with \<open>0 < m\<close> have "m dvd fact n" by (rule Suc)
    then have "m dvd (fact n * Suc n)" by (rule dvd_mult2)
    then show ?thesis by (simp add: mult.commute)
  next
    assume "m = Suc n"
    then have "m dvd (fact n * Suc n)"
      by (auto intro: dvdI simp: ac_simps)
    then show ?thesis by (simp add: mult.commute)
  qed
qed

lemma dvd_prod [iff]: "n dvd (\<Prod>m::nat \<in># mset (n # ns). m)"
  by (simp add: prod_mset_Un)

definition all_prime :: "nat list \<Rightarrow> bool"
  where "all_prime ps \<longleftrightarrow> (\<forall>p\<in>set ps. prime p)"

lemma all_prime_simps:
  "all_prime []"
  "all_prime (p # ps) \<longleftrightarrow> prime p \<and> all_prime ps"
  by (simp_all add: all_prime_def)

lemma all_prime_append: "all_prime (ps @ qs) \<longleftrightarrow> all_prime ps \<and> all_prime qs"
  by (simp add: all_prime_def ball_Un)

lemma split_all_prime:
  assumes "all_prime ms" and "all_prime ns"
  shows "\<exists>qs. all_prime qs \<and>
    (\<Prod>m::nat \<in># mset qs. m) = (\<Prod>m::nat \<in># mset ms. m) * (\<Prod>m::nat \<in># mset ns. m)"
  (is "\<exists>qs. ?P qs \<and> ?Q qs")
proof -
  from assms have "all_prime (ms @ ns)"
    by (simp add: all_prime_append)
  moreover
  have "(\<Prod>m::nat \<in># mset (ms @ ns). m) = (\<Prod>m::nat \<in># mset ms. m) * (\<Prod>m::nat \<in># mset ns. m)"
    using assms by (simp add: prod_mset_Un)
  ultimately have "?P (ms @ ns) \<and> ?Q (ms @ ns)" ..
  then show ?thesis ..
qed

lemma all_prime_nempty_g_one:
  assumes "all_prime ps" and "ps \<noteq> []"
  shows "Suc 0 < (\<Prod>m::nat \<in># mset ps. m)"
  using \<open>ps \<noteq> []\<close> \<open>all_prime ps\<close>
  unfolding One_nat_def [symmetric]
  by (induct ps rule: list_nonempty_induct)
    (simp_all add: all_prime_simps prod_mset_Un prime_gt_1_nat less_1_mult del: One_nat_def)

lemma factor_exists: "Suc 0 < n \<Longrightarrow> (\<exists>ps. all_prime ps \<and> (\<Prod>m::nat \<in># mset ps. m) = n)"
proof (induct n rule: nat_wf_ind)
  case (1 n)
  from \<open>Suc 0 < n\<close>
  have "(\<exists>m k. Suc 0 < m \<and> Suc 0 < k \<and> m < n \<and> k < n \<and> n = m * k) \<or> prime n"
    by (rule not_prime_ex_mk)
  then show ?case
  proof
    assume "\<exists>m k. Suc 0 < m \<and> Suc 0 < k \<and> m < n \<and> k < n \<and> n = m * k"
    then obtain m k where m: "Suc 0 < m" and k: "Suc 0 < k" and mn: "m < n"
      and kn: "k < n" and nmk: "n = m * k"
      by iprover
    from mn and m have "\<exists>ps. all_prime ps \<and> (\<Prod>m::nat \<in># mset ps. m) = m"
      by (rule 1)
    then obtain ps1 where "all_prime ps1" and prod_ps1_m: "(\<Prod>m::nat \<in># mset ps1. m) = m"
      by iprover
    from kn and k have "\<exists>ps. all_prime ps \<and> (\<Prod>m::nat \<in># mset ps. m) = k"
      by (rule 1)
    then obtain ps2 where "all_prime ps2" and prod_ps2_k: "(\<Prod>m::nat \<in># mset ps2. m) = k"
      by iprover
    from \<open>all_prime ps1\<close> \<open>all_prime ps2\<close>
    have "\<exists>ps. all_prime ps \<and> (\<Prod>m::nat \<in># mset ps. m) =
      (\<Prod>m::nat \<in># mset ps1. m) * (\<Prod>m::nat \<in># mset ps2. m)"
      by (rule split_all_prime)
    with prod_ps1_m prod_ps2_k nmk show ?thesis by simp
  next
    assume "prime n" then have "all_prime [n]" by (simp add: all_prime_simps)
    moreover have "(\<Prod>m::nat \<in># mset [n]. m) = n" by (simp)
    ultimately have "all_prime [n] \<and> (\<Prod>m::nat \<in># mset [n]. m) = n" ..
    then show ?thesis ..
  qed
qed

lemma prime_factor_exists:
  assumes N: "(1::nat) < n"
  shows "\<exists>p. prime p \<and> p dvd n"
proof -
  from N obtain ps where "all_prime ps" and prod_ps: "n = (\<Prod>m::nat \<in># mset ps. m)"
    using factor_exists by simp iprover
  with N have "ps \<noteq> []"
    by (auto simp add: all_prime_nempty_g_one)
  then obtain p qs where ps: "ps = p # qs"
    by (cases ps) simp
  with \<open>all_prime ps\<close> have "prime p"
    by (simp add: all_prime_simps)
  moreover from \<open>all_prime ps\<close> ps prod_ps have "p dvd n"
    by (simp only: dvd_prod)
  ultimately show ?thesis by iprover
qed

text \<open>Euclid's theorem: there are infinitely many primes.\<close>

lemma Euclid: "\<exists>p::nat. prime p \<and> n < p"
proof -
  let ?k = "fact n + (1::nat)"
  have "1 < ?k" by simp
  then obtain p where prime: "prime p" and dvd: "p dvd ?k"
    using prime_factor_exists by iprover
  have "n < p"
  proof -
    have "\<not> p \<le> n"
    proof
      assume pn: "p \<le> n"
      from \<open>prime p\<close> have "0 < p" by (rule prime_gt_0_nat)
      then have "p dvd fact n" using pn by (rule dvd_factorial)
      with dvd have "p dvd ?k - fact n" by (rule dvd_diff_nat)
      then have "p dvd 1" by simp
      with prime show False by auto
    qed
    then show ?thesis by simp
  qed
  with prime show ?thesis by iprover
qed

extract Euclid

text \<open>
  The program extracted from the proof of Euclid's theorem looks as follows.
  @{thm [display] Euclid_def}
  The program corresponding to the proof of the factorization theorem is
  @{thm [display] factor_exists_def}
\<close>

instantiation nat :: default
begin

definition "default = (0::nat)"

instance ..

end

instantiation list :: (type) default
begin

definition "default = []"

instance ..

end

primrec iterate :: "nat \<Rightarrow> ('a \<Rightarrow> 'a) \<Rightarrow> 'a \<Rightarrow> 'a list"
where
  "iterate 0 f x = []"
| "iterate (Suc n) f x = (let y = f x in y # iterate n f y)"

lemma "factor_exists 1007 = [53, 19]" by eval
lemma "factor_exists 567 = [7, 3, 3, 3, 3]" by eval
lemma "factor_exists 345 = [23, 5, 3]" by eval
lemma "factor_exists 999 = [37, 3, 3, 3]" by eval
lemma "factor_exists 876 = [73, 3, 2, 2]" by eval

lemma "iterate 4 Euclid 0 = [2, 3, 7, 71]" by eval

end


theory Strong_Convexity
  imports Main "HOL-Analysis.Analysis" "HOL-Analysis.Convex"
begin

definition strong_convex_on :: "'a::euclidean_space set\<Rightarrow> ('a \<Rightarrow> real) \<Rightarrow> real \<Rightarrow> bool"
  where "strong_convex_on s f k \<longleftrightarrow>
    (\<forall>x\<in>s. \<forall>y\<in>s. \<forall>u\<ge>0. \<forall>v\<ge>0. u + v = 1 \<longrightarrow>
     f (u *\<^sub>R x + v *\<^sub>R y) \<le> u * f x + v * f y - (k/2) * u * v * norm(x-y) * norm(x-y) )"

lemma help2_3 : "norm (x+y)^2 = norm x ^ 2 + 2 *\<^sub>R (inner x y) + norm y ^ 2"
  for x y :: "'a::euclidean_space"
  by (smt inner_commute inner_left_distrib power2_norm_eq_inner scaleR_2)

lemma help2_31 : "norm (x - y)^2 = norm x ^ 2 - 2 *\<^sub>R (inner x y) + norm y ^ 2"
  for x y :: "'a::euclidean_space"
  using help2_3
  by (simp add: inner_commute inner_diff_right power2_norm_eq_inner)

lemma help2_2 : "(norm (u  *\<^sub>R x +  v  *\<^sub>R y))^2 = norm (u *\<^sub>R x)^2 + (2 * u * v) *\<^sub>R (inner x y) + norm (v *\<^sub>R y)^2 "
  for x y :: "'a::euclidean_space"
  by (simp add: help2_3)

lemma help2_4: "norm (u *\<^sub>R x)^2  = u^2 * norm(x)^2"
proof -
  have "abs(u)^2 = u^2" by simp
  then show "norm (u *\<^sub>R x)^2  = u^2 * norm(x)^2"
    using norm_scaleR power2_eq_square
    by (simp add: power_mult_distrib)
qed

lemma sq_norm_strong_convex: "strong_convex_on s (\<lambda> w. k * norm(w) * norm(w)) (2*k)"
  for s :: "'a::euclidean_space set"
proof -
  let ?f = "(\<lambda> w. k * norm(w) * norm(w))"
  have "\<forall> x\<in>s. \<forall>y\<in>s. \<forall>u\<ge>0. \<forall>v\<ge>0.( u + v = 1 \<longrightarrow>
     ?f (u *\<^sub>R x + v *\<^sub>R y) \<le> u * ?f x + v * ?f y - (2*k/2) * u * v * norm(x-y) * norm(x-y) )"
  proof (rule)+
    fix x assume"x\<in>s"
    fix y assume"y\<in>s"
    fix u assume"(u::real) \<ge> 0"
    fix v assume"(v::real) \<ge> 0"
    assume "u+v = 1"
    then show "  k *norm (u *\<^sub>R x + v *\<^sub>R y) * norm (u *\<^sub>R x + v *\<^sub>R y) \<le>
u * (k * norm x * norm x) + v *(k * norm y * norm y) - 2 * k / 2 * u * v *norm (x - y) * norm (x - y)"
    proof -
      have  "?f  (u *\<^sub>R x + v *\<^sub>R y) = k*(norm (u  *\<^sub>R x +  v  *\<^sub>R y))^2"
        by (simp add: power2_eq_square)
      also  have "k*(norm (u  *\<^sub>R x +  v  *\<^sub>R y))^2 =
        k*(norm (u *\<^sub>R x)^2 + (2 * u * v) * (inner x y) + norm (v *\<^sub>R y)^2)" by (simp add: help2_2)
      also have " k*(norm (u *\<^sub>R x)^2 + (2 * u * v) * (inner x y) + norm (v *\<^sub>R y)^2) =
             k*(u^2 * norm (x)^2 + (2 * u * v) * (inner x y) + v^2 * norm (y)^2)" using help2_4 by metis
      also  have "k*(u^2 * norm (x)^2 + (2 * u * v) * (inner x y) + v^2 * norm (y)^2)  =
                            k*u*norm(x)^2 + (2 * k * u * v) * (inner x y) + k* v * norm (y)^2
                              - k * u * v * norm(x)^2 - k * u * v *norm(y)^2" using `u+v = 1`  by algebra
      also have "k*u*norm(x)^2 + (2 * k * u * v) * (inner x y) + k* v * norm (y)^2
                              - k * u * v * norm(x)^2 - k * u * v *norm(y)^2 =
                               k*u*norm(x)^2  + k* v * norm (y)^2
                              - (k * u * v) * ( norm(x)^2  -  2  * (inner x y) + norm(y)^2)" using distrib_left  help2_31 by argo
      also have " k*u*norm(x)^2  + k* v * norm (y)^2
                              - (k * u * v) * ( norm(x)^2  -  2  * (inner x y) + norm(y)^2) =
                           k*u*norm(x)^2  + k* v * norm (y)^2  - (k * u * v) * norm(x - y)^2"
        by (simp add: help2_31)

      finally have "?f  (u *\<^sub>R x + v *\<^sub>R y) =  u * ?f x + v * ?f y - (2*k/2) * u * v * norm(x-y) * norm(x-y)"
        by  (simp add: power2_eq_square help2_31)

      then show ?thesis   by linarith
    qed
  qed
  then show ?thesis unfolding strong_convex_on_def by blast
qed

instantiation "fun" :: (type, plus) plus
begin

definition fun_plus_def: "A + B = (\<lambda>x. A x + B x)"

lemma minus_apply [simp, code]: "(A + B) x = A x + B x"
  by (simp add: fun_plus_def)

instance ..

end

instantiation "fun" :: (ab_semigroup_add, ab_semigroup_add) ab_semigroup_add
begin

instance proof
  fix x y z :: "'a => 'b"
  show "x + y + z = x + (y + z)"
    unfolding fun_plus_def
    by (simp add: linordered_field_class.sign_simps(1))
next
  fix x y :: "'a => 'b"
  show "x + y = y + x"
    unfolding fun_plus_def
    by (simp add: linordered_field_class.sign_simps(2))
qed
end

instantiation "fun" :: (comm_monoid_add, comm_monoid_add) comm_monoid_add
begin

definition zero_fun_def:  "0 == (\<lambda>x. 0)"

instance proof
  fix a :: "'a => 'b"
  show "0 + a = a"
    unfolding zero_fun_def fun_plus_def by simp
qed

end

lemma convex_fun_add:
  assumes "convex_on s f" "convex_on s g"
  shows "convex_on s (f + g)"
proof -
  have "(f + g) = (\<lambda> x. f x + g x)" using fun_plus_def by auto
  moreover have "convex_on s (\<lambda>x. f x + g x)" using assms convex_on_add by auto
  ultimately show "convex_on s (f + g)" by auto
qed

lemma strong_convex_sum: "strong_convex_on s f k \<and> convex_on s g  \<longrightarrow>
                            strong_convex_on s ( f + g) k"
proof
  assume "strong_convex_on s f k \<and> convex_on s g"
  then show "strong_convex_on s (f + g) k"
  proof
    have "strong_convex_on s f k" using `strong_convex_on s f k \<and> convex_on s g` by simp
    have "convex_on s g" using `strong_convex_on s f k \<and> convex_on s g` by simp
    have  "(\<forall>x\<in>s. \<forall>y\<in>s. \<forall>u\<ge>0. \<forall>v\<ge>0. u + v = 1 \<longrightarrow>
     (f+g) (u *\<^sub>R x + v *\<^sub>R y) \<le>
      u * (f+g) x + v * (f+g) y - (k/2) * u * v * norm(x-y) * norm(x-y) )"
    proof (rule)+
      fix x assume"x\<in>s"
      fix y assume"y\<in>s"
      fix u assume"(u::real) \<ge> 0"
      fix v assume"(v::real) \<ge> 0"
      assume "u+v = 1"
      then show "(f+g) (u *\<^sub>R x + v *\<^sub>R y) \<le>
      u * (f+g) x + v * (f+g) y - (k/2) * u * v * norm(x-y) * norm(x-y)"
      proof -
        have 1: "f (u *\<^sub>R x + v *\<^sub>R y) \<le>
           u * f x + v * f y - (k/2) * u * v * norm(x-y) * norm(x-y)"
          using  \<open>0 \<le> u\<close> \<open>0 \<le> v\<close> \<open>u + v = 1\<close> \<open>x \<in> s\<close> \<open>y \<in> s\<close>
            `strong_convex_on s f k` unfolding strong_convex_on_def by blast

        have 2: " g (u *\<^sub>R x + v *\<^sub>R y) \<le> u * g x + v * g y"
          using \<open>0 \<le> u\<close> \<open>0 \<le> v\<close> \<open>u + v = 1\<close> \<open>x \<in> s\<close> \<open>y \<in> s\<close> `convex_on s g ` unfolding convex_on_def by blast

        have 3:"f (u *\<^sub>R x + v *\<^sub>R y)  +  g (u *\<^sub>R x + v *\<^sub>R y) \<le>
           u * f x + v * f y - (k/2) * u * v * norm(x-y) * norm(x-y)  +
       u * g x + v * g y "
          using 1 2 by linarith
        then show ?thesis  by (simp add: distrib_left)
      qed
    qed
    then show ?thesis unfolding strong_convex_on_def by auto
  qed
qed

lemma help7:
  assumes "(l::real)<0"
  assumes "\<forall>x. norm (f x - l)< -l"
  shows "\<forall>x. f x < 0"
proof (rule ccontr)
  assume "\<not> (\<forall>x. f x < 0)"
  then show False using assms(2)  real_norm_def by smt
qed

lemma LIM_fun_less_zero1: "f \<midarrow>a\<rightarrow> l \<Longrightarrow> l < 0 \<Longrightarrow> \<exists>r>0. \<forall>x. x \<noteq> a \<and> norm(a - x) < r \<longrightarrow> f x < 0"
  for a :: "'b::euclidean_space" and  l :: "real"
proof -
  assume "f \<midarrow>a\<rightarrow> l" "l < 0"
  then have "\<exists>r. 0 < r \<and> (\<forall>x. x \<noteq> a \<and> norm(a - x) < r \<longrightarrow> norm (f x - l)< -l)"
    using LIM_D[of f l a "-l"]
    by (simp add: norm_minus_commute)
  then obtain r where "0 < r" "(\<forall>x. x \<noteq> a \<and> norm(a - x) < r \<longrightarrow> norm (f x - l)< -l)" by auto
  then have "(\<forall>x. x \<noteq> a \<and> norm(a - x) < r \<longrightarrow>  f x < 0)"
    using `l<0` help7  by auto
  then show ?thesis
    using \<open>0 < r\<close> by blast
qed

lemma metric_LIM_le2:
  fixes a :: "real"
  assumes "f \<midarrow>a\<rightarrow> (l::real)"
  assumes "a\<ge>0"
    and "\<forall>x>a. f x \<ge> 0"
  shows " l \<ge> 0"
proof (rule ccontr)
  assume "\<not> (l \<ge> 0)"
  then have " l < 0"  by simp
  then have " \<exists>r>0. \<forall>x. x \<noteq> a \<and> norm(a - x) < r \<longrightarrow> f x < 0" using assms(1) LIM_fun_less_zero1 by blast
  then have "\<exists>r>0. \<forall>x>a. x \<noteq> a \<and> norm(a - x) < r \<longrightarrow> f x < 0 \<and> f x \<ge> 0"   using assms(3) by blast
  then have "\<exists>r>0. \<forall>x>a. norm(a - x) \<ge> r" by force
  then obtain r where "r>0" and " \<forall>x>a. norm(a - x) \<ge> r" by auto
  then have 1: "\<forall>x>a. norm(a - x) \<ge> r" by auto
  have  "\<exists>k. k>0 \<and>  k <r " using `r>0`  by (simp add: dense)
  then obtain k where "k>0" and "k < r" by auto
  then have "\<exists> x. x>a \<and> x-a = k" by smt
  then have "\<exists> x>a. norm(a-x) < r \<and> norm(a - x) \<ge> r" using  `k<r`1 by auto
  then show False  by linarith
qed

lemma metric_LIM_le_zero:
  fixes a :: "real"
  assumes "f \<midarrow>a\<rightarrow> (l::real)"
  assumes "a\<ge>0"
    and "\<exists>r>0. \<forall>x>a. norm(a-x) < r \<longrightarrow> f x \<ge> 0"
  shows " l \<ge> 0"
proof (rule ccontr)
  assume "\<not> (l \<ge> 0)"
  then have " l < 0"  by simp
  then have " \<exists>r>0. \<forall>x. x \<noteq> a \<and> norm(a - x) < r \<longrightarrow> f x < 0" using assms(1) LIM_fun_less_zero1
    by blast
  then obtain r where "r>0" and 1: "\<forall>x>a. norm(a - x) < r \<longrightarrow> f x < 0" by auto
  obtain r1 where "r1>0" and 2: "\<forall>x>a. norm(a-x) < r1 \<longrightarrow> f x \<ge> 0" using assms(3)
    by auto
  let ?min_r = "min r1 r"
  have 3: " r \<ge> ?min_r " by auto
  have 4: " r1 \<ge> ?min_r " by auto
  have "?min_r>0" using `r>0` `r1>0` by auto
  then have 5: "\<forall>x>a. norm(a - x) < ?min_r \<longrightarrow> f x < 0" using 1 3 by auto
  then have "\<forall>x>a. norm(a - x) < ?min_r \<longrightarrow> f x \<ge> 0" using 2 4 by auto
  then have "\<forall>x>a. norm(a - x) < ?min_r \<longrightarrow> f x < 0 \<and> f x \<ge> 0" using 5 by blast
  then have 6: "\<forall>x>a. norm(a - x) \<ge> ?min_r" by force

  then have  "\<exists>k. k>0 \<and>  k <?min_r " using `?min_r>0` dense by blast
  then obtain k where "k>0" and "k < ?min_r" by auto
  then have "\<exists> x. x>a \<and> x-a = k" by smt
  then have "\<exists> x>a. norm(a-x) < ?min_r \<and> norm(a - x) \<ge> ?min_r" using  `k<?min_r` 6 by auto
  then show False using LIM_fun_less_zero1
    by linarith
qed

lemma help_8: "x > 0 \<Longrightarrow> dist t 0 < r/x \<longrightarrow>
            norm(t) * x < r"
proof
  assume " x>0"
  assume "dist t 0 <  r/x"
  then have " norm(t) * x < (r/x) * x"
    using `dist t 0 <  r/x` `x>0` mult_less_le_imp_less[of "norm t"  "r/x" "x"  "x"] by auto
  then show "norm(t) * x  < r" using `x>0`  nonzero_mult_div_cancel_right by auto
qed

lemma real_collapse [simp]: "(1 - u) * a * b + (-1) * a * b = - u * a * b"
  for a :: "real"
  by (simp add: algebra_simps)

lemma real_left_commute: "a * b * x = b * a * x"
  for a :: real
  by (simp add: mult.commute)

lemma strongly_convex_min:
  assumes "strong_convex_on s f k"
  assumes "x \<in> s"
  assumes "\<forall>y\<in>s. (f x \<le> f y)"
  assumes "w \<in> s"
  assumes "convex s"
  shows "f w - f x \<ge> (k/2)*norm(w - x)^2"
proof (cases "w = x")
  case True
  then show ?thesis by auto
next
  case False
  then show ?thesis
  proof(cases "k = 0")
    case True
    then show ?thesis using assms(3) assms(4) by auto
  next
    case False
    then show ?thesis
    proof -
      have "(\<forall>x\<in>s. \<forall>y\<in>s. \<forall>u\<ge>0. \<forall>v\<ge>0. u + v = 1 \<longrightarrow>
     f (u *\<^sub>R x + v *\<^sub>R y) \<le> u * f x + v * f y - (k/2) * u * v * norm(x-y)^2)"
        using assms(1) unfolding  strong_convex_on_def
        by (simp add: power2_eq_square mult.commute mult.left_commute)
      then have 0:" \<forall>u\<ge>0. \<forall>v\<ge>0. u + v = 1 \<longrightarrow>
     f (u *\<^sub>R w + v *\<^sub>R x) \<le> u * f w + v * f x - (k/2) * u * v * norm(w-x)^2"
        using assms(2) assms(4) by blast

      have  "\<forall>u>0. \<forall>v\<ge>0. u + v = 1 \<longrightarrow>
     (f (u *\<^sub>R w + (1-u) *\<^sub>R x) - f x )/u \<le> f w  - f x - (k/2) * (1-u) * norm(w-x)^2"
      proof(rule)+
        fix u assume "(u::real)>0"
        fix v assume "(v::real) \<ge> 0"
        assume "u + v = 1"
        then show "(f (u *\<^sub>R w + (1-u) *\<^sub>R x) - f x )/u \<le> f w  - f x - (k/2) * (1-u) * norm(w-x)^2"
        proof -
          have "f (u *\<^sub>R w + (1-u) *\<^sub>R x)
            \<le> u * f w + (1-u) * f x - (k/2) * u * (1-u) * norm(w-x)^2" using `u + v = 1` 0
            \<open>0 < u\<close> \<open>0 \<le> v\<close> by auto
          then have " f (u *\<^sub>R w + (1-u) *\<^sub>R x)/u \<le>
        (u * f w + (1-u) * f x - (k/2) * u * (1-u) * norm(w-x)^2)/u" using `u>0`
            by (meson divide_right_mono less_eq_real_def)
          then have " f (u *\<^sub>R w + (1-u) *\<^sub>R x)/u \<le>
              (u * f w)/u + ((1-u) * f x)/u - ((k/2) * u * (1-u) * norm(w-x)^2)/u"
            by (simp add: add_divide_distrib diff_divide_distrib)
          then have " f (u *\<^sub>R w + (1-u) *\<^sub>R x)/u \<le>
               f w + ((1-u) / u)* f x - (k/2) * (1-u) * norm(w-x)^2"
            using \<open>0 < u\<close> add_divide_distrib diff_divide_distrib by auto
          then have " f (u *\<^sub>R w + (1-u) *\<^sub>R x)/u  \<le>
              f w + (1/u)* f x + (-u/u)*f x - (k/2) * (1-u) * norm(w-x)^2"
            by (simp add: diff_divide_distrib Groups.mult_ac(2) add_diff_eq right_diff_distrib')
          then have " f (u *\<^sub>R w + (1-u) *\<^sub>R x)/u - (1/u)* f x \<le>
              f w  - f x - (k/2) * (1-u) * norm(w-x)^2"
            using diff_divide_distrib Groups.mult_ac(2) add_diff_eq right_diff_distrib' `u>0` by force
          then show ?thesis
            by (simp add: diff_divide_distrib)
        qed
      qed
      then have 1:"\<forall>u>0. u <= 1 \<longrightarrow>
     (\<lambda> t. (f (t *\<^sub>R w + (1-t) *\<^sub>R x) - f x )/t) u \<le> (\<lambda> t. f w  - f x - (k/2) * (1-t) * norm(w-x)^2) u" by smt

      have "\<forall>u>0. u <= 1 \<longrightarrow> u *\<^sub>R w + (1 - u) *\<^sub>R x \<in> s "
         using assms(2) assms(4) assms(5) by (simp add: convex_def)
      then have "\<forall>u>0. u <= 1 \<longrightarrow>
    (\<lambda> t. (f (t *\<^sub>R w + (1-t) *\<^sub>R x) - f x )/t) u  \<ge> 0" using assms(3)
          assms(2) assms(4) by auto
      then have 11 : "\<forall>u>0. u <= 1 \<longrightarrow>
    0 \<le> (\<lambda> t. f w  - f x - (k/2) * (1-t) * norm(w-x)^2) u" using 1 by fastforce

      let ?f = "(\<lambda> t. f w  - f x - (k/2) * (1-t) * norm(w-x)^2)"
      let ?L = "(f w  - f x - (k/2) * norm(w-x)^2)"
      have "\<forall>t. dist (?f t) ?L = norm(?f t - ?L)"
        using dist_norm by blast

      then have 2: "\<forall>t. norm(?f t - ?L) =
       norm( (k/2) * (1-t) * norm(w-x)^2 + (-1)* (k/2) * norm(w-x)^2)" by auto

      then have 3: "\<forall>t. norm(?f t - ?L) = norm(t*(k/2) * norm(w-x)^2)"
        using "2" real_left_commute  real_collapse real_left_commute
        by (metis (no_types, hide_lams)  mult_minus_left norm_minus_cancel)

      then have "\<forall>t. norm(t*(k/2) * norm(w-x)^2) = norm(t) * norm(k/2) * norm(w-x)^2"
        using norm_ge_zero norm_mult power2_eq_square real_norm_def
        by smt
      then have 5:"\<forall>t. norm(?f t - ?L) = norm(t) * norm(w-x)^2 * norm((k/2))" using 3  by simp

      have 55: "norm(w-x)^2 * norm((k/2)) > 0" using `w \<noteq> x` `k \<noteq> 0` by auto
      then have "\<forall>r. \<forall>t. t \<noteq> 0 \<and> dist t 0 < ( r/(norm(w-x)^2 * norm(k/2))) \<longrightarrow>
            norm(t) * norm(w-x)^2 * norm((k/2)) < r"  by (simp add: help_8 mult.assoc)

      then have 6: "\<forall>r. \<forall>t. t \<noteq> 0 \<and> dist t 0 < ( r/(norm(w-x)^2 * norm(k/2))) \<longrightarrow>
            dist (?f t) ?L < r" using 5 dist_norm by metis

      then have "\<forall>r>0. (r/(norm(w-x)^2 * norm(k/2))) > 0"
        using divide_pos_pos 55 by blast
      then have "\<forall>r > 0. \<exists>s > 0. \<forall>t. t \<noteq> 0 \<and> dist t 0 < s \<longrightarrow>
          dist (?f t) ?L < r" using 6 by auto
      then have 7:" ?f \<midarrow>0\<rightarrow> ?L" unfolding LIM_def by auto

      then have "\<forall>u>0. u <= 1 \<longrightarrow> 0 \<le> ?f u" using 11 by simp
      then have "\<exists>r>0. \<forall>u>0.  u \<le> r \<longrightarrow> 0 \<le> ?f u"  using zero_less_one by blast
      then have "\<exists>r>0.\<forall>u>0. norm (0 -u) < r \<longrightarrow> 0 \<le> ?f u" by auto
      then have "?L \<ge> 0" using metric_LIM_le_zero using 7 by blast
      then show ?thesis by auto
    qed
  qed
qed

lemma strong_conv_if_eq: " f = g \<Longrightarrow> strong_convex_on s f k \<Longrightarrow> strong_convex_on s g k"
  using  HOL.subst by auto

lemma strong_conv_then_conv:
  assumes k_pos: "k \<ge> 0"
  shows "strong_convex_on s f k \<Longrightarrow> convex_on s f"
proof -
  assume "strong_convex_on s f k"
  then have 1:" (\<forall>x\<in>s. \<forall>y\<in>s. \<forall>u\<ge>0. \<forall>v\<ge>0. u + v = 1 \<longrightarrow>
     f (u *\<^sub>R x + v *\<^sub>R y) \<le> u * f x + v * f y - (k/2) * u * v * norm(x-y) * norm(x-y) )"
    unfolding strong_convex_on_def by auto
  have "\<forall>x\<in>s. \<forall>y\<in>s. \<forall>u\<ge>0. \<forall>v\<ge>0. u + v = 1 \<longrightarrow> (k/2) * u * v * norm(x-y) * norm(x-y) \<ge> 0"
    using k_pos  by simp
  then have "\<forall>x\<in>s. \<forall>y\<in>s. \<forall>u\<ge>0. \<forall>v\<ge>0. u + v = 1 \<longrightarrow>
  u * f x + v * f y - (k/2) * u * v * norm(x-y) * norm(x-y)  \<le>
  u * f x + v * f y " by auto
  then have "(\<forall>x\<in>s. \<forall>y\<in>s. \<forall>u\<ge>0. \<forall>v\<ge>0. u + v = 1 \<longrightarrow>
     f (u *\<^sub>R x + v *\<^sub>R y) \<le> u * f x + v * f y)" using 1 by smt
  then show "convex_on s f"  by (simp add: convex_on_def)
qed

end


theory Yen imports CoinClass begin

datatype Yen = Y1 | Y5 | Y10 | Y50 | Y100 | Y500

lemma UNIV_Yen: "(UNIV::Yen set) = {Y1, Y5, Y10, Y50, Y100, Y500}"
  apply(rule equalityI)
  apply(rule subsetI)
  apply(case_tac x; force)
  apply(rule subset_UNIV)
  done

theorem finite_UNIV_Yen: "finite (UNIV::Yen set)"
  apply(subst UNIV_Yen)
  apply(subst finite.intros)+
  apply(rule TrueI)
  done

theorem finite_Yen: "finite C" for C :: "Yen set"
  apply(rule rev_finite_subset)
  apply(rule finite_UNIV_Yen)
  apply(rule subset_UNIV)
  done

lemma Yen_double_exhaust: "\<lbrakk>
    P Y1 Y1; P Y1 Y5; P Y1 Y10; P Y1 Y50; P Y1 Y100; P Y1 Y500;
    P Y5 Y1; P Y5 Y5; P Y5 Y10; P Y5 Y50; P Y5 Y100; P Y5 Y500;
    P Y10 Y1; P Y10 Y5; P Y10 Y10; P Y10 Y50; P Y10 Y100; P Y10 Y500;
    P Y50 Y1; P Y50 Y5; P Y50 Y10; P Y50 Y50; P Y50 Y100; P Y50 Y500;
    P Y100 Y1; P Y100 Y5; P Y100 Y10; P Y100 Y50; P Y100 Y100; P Y100 Y500;
    P Y500 Y1; P Y500 Y5; P Y500 Y10; P Y500 Y50; P Y500 Y100; P Y500 Y500
\<rbrakk> \<Longrightarrow> P c1 c2"
  apply(rule_tac y=c1 in Yen.exhaust)
  apply(rule_tac y=c2 in Yen.exhaust; erule ssubst; erule ssubst; assumption)
  apply(rule_tac y=c2 in Yen.exhaust; erule ssubst; erule ssubst; assumption)
  apply(rule_tac y=c2 in Yen.exhaust; erule ssubst; erule ssubst; assumption)
  apply(rule_tac y=c2 in Yen.exhaust; erule ssubst; erule ssubst; assumption)
  apply(rule_tac y=c2 in Yen.exhaust; erule ssubst; erule ssubst; assumption)
  apply(rule_tac y=c2 in Yen.exhaust; erule ssubst; erule ssubst; assumption)
  done

instantiation Yen :: linorder begin
fun Yen_val_unit :: "Yen \<Rightarrow> val" where
  "Yen_val_unit Y1 = 1" |
  "Yen_val_unit Y5 = 5" |
  "Yen_val_unit Y10 = 10" |
  "Yen_val_unit Y50 = 50" |
  "Yen_val_unit Y100 = 100" |
  "Yen_val_unit Y500 = 500"

lemma inj_Yen_val_unit: "inj Yen_val_unit"
  apply(unfold inj_def)
  apply(intro allI)
  apply(rule Yen_double_exhaust)
  apply(auto)
  done

lemma dvd_Yen_val_unit[rule_format]: "Yen_val_unit c1 < Yen_val_unit c2 \<longrightarrow> Yen_val_unit c1 dvd Yen_val_unit c2"
  apply(rule Yen_double_exhaust)
  apply(auto)
  done

lemma Yen_val_unit_gt_0: "Yen_val_unit c > 0"
  apply(case_tac c; auto)
  done

lemma Yen_val_unit_range: "range Yen_val_unit = {1, 5, 10, 50, 100, 500}"
  apply(auto)
  apply(case_tac "xa"; auto)
  apply(subst One_nat_def[symmetric])
  apply(fold Yen_val_unit.simps)
  apply(rule range_eqI; rule refl)
  apply(rule range_eqI; rule refl)
  apply(rule range_eqI; rule refl)
  apply(rule range_eqI; rule refl)
  apply(rule range_eqI; rule refl)
  apply(rule range_eqI; rule refl)
  done

definition "less_Yen (a::Yen) (b::Yen) \<equiv> Yen_val_unit a < Yen_val_unit b"
definition "less_eq_Yen (a::Yen) (b::Yen) \<equiv> Yen_val_unit a \<le> Yen_val_unit b"

instance
  apply(standard)
  apply(auto simp add: less_Yen_def less_eq_Yen_def inj_def)
  apply(insert inj_Yen_val_unit)
  apply(auto simp add: inj_def)
  done
end

lemma strict_mono_Yen_val_unit: "strict_mono Yen_val_unit"
  apply(simp add: strict_mono_def less_Yen_def)
  done

instantiation Yen :: order_bot begin
definition "bot_Yen \<equiv> Y1"
instance
  apply(standard)
  apply(unfold bot_Yen_def less_eq_Yen_def)
  apply(case_tac "a"; auto)
  done
end

instantiation Yen :: order_top begin
definition "top_Yen \<equiv> Y500"
instance
  apply(standard)
  apply(unfold top_Yen_def less_eq_Yen_def)
  apply(case_tac "a"; auto)
  done
end

instantiation Yen :: Inf begin
definition "Inf_Yen C \<equiv>
  if Y1 \<in> C then Y1
    else if Y5 \<in> C then Y5
      else if Y10 \<in> C then Y10
        else if Y50 \<in> C then Y50
          else if Y100 \<in> C then Y100
            else Y500"

lemma Inf_empty_is_top_Yen: "Inf {} = (top::Yen)"
  apply(unfold top_Yen_def Inf_Yen_def)
  apply(auto)
  done

lemma Yen_val_unit_Inf_le: "x \<in> A \<Longrightarrow> Yen_val_unit (Inf A) \<le> Yen_val_unit x"
  apply(unfold Inf_Yen_def)
  apply(case_tac x; auto)
  done

lemma Yen_val_unit_le_Inf: "(\<forall>x \<in> A. Yen_val_unit z \<le> Yen_val_unit x)
    \<Longrightarrow> Yen_val_unit z \<le> Yen_val_unit (Inf A)"
  apply(unfold Inf_Yen_def)
  apply(case_tac z; auto)
  done

instance by standard
end

instantiation Yen :: Sup begin
definition "Sup_Yen C \<equiv>
  if Y500 \<in> C then Y500
    else if Y100 \<in> C then Y100
      else if Y50 \<in> C then Y50
        else if Y10 \<in> C then Y10
          else if Y5 \<in> C then Y5
            else Y1"

lemma Sup_empty_is_bot_Yen: "Sup {} = (bot::Yen)"
  apply(unfold bot_Yen_def Sup_Yen_def)
  apply(auto)
  done

lemma Yen_val_unit_le_Sup: "x \<in> A \<Longrightarrow> Yen_val_unit x \<le> Yen_val_unit (Sup A)"
  apply(unfold Sup_Yen_def)
  apply(case_tac x; auto)
  done

lemma Yen_val_unit_Sup_le: "(\<forall>x \<in> A. Yen_val_unit x \<le> Yen_val_unit z)
    \<Longrightarrow> Yen_val_unit (Sup A) \<le> Yen_val_unit z"
  apply(unfold Sup_Yen_def)
  apply(case_tac z; auto)
  done

instance by standard
end

instantiation Yen :: complete_lattice begin
definition "inf_Yen (a::Yen) (b::Yen) \<equiv> if a \<le> b then a else b"
definition "sup_Yen (a::Yen) (b::Yen) \<equiv> if a \<le> b then b else a"
instance
  apply(standard)
  apply(auto simp add: less_eq_Yen_def inf_Yen_def sup_Yen_def top_Yen_def bot_Yen_def)
  apply(auto intro: Yen_val_unit_Inf_le Yen_val_unit_le_Inf Yen_val_unit_le_Sup Yen_val_unit_Sup_le)
  apply(fold top_Yen_def bot_Yen_def)
  apply(auto intro: Inf_empty_is_top_Yen Sup_empty_is_bot_Yen)
  done
end

instantiation Yen :: coins begin
definition "val_unit_Yen \<equiv> Yen_val_unit"
instance
  apply(standard)
  apply(auto simp add: val_unit_Yen_def bot_Yen_def intro: strict_mono_Yen_val_unit dvd_Yen_val_unit)
  done
end
end


theory Ex013
imports Main
begin

lemma "(A \<longrightarrow> B) \<longrightarrow> (\<not>B \<longrightarrow> \<not>A)"
proof -
{
  assume "A \<longrightarrow> B"
  {
    assume "\<not>B"
    {
      assume A
      with \<open>A \<longrightarrow> B\<close> have B by (rule impE)
      with \<open>\<not>B\<close> have False by contradiction
    }
    hence "\<not>A" by (rule notI)
  }
  hence "\<not>B \<longrightarrow> \<not>A" by (rule impI)
}
thus ?thesis by (rule impI)
qed


theory P3 imports Main
begin

fun replace :: "'a \<Rightarrow> 'a \<Rightarrow> 'a list \<Rightarrow> 'a list"  where
"replace x y Nil = Nil" |
"(replace x y (Cons z xs)) = (if x=z then (Cons y (replace x y xs)) else (Cons z (replace x y xs)))"

lemma [simp]: "replace x y (zs @ [x]) = replace x y zs @ [y]"
  apply (induct zs)
   apply auto
  done

lemma [simp]: "x \<noteq> a \<Longrightarrow> replace x y zs @ [a] = replace x y (zs @ [a])"
  apply (induct zs)
   apply auto
  done

theorem "rev(replace x y zs) = replace x y (rev zs)"
  apply (induct zs)
   apply auto
  done

lemma "replace x y (replace u v zs) = replace u v (replace x y zs)"
  nitpick
  oops

lemma "replace y z (replace x y zs) = replace x z zs"
  nitpick
  oops

fun del1 :: "'a \<Rightarrow> 'a list \<Rightarrow> 'a list" where
"del1 x Nil = Nil" |
"del1 x (y # xs) = (if x=y then xs else (y # xs))"

fun delall :: "'a \<Rightarrow> 'a list \<Rightarrow> 'a list" where
"delall x Nil = Nil" |
"delall x (y # xs) = (if x=y then (delall x xs) else (y # (delall x xs)))"

theorem "del1 x (delall x xs) = delall x xs"
  apply (induct xs)
   apply auto
  done

theorem "delall x (delall x xs) = delall x xs"
  apply (induct xs)
   apply auto
  done

theorem "delall x (del1 x xs) = delall x xs"
  apply (induct xs)
   apply auto
  done

lemma "del1 x (del1 y zs) = del1 y (del1 x zs)"
  nitpick
  oops

lemma "delall x (del1 y zs) = del1 y (delall x zs)"
  nitpick
  oops

theorem "delall x (delall y xs) = delall y (delall x xs)"
  apply (induct xs)
   apply auto
  done

lemma "del1 y (replace x y xs) = del1 x xs"
  nitpick
  oops

lemma "delall y (replace x y xs) = delall x xs"
  nitpick
  oops

theorem "replace x y (delall x xs) = delall x xs"
  apply (induct xs)
   apply auto
  done

lemma "replace x y (delall z xs) = delall z (replace x y xs)"
  nitpick
  oops

lemma "rev(del1 x xs) = del1 x (rev xs)"
  nitpick
  oops

lemma [simp]: "delall x (xs @ [x]) = delall x xs"
  apply (induct xs)
  apply auto
  done

lemma [simp]: "x \<noteq> a \<Longrightarrow> delall x xs @ [a] = delall x (xs @ [a])"
  apply (induct xs)
   apply auto
  done

theorem "rev(delall x xs) = delall x (rev xs)"
  apply (induct xs)
   apply auto
  done

end


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

header{*Inverse of a matrix using the Gauss Jordan algorithm*}

theory Inverse
imports
  Gauss_Jordan_PA
begin

subsection{*Several properties*}

text{*Properties about Gauss Jordan algorithm, reduced row echelon form, rank, identity matrix and invertibility*}

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

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

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

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

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

subsection{*Computing the inverse of a matrix using the Gauss Jordan algorithm*}

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

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

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

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

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

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

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

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

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

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

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

end