(*
  File: Primes_Ex.thy
  Author: Bohua Zhan

  Elementary number theory of primes, up to the proof of infinitude
  of primes and the unique factorization theorem.

  Follows the development in HOL/Computational_Algebra/Primes.thy.
*)

section \<open>Primes\<close>

theory Primes_Ex
  imports Auto2_Main
begin

subsection \<open>Basic definition\<close>

definition prime :: "nat \<Rightarrow> bool" where [rewrite]:
  "prime p = (1 < p \<and> (\<forall>m. m dvd p \<longrightarrow> m = 1 \<or> m = p))"

lemma primeD1 [forward]: "prime p \<Longrightarrow> 1 < p" by auto2
lemma primeD2: "prime p \<Longrightarrow> m dvd p \<Longrightarrow> m = 1 \<or> m = p" by auto2
setup \<open>add_forward_prfstep_cond @{thm primeD2} [with_cond "?m \<noteq> 1", with_cond "?m \<noteq> ?p"]\<close>
setup \<open>del_prfstep_thm_eqforward @{thm prime_def}\<close>

(* Exists a prime p. *)
theorem exists_prime [resolve]: "\<exists>p. prime p"
@proof @have "prime 2" @qed

lemma prime_odd_nat: "prime p \<Longrightarrow> p > 2 \<Longrightarrow> odd p" by auto2

lemma prime_imp_coprime_nat [backward2]: "prime p \<Longrightarrow> \<not> p dvd n \<Longrightarrow> coprime p n" by auto2

lemma prime_dvd_mult_nat: "prime p \<Longrightarrow> p dvd m * n \<Longrightarrow> p dvd m \<or> p dvd n" by auto2
setup \<open>add_forward_prfstep_cond @{thm prime_dvd_mult_nat}
  (with_conds ["?m \<noteq> ?p", "?n \<noteq> ?p", "?m \<noteq> ?p * ?m'", "?n \<noteq> ?p * ?n'"])\<close>

theorem prime_dvd_intro: "prime p \<Longrightarrow> p * q = m * n \<Longrightarrow> p dvd m \<or> p dvd n"
@proof @have "p dvd m * n" @qed
setup \<open>add_forward_prfstep_cond @{thm prime_dvd_intro}
  (with_conds ["?m \<noteq> ?p", "?n \<noteq> ?p", "?m \<noteq> ?p * ?m'", "?n \<noteq> ?p * ?n'"])\<close>

lemma prime_dvd_mult_eq_nat: "prime p \<Longrightarrow> p dvd m * n = (p dvd m \<or> p dvd n)" by auto2

lemma not_prime_eq_prod_nat [backward1]: "n > 1 \<Longrightarrow> \<not> prime n \<Longrightarrow>
    \<exists>m k. n = m * k \<and> 1 < m \<and> m < n \<and> 1 < k \<and> k < n"
@proof
  @obtain m where "m dvd n \<and> m \<noteq> 1 \<and> m \<noteq> n"
  @obtain k where "n = m * k" @have "m \<le> m * k" @have "k \<le> m * k"
@qed

lemma prime_dvd_power_nat: "prime p \<Longrightarrow> p dvd x^n \<Longrightarrow> p dvd x" by auto2
setup \<open>add_forward_prfstep_cond @{thm prime_dvd_power_nat} [with_cond "?p \<noteq> ?x"]\<close>

lemma prime_dvd_power_nat_iff: "prime p \<Longrightarrow> n > 0 \<Longrightarrow> p dvd x^n \<longleftrightarrow> p dvd x" by auto2

lemma prime_nat_code: "prime p = (1 < p \<and> (\<forall>x. 1 < x \<and> x < p \<longrightarrow> \<not> x dvd p))" by auto2

lemma prime_factor_nat [backward]: "n \<noteq> 1 \<Longrightarrow> \<exists>p. p dvd n \<and> prime p"
@proof
  @strong_induct n
  @case "prime n" @case "n = 0"
  @obtain k where "k \<noteq> 1" "k \<noteq> n" "k dvd n"
  @apply_induct_hyp k
@qed

lemma prime_divprod_pow_nat:
  "prime p \<Longrightarrow> coprime a b \<Longrightarrow> p^n dvd a * b \<Longrightarrow> p^n dvd a \<or> p^n dvd b" by auto2

lemma prime_product [forward]: "prime (p * q) \<Longrightarrow> p = 1 \<or> q = 1"
@proof @have "p dvd q * p" @qed

lemma prime_exp: "prime (p ^ n) \<longleftrightarrow> n = 1 \<and> prime p" by auto2

lemma prime_power_mult: "prime p \<Longrightarrow> x * y = p ^ k \<Longrightarrow> \<exists>i j. x = p ^ i \<and> y = p ^ j"
@proof
  @induct k arbitrary x y @with
    @subgoal "k = Suc k'"
      @case "p dvd x" @with
        @obtain x' where "x = p * x'" @have "x * y = p * (x' * y)"
        @obtain i j where "x' = p ^ i" "y = p ^ j" @have "x = p ^ Suc i" @end
      @case "p dvd y" @with
        @obtain y' where "y = p * y'" @have "x * y = p * (x * y')"
        @obtain i j where "x = p ^ i" "y' = p ^ j" @have "y = p ^ Suc j" @end
    @endgoal
  @end
@qed

subsection \<open>Infinitude of primes\<close>

theorem bigger_prime [resolve]: "\<exists>p. prime p \<and> n < p"
@proof
  @obtain p where "prime p" "p dvd fact n + 1"
  @case "n \<ge> p" @with @have "(p::nat) dvd fact n" @end
@qed

theorem primes_infinite: "\<not> finite {p. prime p}"
@proof
  @obtain b where "prime b" "Max {p. prime p} < b"
@qed

subsection \<open>Existence and uniqueness of prime factorization\<close>

theorem factorization_exists: "n > 0 \<Longrightarrow> \<exists>M. (\<forall>p\<in>#M. prime p) \<and> n = (\<Prod>i\<in>#M. i)"
@proof
  @strong_induct n
  @case "n = 1" @with @have "n = (\<Prod>i\<in># {#}. i)" @end
  @case "prime n" @with @have "n = (\<Prod>i\<in># {#n#}. i)" @end
  @obtain m k where "n = m * k" "1 < m" "m < n" "1 < k" "k < n"
  @apply_induct_hyp m
  @obtain M where "(\<forall>p\<in>#M. prime p)" "m = (\<Prod>i\<in>#M. i)"
  @apply_induct_hyp k
  @obtain K where "(\<forall>p\<in>#K. prime p)" "k = (\<Prod>i\<in>#K. i)"
  @have "n = (\<Prod>i\<in>#(M+K). i)"
@qed

theorem prime_dvd_multiset [backward1]: "prime p \<Longrightarrow> p dvd (\<Prod>i\<in>#M. i) \<Longrightarrow> \<exists>n. n\<in>#M \<and> p dvd n"
@proof
  @strong_induct M
  @case "M = {#}"
  @obtain M' m where "M = M' + {#m#}"
  @contradiction @apply_induct_hyp M'
@qed

theorem factorization_unique_aux:
  "\<forall>p\<in>#M. prime p \<Longrightarrow> \<forall>p\<in>#N. prime p \<Longrightarrow> (\<Prod>i\<in>#M. i) dvd (\<Prod>i\<in>#N. i) \<Longrightarrow> M \<subseteq># N"
@proof
  @strong_induct M arbitrary N
  @case "M = {#}"
  @obtain M' m where "M = M' + {#m#}"
  @have "m dvd (\<Prod>i\<in>#M. i)"
  @obtain n where "n \<in># N" "m dvd n"
  @obtain N' where "N = N' + {#n#}"
  @have "m = n"
  @have "(\<Prod>i\<in>#M'. i) dvd (\<Prod>i\<in>#N'. i)"
  @apply_induct_hyp M' N'
@qed
setup \<open>add_forward_prfstep_cond @{thm factorization_unique_aux} [with_cond "?M \<noteq> ?N"]\<close>

theorem factorization_unique:
  "\<forall>p\<in>#M. prime p \<Longrightarrow> \<forall>p\<in>#N. prime p \<Longrightarrow> (\<Prod>i\<in>#M. i) = (\<Prod>i\<in>#N. i) \<Longrightarrow> M = N"
@proof @have "M \<subseteq># N" @qed
setup \<open>del_prfstep_thm @{thm factorization_unique_aux}\<close>

end


theory "insertion-sort"
  imports Main "HOL-Library.Multiset"
begin

declare[[names_short]]

text \<open>non-tail recursive\<close>

primrec insert:: "nat \<Rightarrow> nat list \<Rightarrow> nat list" where
insert_Nil: "insert x [] = [x]" |
insert_Cons: "insert x (y#ys) = (if x < y then (x#y#ys) else y#insert x ys)"

value "insert 1 [2,4,10]"

primrec insertion_sort:: "nat list \<Rightarrow> nat list" where
insertion_sort_Nil : "insertion_sort []  = []" |
insertion_sort_Cons: "insertion_sort (x#xs)  = insert x (insertion_sort(xs))"

value "insert_sort [2,4,10,0,3]"

lemma sorted3 : "\<lbrakk>sorted(y#ys); \<not> x < y\<rbrakk> \<Longrightarrow> sorted (y#insert x ys) = (y \<le> x \<and> sorted(insert x ys))"
proof(induction ys  rule: sorted.induct)
  case 1
  then show "sorted (y # insert x []) = (y \<le> x \<and> sorted (insert x []))" by auto
next
  case (2 x ys)
  then show ?case by (simp del:List.linorder_class.sorted.simps add:sorted2_simps)
qed

lemma insert_order: "sorted(ys) \<Longrightarrow> sorted (insert x ys)"
proof (induct ys arbitrary: x)
  case Nil
  then show "sorted (insert x [])" by simp
next
  case (Cons y ys)
  then show "sorted (insert x (y # ys))"
  proof (cases "x < y")
    case True
    then show "sorted (insert x (y # ys))"
    proof (simp only: True insert_Cons if_True)
      show "sorted (x # y # ys)"
      proof(simp)
        show "x \<le> y \<and> Ball (set ys) ((\<le>) x) \<and> Ball (set ys) ((\<le>) y) \<and> sorted ys"
        proof(intro conjI)
          show "x \<le> y"  by (simp add: Orderings.order_class.order.strict_implies_order True)
        next
          show "Ball (set ys) ((\<le>) x)" using True local.Cons.prems by auto
        next
          show "Ball (set ys) ((\<le>) y)"  using List.linorder_class.sorted.simps(2) local.Cons.prems by simp
        next
          show "sorted ys" using List.linorder_class.sorted.simps(2) local.Cons.prems by simp
        qed
      qed
    qed
  next
    case False
    then show "sorted (insert x (y # ys))"
    proof(simp only:False insert_Cons if_False)
      show "sorted (y # insert x ys)"
      proof(simp  del:List.linorder_class.sorted.simps add: False sorted3 "local.Cons.prems")
        show "y \<le> x \<and> sorted (insert x ys)"
        proof(rule conjI)
          show "y \<le> x"  by (simp add: False leI)
        next
          have "sorted ys" using "local.Cons.prems" List.linorder_class.sorted.simps(2) by blast
          then show "sorted (insert x ys)"  by (simp add: local.Cons.hyps)
        qed
      qed
    qed
  qed
qed

theorem insertion_sort_order : "sorted(insertion_sort(ys))"
proof (induct ys)
  case Nil
  then show "sorted (insertion_sort [])" by simp
next
  case (Cons y ys)
  show "sorted (insertion_sort (y # ys))"
  proof (simp only: insertion_sort_Cons)
    show "sorted (insert y (insertion_sort ys))" by (simp only: "local.Cons.hyps" insert_order)
  qed
qed

lemma insert_permutation: "mset (insert x ys) = mset (x#ys)"
proof(induct ys arbitrary: x)
  case Nil
  then show "mset (insert x []) = mset [x]" by simp
next
  case (Cons y ys)
  then show "mset (insert x (y # ys)) = mset (x # y # ys)"
  proof (cases "x < y")
    case True
    then show "mset (insert x (y # ys)) = mset (x # y # ys)" by simp
  next
    case False
    have "mset (insert x (y # ys)) = mset (y#insert x ys)" using False by simp
    also have "... = {#y#} + mset(insert x ys)" by simp
    also have "... = {#y#} + mset (x # ys)" using "local.Cons.hyps" False by simp
    also have "... = mset (x # y # ys)"  by simp
    finally show "mset (insert x (y # ys)) = mset (x # y # ys)" by this
  qed
qed

theorem insertion_sort_permutation: "mset (insertion_sort ys) = mset ys"
proof(induct ys)
  case Nil
  then show "mset (insertion_sort []) = mset []" by simp
next
  case (Cons x xs)
  have "mset (insertion_sort (x # xs)) = mset (insert x (insertion_sort(xs)))" by simp
  also have "... =  mset(x#(insertion_sort(xs)))" using  insert_permutation by simp
  also have "... =  {#x#} + mset(insertion_sort(xs))" by simp
  also have "... =  {#x#} +  mset xs" using "local.Cons.hyps" by simp
  also have "... =  mset (x # xs)" using "local.Cons.hyps" by simp
  finally show "mset (insertion_sort (x # xs)) = mset (x # xs)" by this
qed

text \<open>tail recursive\<close>

fun insertion_sort_tail:: "nat list \<Rightarrow> nat list \<Rightarrow> nat list" where
insertion_sort_tail_Nil : "insertion_sort_tail [] accum  = accum" |
insertion_sort_tail_Cons: "insertion_sort_tail (x#xs) accum  = insertion_sort_tail (xs) (insert x accum)"

value "insert_sort_tail ([2,4,10]) ([])"

theorem insert_sort_tail_order: "sorted(ACCUM) \<Longrightarrow> sorted(insertion_sort_tail xs ACCUM)"
proof(induct xs arbitrary:ACCUM)
  case Nil
  then show "sorted (insertion_sort_tail [] ACCUM)" by simp
next
  case (Cons a xs)
  then show "sorted (insertion_sort_tail (a # xs) ACCUM)" by (simp add: insert_order)
qed

theorem insertion_sort_tail_permutation: "mset (insertion_sort_tail xs ACCUM) = mset (xs@ACCUM)"
proof(induct xs arbitrary:ACCUM)
  case Nil
  then show "mset (insertion_sort_tail [] ACCUM) = mset ([] @ ACCUM)" by simp
next
  case (Cons a xs)
  then show ?case by (simp add: insert_permutation)
qed


(*  Title:      HOL/Library/Permutation.thy
    Author:     Lawrence C Paulson and Thomas M Rasmussen and Norbert Voelker
*)

section {* Permutations *}

theory Permutation
imports Multiset
begin

inductive perm :: "'a list \<Rightarrow> 'a list \<Rightarrow> bool"  ("_ <~~> _"  [50, 50] 50)  (* FIXME proper infix, without ambiguity!? *)
where
  Nil [intro!]: "[] <~~> []"
| swap [intro!]: "y # x # l <~~> x # y # l"
| Cons [intro!]: "xs <~~> ys \<Longrightarrow> z # xs <~~> z # ys"
| trans [intro]: "xs <~~> ys \<Longrightarrow> ys <~~> zs \<Longrightarrow> xs <~~> zs"

lemma perm_refl [iff]: "l <~~> l"
  by (induct l) auto

subsection {* Some examples of rule induction on permutations *}

lemma xperm_empty_imp: "[] <~~> ys \<Longrightarrow> ys = []"
  by (induct xs == "[] :: 'a list" ys pred: perm) simp_all

text {* \medskip This more general theorem is easier to understand! *}

lemma perm_length: "xs <~~> ys \<Longrightarrow> length xs = length ys"
  by (induct pred: perm) simp_all

lemma perm_empty_imp: "[] <~~> xs \<Longrightarrow> xs = []"
  by (drule perm_length) auto

lemma perm_sym: "xs <~~> ys \<Longrightarrow> ys <~~> xs"
  by (induct pred: perm) auto

subsection {* Ways of making new permutations *}

text {* We can insert the head anywhere in the list. *}

lemma perm_append_Cons: "a # xs @ ys <~~> xs @ a # ys"
  by (induct xs) auto

lemma perm_append_swap: "xs @ ys <~~> ys @ xs"
  apply (induct xs)
    apply simp_all
  apply (blast intro: perm_append_Cons)
  done

lemma perm_append_single: "a # xs <~~> xs @ [a]"
  by (rule perm.trans [OF _ perm_append_swap]) simp

lemma perm_rev: "rev xs <~~> xs"
  apply (induct xs)
   apply simp_all
  apply (blast intro!: perm_append_single intro: perm_sym)
  done

lemma perm_append1: "xs <~~> ys \<Longrightarrow> l @ xs <~~> l @ ys"
  by (induct l) auto

lemma perm_append2: "xs <~~> ys \<Longrightarrow> xs @ l <~~> ys @ l"
  by (blast intro!: perm_append_swap perm_append1)

subsection {* Further results *}

lemma perm_empty [iff]: "[] <~~> xs \<longleftrightarrow> xs = []"
  by (blast intro: perm_empty_imp)

lemma perm_empty2 [iff]: "xs <~~> [] \<longleftrightarrow> xs = []"
  apply auto
  apply (erule perm_sym [THEN perm_empty_imp])
  done

lemma perm_sing_imp: "ys <~~> xs \<Longrightarrow> xs = [y] \<Longrightarrow> ys = [y]"
  by (induct pred: perm) auto

lemma perm_sing_eq [iff]: "ys <~~> [y] \<longleftrightarrow> ys = [y]"
  by (blast intro: perm_sing_imp)

lemma perm_sing_eq2 [iff]: "[y] <~~> ys \<longleftrightarrow> ys = [y]"
  by (blast dest: perm_sym)

subsection {* Removing elements *}

lemma perm_remove: "x \<in> set ys \<Longrightarrow> ys <~~> x # remove1 x ys"
  by (induct ys) auto

text {* \medskip Congruence rule *}

lemma perm_remove_perm: "xs <~~> ys \<Longrightarrow> remove1 z xs <~~> remove1 z ys"
  by (induct pred: perm) auto

lemma remove_hd [simp]: "remove1 z (z # xs) = xs"
  by auto

lemma cons_perm_imp_perm: "z # xs <~~> z # ys \<Longrightarrow> xs <~~> ys"
  by (drule_tac z = z in perm_remove_perm) auto

lemma cons_perm_eq [iff]: "z#xs <~~> z#ys \<longleftrightarrow> xs <~~> ys"
  by (blast intro: cons_perm_imp_perm)

lemma append_perm_imp_perm: "zs @ xs <~~> zs @ ys \<Longrightarrow> xs <~~> ys"
  by (induct zs arbitrary: xs ys rule: rev_induct) auto

lemma perm_append1_eq [iff]: "zs @ xs <~~> zs @ ys \<longleftrightarrow> xs <~~> ys"
  by (blast intro: append_perm_imp_perm perm_append1)

lemma perm_append2_eq [iff]: "xs @ zs <~~> ys @ zs \<longleftrightarrow> xs <~~> ys"
  apply (safe intro!: perm_append2)
  apply (rule append_perm_imp_perm)
  apply (rule perm_append_swap [THEN perm.trans])
    -- {* the previous step helps this @{text blast} call succeed quickly *}
  apply (blast intro: perm_append_swap)
  done

lemma multiset_of_eq_perm: "multiset_of xs = multiset_of ys \<longleftrightarrow> xs <~~> ys"
  apply (rule iffI)
  apply (erule_tac [2] perm.induct)
  apply (simp_all add: union_ac)
  apply (erule rev_mp)
  apply (rule_tac x=ys in spec)
  apply (induct_tac xs)
  apply auto
  apply (erule_tac x = "remove1 a x" in allE)
  apply (drule sym)
  apply simp
  apply (subgoal_tac "a \<in> set x")
  apply (drule_tac z = a in perm.Cons)
  apply (erule perm.trans)
  apply (rule perm_sym)
  apply (erule perm_remove)
  apply (drule_tac f=set_of in arg_cong)
  apply simp
  done

lemma multiset_of_le_perm_append: "multiset_of xs \<le> multiset_of ys \<longleftrightarrow> (\<exists>zs. xs @ zs <~~> ys)"
  apply (auto simp: multiset_of_eq_perm[THEN sym] mset_le_exists_conv)
  apply (insert surj_multiset_of)
  apply (drule surjD)
  apply (blast intro: sym)+
  done

lemma perm_set_eq: "xs <~~> ys \<Longrightarrow> set xs = set ys"
  by (metis multiset_of_eq_perm multiset_of_eq_setD)

lemma perm_distinct_iff: "xs <~~> ys \<Longrightarrow> distinct xs = distinct ys"
  apply (induct pred: perm)
     apply simp_all
   apply fastforce
  apply (metis perm_set_eq)
  done

lemma eq_set_perm_remdups: "set xs = set ys \<Longrightarrow> remdups xs <~~> remdups ys"
  apply (induct xs arbitrary: ys rule: length_induct)
  apply (case_tac "remdups xs")
   apply simp_all
  apply (subgoal_tac "a \<in> set (remdups ys)")
   prefer 2 apply (metis list.set(2) insert_iff set_remdups)
  apply (drule split_list) apply (elim exE conjE)
  apply (drule_tac x = list in spec) apply (erule impE) prefer 2
   apply (drule_tac x = "ysa @ zs" in spec) apply (erule impE) prefer 2
    apply simp
    apply (subgoal_tac "a # list <~~> a # ysa @ zs")
     apply (metis Cons_eq_appendI perm_append_Cons trans)
    apply (metis Cons Cons_eq_appendI distinct.simps(2)
      distinct_remdups distinct_remdups_id perm_append_swap perm_distinct_iff)
   apply (subgoal_tac "set (a # list) =
      set (ysa @ a # zs) \<and> distinct (a # list) \<and> distinct (ysa @ a # zs)")
    apply (fastforce simp add: insert_ident)
   apply (metis distinct_remdups set_remdups)
   apply (subgoal_tac "length (remdups xs) < Suc (length xs)")
   apply simp
   apply (subgoal_tac "length (remdups xs) \<le> length xs")
   apply simp
   apply (rule length_remdups_leq)
  done

lemma perm_remdups_iff_eq_set: "remdups x <~~> remdups y \<longleftrightarrow> set x = set y"
  by (metis List.set_remdups perm_set_eq eq_set_perm_remdups)

lemma permutation_Ex_bij:
  assumes "xs <~~> ys"
  shows "\<exists>f. bij_betw f {..<length xs} {..<length ys} \<and> (\<forall>i<length xs. xs ! i = ys ! (f i))"
  using assms
proof induct
  case Nil
  then show ?case
    unfolding bij_betw_def by simp
next
  case (swap y x l)
  show ?case
  proof (intro exI[of _ "Fun.swap 0 1 id"] conjI allI impI)
    show "bij_betw (Fun.swap 0 1 id) {..<length (y # x # l)} {..<length (x # y # l)}"
      by (auto simp: bij_betw_def)
    fix i
    assume "i < length (y # x # l)"
    show "(y # x # l) ! i = (x # y # l) ! (Fun.swap 0 1 id) i"
      by (cases i) (auto simp: Fun.swap_def gr0_conv_Suc)
  qed
next
  case (Cons xs ys z)
  then obtain f where bij: "bij_betw f {..<length xs} {..<length ys}"
    and perm: "\<forall>i<length xs. xs ! i = ys ! (f i)"
    by blast
  let ?f = "\<lambda>i. case i of Suc n \<Rightarrow> Suc (f n) | 0 \<Rightarrow> 0"
  show ?case
  proof (intro exI[of _ ?f] allI conjI impI)
    have *: "{..<length (z#xs)} = {0} \<union> Suc ` {..<length xs}"
            "{..<length (z#ys)} = {0} \<union> Suc ` {..<length ys}"
      by (simp_all add: lessThan_Suc_eq_insert_0)
    show "bij_betw ?f {..<length (z#xs)} {..<length (z#ys)}"
      unfolding *
    proof (rule bij_betw_combine)
      show "bij_betw ?f (Suc ` {..<length xs}) (Suc ` {..<length ys})"
        using bij unfolding bij_betw_def
        by (auto intro!: inj_onI imageI dest: inj_onD simp: image_comp comp_def)
    qed (auto simp: bij_betw_def)
    fix i
    assume "i < length (z # xs)"
    then show "(z # xs) ! i = (z # ys) ! (?f i)"
      using perm by (cases i) auto
  qed
next
  case (trans xs ys zs)
  then obtain f g
    where bij: "bij_betw f {..<length xs} {..<length ys}" "bij_betw g {..<length ys} {..<length zs}"
    and perm: "\<forall>i<length xs. xs ! i = ys ! (f i)" "\<forall>i<length ys. ys ! i = zs ! (g i)"
    by blast
  show ?case
  proof (intro exI[of _ "g \<circ> f"] conjI allI impI)
    show "bij_betw (g \<circ> f) {..<length xs} {..<length zs}"
      using bij by (rule bij_betw_trans)
    fix i
    assume "i < length xs"
    with bij have "f i < length ys"
      unfolding bij_betw_def by force
    with `i < length xs` show "xs ! i = zs ! (g \<circ> f) i"
      using trans(1,3)[THEN perm_length] perm by auto
  qed
qed

end


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

section\<open>Computing determinants of matrices using the Gauss Jordan algorithm\<close>

theory Determinants2
imports
  Gauss_Jordan_PA
begin

subsection\<open>Some previous properties\<close>

subsubsection\<open>Relationships between determinants and elementary row operations\<close>

lemma det_interchange_rows:
shows "det (interchange_rows A i j) = of_int (if i = j then 1 else -1) * det A"
proof -
  have "(interchange_rows A i j) = (\<chi> a. A $ (Fun.swap i j id) a)" unfolding interchange_rows_def Fun.swap_def by vector
  hence "det(interchange_rows A i j) = det(\<chi> a. A$(Fun.swap i j id) a)" by simp
  also have "... = of_int (sign (Fun.swap i j id)) * det A" by (rule det_permute_rows[of "Fun.swap i j id" A], simp add: permutes_swap_id)
  finally show ?thesis unfolding sign_swap_id .
qed

corollary det_interchange_different_rows:
assumes i_not_j: "i \<noteq> j"
shows "det (interchange_rows A i j) = - det A" unfolding det_interchange_rows using i_not_j by simp

corollary det_interchange_same_rows:
assumes i_eq_j: "i = j"
shows "det (interchange_rows A i j) = det A" unfolding det_interchange_rows using i_eq_j by simp

lemma det_mult_row:
shows "det (mult_row A a k) = k * det A"
proof -
have A_rw: "(\<chi> i. if i = a then A$a else A$i) = A" by vector
have "(mult_row A a k) = (\<chi> i. if i = a then k *s A $ a else A $ i)" unfolding mult_row_def by vector
hence "det(mult_row A a k) = det(\<chi> i. if i = a then k *s A $ a else A $ i)" by simp
also have "... =  k * det(\<chi> i. if i = a then A$a else A$i)" unfolding det_row_mul ..
also have "... = k * det A" unfolding A_rw ..
finally show ?thesis .
qed

(*The name det_row_add is already used in the Determinants.thy file of the standard library*)
lemma det_row_add':
assumes i_not_j: "i \<noteq> j"
shows "det (row_add A i j q) = det A"
proof -
have "(row_add A i j q) = (\<chi> k. if k = i then row i A + q *s row j A else row k A)"
unfolding row_add_def row_def by vector
hence "det(row_add A i j q) = det(\<chi> k. if k = i then row i A + q *s row j A else row k A)" by simp
also have "... = det A" unfolding det_row_operation[OF i_not_j] ..
finally show ?thesis .
qed

subsubsection\<open>Relationships between determinants and elementary column operations\<close>

lemma det_interchange_columns:
shows "det (interchange_columns A i j) = of_int (if i = j then 1 else -1) * det A"
proof -
have "(interchange_columns A i j) = (\<chi> a b. A $ a $ (Fun.swap i j id) b)" unfolding interchange_columns_def Fun.swap_def by vector
hence "det(interchange_columns A i j) = det(\<chi> a b. A $ a $ (Fun.swap i j id) b)" by simp
also have "... = of_int (sign (Fun.swap i j id)) * det A" by (rule det_permute_columns[of "Fun.swap i j id" A], simp add: permutes_swap_id)
finally show ?thesis unfolding sign_swap_id .
qed

corollary det_interchange_different_columns:
assumes i_not_j: "i \<noteq> j"
shows "det (interchange_columns A i j) = - det A" unfolding det_interchange_columns using i_not_j by simp

corollary det_interchange_same_columns:
assumes i_eq_j: "i = j"
shows "det (interchange_columns A i j) = det A" unfolding det_interchange_columns using i_eq_j by simp

lemma det_mult_columns:
shows "det (mult_column A a k) = k * det A"
proof -
have "mult_column A a k = transpose (mult_row (transpose A) a k)" unfolding transpose_def mult_row_def mult_column_def by vector
hence "det (mult_column A a k) = det (transpose (mult_row (transpose A) a k))" by simp
also have "... = det (mult_row (transpose A) a k)" unfolding det_transpose ..
also have "... = k * det (transpose A)" unfolding det_mult_row ..
also have "... = k * det A" unfolding det_transpose ..
finally show ?thesis .
qed

lemma det_column_add:
assumes i_not_j: "i \<noteq> j"
shows "det (column_add A i j q) = det A"
proof -
have "(column_add A i j q) = (transpose (row_add (transpose A) i j q))" unfolding transpose_def column_add_def row_add_def by vector
hence "det (column_add A i j q) = det (transpose (row_add (transpose A) i j q))" by simp
also have "... = det (row_add (transpose A) i j q)" unfolding det_transpose ..
also have "... = det A" unfolding det_row_add'[OF i_not_j] det_transpose ..
finally show ?thesis .
qed

subsection\<open>Proving that the determinant can be computed by means of the Gauss Jordan algorithm\<close>

subsubsection\<open>Previous properties\<close>

lemma det_row_add_iterate_upt_n:
fixes A::"'a::{comm_ring_1}^'n::{mod_type}^'n::{mod_type}"
assumes n: "n<nrows A"
shows "det (row_add_iterate A n i j) = det A"
using n
proof (induct n arbitrary: A)
case 0
show ?case unfolding row_add_iterate.simps using det_row_add'[of 0 i A] by auto
next
case (Suc n)
show ?case  unfolding row_add_iterate.simps
proof (auto)
show "det (row_add_iterate A n i j) = det A" using Suc.hyps Suc.prems by simp
assume Suc_n_not_i: "Suc n \<noteq> to_nat i"
have "det (row_add_iterate (row_add A (from_nat (Suc n)) i (- A $ from_nat (Suc n) $ j)) n i j)
= det (row_add A (from_nat (Suc n)) i (- A $ from_nat (Suc n) $ j))"
proof (rule Suc.hyps, unfold nrows_def)
show " n < CARD('n)" using Suc.prems unfolding nrows_def by auto
qed
also have "... = det A"
  proof (rule det_row_add',rule ccontr, simp)
    assume "from_nat (Suc n) = i"
      hence "to_nat (from_nat (Suc n)::'n) = to_nat i" by simp
      hence "(Suc n) = to_nat i" unfolding to_nat_from_nat_id[OF Suc.prems[unfolded nrows_def]] .
      thus False using Suc_n_not_i by contradiction
    qed
finally show "det (row_add_iterate (row_add A (from_nat (Suc n)) i (- A $ from_nat (Suc n) $ j)) n i j) = det A" .
qed
qed

corollary det_row_add_iterate:
fixes A::"'a::{comm_ring_1}^'n::{mod_type}^'n::{mod_type}"
shows "det (row_add_iterate A (nrows A - 1) i j) = det A"
by (metis det_row_add_iterate_upt_n diff_less neq0_conv nrows_not_0 zero_less_one)

lemma det_Gauss_Jordan_in_ij:
fixes A::"'a::{field}^'n::{mod_type}^'n::{mod_type}" and i j::"'n"
defines A': "A'== mult_row (interchange_rows A i (LEAST n. A $ n $ j \<noteq> 0 \<and> i \<le> n)) i (1 / (interchange_rows A i (LEAST n. A $ n $ j \<noteq> 0 \<and> i \<le> n)) $ i $ j)"
shows "det (Gauss_Jordan_in_ij A i j) = det A' "
proof -
have nrows_eq: "nrows A' = nrows A" unfolding nrows_def by simp
have "row_add_iterate A' (nrows A - 1) i j  =  Gauss_Jordan_in_ij A i j" using row_add_iterate_eq_Gauss_Jordan_in_ij  unfolding A' .
hence "det (Gauss_Jordan_in_ij A i j) = det (row_add_iterate A' (nrows A - 1) i j)" by simp
also have "... = det A'" by (rule det_row_add_iterate[of A', unfolded nrows_eq])
finally show ?thesis .
qed

lemma det_Gauss_Jordan_in_ij_1:
fixes A::"'a::{field}^'n::{mod_type}^'n::{mod_type}" and i j::"'n"
defines A': "A'== mult_row (interchange_rows A i (LEAST n. A $ n $ j \<noteq> 0 \<and> i \<le> n)) i (1 / (interchange_rows A i (LEAST n. A $ n $ j \<noteq> 0 \<and> i \<le> n)) $ i $ j)"
assumes i: "(LEAST n. A $ n $ j \<noteq> 0 \<and> i \<le> n) = i"
shows "det (Gauss_Jordan_in_ij A i j) = 1/(A$i$j) * det A"
proof -
have "det (Gauss_Jordan_in_ij A i j) = det A' " using det_Gauss_Jordan_in_ij unfolding A' by auto
also have "... = 1/(A$i$j) * det A" unfolding A' det_mult_row unfolding i det_interchange_rows by auto
finally show ?thesis .
qed

lemma det_Gauss_Jordan_in_ij_2:
fixes A::"'a::{field}^'n::{mod_type}^'n::{mod_type}" and i j::"'n"
defines A': "A'== mult_row (interchange_rows A i (LEAST n. A $ n $ j \<noteq> 0 \<and> i \<le> n)) i (1 / (interchange_rows A i (LEAST n. A $ n $ j \<noteq> 0 \<and> i \<le> n)) $ i $ j)"
assumes i: "(LEAST n. A $ n $ j \<noteq> 0 \<and> i \<le> n) \<noteq> i"
shows "det (Gauss_Jordan_in_ij A i j) = - 1/(A $ (LEAST n. A $ n $ j \<noteq> 0 \<and> i \<le> n) $ j) * det A"
proof -
have "det (Gauss_Jordan_in_ij A i j) = det A' " using det_Gauss_Jordan_in_ij unfolding A' by auto
also have "... = - 1/(A$ (LEAST n. A $ n $ j \<noteq> 0 \<and> i \<le> n) $j) * det A" unfolding A' det_mult_row unfolding det_interchange_rows using i by auto
finally show ?thesis .
qed

subsubsection\<open>Definitions\<close>

text\<open>The following definitions allow the computation of the determinant of a matrix using the Gauss-Jordan algorithm. In the first component the determinant of each transformation
is accumulated and the second component contains the matrix transformed into a reduced row echelon form matrix\<close>

definition Gauss_Jordan_in_ij_det_P :: "'a::{semiring_1, inverse, one, uminus}^'m^'n::{finite, ord}=> 'n=>'m=>('a \<times> ('a^'m^'n::{finite, ord}))"
  where "Gauss_Jordan_in_ij_det_P A i j = (let n = (LEAST n. A $ n $ j \<noteq> 0 \<and> i \<le> n) in (if i = n then 1/(A $ i $ j) else - 1/(A $ n $ j), Gauss_Jordan_in_ij A i j))"

definition Gauss_Jordan_column_k_det_P where "Gauss_Jordan_column_k_det_P A' k =
(let det_P= fst A'; i = fst (snd A'); A = snd (snd A'); from_nat_i = from_nat i; from_nat_k = from_nat k
 in if (\<forall>m\<ge>from_nat_i. A $ m $ from_nat_k = 0) \<or> i = nrows A then (det_P, i, A)
    else let gauss = Gauss_Jordan_in_ij_det_P A (from_nat_i) (from_nat_k) in (fst gauss * det_P, i + 1, snd gauss))"

definition Gauss_Jordan_upt_k_det_P
  where "Gauss_Jordan_upt_k_det_P A k = (let foldl = foldl Gauss_Jordan_column_k_det_P (1, 0, A) [0..<Suc k] in (fst foldl, snd (snd foldl)))"
definition Gauss_Jordan_det_P
  where "Gauss_Jordan_det_P A = Gauss_Jordan_upt_k_det_P A (ncols A - 1)"

subsubsection\<open>Proofs\<close>

text\<open>This is an equivalent definition created to achieve a more efficient computation.\<close>
lemma Gauss_Jordan_in_ij_det_P_code[code]:
shows "Gauss_Jordan_in_ij_det_P A i j =
    (let n = (LEAST n. A $ n $ j \<noteq> 0 \<and> i \<le> n);
         interchange_A = interchange_rows A i n;
         A' = mult_row interchange_A i (1 / interchange_A $ i $ j) in (if i = n then 1/(A $ i $ j) else - 1/(A $ n $ j), Gauss_Jordan_wrapper i j A' interchange_A))"
         unfolding Gauss_Jordan_in_ij_det_P_def Gauss_Jordan_in_ij_def Gauss_Jordan_wrapper_def Let_def by auto

lemma det_Gauss_Jordan_in_ij_det_P:
fixes A::"'a::{field}^'n::{mod_type}^'n::{mod_type}" and i j::"'n"
shows "(fst (Gauss_Jordan_in_ij_det_P A i j)) * det A  = det (snd (Gauss_Jordan_in_ij_det_P A i j))"
unfolding Gauss_Jordan_in_ij_det_P_def Let_def fst_conv snd_conv
using det_Gauss_Jordan_in_ij_1[of A j i]
using det_Gauss_Jordan_in_ij_2[of A j i] by auto

lemma det_Gauss_Jordan_column_k_det_P:
fixes A::"'a::{field}^'n::{mod_type}^'n::{mod_type}"
assumes det: "det_P * det B = det A"
shows "(fst (Gauss_Jordan_column_k_det_P (det_P,i,A) k)) * det B = det (snd (snd (Gauss_Jordan_column_k_det_P (det_P,i,A) k)))"
proof (unfold Gauss_Jordan_column_k_det_P_def Let_def, auto simp add: assms)
fix m
assume i_not_nrows: "i \<noteq> nrows A"
and i_less_m: "from_nat i \<le> m"
and Amk_not_0: "A $ m $ from_nat k \<noteq> 0"
show  "fst (Gauss_Jordan_in_ij_det_P A (from_nat i) (from_nat k)) * det_P * det B =
        det (snd (Gauss_Jordan_in_ij_det_P A (from_nat i) (from_nat k)))" unfolding mult.assoc det
        unfolding det_Gauss_Jordan_in_ij_det_P ..
qed

lemma det_Gauss_Jordan_upt_k_det_P:
fixes A::"'a::{field}^'n::{mod_type}^'n::{mod_type}"
shows "(fst (Gauss_Jordan_upt_k_det_P A k)) * det A = det (snd (Gauss_Jordan_upt_k_det_P A k))"
proof (induct k)
case 0
show ?case
unfolding Gauss_Jordan_upt_k_det_P_def Let_def unfolding fst_conv snd_conv by (simp add:det_Gauss_Jordan_column_k_det_P)
next
case (Suc k)
have suc_rw: "[0..<Suc (Suc k)] = [0..<Suc k] @ [Suc k]" by simp
have fold_expand: "(foldl Gauss_Jordan_column_k_det_P (1, 0, A) [0..<Suc k])
= (fst (foldl Gauss_Jordan_column_k_det_P (1, 0, A) [0..<Suc k]), fst (snd (foldl Gauss_Jordan_column_k_det_P (1, 0, A) [0..<Suc k])),
  snd (snd (foldl Gauss_Jordan_column_k_det_P (1, 0, A) [0..<Suc k])))" by simp
show ?case unfolding Gauss_Jordan_upt_k_det_P_def Let_def
unfolding suc_rw foldl_append List.foldl.simps fst_conv snd_conv
by(subst (1 2) fold_expand, rule det_Gauss_Jordan_column_k_det_P, rule Suc.hyps[unfolded Gauss_Jordan_upt_k_det_P_def Let_def fst_conv snd_conv])
qed

lemma det_Gauss_Jordan_det_P:
fixes A::"'a::{field}^'n::{mod_type}^'n::{mod_type}"
shows "(fst (Gauss_Jordan_det_P A)) * det A = det (snd (Gauss_Jordan_det_P A))"
using det_Gauss_Jordan_upt_k_det_P unfolding Gauss_Jordan_det_P_def by simp

definition upper_triangular_upt_k where "upper_triangular_upt_k A k = (\<forall>i j. j<i \<and> to_nat j < k \<longrightarrow> A $ i $ j = 0)"
definition upper_triangular where "upper_triangular A = (\<forall>i j. j<i \<longrightarrow> A $ i $ j = 0)"

lemma upper_triangular_upt_imp_upper_triangular:
assumes "upper_triangular_upt_k A (nrows A)"
shows "upper_triangular A"
using assms unfolding upper_triangular_upt_k_def upper_triangular_def nrows_def
using to_nat_less_card[where ?'a='b] by blast

lemma rref_imp_upper_triagular_upt:
fixes A::"'a::{one, zero}^'n::{mod_type}^'n::{mod_type}"
assumes "reduced_row_echelon_form A"
shows "upper_triangular_upt_k A k"
proof (induct k)
case 0
show ?case unfolding upper_triangular_upt_k_def by simp
next
case (Suc k)
show ?case unfolding upper_triangular_upt_k_def proof (clarify)
fix i j::'n
assume j_less_i: "j < i" and j_less_suc_k: "to_nat j < Suc k"
show "A $ i $ j = 0"
  proof (cases "to_nat j < k")
  case True
  thus ?thesis using Suc.hyps unfolding upper_triangular_upt_k_def using j_less_i True by auto
  next
  case False
  hence j_eq_k: "to_nat j = k" using j_less_suc_k by simp
  have rref_suc: "reduced_row_echelon_form_upt_k A (Suc k)" by (metis assms rref_implies_rref_upt)

  show ?thesis
    proof (cases "A $ i $ from_nat k = 0")
      case True
      have "from_nat k = j" by (metis from_nat_to_nat_id j_eq_k)
      thus ?thesis using True by simp
      next
      case False
      have zero_i_k: "is_zero_row_upt_k i k A" unfolding is_zero_row_upt_k_def
      by (metis (hide_lams, mono_tags) Suc.hyps leD le_less_linear less_imp_le j_eq_k j_less_i le_trans to_nat_mono' upper_triangular_upt_k_def)
      have not_zero_i_suc_k: "\<not> is_zero_row_upt_k i (Suc k) A" unfolding is_zero_row_upt_k_def using False by (metis j_eq_k lessI to_nat_from_nat)
      have Least_eq: "(LEAST n. A $ i $ n \<noteq> 0) = from_nat k"
        proof (rule Least_equality)
           show "A $ i $ from_nat k \<noteq> 0" using False by simp
           show "\<And>y. A $ i $ y \<noteq> 0 \<Longrightarrow> from_nat k \<le> y" by (metis (full_types) is_zero_row_upt_k_def not_le_imp_less to_nat_le zero_i_k)
        qed
      have i_not_k: "i \<noteq> from_nat k" by (metis less_irrefl from_nat_to_nat_id j_eq_k j_less_i)
      show ?thesis using rref_upt_condition4_explicit[OF rref_suc not_zero_i_suc_k i_not_k] unfolding Least_eq
      using rref_upt_condition1_explicit[OF rref_suc]
      using Suc.hyps unfolding upper_triangular_upt_k_def
      by (metis (mono_tags) leD not_le_imp_less is_zero_row_upt_k_def is_zero_row_upt_k_suc j_eq_k j_less_i not_zero_i_suc_k to_nat_from_nat to_nat_mono')
qed
qed
qed
qed

lemma rref_imp_upper_triagular:
assumes "reduced_row_echelon_form A"
shows "upper_triangular A"
by (metis assms rref_imp_upper_triagular_upt upper_triangular_upt_imp_upper_triangular)

lemma det_Gauss_Jordan[code_unfold]:
fixes A::"'a::{field}^'n::{mod_type}^'n::{mod_type}"
shows "det (Gauss_Jordan A) = prod (\<lambda>i. (Gauss_Jordan A)$i$i) (UNIV:: 'n set)"
using det_upperdiagonal rref_imp_upper_triagular[OF rref_Gauss_Jordan[of A]] unfolding upper_triangular_def by blast

lemma snd_Gauss_Jordan_in_ij_det_P_is_snd_Gauss_Jordan_in_ij_PA:
shows "snd (Gauss_Jordan_in_ij_det_P A i j) = snd (Gauss_Jordan_in_ij_PA (P,A) i j)"
unfolding Gauss_Jordan_in_ij_det_P_def Gauss_Jordan_in_ij_PA_def
unfolding  Gauss_Jordan_in_ij_def Let_def snd_conv fst_conv ..

lemma snd_Gauss_Jordan_column_k_det_P_is_snd_Gauss_Jordan_column_k_PA:
shows "snd (Gauss_Jordan_column_k_det_P (n,i,A) k) = snd (Gauss_Jordan_column_k_PA (P,i,A) k)"
unfolding Gauss_Jordan_column_k_det_P_def Gauss_Jordan_column_k_PA_def Let_def snd_conv unfolding fst_conv
using snd_Gauss_Jordan_in_ij_det_P_is_snd_Gauss_Jordan_in_ij_PA by auto

lemma det_fst_row_add_iterate_PA:
fixes A::"'a::{comm_ring_1}^'n::{mod_type}^'n::{mod_type}"
assumes n: "n<nrows A"
shows "det (fst (row_add_iterate_PA (P,A) n i j)) = det P"
using n
proof (induct n arbitrary: P A)
case 0
show ?case unfolding row_add_iterate_PA.simps using det_row_add'[of 0 i P] by simp
next
case (Suc n)
have n: "n<nrows A" using Suc.prems by simp
show ?case
proof (cases "Suc n = to_nat i")
case True show ?thesis unfolding row_add_iterate_PA.simps if_P[OF True] using Suc.hyps[OF n] .
next
case False
define P' where "P' = row_add P (from_nat (Suc n)) i (- A $ from_nat (Suc n) $ j)"
define A' where "A' = row_add A (from_nat (Suc n)) i (- A $ from_nat (Suc n) $ j)"
have n2: "n< nrows A'" using n unfolding nrows_def .
have "det (fst (row_add_iterate_PA (P, A) (Suc n) i j)) = det (fst (row_add_iterate_PA (P', A') n i j))" unfolding row_add_iterate_PA.simps if_not_P[OF False] P'_def A'_def ..
also have "... = det P'" using Suc.hyps[OF n2] .
also have "... = det P" unfolding P'_def
proof (rule det_row_add', rule ccontr, simp)
    assume "from_nat (Suc n) = i"
      hence "to_nat (from_nat (Suc n)::'n) = to_nat i" by simp
      hence "(Suc n) = to_nat i" unfolding to_nat_from_nat_id[OF Suc.prems[unfolded nrows_def]] .
      thus False using False by contradiction
    qed
finally show ?thesis .
qed
qed

lemma det_fst_Gauss_Jordan_in_ij_PA_eq_fst_Gauss_Jordan_in_ij_det_P:
fixes A::"'a::{field}^'n::{mod_type}^'n::{mod_type}"
shows "fst (Gauss_Jordan_in_ij_det_P A i j) * det P = det (fst (Gauss_Jordan_in_ij_PA (P,A) i j))"
proof -
define P' where "P' = mult_row (interchange_rows P i (LEAST n. A $ n $ j \<noteq> 0 \<and> i \<le> n)) i (1 / interchange_rows A i (LEAST n. A $ n $ j \<noteq> 0 \<and> i \<le> n) $ i $ j)"
define A' where "A' = mult_row (interchange_rows A i (LEAST n. A $ n $ j \<noteq> 0 \<and> i \<le> n)) i (1 / interchange_rows A i (LEAST n. A $ n $ j \<noteq> 0 \<and> i \<le> n) $ i $ j)"
have "det (fst (Gauss_Jordan_in_ij_PA (P,A) i j)) = det (fst (row_add_iterate_PA (P',A') (nrows A - 1) i j))"
unfolding fst_row_add_iterate_PA_eq_fst_Gauss_Jordan_in_ij_PA[symmetric] A'_def P'_def ..
also have "...= det P'" by (rule det_fst_row_add_iterate_PA, simp add: nrows_def)
also have "... = (if i = (LEAST n. A $ n $ j \<noteq> 0 \<and> i \<le> n) then 1 / A $ i $ j else - 1 / A $ (LEAST n. A $ n $ j \<noteq> 0 \<and> i \<le> n) $ j) * det P"
proof (cases "i = (LEAST n. A $ n $ j \<noteq> 0 \<and> i \<le> n)")
case True show ?thesis
unfolding if_P[OF True] P'_def unfolding True[symmetric] unfolding interchange_same_rows unfolding det_mult_row ..
next
case False
show ?thesis unfolding if_not_P[OF False] P'_def unfolding det_mult_row unfolding det_interchange_different_rows[OF False] by simp
qed
also have "... = fst (Gauss_Jordan_in_ij_det_P A i j) * det P"
unfolding Gauss_Jordan_in_ij_det_P_def by simp
finally show ?thesis ..
qed

lemma det_fst_Gauss_Jordan_column_k_PA_eq_fst_Gauss_Jordan_column_k_det_P:
fixes A::"'a::{field}^'n::{mod_type}^'n::{mod_type}"
shows "fst (Gauss_Jordan_column_k_det_P (det P,i,A) k) = det (fst (Gauss_Jordan_column_k_PA (P,i,A) k))"
unfolding Gauss_Jordan_column_k_det_P_def Gauss_Jordan_column_k_PA_def Let_def snd_conv fst_conv
using det_fst_Gauss_Jordan_in_ij_PA_eq_fst_Gauss_Jordan_in_ij_det_P by auto

lemma fst_snd_Gauss_Jordan_column_k_det_P_eq_fst_snd_Gauss_Jordan_column_k_PA:
shows "fst (snd (Gauss_Jordan_column_k_det_P (n,i,A) k)) = fst (snd (Gauss_Jordan_column_k_PA (P,i,A) k))"
unfolding Gauss_Jordan_column_k_det_P_def Gauss_Jordan_column_k_PA_def Let_def snd_conv fst_conv
by auto

text\<open>The way of proving the following lemma is very similar to the demonstration of @{thm "rref_and_index_Gauss_Jordan_upt_k"}.\<close>

lemma foldl_Gauss_Jordan_column_k_det_P:
fixes A::"'a::{field}^'n::{mod_type}^'n::{mod_type}"
shows det_fst_Gauss_Jordan_upt_k_PA_eq_fst_Gauss_Jordan_upt_k_det_P: "fst (Gauss_Jordan_upt_k_det_P A k) = det (fst (Gauss_Jordan_upt_k_PA A k))"
and snd_Gauss_Jordan_upt_k_det_P_is_snd_Gauss_Jordan_upt_k_PA: "snd (Gauss_Jordan_upt_k_det_P A k) = snd (Gauss_Jordan_upt_k_PA A k)"
and fst_snd_foldl_Gauss_det_P_PA: "fst (snd (foldl Gauss_Jordan_column_k_det_P (1, 0, A) [0..<Suc k])) = fst (snd (foldl Gauss_Jordan_column_k_PA (mat 1, 0, A) [0..<Suc k]))"
proof (induct k)
case 0
show "fst (Gauss_Jordan_upt_k_det_P A 0) = det (fst (Gauss_Jordan_upt_k_PA A 0))"
unfolding Gauss_Jordan_upt_k_det_P_def Gauss_Jordan_upt_k_PA_def Let_def
by (simp, metis det_fst_Gauss_Jordan_column_k_PA_eq_fst_Gauss_Jordan_column_k_det_P det_I)
show "snd (Gauss_Jordan_upt_k_det_P A 0) = snd (Gauss_Jordan_upt_k_PA A 0)"
unfolding Gauss_Jordan_upt_k_det_P_def Gauss_Jordan_upt_k_PA_def Let_def snd_conv
apply auto using snd_Gauss_Jordan_column_k_det_P_is_snd_Gauss_Jordan_column_k_PA by metis
show "fst (snd (foldl Gauss_Jordan_column_k_det_P (1, 0, A) [0..<Suc 0])) = fst (snd (foldl Gauss_Jordan_column_k_PA (mat 1, 0, A) [0..<Suc 0]))"
using [[unfold_abs_def = false]]
unfolding Gauss_Jordan_column_k_det_P_def Gauss_Jordan_column_k_PA_def apply auto
using fst_snd_Gauss_Jordan_column_k_det_P_eq_fst_snd_Gauss_Jordan_column_k_PA by metis
next
fix k
assume hyp1: "fst (Gauss_Jordan_upt_k_det_P A k) = det (fst (Gauss_Jordan_upt_k_PA A k))"
and hyp2: "snd (Gauss_Jordan_upt_k_det_P A k) = snd (Gauss_Jordan_upt_k_PA A k)"
and hyp3: "fst (snd (foldl Gauss_Jordan_column_k_det_P (1, 0, A) [0..<Suc k])) = fst (snd (foldl Gauss_Jordan_column_k_PA (mat 1, 0, A) [0..<Suc k]))"
have list_rw: "[0..<Suc (Suc k)] = [0..<Suc k] @ [Suc k]" by simp
have det_mat_nn: "det (mat 1::'a^'n::{mod_type}^'n::{mod_type}) = 1" using det_I by simp
define f where "f = foldl Gauss_Jordan_column_k_det_P (1, 0, A) [0..<Suc k]"
define g where "g = foldl Gauss_Jordan_column_k_PA (mat 1, 0, A) [0..<Suc k]"
have f_rw: "f = (fst f, fst (snd f), snd(snd f))" by simp
have g_rw: "g = (fst g, fst (snd g), snd(snd g))" by simp
have fst_snd: "fst (snd f) = fst (snd g)" unfolding f_def g_def using hyp3 unfolding Gauss_Jordan_upt_k_det_P_def Gauss_Jordan_upt_k_PA_def Let_def fst_conv snd_conv .
have snd_snd: "snd (snd f) = snd (snd g)" unfolding f_def g_def using hyp2 unfolding Gauss_Jordan_upt_k_det_P_def Gauss_Jordan_upt_k_PA_def Let_def fst_conv snd_conv .
have fst_det: "fst f = det (fst g)" unfolding f_def g_def using hyp1 unfolding Gauss_Jordan_upt_k_det_P_def Gauss_Jordan_upt_k_PA_def Let_def fst_conv by simp
show "fst (snd (foldl Gauss_Jordan_column_k_det_P (1, 0, A) [0..<Suc k])) = fst (snd (foldl Gauss_Jordan_column_k_PA (mat 1, 0, A) [0..<Suc k])) \<Longrightarrow>
        fst (Gauss_Jordan_upt_k_det_P A (Suc k)) = det (fst (Gauss_Jordan_upt_k_PA A (Suc k)))"
unfolding Gauss_Jordan_upt_k_det_P_def
unfolding Gauss_Jordan_upt_k_PA_def Let_def fst_conv
unfolding list_rw foldl_append unfolding List.foldl.simps
unfolding f_def[symmetric] g_def[symmetric]
apply (subst f_rw)
apply (subst g_rw)
unfolding fst_snd snd_snd fst_det
by (rule det_fst_Gauss_Jordan_column_k_PA_eq_fst_Gauss_Jordan_column_k_det_P)
show "snd (Gauss_Jordan_upt_k_det_P A (Suc k)) = snd (Gauss_Jordan_upt_k_PA A (Suc k))"
unfolding Gauss_Jordan_upt_k_det_P_def
unfolding Gauss_Jordan_upt_k_PA_def Let_def fst_conv
unfolding list_rw foldl_append unfolding List.foldl.simps
unfolding f_def[symmetric] g_def[symmetric]
apply (subst f_rw)
apply (subst g_rw)
unfolding fst_snd snd_snd fst_det
by (metis fst_snd prod.collapse snd_Gauss_Jordan_column_k_det_P_is_snd_Gauss_Jordan_column_k_PA snd_eqD snd_snd)
show "fst (snd (foldl Gauss_Jordan_column_k_det_P (1, 0, A) [0..<Suc (Suc k)])) = fst (snd (foldl Gauss_Jordan_column_k_PA (mat 1, 0, A) [0..<Suc (Suc k)]))"
unfolding Gauss_Jordan_upt_k_det_P_def
unfolding Gauss_Jordan_upt_k_PA_def Let_def fst_conv
unfolding list_rw foldl_append unfolding List.foldl.simps
unfolding f_def[symmetric] g_def[symmetric]
apply (subst f_rw)
apply (subst g_rw)
unfolding fst_snd snd_snd fst_det by (rule fst_snd_Gauss_Jordan_column_k_det_P_eq_fst_snd_Gauss_Jordan_column_k_PA)
qed

lemma snd_Gauss_Jordan_det_P_is_Gauss_Jordan:
fixes A::"'a::{field}^'n::{mod_type}^'n::{mod_type}"
shows "snd (Gauss_Jordan_det_P A) = (Gauss_Jordan A)"
unfolding Gauss_Jordan_det_P_def Gauss_Jordan_def unfolding snd_Gauss_Jordan_upt_k_det_P_is_snd_Gauss_Jordan_upt_k_PA
snd_Gauss_Jordan_upt_k_PA ..

lemma det_snd_Gauss_Jordan_det_P[code_unfold]:
fixes A::"'a::{field}^'n::{mod_type}^'n::{mod_type}"
shows "det (snd (Gauss_Jordan_det_P A)) = prod (\<lambda>i. (snd (Gauss_Jordan_det_P A))$i$i) (UNIV:: 'n set)"
unfolding snd_Gauss_Jordan_det_P_is_Gauss_Jordan det_Gauss_Jordan ..

lemma det_fst_Gauss_Jordan_PA_eq_fst_Gauss_Jordan_det_P:
fixes A::"'a::{field}^'n::{mod_type}^'n::{mod_type}"
shows "fst (Gauss_Jordan_det_P A) = det (fst (Gauss_Jordan_PA A))"
by (unfold Gauss_Jordan_det_P_def Gauss_Jordan_PA_def, rule det_fst_Gauss_Jordan_upt_k_PA_eq_fst_Gauss_Jordan_upt_k_det_P)

lemma fst_Gauss_Jordan_det_P_not_0:
fixes A::"'a::{field}^'n::{mod_type}^'n::{mod_type}"
shows "fst (Gauss_Jordan_det_P A) \<noteq> 0"
unfolding det_fst_Gauss_Jordan_PA_eq_fst_Gauss_Jordan_det_P
by (metis (mono_tags) det_I det_mul invertible_fst_Gauss_Jordan_PA matrix_inv_right mult_zero_left zero_neq_one)

lemma det_code_equation[code_unfold]:
fixes A::"'a::{field}^'n::{mod_type}^'n::{mod_type}"
shows "det A = (let A' = Gauss_Jordan_det_P A in prod (\<lambda>i. (snd (A'))$i$i) (UNIV::'n set)/(fst (A')))"
unfolding Let_def using det_Gauss_Jordan_det_P[of A]
unfolding det_snd_Gauss_Jordan_det_P
by (simp add: fst_Gauss_Jordan_det_P_not_0 nonzero_eq_divide_eq ac_simps)

end


theory Ex1_3
  imports Main
begin

primrec alls :: "('a \<Rightarrow> bool) \<Rightarrow> 'a list \<Rightarrow> bool" where
  "alls _ [] = True"|
  "alls P (x # xs) = (P x \<and> alls P xs)"

primrec exs :: "('a \<Rightarrow> bool) \<Rightarrow> 'a list \<Rightarrow> bool" where
  "exs _ [] = False"|
  "exs P (x # xs) = (P x \<or> exs P xs)"

lemma "alls (\<lambda>x. P x \<and> Q x) xs = (alls P xs \<and> alls Q xs)" by (induct xs , auto)

lemma helper : "alls P (xs @ ys) = (alls P xs \<and>  alls P ys)" by (induct xs ; simp)

lemma "alls  P (rev xs) = alls P xs" by (induct xs, auto simp add : helper)

(* lemma "exs (\<lambda>x . P x \<and> Q x) xs = (exs  P xs \<and> exs Q xs)" quickcheck *)

lemma "P a  \<Longrightarrow> P b = False \<Longrightarrow> Q b \<Longrightarrow> Q a = False  \<Longrightarrow> a \<noteq> b \<Longrightarrow> exs (\<lambda>x. P x \<and> Q x) [a ,b] = (exs P [a,b] \<and> exs Q [a,b]) \<Longrightarrow> False" by simp

lemma "exs P (map f xs) = exs (P o f) xs " by (induct xs; simp)

lemma helper2 : "exs P (xs @ ys) = (exs P xs \<or> exs P ys)" by (induct xs, auto)

lemma "exs P (rev xs) = exs P xs"
proof (induct xs)
  case Nil
  then show ?case by simp
next
  case (Cons a xs)
  assume a:"exs P (rev xs) = exs P xs"
  have "exs P (rev (a # xs)) = exs P (rev xs @ [a])" by simp
  also have "\<dots> = (exs P (rev xs) \<or> exs P [a])" by (simp add : helper2)
  also have "\<dots> = (exs P xs \<or> exs P [a])"  by (simp add : a)
  finally show ?case by auto
qed

lemma "exs (\<lambda>x . P x \<or> Q x) xs = exs P xs \<or> exs Q xs"  by (induct xs; auto)

lemma "exs P xs = (\<not> (alls (\<lambda>x . \<not> (P x)) xs))" by (induct  xs, simp_all)

primrec is_in :: "'a \<Rightarrow> 'a list \<Rightarrow> bool" where
  "is_in _ []= False "|
  "is_in val (x # xs) = ((val = x) \<or> is_in val xs) "

lemma "is_in a xs = exs (\<lambda>x . x = a) xs" by (induct xs, auto)

primrec nodups :: "'a list \<Rightarrow> bool" where
  "nodups [] = True"|
  "nodups (x#xs) = ((\<not>(is_in x xs))  \<and> nodups xs)"

primrec deldups :: "'a list \<Rightarrow> 'a list" where
  "deldups [] = []"|
  "deldups (x#xs) = (if is_in x xs  then deldups xs else x # deldups xs)"

lemma "length (deldups xs) \<le> length xs" by (induct xs, simp_all)

lemma helper3 : "\<not> (is_in x xs) \<Longrightarrow> \<not> (is_in x (deldups xs))" by (induct xs, simp_all)

lemma "nodups (deldups xs)"
proof (induct xs)
  case Nil
  then show ?case by simp
next
  case (Cons a xs)
  assume hyp:"nodups (deldups xs)"
  show ?case
  proof (cases "is_in a xs")
    case True
    assume a:"is_in a xs"
    show ?thesis using hyp a by auto
  next
    case False
    assume a:"\<not> is_in a xs"
    have "nodups (deldups (a # xs)) = nodups (a # deldups (xs))" using a by simp
    also have "\<dots> = ((\<not>(is_in a (deldups xs))) \<and>  nodups (deldups xs))" by (simp only : nodups.simps)
    also have "\<dots> = ((\<not>(is_in a (deldups xs))) \<and> True )" using hyp by simp
    also have "\<dots> = (True \<and> True)" using helper3 and a by simp
    finally show ?thesis using helper3 and a and hyp by simp
  qed
qed

(* lemma "deldups (rev xs) = rev (deldups xs)" quickcheck *)

lemma "let ls = [x,y,x,x] in deldups (rev ls) = rev (deldups ls) \<Longrightarrow> x \<noteq> y \<Longrightarrow> False " by simp


theory Spec
  imports Main "~~/src/HOL/Library/Sublist"
begin

section {* Sequential Composition of Languages *}

definition
  Sequ :: "string set \<Rightarrow> string set \<Rightarrow> string set" ("_ ;; _" [100,100] 100)
where
  "A ;; B = {s1 @ s2 | s1 s2. s1 \<in> A \<and> s2 \<in> B}"

text {* Two Simple Properties about Sequential Composition *}

lemma Sequ_empty_string [simp]:
  shows "A ;; {[]} = A"
  and   "{[]} ;; A = A"
by (simp_all add: Sequ_def)

lemma Sequ_empty [simp]:
  shows "A ;; {} = {}"
  and   "{} ;; A = {}"
by (simp_all add: Sequ_def)

section {* Semantic Derivative (Left Quotient) of Languages *}

definition
  Der :: "char \<Rightarrow> string set \<Rightarrow> string set"
where
  "Der c A \<equiv> {s. c # s \<in> A}"

definition
  Ders :: "string \<Rightarrow> string set \<Rightarrow> string set"
where
  "Ders s A \<equiv> {s'. s @ s' \<in> A}"

lemma Der_null [simp]:
  shows "Der c {} = {}"
unfolding Der_def
by auto

lemma Der_empty [simp]:
  shows "Der c {[]} = {}"
unfolding Der_def
by auto

lemma Der_char [simp]:
  shows "Der c {[d]} = (if c = d then {[]} else {})"
unfolding Der_def
by auto

lemma Der_union [simp]:
  shows "Der c (A \<union> B) = Der c A \<union> Der c B"
unfolding Der_def
by auto

lemma Der_Sequ [simp]:
  shows "Der c (A ;; B) = (Der c A) ;; B \<union> (if [] \<in> A then Der c B else {})"
unfolding Der_def Sequ_def
by (auto simp add: Cons_eq_append_conv)

section {* Kleene Star for Languages *}

inductive_set
  Star :: "string set \<Rightarrow> string set" ("_\<star>" [101] 102)
  for A :: "string set"
where
  start[intro]: "[] \<in> A\<star>"
| step[intro]:  "\<lbrakk>s1 \<in> A; s2 \<in> A\<star>\<rbrakk> \<Longrightarrow> s1 @ s2 \<in> A\<star>"

(* Arden's lemma *)

lemma Star_cases:
  shows "A\<star> = {[]} \<union> A ;; A\<star>"
unfolding Sequ_def
by (auto) (metis Star.simps)

lemma Star_decomp:
  assumes "c # x \<in> A\<star>"
  shows "\<exists>s1 s2. x = s1 @ s2 \<and> c # s1 \<in> A \<and> s2 \<in> A\<star>"
using assms
by (induct x\<equiv>"c # x" rule: Star.induct)
   (auto simp add: append_eq_Cons_conv)

lemma Star_Der_Sequ:
  shows "Der c (A\<star>) \<subseteq> (Der c A) ;; A\<star>"
unfolding Der_def Sequ_def
by(auto simp add: Star_decomp)

lemma Der_star [simp]:
  shows "Der c (A\<star>) = (Der c A) ;; A\<star>"
proof -
  have "Der c (A\<star>) = Der c ({[]} \<union> A ;; A\<star>)"
    by (simp only: Star_cases[symmetric])
  also have "... = Der c (A ;; A\<star>)"
    by (simp only: Der_union Der_empty) (simp)
  also have "... = (Der c A) ;; A\<star> \<union> (if [] \<in> A then Der c (A\<star>) else {})"
    by simp
  also have "... =  (Der c A) ;; A\<star>"
    using Star_Der_Sequ by auto
  finally show "Der c (A\<star>) = (Der c A) ;; A\<star>" .
qed

section {* Regular Expressions *}

datatype rexp =
  ZERO
| ONE
| CR char
| SEQ rexp rexp
| ALT rexp rexp
| STAR rexp

section {* Semantics of Regular Expressions *}

fun
  L :: "rexp \<Rightarrow> string set"
where
  "L (ZERO) = {}"
| "L (ONE) = {[]}"
| "L (CR c) = {[c]}"
| "L (SEQ r1 r2) = (L r1) ;; (L r2)"
| "L (ALT r1 r2) = (L r1) \<union> (L r2)"
| "L (STAR r) = (L r)\<star>"

section {* Nullable, Derivatives *}

fun
 nullable :: "rexp \<Rightarrow> bool"
where
  "nullable (ZERO) = False"
| "nullable (ONE) = True"
| "nullable (CR c) = False"
| "nullable (ALT r1 r2) = (nullable r1 \<or> nullable r2)"
| "nullable (SEQ r1 r2) = (nullable r1 \<and> nullable r2)"
| "nullable (STAR r) = True"

fun
 der :: "char \<Rightarrow> rexp \<Rightarrow> rexp"
where
  "der c (ZERO) = ZERO"
| "der c (ONE) = ZERO"
| "der c (CR d) = (if c = d then ONE else ZERO)"
| "der c (ALT r1 r2) = ALT (der c r1) (der c r2)"
| "der c (SEQ r1 r2) =
     (if nullable r1
      then ALT (SEQ (der c r1) r2) (der c r2)
      else SEQ (der c r1) r2)"
| "der c (STAR r) = SEQ (der c r) (STAR r)"

fun
 ders :: "string \<Rightarrow> rexp \<Rightarrow> rexp"
where
  "ders [] r = r"
| "ders (c # s) r = ders s (der c r)"

lemma nullable_correctness:
  shows "nullable r  \<longleftrightarrow> [] \<in> (L r)"
  apply(induct r)
by (induct r) (auto simp add: Sequ_def)

lemma der_correctness:
  shows "L (der c r) = Der c (L r)"
by (induct r) (simp_all add: nullable_correctness)

lemma ders_correctness:
  shows "L (ders s r) = Ders s (L r)"
by (induct s arbitrary: r)
   (simp_all add: Ders_def der_correctness Der_def)

lemma ders_append:
  shows "ders (s1 @ s2) r = ders s2 (ders s1 r)"
  apply(induct s1 arbitrary: s2 r)
  apply(auto)
  done

section {* Values *}

datatype val =
  Void
| Char char
| Seq val val
| Right val
| Left val
| Stars "val list"

section {* The string behind a value *}

fun
  flat :: "val \<Rightarrow> string"
where
  "flat (Void) = []"
| "flat (Char c) = [c]"
| "flat (Left v) = flat v"
| "flat (Right v) = flat v"
| "flat (Seq v1 v2) = (flat v1) @ (flat v2)"
| "flat (Stars []) = []"
| "flat (Stars (v#vs)) = (flat v) @ (flat (Stars vs))"

abbreviation
  "flats vs \<equiv> concat (map flat vs)"

lemma flat_Stars [simp]:
 "flat (Stars vs) = flats vs"
by (induct vs) (auto)

lemma Star_concat:
  assumes "\<forall>s \<in> set ss. s \<in> A"
  shows "concat ss \<in> A\<star>"
using assms by (induct ss) (auto)

lemma Star_cstring:
  assumes "s \<in> A\<star>"
  shows "\<exists>ss. concat ss = s \<and> (\<forall>s \<in> set ss. s \<in> A \<and> s \<noteq> [])"
using assms
apply(induct rule: Star.induct)
apply(auto)[1]
apply(rule_tac x="[]" in exI)
apply(simp)
apply(erule exE)
apply(clarify)
apply(case_tac "s1 = []")
apply(rule_tac x="ss" in exI)
apply(simp)
apply(rule_tac x="s1#ss" in exI)
apply(simp)
done

section {* Lexical Values *}
inductive
  Prf3 :: "val \<Rightarrow> rexp \<Rightarrow> bool" ("\<bbar> _ : _" [100, 100] 100)
where
 "\<lbrakk>\<bbar> v1 : r1; \<bbar>   v2 : r2\<rbrakk> \<Longrightarrow> \<bbar>  Seq v1 v2 : SEQ r1 r2"
| "\<bbar> v1 : r1 \<Longrightarrow> \<bbar> Left v1 : ALT r1 r2"
| "\<bbar> v2 : r2 \<Longrightarrow> \<bbar> Right v2 : ALT r1 r2"
| "\<bbar> Void : ONE"
| "\<bbar> Char c : CR c"
| "\<forall>v \<in> set vs. \<bbar> v : r \<and>(flat v = [] \<longrightarrow> length vs \<le> 1)  \<Longrightarrow> \<bbar> Stars vs : STAR r"

inductive_cases Prf3_elims:
  "\<bbar> v: ZERO"
  "\<bbar> v: SEQ r1 r2"
  "\<bbar> v: ALT r1 r2"
  "\<bbar> v : ONE"
  "\<bbar> v : CR c"
  "\<bbar> vs: STAR r"

inductive
  Prf2 :: "val \<Rightarrow> rexp \<Rightarrow> bool" ("\<turnstile> _ : _" [100, 100] 100)
where
 "\<lbrakk>\<turnstile> v1 : r1; \<turnstile>   v2 : r2\<rbrakk> \<Longrightarrow> \<turnstile>  Seq v1 v2 : SEQ r1 r2"
| "\<turnstile> v1 : r1 \<Longrightarrow> \<turnstile> Left v1 : ALT r1 r2"
| "\<turnstile> v2 : r2 \<Longrightarrow> \<turnstile> Right v2 : ALT r1 r2"
| "\<turnstile> Void : ONE"
| "\<turnstile> Char c : CR c"
| "\<forall>v \<in> set vs. \<turnstile> v : r  \<Longrightarrow> \<turnstile> Stars vs : STAR r"

inductive_cases Prf2_elims:
  "\<turnstile> v: ZERO"
  "\<turnstile> v: SEQ r1 r2"
  "\<turnstile> v: ALT r1 r2"
  "\<turnstile> v : ONE"
  "\<turnstile> v : CR c"
  "\<turnstile> vs: STAR r"

lemma Prf2_Stars_appendE:
  assumes " \<turnstile> Stars (vs1@vs2) : STAR r"
  shows "\<turnstile> Stars vs1 : STAR r \<and> \<turnstile> Stars vs2 : STAR r"
  using assms
  apply(rule Prf2_elims)
  by (auto intro: Prf2.intros elim!: Prf2_elims)

thm Prf2.intros
thm Prf2_elims

inductive
  Prf :: "val \<Rightarrow> rexp \<Rightarrow> bool" ("\<Turnstile> _ : _" [100, 100] 100)
where
 "\<lbrakk>\<Turnstile> v1 : r1; \<Turnstile> v2 : r2\<rbrakk> \<Longrightarrow> \<Turnstile>  Seq v1 v2 : SEQ r1 r2"
| "\<Turnstile> v1 : r1 \<Longrightarrow> \<Turnstile> Left v1 : ALT r1 r2"
| "\<Turnstile> v2 : r2 \<Longrightarrow> \<Turnstile> Right v2 : ALT r1 r2"
| "\<Turnstile> Void : ONE"
| "\<Turnstile> Char c : CR c"
| "\<forall>v \<in> set vs. \<Turnstile> v : r \<and> flat v \<noteq> [] \<Longrightarrow> \<Turnstile> Stars vs : STAR r"

inductive_cases Prf_elims:
  "\<Turnstile> v : ZERO"
  "\<Turnstile> v : SEQ r1 r2"
  "\<Turnstile> v : ALT r1 r2"
  "\<Turnstile> v : ONE"
  "\<Turnstile> v : CR c"
  "\<Turnstile> vs : STAR r"

lemma Prf_Stars_appendE:
  assumes "\<Turnstile> Stars (vs1 @ vs2) : STAR r"
  shows "\<Turnstile> Stars vs1 : STAR r \<and> \<Turnstile> Stars vs2 : STAR r"
using assms
by (auto intro: Prf.intros elim!: Prf_elims)

lemma Star_cval:
  assumes "\<forall>s\<in>set ss. \<exists>v. s = flat v \<and> \<Turnstile> v : r"
  shows "\<exists>vs. flats vs = concat ss \<and> (\<forall>v\<in>set vs. \<Turnstile> v : r \<and> flat v \<noteq> [])"
using assms
apply(induct ss)
apply(auto)
apply(rule_tac x="[]" in exI)
apply(simp)
apply(case_tac "flat v = []")
apply(rule_tac x="vs" in exI)
apply(simp)
apply(rule_tac x="v#vs" in exI)
apply(simp)
done

lemma Star2_cval:
  assumes "\<forall>s\<in>set ss. \<exists>v. s = flat v \<and> \<turnstile> v : r"
  shows "\<exists>vs. flats vs = concat ss \<and> (\<forall>v\<in>set vs. \<turnstile> v : r \<and> flat v \<noteq> [])"
using assms
apply(induct ss)
apply(auto)
apply(rule_tac x="[]" in exI)
apply(simp)
apply(case_tac "flat v = []")
apply(rule_tac x="vs" in exI)
apply(simp)
apply(rule_tac x="v#vs" in exI)
apply(simp)
done

lemma L_flat_Prf1:
  assumes "\<Turnstile> v : r"
  shows "flat v \<in> L r"
using assms
by (induct) (auto simp add: Sequ_def Star_concat)

lemma L_flat_2Prf1:
  assumes "\<turnstile> v : r"
  shows "flat v \<in> L r"
  using assms
  by (induct) (auto simp add: Sequ_def Star_concat)
thm Sequ_def  Star_concat

lemma L_flat_Prf2:
  assumes "s \<in> L r"
  shows "\<exists>v. \<Turnstile> v : r \<and> flat v = s"
using assms
proof(induct r arbitrary: s)
  case (STAR r s)
  have IH: "\<And>s. s \<in> L r \<Longrightarrow> \<exists>v. \<Turnstile> v : r \<and> flat v = s" by fact
  have "s \<in> L (STAR r)" by fact
  then obtain ss where "concat ss = s" "\<forall>s \<in> set ss. s \<in> L r \<and> s \<noteq> []"
  using Star_cstring by auto
  then obtain vs where "flats vs = s" "\<forall>v\<in>set vs. \<Turnstile> v : r \<and> flat v \<noteq> []"
  using IH Star_cval by metis
  then show "\<exists>v. \<Turnstile> v : STAR r \<and> flat v = s"
  using Prf.intros(6) flat_Stars by blast
next
  case (SEQ r1 r2 s)
  then show "\<exists>v. \<Turnstile> v : SEQ r1 r2 \<and> flat v = s"
  unfolding Sequ_def L.simps by (fastforce intro: Prf.intros)
next
  case (ALT r1 r2 s)
  then show "\<exists>v. \<Turnstile> v : ALT r1 r2 \<and> flat v = s"
  unfolding L.simps by (fastforce intro: Prf.intros)
qed (auto intro: Prf.intros)

lemma L_flat_2Prf2:
  assumes "s \<in> L r"
  shows "\<exists>v. \<turnstile> v : r \<and> flat v = s"
using assms
proof(induct r arbitrary: s)
  case (STAR r s)
  have IH: "\<And>s. s \<in> L r \<Longrightarrow> \<exists>v. \<turnstile> v : r \<and> flat v = s" by fact
  have "s \<in> L (STAR r)" by fact
  then obtain ss where "concat ss = s" "\<forall>s \<in> set ss. s \<in> L r \<and> s \<noteq> []"
  using Star_cstring by auto
  then obtain vs where "flats vs = s" "\<forall>v\<in>set vs. \<turnstile> v : r \<and> flat v \<noteq> []"
  using IH Star2_cval by metis
  then show "\<exists>v. \<turnstile> v : STAR r \<and> flat v = s"
  using Prf2.intros flat_Stars by blast
next
  case (SEQ r1 r2 s)
  then show "\<exists>v. \<turnstile> v : SEQ r1 r2 \<and> flat v = s"
  unfolding Sequ_def L.simps by (fastforce intro: Prf2.intros)
next
  case (ALT r1 r2 s)
  then show "\<exists>v. \<turnstile> v : ALT r1 r2 \<and> flat v = s"
  unfolding L.simps by (fastforce intro: Prf2.intros)
qed (auto intro: Prf2.intros)

lemma L_flat_Prf:
  shows "L(r) = {flat v | v. \<Turnstile> v : r}"
using L_flat_Prf1 L_flat_Prf2 by blast

lemma L_flat_2Prf:
  shows "L(r) = {flat v | v. \<turnstile> v : r}"
  using L_flat_2Prf1 L_flat_2Prf2 by blast

(*using L_flat_2Prf1 L_flat_2Prf2 by blast
*)

section {* Sets of Lexical Values *}

text {*
  Shows that lexical values are finite for a given regex and string.
*}

definition
  LV :: "rexp \<Rightarrow> string \<Rightarrow> val set"
where  "LV r s \<equiv> {v. \<Turnstile> v : r \<and> flat v = s}"

definition
  LV2 :: "rexp \<Rightarrow> string \<Rightarrow> val set"
  where "LV2 r s \<equiv> {v. \<turnstile> v : r \<and> flat v = s}"

lemma LV_simps:
  shows "LV ZERO s = {}"
  and   "LV ONE s = (if s = [] then {Void} else {})"
  and   "LV (CR c) s = (if s = [c] then {Char c} else {})"
  and   "LV (ALT r1 r2) s = Left ` LV r1 s \<union> Right ` LV r2 s"
unfolding LV_def
by (auto intro: Prf.intros elim: Prf.cases)

lemma LV2_simps:
  shows "LV2 ZERO S = {}"
and "LV2 ONE s = (if s = [] then {Void} else {})"
and "LV2 (CR c) s = (if s = [c] then {Char c} else {})"
and "LV2 (ALT r1 r2) s = Left ` LV2 r1 s \<union> Right ` LV2 r2 s"
  unfolding LV2_def
by (auto intro: Prf2.intros elim: Prf2.cases)

abbreviation
  "Prefixes s \<equiv> {s'. prefix s' s}"

abbreviation
  "Suffixes s \<equiv> {s'. suffix s' s}"

abbreviation
  "SSuffixes s \<equiv> {s'. strict_suffix s' s}"

lemma Suffixes_cons [simp]:
  shows "Suffixes (c # s) = Suffixes s \<union> {c # s}"
by (auto simp add: suffix_def Cons_eq_append_conv)

lemma finite_Suffixes:
  shows "finite (Suffixes s)"
by (induct s) (simp_all)

lemma finite_SSuffixes:
  shows "finite (SSuffixes s)"
proof -
  have "SSuffixes s \<subseteq> Suffixes s"
   unfolding strict_suffix_def suffix_def by auto
  then show "finite (SSuffixes s)"
   using finite_Suffixes finite_subset by blast
qed

lemma finite_Prefixes:
  shows "finite (Prefixes s)"
proof -
  have "finite (Suffixes (rev s))"
    by (rule finite_Suffixes)
  then have "finite (rev ` Suffixes (rev s))" by simp
  moreover
  have "rev ` (Suffixes (rev s)) = Prefixes s"
  unfolding suffix_def prefix_def image_def
   by (auto)(metis rev_append rev_rev_ident)+
  ultimately show "finite (Prefixes s)" by simp
qed

lemma LV_STAR_finite:
  assumes "\<forall>s. finite (LV r s)"
  shows "finite (LV (STAR r) s)"
proof(induct s rule: length_induct)
  fix s::"char list"
  assume "\<forall>s'. length s' < length s \<longrightarrow> finite (LV (STAR r) s')"
  then have IH: "\<forall>s' \<in> SSuffixes s. finite (LV (STAR r) s')"
    by (force simp add: strict_suffix_def suffix_def)
  define f where "f \<equiv> \<lambda>(v, vs). Stars (v # vs)"
  define S1 where "S1 \<equiv> \<Union>s' \<in> Prefixes s. LV r s'"
  define S2 where "S2 \<equiv> \<Union>s2 \<in> SSuffixes s. Stars -` (LV (STAR r) s2)"
  have "finite S1" using assms
    unfolding S1_def by (simp_all add: finite_Prefixes)
  moreover
  with IH have "finite S2" unfolding S2_def
    by (auto simp add: finite_SSuffixes inj_on_def finite_vimageI)
  ultimately
  have "finite ({Stars []} \<union> f ` (S1 \<times> S2))" by simp
  moreover
  have "LV (STAR r) s \<subseteq> {Stars []} \<union> f ` (S1 \<times> S2)"
  unfolding S1_def S2_def f_def
  unfolding LV_def image_def prefix_def strict_suffix_def
  apply(auto)
  apply(case_tac x)
  apply(auto elim: Prf_elims)
  apply(erule Prf_elims)
  apply(auto)
  apply(case_tac vs)
  apply(auto intro: Prf.intros)
  apply(rule exI)
  apply(rule conjI)
  apply(rule_tac x="flat a" in exI)
  apply(rule conjI)
  apply(rule_tac x="flats list" in exI)
  apply(simp)
   apply(blast)
  apply(simp add: suffix_def)
  using Prf.intros(6) by blast
  ultimately
  show "finite (LV (STAR r) s)" by (simp add: finite_subset)
qed

lemma LV_finite:
  shows "finite (LV r s)"
proof(induct r arbitrary: s)
  case (ZERO s)
  show "finite (LV ZERO s)" by (simp add: LV_simps)
next
  case (ONE s)
  show "finite (LV ONE s)" by (simp add: LV_simps)
next
  case (CR c s)
  show "finite (LV (CR c) s)" by (simp add: LV_simps)
next
  case (ALT r1 r2 s)
  then show "finite (LV (ALT r1 r2) s)" by (simp add: LV_simps)
next
  case (SEQ r1 r2 s)
  define f where "f \<equiv> \<lambda>(v1, v2). Seq v1 v2"
  define S1 where "S1 \<equiv> \<Union>s' \<in> Prefixes s. LV r1 s'"
  define S2 where "S2 \<equiv> \<Union>s' \<in> Suffixes s. LV r2 s'"
  have IHs: "\<And>s. finite (LV r1 s)" "\<And>s. finite (LV r2 s)" by fact+
  then have "finite S1" "finite S2" unfolding S1_def S2_def
    by (simp_all add: finite_Prefixes finite_Suffixes)
  moreover
  have "LV (SEQ r1 r2) s \<subseteq> f ` (S1 \<times> S2)"
    unfolding f_def S1_def S2_def
    unfolding LV_def image_def prefix_def suffix_def
    apply (auto elim!: Prf_elims)
    by (metis (mono_tags, lifting) mem_Collect_eq)
  ultimately
  show "finite (LV (SEQ r1 r2) s)"
    by (simp add: finite_subset)
next
  case (STAR r s)
  then show "finite (LV (STAR r) s)" by (simp add: LV_STAR_finite)
qed

section {* Our POSIX Definition *}

inductive
  Posix :: "string \<Rightarrow> rexp \<Rightarrow> val \<Rightarrow> bool" ("_ \<in> _ \<rightarrow> _" [100, 100, 100] 100)
where
  Posix_ONE: "[] \<in> ONE \<rightarrow> Void"
| Posix_CHAR: "[c] \<in> (CR c) \<rightarrow> (Char c)"
| Posix_ALT1: "s \<in> r1 \<rightarrow> v \<Longrightarrow> s \<in> (ALT r1 r2) \<rightarrow> (Left v)"
| Posix_ALT2: "\<lbrakk>s \<in> r2 \<rightarrow> v; s \<notin> L(r1)\<rbrakk> \<Longrightarrow> s \<in> (ALT r1 r2) \<rightarrow> (Right v)"
| Posix_SEQ: "\<lbrakk>s1 \<in> r1 \<rightarrow> v1; s2 \<in> r2 \<rightarrow> v2;
    \<not>(\<exists>s\<^sub>3 s\<^sub>4. s\<^sub>3 \<noteq> [] \<and> s\<^sub>3 @ s\<^sub>4 = s2 \<and> (s1 @ s\<^sub>3) \<in> L r1 \<and> s\<^sub>4 \<in> L r2)\<rbrakk> \<Longrightarrow>
    (s1 @ s2) \<in> (SEQ r1 r2) \<rightarrow> (Seq v1 v2)"
| Posix_STAR1: "\<lbrakk>s1 \<in> r \<rightarrow> v; s2 \<in> STAR r \<rightarrow> Stars vs; flat v \<noteq> [];
    \<not>(\<exists>s\<^sub>3 s\<^sub>4. s\<^sub>3 \<noteq> [] \<and> s\<^sub>3 @ s\<^sub>4 = s2 \<and> (s1 @ s\<^sub>3) \<in> L r \<and> s\<^sub>4 \<in> L (STAR r))\<rbrakk>
    \<Longrightarrow> (s1 @ s2) \<in> STAR r \<rightarrow> Stars (v # vs)"
| Posix_STAR2: "[] \<in> STAR r \<rightarrow> Stars []"

inductive_cases Posix_elims:
  "s \<in> ZERO \<rightarrow> v"
  "s \<in> ONE \<rightarrow> v"
  "s \<in> CR c \<rightarrow> v"
  "s \<in> ALT r1 r2 \<rightarrow> v"
  "s \<in> SEQ r1 r2 \<rightarrow> v"
  "s \<in> STAR r \<rightarrow> v"

(*
inductive
Posix_split :: "string \<Rightarrow> string \<Rightarrow>
*)

lemma Posix1:
  assumes "s \<in> r \<rightarrow> v"
  shows "s \<in> L r" "flat v = s"
using assms
by (induct s r v rule: Posix.induct)
   (auto simp add: Sequ_def)

text {*
  Our Posix definition determines a unique value.
*}

lemma Posix_determ:
  assumes "s \<in> r \<rightarrow> v1" "s \<in> r \<rightarrow> v2"
  shows "v1 = v2"
using assms
proof (induct s r v1 arbitrary: v2 rule: Posix.induct)
  case (Posix_ONE v2)
  have "[] \<in> ONE \<rightarrow> v2" by fact
  then show "Void = v2" by cases auto
next
  case (Posix_CHAR c v2)
  have "[c] \<in> CR c \<rightarrow> v2" by fact
  then show "Char c = v2" by cases auto
next
  case (Posix_ALT1 s r1 v r2 v2)
  have "s \<in> ALT r1 r2 \<rightarrow> v2" by fact
  moreover
  have "s \<in> r1 \<rightarrow> v" by fact
  then have "s \<in> L r1" by (simp add: Posix1)
  ultimately obtain v' where eq: "v2 = Left v'" "s \<in> r1 \<rightarrow> v'" by cases auto
  moreover
  have IH: "\<And>v2. s \<in> r1 \<rightarrow> v2 \<Longrightarrow> v = v2" by fact
  ultimately have "v = v'" by simp
  then show "Left v = v2" using eq by simp
next
  case (Posix_ALT2 s r2 v r1 v2)
  have "s \<in> ALT r1 r2 \<rightarrow> v2" by fact
  moreover
  have "s \<notin> L r1" by fact
  ultimately obtain v' where eq: "v2 = Right v'" "s \<in> r2 \<rightarrow> v'"
    by cases (auto simp add: Posix1)
  moreover
  have IH: "\<And>v2. s \<in> r2 \<rightarrow> v2 \<Longrightarrow> v = v2" by fact
  ultimately have "v = v'" by simp
  then show "Right v = v2" using eq by simp
next
  case (Posix_SEQ s1 r1 v1 s2 r2 v2 v')
  have "(s1 @ s2) \<in> SEQ r1 r2 \<rightarrow> v'"
       "s1 \<in> r1 \<rightarrow> v1" "s2 \<in> r2 \<rightarrow> v2"
       "\<not> (\<exists>s\<^sub>3 s\<^sub>4. s\<^sub>3 \<noteq> [] \<and> s\<^sub>3 @ s\<^sub>4 = s2 \<and> s1 @ s\<^sub>3 \<in> L r1 \<and> s\<^sub>4 \<in> L r2)" by fact+
  then obtain v1' v2' where "v' = Seq v1' v2'" "s1 \<in> r1 \<rightarrow> v1'" "s2 \<in> r2 \<rightarrow> v2'"
  apply(cases) apply (auto simp add: append_eq_append_conv2)
  using Posix1(1) by fastforce+
  moreover
  have IHs: "\<And>v1'. s1 \<in> r1 \<rightarrow> v1' \<Longrightarrow> v1 = v1'"
            "\<And>v2'. s2 \<in> r2 \<rightarrow> v2' \<Longrightarrow> v2 = v2'" by fact+
  ultimately show "Seq v1 v2 = v'" by simp
next
  case (Posix_STAR1 s1 r v s2 vs v2)
  have "(s1 @ s2) \<in> STAR r \<rightarrow> v2"
       "s1 \<in> r \<rightarrow> v" "s2 \<in> STAR r \<rightarrow> Stars vs" "flat v \<noteq> []"
       "\<not> (\<exists>s\<^sub>3 s\<^sub>4. s\<^sub>3 \<noteq> [] \<and> s\<^sub>3 @ s\<^sub>4 = s2 \<and> s1 @ s\<^sub>3 \<in> L r \<and> s\<^sub>4 \<in> L (STAR r))" by fact+
  then obtain v' vs' where "v2 = Stars (v' # vs')" "s1 \<in> r \<rightarrow> v'" "s2 \<in> (STAR r) \<rightarrow> (Stars vs')"
  apply(cases) apply (auto simp add: append_eq_append_conv2)
  using Posix1(1) apply fastforce
  apply (metis Posix1(1) Posix_STAR1.hyps(6) append_Nil append_Nil2)
  using Posix1(2) by blast
  moreover
  have IHs: "\<And>v2. s1 \<in> r \<rightarrow> v2 \<Longrightarrow> v = v2"
            "\<And>v2. s2 \<in> STAR r \<rightarrow> v2 \<Longrightarrow> Stars vs = v2" by fact+
  ultimately show "Stars (v # vs) = v2" by auto
next
  case (Posix_STAR2 r v2)
  have "[] \<in> STAR r \<rightarrow> v2" by fact
  then show "Stars [] = v2" by cases (auto simp add: Posix1)
qed

text {*
  Our POSIX values are lexical values.
*}

lemma Posix_LV:
  assumes "s \<in> r \<rightarrow> v"
  shows "v \<in> LV r s"
  using assms unfolding LV_def
  apply(induct rule: Posix.induct)
  apply(auto simp add: intro!: Prf.intros elim!: Prf_elims)
  done

lemma Posix_Prf:
  assumes "s \<in> r \<rightarrow> v"
  shows "\<Turnstile> v : r"
  using assms Posix_LV LV_def
  by simp

end


section \<open>Maximum Segment Sum\<close>

theory Maximum_Segment_Sum
  imports Main
begin

text \<open>The \emph{maximum segment sum} problem is to compute, given a list of numbers,
the largest of the sums of the contiguous segments of that list. It is also known
as the \emph{maximum sum subarray} problem and has been considered many times in the literature;
the Wikipedia article
\href{https://en.wikipedia.org/wiki/Maximum\_subarray\_problem}{Maximum subarray problem} is a good starting point.

We assume that the elements of the list are not necessarily numbers but just elements
of some linearly ordered group.\<close>

class linordered_group_add = linorder + group_add +
assumes add_left_mono: "a \<le> b \<Longrightarrow> c + a \<le> c + b"
assumes add_right_mono: "a \<le> b \<Longrightarrow> a + c \<le> b + c"
begin

lemma max_add_distrib_left: "max y z + x = max (y+x) (z+x)"
by (metis add_right_mono max.absorb_iff1 max_def)

lemma max_add_distrib_right: "x + max y z = max (x+y) (x+z)"
by (metis add_left_mono max.absorb1 max.cobounded2 max_def)

subsection \<open>Naive Solution\<close>

fun mss_rec_naive_aux :: "'a list \<Rightarrow> 'a" where
  "mss_rec_naive_aux [] = 0"
| "mss_rec_naive_aux (x#xs) = max 0 (x + mss_rec_naive_aux xs)"

fun mss_rec_naive :: "'a list \<Rightarrow> 'a" where
  "mss_rec_naive [] = 0"
| "mss_rec_naive (x#xs) = max (mss_rec_naive_aux (x#xs)) (mss_rec_naive xs)"

definition fronts :: "'a list \<Rightarrow> 'a list set" where
  "fronts xs = {as. \<exists>bs. xs = as @ bs}"

definition "front_sums xs \<equiv> sum_list ` fronts xs"

lemma fronts_cons: "fronts (x#xs) = ((#) x) ` fronts xs \<union> {[]}" (is "?l = ?r")
proof
  show "?l \<subseteq> ?r"
  proof
    fix as assume "as \<in> ?l"
    then show "as \<in> ?r" by (cases as) (auto simp: fronts_def)
  qed
  show "?r \<subseteq> ?l" unfolding fronts_def by auto
qed

lemma front_sums_cons: "front_sums (x#xs) = (+) x ` front_sums xs \<union> {0}"
proof -
  have "sum_list ` ((#) x) ` fronts xs = (+) x ` front_sums xs" unfolding front_sums_def by force
  then show ?thesis by (simp add: front_sums_def fronts_cons)
qed

lemma finite_fronts: "finite (fronts xs)"
  by (induction xs) (simp add: fronts_def, simp add: fronts_cons)

lemma finite_front_sums: "finite (front_sums xs)"
  using front_sums_def finite_fronts by simp

lemma front_sums_not_empty: "front_sums xs \<noteq> {}"
  unfolding front_sums_def fronts_def using image_iff by fastforce

lemma max_front_sum: "Max (front_sums (x#xs)) = max 0 (x + Max (front_sums xs))"
using finite_front_sums front_sums_not_empty
by (auto simp add: front_sums_cons hom_Max_commute max_add_distrib_right)

lemma mss_rec_naive_aux_front_sums: "mss_rec_naive_aux xs = Max (front_sums xs)"
by (induction xs) (simp add: front_sums_def fronts_def, auto simp: max_front_sum)

lemma front_sums: "front_sums xs = {s. \<exists>as bs. xs = as @ bs \<and> s = sum_list as}"
unfolding front_sums_def fronts_def by auto

lemma mss_rec_naive_aux: "mss_rec_naive_aux xs = Max {s. \<exists>as bs. xs = as @ bs \<and> s = sum_list as}"
using front_sums mss_rec_naive_aux_front_sums by simp

definition mids :: "'a list \<Rightarrow> 'a list set" where
  "mids xs \<equiv> {bs. \<exists>as cs. xs = as @ bs @ cs}"

definition "mid_sums xs \<equiv> sum_list ` mids xs"

lemma fronts_mids: "bs \<in> fronts xs \<Longrightarrow> bs \<in> mids xs"
unfolding fronts_def mids_def by auto

lemma mids_mids_cons: "bs \<in> mids xs \<Longrightarrow> bs \<in> mids (x#xs)"
proof-
  fix bs assume "bs \<in> mids xs"
  then obtain as cs where "xs = as @ bs @ cs" unfolding mids_def by blast
  then have "x # xs = (x#as) @ bs @ cs" by simp
  then show "bs \<in> mids (x#xs)" unfolding mids_def by blast
qed

lemma mids_cons: "mids (x#xs) = fronts (x#xs) \<union> mids xs" (is "?l = ?r")
proof
  show "?l \<subseteq> ?r"
  proof
    fix bs assume "bs \<in> ?l"
    then obtain as cs where as_bs_cs: "(x#xs) = as @ bs @ cs" unfolding mids_def by blast
    then show "bs \<in> ?r"
    proof (cases as)
      case Nil
      then have "bs \<in> fronts (x#xs)" by (simp add: fronts_def as_bs_cs)
      then show ?thesis by simp
    next
      case (Cons a as')
      then have "xs = as' @ bs @ cs" using as_bs_cs by simp
      then show ?thesis unfolding mids_def by auto
    qed
  qed
  show "?r \<subseteq> ?l" using fronts_mids mids_mids_cons by auto
qed

lemma mid_sums_cons: "mid_sums (x#xs) = front_sums (x#xs) \<union> mid_sums xs"
  unfolding mid_sums_def by (auto simp: mids_cons front_sums_def)

lemma finite_mids: "finite (mids xs)"
  by (induction xs) (simp add: mids_def, simp add: mids_cons finite_fronts)

lemma finite_mid_sums: "finite (mid_sums xs)"
  by (simp add: mid_sums_def finite_mids)

lemma mid_sums_not_empty: "mid_sums xs \<noteq> {}"
  unfolding mid_sums_def mids_def by blast

lemma max_mid_sums_cons: "Max (mid_sums (x#xs)) = max (Max (front_sums (x#xs))) (Max (mid_sums xs))"
  by (auto simp: mid_sums_cons Max_Un finite_front_sums finite_mid_sums front_sums_not_empty mid_sums_not_empty)

lemma mss_rec_naive_max_mid_sum: "mss_rec_naive xs = Max (mid_sums xs)"
  by (induction xs) (simp add: mid_sums_def mids_def, auto simp: max_mid_sums_cons mss_rec_naive_aux front_sums)

lemma mid_sums: "mid_sums xs = {s. \<exists>as bs cs. xs = as @ bs @ cs \<and> s = sum_list bs}"
  by (auto simp: mid_sums_def mids_def)

theorem mss_rec_naive: "mss_rec_naive xs = Max {s. \<exists>as bs cs. xs = as @ bs @ cs \<and> s = sum_list bs}"
  unfolding mss_rec_naive_max_mid_sum mid_sums by simp

subsection \<open>Kadane's Algorithms\<close>

fun kadane :: "'a list \<Rightarrow> 'a \<Rightarrow> 'a \<Rightarrow> 'a" where
  "kadane [] cur m = m"
| "kadane (x#xs) cur m =
    (let cur' = max (cur + x) x in
      kadane xs cur' (max m cur'))"

definition "mss_kadane xs \<equiv> kadane xs 0 0"

lemma Max_front_sums_geq_0: "Max (front_sums xs) \<ge> 0"
proof-
  have "[] \<in> fronts xs" unfolding fronts_def by blast
  then have "0 \<in> front_sums xs" unfolding front_sums_def by force
  then show ?thesis using finite_front_sums Max_ge by simp
qed

lemma Max_mid_sums_geq_0: "Max (mid_sums xs) \<ge> 0"
proof-
  have "0 \<in> mid_sums xs" unfolding mid_sums_def mids_def by force
  then show ?thesis using finite_mid_sums Max_ge by simp
qed

lemma kadane: "m \<ge> cur \<Longrightarrow> m \<ge> 0 \<Longrightarrow> kadane xs cur m = max m (max (cur + Max (front_sums xs)) (Max (mid_sums xs)))"
proof (induction xs cur m rule: kadane.induct)
  case (1 cur m)
  then show ?case unfolding front_sums_def fronts_def mid_sums_def mids_def by auto
next
  case (2 x xs cur m)
  then show ?case
    apply (auto simp: max_front_sum max_mid_sums_cons Let_def)
    by (smt (verit, ccfv_threshold) Max_front_sums_geq_0 add_assoc add_0_right max.assoc max.coboundedI1 max.left_commute max.orderE max_add_distrib_left max_add_distrib_right)
qed

lemma Max_front_sums_leq_Max_mid_sums: "Max (front_sums xs) \<le> Max (mid_sums xs)"
proof-
  have "front_sums xs \<subseteq> mid_sums xs" unfolding front_sums_def mid_sums_def using fronts_mids subset_iff by blast
  then show ?thesis using front_sums_not_empty finite_mid_sums Max_mono by blast
qed

lemma mss_kadane_mid_sums: "mss_kadane xs = Max (mid_sums xs)"
  unfolding mss_kadane_def using kadane Max_mid_sums_geq_0 Max_front_sums_leq_Max_mid_sums by auto

theorem mss_kadane: "mss_kadane xs = Max {s. \<exists>as bs cs. xs = as @ bs @ cs \<and> s = sum_list bs}"
  using mss_kadane_mid_sums mid_sums by auto

end

end