theory Chapter13_7
imports "HOL-IMP.Abs_Int2"
begin

text\<open>
\setcounter{exercise}{15}
\exercise
Give a readable proof that if @{text "\<gamma> ::"} \noquotes{@{typ[source]"'a::lattice \<Rightarrow> 'b::lattice"}}
is a monotone function, then @{prop "\<gamma> (a\<^sub>1 \<sqinter> a\<^sub>2) \<le> \<gamma> a\<^sub>1 \<sqinter> \<gamma> a\<^sub>2"}:
\<close>

lemma fixes \<gamma> :: "'a::lattice \<Rightarrow> 'b :: lattice"
assumes mono: "\<And>x y. x \<le> y \<Longrightarrow> \<gamma> x \<le> \<gamma> y"
shows "\<gamma> (a\<^sub>1 \<sqinter> a\<^sub>2) \<le> \<gamma> a\<^sub>1 \<sqinter> \<gamma> a\<^sub>2" (is "\<gamma> ?m \<le> _")
proof -
  have "\<gamma> ?m \<le> \<gamma> a\<^sub>1" by (intro mono, auto)
  moreover
  have "\<gamma> ?m \<le> \<gamma> a\<^sub>2" by (intro mono, auto)
  ultimately show ?thesis by simp
qed

text\<open>
Give an example of two lattices and a monotone @{text \<gamma>}
where @{prop"\<gamma> a\<^sub>1 \<sqinter> \<gamma> a\<^sub>2 \<le> \<gamma> (a\<^sub>1 \<sqinter> a\<^sub>2)"} does not hold.

Consider {a, c, t, b} of unique elements with order generated by t being top and b being bottom.
Let f be identity with codomain {a, c, d, t, b} of unique elements, with order generated by t
being top, b being bottom, and "d \<le> a", "d \<le> c".
then \<gamma> (a \<sqinter> c) = b < d = \<gamma> a \<sqinter> \<gamma> c.
\<close>

text\<open>
\endexercise

\exercise
Consider a simple sign analysis based on this abstract domain:
\<close>

datatype sign = None | Neg | Pos0 | Any

fun \<gamma> :: "sign \<Rightarrow> val set" where
"\<gamma> None = {}" |
"\<gamma> Neg = {i. i < 0}" |
"\<gamma> Pos0 = {i. i \<ge> 0}" |
"\<gamma> Any = UNIV"

text\<open>
Define inverse analyses for ``@{text"+"}'' and ``@{text"<"}''
and prove the required correctness properties:
\<close>

fun inv_plus' :: "sign \<Rightarrow> sign \<Rightarrow> sign \<Rightarrow> sign * sign" where
  "inv_plus' None _ _ = (None, None)" |
  "inv_plus' _ None _ = (None, None)" |
  "inv_plus' _ _ None = (None, None)" |
  "inv_plus' Neg Pos0 Pos0 = (None, None)" |
  "inv_plus' Pos0 Neg Neg = (None, None)" |
  "inv_plus' Neg Pos0 Any = (Pos0, Neg)" |
  "inv_plus' Neg Any Pos0 = (Neg, Pos0)" |
  "inv_plus' Pos0 Neg Any = (Neg, Pos0)" |
  "inv_plus' Pos0 Any Neg = (Pos0, Neg)" |
  "inv_plus' _ a b = (a, b)"

lemma
  "\<lbrakk> inv_plus' a a1 a2 = (a1',a2');  i1 \<in> \<gamma> a1;  i2 \<in> \<gamma> a2; i1+i2 \<in> \<gamma> a \<rbrakk>
  \<Longrightarrow> i1 \<in> \<gamma> a1' \<and> i2 \<in> \<gamma> a2' "
  by (cases a; cases a1; cases a2) auto

fun inv_less' :: "bool \<Rightarrow> sign \<Rightarrow> sign \<Rightarrow> sign * sign" where
  "inv_less' _ None _ = (None, None)" |
  "inv_less' _ _ None = (None, None)" |
  "inv_less' True Pos0 Neg = (None, None)" |
  "inv_less' False Neg Pos0 = (None, None)" |
  "inv_less' True Pos0 Any = (Pos0, Pos0)" |
  "inv_less' True Any Neg = (Neg, Neg)" |
  "inv_less' False Neg Any = (Neg, Neg)" |
  "inv_less' False Any Pos0 = (Pos0, Pos0)" |
  "inv_less' _ a b = (a, b)"

lemma
  "\<lbrakk> inv_less' bv a1 a2 = (a1',a2');  i1 \<in> \<gamma> a1;  i2 \<in> \<gamma> a2; (i1<i2) = bv \<rbrakk>
  \<Longrightarrow> i1 \<in> \<gamma> a1' \<and> i2 \<in> \<gamma> a2'"
  by (cases bv; cases a1; cases a2) auto

text\<open>
\indent
For the ambitious: turn the above fragment into a full-blown abstract interpreter
by replacing the interval analysis in theory @{theory "HOL-IMP.Abs_Int2"}@{text"_ivl"}
by a sign analysis.
\endexercise
\<close>

end


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

section \<open>Permutations\<close>

theory Permutation
imports Main
begin

inductive perm :: "'a list \<Rightarrow> 'a list \<Rightarrow> bool"  (infixr \<open><~~>\<close> 50)
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"

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

subsection \<open>Some examples of rule induction on permutations\<close>

proposition perm_empty_imp: "[] <~~> ys \<Longrightarrow> ys = []"
  by (induction "[] :: 'a list" ys pred: perm) simp_all

text \<open>\medskip This more general theorem is easier to understand!\<close>

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

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

subsection \<open>Ways of making new permutations\<close>

text \<open>We can insert the head anywhere in the list.\<close>

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

proposition perm_append_swap: "xs @ ys <~~> ys @ xs"
  by (induct xs) (auto intro: perm_append_Cons)

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

proposition perm_rev: "rev xs <~~> xs"
  by (induct xs) (auto intro!: perm_append_single intro: perm_sym)

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

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

subsection \<open>Further results\<close>

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

proposition perm_empty2 [iff]: "xs <~~> [] \<longleftrightarrow> xs = []"
  using perm_sym by auto

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

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

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

subsection \<open>Removing elements\<close>

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

text \<open>\medskip Congruence rule\<close>

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

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

proposition cons_perm_imp_perm: "z # xs <~~> z # ys \<Longrightarrow> xs <~~> ys"
  by (drule perm_remove_perm [where z = z]) auto

proposition cons_perm_eq [iff]: "z#xs <~~> z#ys \<longleftrightarrow> xs <~~> ys"
  by (meson cons_perm_imp_perm perm.Cons)

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

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

proposition perm_append2_eq [iff]: "xs @ zs <~~> ys @ zs \<longleftrightarrow> xs <~~> ys"
  by (meson perm.trans perm_append1_eq perm_append_swap)

proposition prem_seteq: "xs <~~> ys \<Longrightarrow> x \<in> set xs \<Longrightarrow> x \<in> set ys"
proof(induct xs arbitrary:ys)
  case Nil
  then show ?case by simp
next
  case (Cons a xs)
  then show ?case
  proof(cases "x = a")
    case True
    then show ?thesis using Cons
      by (metis (no_types, opaque_lifting) dual_order.refl impossible_Cons perm_length
          perm_remove_perm remove1_idem remove_hd)
  next
    case False
    have 1: "x \<in> set xs"
      using False Cons by simp
    have 2: "xs <~~> remove1 a ys"
      using Cons(2) perm_remove_perm by (metis remove_hd)
    then show ?thesis using 1 Cons(1) by (metis notin_set_remove1)
  qed
qed

proposition distinct_perm: "xs <~~> ys \<Longrightarrow> distinct xs \<Longrightarrow> distinct ys"
proof(induct xs arbitrary:ys)
  case Nil
  then show ?case by simp
next
  case (Cons x xs)
  have tmp1: "xs <~~> remove1 x ys"
    using Cons(2) perm_remove_perm by (metis remove_hd)
  have tmp2: "distinct (remove1 x ys)"
    using Cons(1,3) tmp1 by auto
  have tmp3: "x \<notin> set xs"
    using Cons by simp
  have tmp4: "x \<notin> set (remove1 x ys)"
    using Cons tmp1 by (meson perm_sym prem_seteq tmp3)
  have tmp5: "x \<in> set ys"
    using Cons(2) by (simp add: prem_seteq)
  have tmp6: "set (x#(remove1 x ys)) = set ys"
    using tmp4 tmp5
    by (metis (mono_tags, opaque_lifting) equalityI insert_subset list.set(2)
        perm_remove prem_seteq set_remove1_subset subsetI)
  then show ?case using tmp2 tmp3 tmp4 tmp5
    by (metis Cons.prems(1) card_distinct distinct.simps(2) distinct_card length_Cons perm_length tmp1)

qed

lemma perm_remove2: "x \<in> set ys \<Longrightarrow> xs <~~> remove1 x ys \<Longrightarrow> x#xs <~~> ys"
proof(induct ys arbitrary:xs)
  case Nil
  then show ?case using perm_remove by fastforce
next
  case (Cons a ys)
  then show ?case
  proof(cases "x = a")
    case True
    then show ?thesis using Cons(3) unfolding remove1.simps by auto
  next
    case False
    then show ?thesis using Cons by (meson perm.Cons perm.trans perm_remove perm_sym)
  qed
qed

lemma perm_remove3: "x \<in> set ys \<Longrightarrow> ys@xs <~~> (remove1 x ys)@xs@[x]"
proof(induct ys)
  case Nil
  then show ?case using perm_remove by fastforce
next
  case (Cons a ys)
  then show ?case
  proof(cases "x = a")
    case True
    then show ?thesis unfolding remove1.simps by (metis (mono_tags, lifting) append_Cons
          append_eq_appendI perm_append_single)
  next
    case False
    then show ?thesis using Cons by simp
  qed
qed

end


section \<open>Basic Randomized Algorithms\label{sec:basic_randomized_algorithms}\<close>

text \<open>This section introduces a few randomized algorithms for well-known distributions. These both
serve as building blocks for more complex algorithms and as examples describing how to use the
framework.\<close>

theory Basic_Randomized_Algorithms
  imports
    Randomized_Algorithm
    Probabilistic_While.Bernoulli
    Probabilistic_While.Geometric
    Permuted_Congruential_Generator
begin

text \<open>A simple example: Here we define a randomized algorithm that can sample uniformly from
@{term "pmf_of_set {..<(2::nat)^n}"}. (The same problem for general ranges is discussed in
Section~\ref{sec:dice_roll}).\<close>

fun binary_dice_roll :: "nat \<Rightarrow> nat random_alg"
  where
    "binary_dice_roll 0 = return_ra 0" |
    "binary_dice_roll (Suc n) =
      do { h \<leftarrow> binary_dice_roll n;
           c \<leftarrow> coin_ra;
           return_ra (of_bool c + 2 * h)
        }"

text \<open>Because the algorithm terminates unconditionally it is easy to verify that
@{term "binary_dice_roll"} terminates almost surely:\<close>

lemma binary_dice_roll_terminates: "terminates_almost_surely (binary_dice_roll n)"
  by (induction n) (auto intro:terminates_almost_surely_intros)

text \<open>The corresponding PMF can be written as:\<close>

fun binary_dice_roll_pmf :: "nat \<Rightarrow> nat pmf"
  where
    "binary_dice_roll_pmf 0 = return_pmf 0" |
    "binary_dice_roll_pmf (Suc n) =
      do { h \<leftarrow> binary_dice_roll_pmf n;
           c \<leftarrow> coin_pmf;
           return_pmf (of_bool c + 2 * h)
        }"

text \<open>To verify that the distribution of the result of @{term "binary_dice_roll"} is
@{term "binary_dice_roll_pmf"} we can rely on the @{thm [source] pmf_of_ra_simps} simp rules
and the @{thm [source] "terminates_almost_surely_intros"} introduction rules:\<close>

lemma "pmf_of_ra (binary_dice_roll n) = binary_dice_roll_pmf n"
  using binary_dice_roll_terminates
  by (induction n) (simp_all add:terminates_almost_surely_intros pmf_of_ra_simps)

text \<open>Let us now consider an algorithm that does not terminate unconditionally but just almost
surely:\<close>

partial_function (random_alg) binary_geometric :: "nat \<Rightarrow> nat random_alg"
  where
    "binary_geometric n =
      do { c \<leftarrow> coin_ra;
           if c then (return_ra n) else binary_geometric (n+1)
        }"

text \<open>This is necessary for running randomized algorithms defined with the
@{command "partial_function"} directive:\<close>
declare binary_geometric.simps[code]

text \<open>In this case, we need to map to an SPMF:\<close>

partial_function (spmf) binary_geometric_spmf :: "nat \<Rightarrow> nat spmf"
  where
    "binary_geometric_spmf n =
      do { c \<leftarrow> coin_spmf;
           if c then (return_spmf n) else binary_geometric_spmf (n+1)
        }"

text \<open>We use the transfer rules for @{term "spmf_of_ra"} to show the correspondence:\<close>

lemma binary_geometric_ra_correct:
  "spmf_of_ra (binary_geometric x) = binary_geometric_spmf x"
proof -
  include lifting_syntax
  have "((=) ===> rel_spmf_of_ra) binary_geometric_spmf binary_geometric"
    unfolding binary_geometric_def binary_geometric_spmf_def
    apply (rule fixp_ra_parametric[OF binary_geometric_spmf.mono binary_geometric.mono])
    by transfer_prover
  thus ?thesis
    unfolding rel_fun_def rel_spmf_of_ra_def by auto
qed

text \<open>Bernoulli distribution: For this example we show correspondence with the already existing
definition of @{term "bernoulli"} SPMF.\<close>

partial_function (random_alg) bernoulli_ra :: "real \<Rightarrow> bool random_alg" where
  "bernoulli_ra p = do {
     b \<leftarrow> coin_ra;
     if b then return_ra (p \<ge> 1 / 2)
     else if p < 1 / 2 then bernoulli_ra (2 * p)
     else bernoulli_ra (2 * p - 1)
   }"

declare bernoulli_ra.simps[code]

text \<open>The following is a different technique to show equivalence of an SPMF with a randomized
algorithm. It only works if the SPMF has weight $1$. First we show that the SPMF is a lower
bound:\<close>

lemma bernoulli_ra_correct_aux: "ord_spmf (=) (bernoulli x) (spmf_of_ra (bernoulli_ra x))"
proof (induction arbitrary:x rule:bernoulli.fixp_induct)
  case 1
  thus ?case by simp
next
  case 2
  thus ?case by simp
next
  case (3 p)
  thus ?case by (subst bernoulli_ra.simps)
      (auto intro:ord_spmf_bind_reflI simp:spmf_of_ra_simps)
qed

text \<open>Then relying on the fact that the SPMF has weight one, we can derive equivalence:\<close>

lemma bernoulli_ra_correct: "bernoulli x = spmf_of_ra (bernoulli_ra x)"
  using lossless_bernoulli weight_spmf_le_1 unfolding lossless_spmf_def
  by (intro eq_iff_ord_spmf[OF _ bernoulli_ra_correct_aux]) auto

text \<open>Because @{term "bernoulli p"} is a lossless SPMF equivalent to
@{term "spmf_of_pmf (bernoulli_pmf p)"} it is also possible to express the above, without referring
to SPMFs:\<close>

lemma
  "terminates_almost_surely (bernoulli_ra p)"
  "bernoulli_pmf p = pmf_of_ra (bernoulli_ra p)"
  unfolding terminates_almost_surely_def pmf_of_ra_def bernoulli_ra_correct[symmetric]
  by (simp_all add: bernoulli_eq_bernoulli_pmf pmf_of_spmf)

context
  includes lifting_syntax
begin

lemma bernoulli_ra_transfer [transfer_rule]:
  "((=) ===> rel_spmf_of_ra) bernoulli bernoulli_ra"
  unfolding rel_fun_def rel_spmf_of_ra_def bernoulli_ra_correct by simp

end

text \<open>Using the randomized algorithm for the Bernoulli distribution, we can introduce one for the
general geometric distribution:\<close>

partial_function (random_alg) geometric_ra :: "real \<Rightarrow> nat random_alg" where
  "geometric_ra p = do {
     b \<leftarrow> bernoulli_ra p;
     if b then return_ra 0 else map_ra ((+) 1) (geometric_ra p)
  }"
declare geometric_ra.simps[code]

lemma geometric_ra_correct: "spmf_of_ra (geometric_ra x) = geometric_spmf x"
proof -
  include lifting_syntax
  have "((=) ===> rel_spmf_of_ra) geometric_spmf geometric_ra"
    unfolding geometric_ra_def geometric_spmf_def
    apply (rule fixp_ra_parametric[OF geometric_spmf.mono geometric_ra.mono])
    by transfer_prover
  thus ?thesis
    unfolding rel_fun_def rel_spmf_of_ra_def by auto
qed

text \<open>Replication of a distribution\<close>

fun replicate_ra :: "nat \<Rightarrow> 'a random_alg \<Rightarrow> 'a list random_alg"
  where
    "replicate_ra 0 f = return_ra []" |
    "replicate_ra (Suc n) f = do { xh \<leftarrow> f; xt \<leftarrow> replicate_ra n f; return_ra (xh#xt) }"

fun replicate_spmf :: "nat \<Rightarrow> 'a spmf \<Rightarrow> 'a list spmf"
  where
    "replicate_spmf 0 f = return_spmf []" |
    "replicate_spmf (Suc n) f = do { xh \<leftarrow> f; xt \<leftarrow> replicate_spmf n f; return_spmf (xh#xt) }"

lemma replicate_ra_correct: "spmf_of_ra (replicate_ra n f) = replicate_spmf n (spmf_of_ra f)"
  by (induction n) (auto simp :spmf_of_ra_simps)

lemma replicate_spmf_of_pmf: "replicate_spmf n (spmf_of_pmf f) = spmf_of_pmf (replicate_pmf n f)"
  by (induction n) (simp_all add:spmf_of_pmf_bind)

text \<open>Binomial distribution\<close>

definition binomial_ra :: "nat \<Rightarrow> real \<Rightarrow> nat random_alg"
  where "binomial_ra n p = map_ra (length \<circ> filter id) (replicate_ra n (bernoulli_ra p))"

lemma
  assumes "p \<in> {0..1}"
  shows "spmf_of_ra (binomial_ra n p) = spmf_of_pmf (binomial_pmf n p)"
proof -
  have "spmf_of_ra (replicate_ra n (bernoulli_ra p))=spmf_of_pmf(replicate_pmf n (bernoulli_pmf p))"
    unfolding replicate_ra_correct bernoulli_ra_correct[symmetric] bernoulli_eq_bernoulli_pmf
    by (simp add:replicate_spmf_of_pmf)

  thus ?thesis
    unfolding binomial_pmf_altdef[OF assms] binomial_ra_def
    by (simp flip:map_spmf_of_pmf add:spmf_of_ra_map)
qed

text \<open>Running randomized algorithms: Here we use the PRG introduced in
Section~\ref{sec:permuted_congruential_generator}.\<close>

value "run_ra (binomial_ra 10 0.5) (random_coins 42)"

value "run_ra (replicate_ra 20 (bernoulli_ra 0.3)) (random_coins 42)"

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 ``Maximum subarray problem''
\<^url>\<open>https://en.wikipedia.org/wiki/Maximum_subarray_problem\<close> 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


header {* Generators *}

theory "Generators"
imports
   "~~/src/HOL/Algebra/Group"
   "~~/src/HOL/Algebra/Lattice"
begin

text {* This theory is not specific to Free Groups and could be moved to a more
general place. It defines the subgroup generated by a set of generators and
that homomorphisms agree on the generated subgroup if they agree on the
generators. *}

notation subgroup (infix "\<le>" 80)

subsection {* The subgroup generated by a set *}

text {* The span of a set of subgroup generators, i.e. the generated subgroup, can
be defined inductively or as the intersection of all subgroups containing the
generators. Here, we define it inductively and proof the equivalence *}

inductive_set gen_span :: "('a,'b) monoid_scheme \<Rightarrow> 'a set \<Rightarrow> 'a set" ("\<langle>_\<rangle>\<index>")
  for G and gens
where gen_one [intro!, simp]: "\<one>\<^bsub>G\<^esub> \<in> \<langle>gens\<rangle>\<^bsub>G\<^esub>"
    | gen_gens: "x \<in> gens \<Longrightarrow> x \<in> \<langle>gens\<rangle>\<^bsub>G\<^esub>"
    | gen_inv: "x \<in> \<langle>gens\<rangle>\<^bsub>G\<^esub> \<Longrightarrow> inv\<^bsub>G\<^esub> x \<in> \<langle>gens\<rangle>\<^bsub>G\<^esub>"
    | gen_mult: "\<lbrakk> x \<in> \<langle>gens\<rangle>\<^bsub>G\<^esub>; y \<in> \<langle>gens\<rangle>\<^bsub>G\<^esub> \<rbrakk> \<Longrightarrow>  x \<otimes>\<^bsub>G\<^esub> y \<in> \<langle>gens\<rangle>\<^bsub>G\<^esub>"

lemma (in group) gen_span_closed:
  assumes "gens \<subseteq> carrier G"
  shows "\<langle>gens\<rangle>\<^bsub>G\<^esub> \<subseteq> carrier G"
proof (* How can I do this in one "by" line? *)
  fix x
  from assms show "x \<in> \<langle>gens\<rangle>\<^bsub>G\<^esub> \<Longrightarrow> x \<in> carrier G"
    by -(induct rule:gen_span.induct, auto)
qed

lemma (in group) gen_subgroup_is_subgroup:
      "gens \<subseteq> carrier G \<Longrightarrow> \<langle>gens\<rangle>\<^bsub>G\<^esub> \<le> G"
by(rule subgroupI)(auto intro:gen_span.intros simp add:gen_span_closed)

lemma (in group) gen_subgroup_is_smallest_containing:
  assumes "gens \<subseteq> carrier G"
    shows "\<Inter>{H. H \<le> G \<and> gens \<subseteq> H} = \<langle>gens\<rangle>\<^bsub>G\<^esub>"
proof
  show "\<langle>gens\<rangle>\<^bsub>G\<^esub> \<subseteq> \<Inter>{H. H \<le> G \<and> gens \<subseteq> H}"
  proof(rule Inf_greatest)
    fix H
    assume "H \<in> {H. H \<le> G \<and> gens \<subseteq> H}"
    hence "H \<le> G" and "gens \<subseteq> H" by auto
    show "\<langle>gens\<rangle>\<^bsub>G\<^esub> \<subseteq> H"
    proof
      fix x
      from `H \<le> G` and `gens \<subseteq> H`
      show "x \<in> \<langle>gens\<rangle>\<^bsub>G\<^esub> \<Longrightarrow> x \<in> H"
       unfolding subgroup_def
       by -(induct rule:gen_span.induct, auto)
    qed
  qed
next
  from `gens \<subseteq> carrier G`
  have "\<langle>gens\<rangle>\<^bsub>G\<^esub> \<le> G" by (rule gen_subgroup_is_subgroup)
  moreover
  have "gens \<subseteq> \<langle>gens\<rangle>\<^bsub>G\<^esub>" by (auto intro:gen_span.intros)
  ultimately
  show "\<Inter>{H. H \<le> G \<and> gens \<subseteq> H} \<subseteq> \<langle>gens\<rangle>\<^bsub>G\<^esub>"
    by(auto intro:Inter_lower)
qed

subsection {* Generators and homomorphisms *}

text {* Two homorphisms agreeing on some elements agree on the span of those elements.*}

lemma hom_unique_on_span:
  assumes "group G"
      and "group H"
      and "gens \<subseteq> carrier G"
      and "h \<in> hom G H"
      and "h' \<in> hom G H"
      and "\<forall>g \<in> gens. h g = h' g"
  shows "\<forall>x \<in> \<langle>gens\<rangle>\<^bsub>G\<^esub>. h x = h' x"
proof
  interpret G: group G by fact
  interpret H: group H by fact
  interpret h: group_hom G H h by unfold_locales fact
  interpret h': group_hom G H h' by unfold_locales fact

  fix x
  from `gens \<subseteq> carrier G` have "\<langle>gens\<rangle>\<^bsub>G\<^esub> \<subseteq> carrier G" by (rule G.gen_span_closed)
  with assms show "x \<in> \<langle>gens\<rangle>\<^bsub>G\<^esub> \<Longrightarrow> h x = h' x" apply -
  proof(induct rule:gen_span.induct)
    case (gen_mult x y)
      hence x: "x \<in> carrier G" and y: "y \<in> carrier G" and
            hx: "h x = h' x" and hy: "h y = h' y" by auto
      thus "h (x \<otimes>\<^bsub>G\<^esub> y) = h' (x \<otimes>\<^bsub>G\<^esub> y)" by simp
  qed auto
qed

subsection {* Sets of generators *}

text {* There is no definition for ``@{text gens} is a generating set of
@{text G}''. This is easily expressed by @{text "\<langle>gens\<rangle> = carrier G"}. *}

text {* The following is an application of @{text hom_unique_on_span} on a
generating set of the whole group. *}

lemma (in group) hom_unique_by_gens:
  assumes "group H"
      and gens: "\<langle>gens\<rangle>\<^bsub>G\<^esub> = carrier G"
      and "h \<in> hom G H"
      and "h' \<in> hom G H"
      and "\<forall>g \<in> gens. h g = h' g"
  shows "\<forall>x \<in> carrier G. h x = h' x"
proof
  fix x

  from gens have "gens \<subseteq> carrier G" by (auto intro:gen_span.gen_gens)
  with assms and group_axioms have r: "\<forall>x \<in> \<langle>gens\<rangle>\<^bsub>G\<^esub>. h x = h' x"
    by -(erule hom_unique_on_span, auto)
  with gens show "x \<in> carrier G \<Longrightarrow> h x = h' x" by auto
qed

lemma (in group_hom) hom_span:
  assumes "gens \<subseteq> carrier G"
  shows "h ` (\<langle>gens\<rangle>\<^bsub>G\<^esub>) = \<langle>h ` gens\<rangle>\<^bsub>H\<^esub>"
proof(rule Set.set_eqI, rule iffI)
  from `gens \<subseteq> carrier G`
  have "\<langle>gens\<rangle>\<^bsub>G\<^esub> \<subseteq> carrier G" by (rule G.gen_span_closed)

  fix y
  assume "y \<in> h ` \<langle>gens\<rangle>\<^bsub>G\<^esub>"
  then obtain x where "x \<in> \<langle>gens\<rangle>\<^bsub>G\<^esub>" and "y = h x" by auto
  from `x \<in> \<langle>gens\<rangle>\<^bsub>G\<^esub>`
  have "h x \<in> \<langle>h ` gens\<rangle>\<^bsub>H\<^esub>"
  proof(induct x)
    case (gen_inv x)
    hence "x \<in> carrier G" and "h x \<in> \<langle>h ` gens\<rangle>\<^bsub>H\<^esub>"
      using `\<langle>gens\<rangle>\<^bsub>G\<^esub> \<subseteq> carrier G`
      by auto
    thus ?case by (auto intro:gen_span.intros)
  next
    case (gen_mult x y)
    hence "x \<in> carrier G" and "h x \<in> \<langle>h ` gens\<rangle>\<^bsub>H\<^esub>"
    and   "y \<in> carrier G" and "h y \<in> \<langle>h ` gens\<rangle>\<^bsub>H\<^esub>"
      using `\<langle>gens\<rangle>\<^bsub>G\<^esub> \<subseteq> carrier G`
      by auto
    thus ?case by (auto intro:gen_span.intros)
  qed(auto intro: gen_span.intros)
  with `y = h x`
  show "y \<in> \<langle>h ` gens\<rangle>\<^bsub>H\<^esub>" by simp
next
  fix x
  show "x \<in> \<langle>h ` gens\<rangle>\<^bsub>H\<^esub> \<Longrightarrow> x \<in> h ` \<langle>gens\<rangle>"
  proof(induct x rule:gen_span.induct)
    case (gen_inv y)
      then  obtain x where "y = h x" and "x \<in> \<langle>gens\<rangle>" by auto
      moreover
      hence "x \<in> carrier G"  using `gens \<subseteq> carrier G`
        by (auto dest:G.gen_span_closed)
      ultimately show ?case
        by (auto intro:hom_inv[THEN sym] rev_image_eqI gen_span.gen_inv simp del:group_hom.hom_inv hom_inv)
  next
   case (gen_mult y y')
      then  obtain x and x'
        where "y = h x" and "x \<in> \<langle>gens\<rangle>"
        and "y' = h x'" and "x' \<in> \<langle>gens\<rangle>" by auto
      moreover
      hence "x \<in> carrier G" and "x' \<in> carrier G" using `gens \<subseteq> carrier G`
        by (auto dest:G.gen_span_closed)
      ultimately show ?case
        by (auto intro:hom_mult[THEN sym] rev_image_eqI gen_span.gen_mult simp del:group_hom.hom_mult hom_mult)
  qed(auto intro:rev_image_eqI intro:gen_span.intros)
qed

subsection {* Product of a list of group elements *}

text {* Not strictly related to generators of groups, this is still a general
group concept and not related to Free Groups. *}

abbreviation (in monoid) m_concat
  where "m_concat l \<equiv> foldr (op \<otimes>) l \<one>"

lemma (in monoid) m_concat_closed[simp]:
 "set l \<subseteq> carrier G \<Longrightarrow> m_concat l \<in> carrier G"
  by (induct l, auto)

lemma (in monoid) m_concat_append[simp]:
  assumes "set a \<subseteq> carrier G"
      and "set b \<subseteq> carrier G"
  shows "m_concat (a@b) = m_concat a \<otimes> m_concat b"
using assms
by(induct a)(auto simp add: m_assoc)

lemma (in monoid) m_concat_cons[simp]:
  "\<lbrakk> x \<in> carrier G ; set xs \<subseteq> carrier G \<rbrakk> \<Longrightarrow> m_concat (x#xs) = x \<otimes> m_concat xs"
by(induct xs)(auto simp add: m_assoc)

lemma (in monoid) m_concat_power[simp]: "x \<in> carrier G \<Longrightarrow> m_concat (replicate n x) = x (^) n"
by(induct n, auto simp add:nat_pow_mult1l)

subsection {* Isomorphisms *}

text {* A nicer way of proving that something is a group homomorphism or
isomorphism. *}

lemma group_homI[intro]:
  assumes range: "h ` (carrier g1) \<subseteq> carrier g2"
      and hom: "\<forall>x\<in>carrier g1. \<forall>y\<in>carrier g1. h (x \<otimes>\<^bsub>g1\<^esub> y) = h x \<otimes>\<^bsub>g2\<^esub> h y"
  shows "h \<in> hom g1 g2"
proof-
  have "h \<in> carrier g1 \<rightarrow> carrier g2" using range  by auto
  thus "h \<in> hom g1 g2" using hom unfolding hom_def by auto
qed

lemma (in group_hom) hom_injI:
  assumes "\<forall>x\<in>carrier G. h x = \<one>\<^bsub>H\<^esub> \<longrightarrow> x = \<one>\<^bsub>G\<^esub>"
  shows "inj_on h (carrier G)"
unfolding inj_on_def
proof(rule ballI, rule ballI, rule impI)
  fix x
  fix y
  assume x: "x\<in>carrier G"
     and y: "y\<in>carrier G"
     and "h x = h y"
  hence "h (x \<otimes> inv y) = \<one>\<^bsub>H\<^esub>" and "x \<otimes> inv y \<in> carrier G"
    by auto
  with assms
  have "x \<otimes> inv y = \<one>" by auto
  thus "x = y" using x and y
    by(auto dest: G.inv_equality)
qed

lemma (in group_hom) group_hom_isoI:
  assumes inj1: "\<forall>x\<in>carrier G. h x = \<one>\<^bsub>H\<^esub> \<longrightarrow> x = \<one>\<^bsub>G\<^esub>"
      and surj: "h ` (carrier G) = carrier H"
  shows "h \<in> G \<cong> H"
proof-
  from inj1
  have "inj_on h (carrier G)"
    by(auto intro: hom_injI)
  hence bij: "bij_betw h (carrier G) (carrier H)"
    using surj  unfolding bij_betw_def by auto
  thus "h \<in> G \<cong> H"
    unfolding iso_def by auto
qed

lemma group_isoI[intro]:
  assumes G: "group G"
      and H: "group H"
      and inj1: "\<forall>x\<in>carrier G. h x = \<one>\<^bsub>H\<^esub> \<longrightarrow> x = \<one>\<^bsub>G\<^esub>"
      and surj: "h ` (carrier G) = carrier H"
      and hom: "\<forall>x\<in>carrier G. \<forall>y\<in>carrier G. h (x \<otimes>\<^bsub>G\<^esub> y) = h x \<otimes>\<^bsub>H\<^esub> h y"
  shows "h \<in> G \<cong> H"
proof-
  from surj
  have "h \<in> carrier G \<rightarrow> carrier H"
    by auto
  then interpret group_hom G H h using G and H and hom
    by (auto intro!: group_hom.intro group_hom_axioms.intro)
  show ?thesis
  using assms unfolding hom_def by (auto intro: group_hom_isoI)
qed
end


section \<open>Weak and Strong Duality of Linear Programming\<close>

theory LP_Duality
  imports
    Linear_Inequalities.Farkas_Lemma
    Minimum_Maximum
begin

lemma weak_duality_theorem:
  fixes A :: "'a :: linordered_comm_semiring_strict mat"
  assumes A: "A \<in> carrier_mat nr nc"
    and b: "b \<in> carrier_vec nr"
    and c: "c \<in> carrier_vec nc"
    and x: "x \<in> carrier_vec nc"
    and Axb: "A *\<^sub>v x \<le> b"
    and y0: "y \<ge> 0\<^sub>v nr"
    and yA: "A\<^sup>T *\<^sub>v y = c"
  shows "c \<bullet> x \<le> b \<bullet> y"
proof -
  from y0 have y: "y \<in> carrier_vec nr" unfolding less_eq_vec_def by auto
  have "c \<bullet> x = (A\<^sup>T *\<^sub>v y) \<bullet> x" unfolding yA by simp
  also have "\<dots> = y \<bullet> (A *\<^sub>v x)" using x y A by (metis transpose_vec_mult_scalar)
  also have "\<dots> \<le> y \<bullet> b"
    unfolding scalar_prod_def using A b Axb y0
    by (auto intro!: sum_mono mult_left_mono simp: less_eq_vec_def)
  also have "\<dots> = b \<bullet> y" using y b by (metis comm_scalar_prod)
  finally show ?thesis .
qed

corollary unbounded_primal_solutions:
  fixes A :: "'a :: linordered_idom mat"
  assumes A: "A \<in> carrier_mat nr nc"
    and b: "b \<in> carrier_vec nr"
    and c: "c \<in> carrier_vec nc"
    and unbounded: "\<forall> v. \<exists> x \<in> carrier_vec nc. A *\<^sub>v x \<le> b \<and> c \<bullet> x \<ge> v"
  shows "\<not> (\<exists> y. y \<ge> 0\<^sub>v nr \<and> A\<^sup>T *\<^sub>v y = c)"
proof
  assume "(\<exists> y. y \<ge> 0\<^sub>v nr \<and> A\<^sup>T *\<^sub>v y = c)"
  then obtain y where y: "y \<ge> 0\<^sub>v nr" and Ayc: "A\<^sup>T *\<^sub>v y = c"
    by auto
  from unbounded[rule_format, of "b \<bullet> y + 1"]
  obtain x where x: "x \<in> carrier_vec nc" and Axb: "A *\<^sub>v x \<le> b"
    and le: "b \<bullet> y + 1 \<le> c \<bullet> x" by auto
  from weak_duality_theorem[OF A b c x Axb y Ayc]
  have "c \<bullet> x \<le> b \<bullet> y" by auto
  with le show False by  auto
qed

corollary unbounded_dual_solutions:
  fixes A :: "'a :: linordered_idom mat"
  assumes A: "A \<in> carrier_mat nr nc"
    and b: "b \<in> carrier_vec nr"
    and c: "c \<in> carrier_vec nc"
    and unbounded: "\<forall> v. \<exists> y. y \<ge> 0\<^sub>v nr \<and> A\<^sup>T *\<^sub>v y = c \<and> b \<bullet> y \<le> v"
  shows "\<not> (\<exists> x \<in> carrier_vec nc. A *\<^sub>v x \<le> b)"
proof
  assume "\<exists> x \<in> carrier_vec nc. A *\<^sub>v x \<le> b"
  then obtain x where x: "x \<in> carrier_vec nc" and Axb: "A *\<^sub>v x \<le> b" by auto
  from unbounded[rule_format, of "c \<bullet> x - 1"]
  obtain y where y: "y\<ge>0\<^sub>v nr" and Ayc: "A\<^sup>T *\<^sub>v y = c" and le: "b \<bullet> y \<le> c \<bullet> x - 1" by auto
  from weak_duality_theorem[OF A b c x Axb y Ayc]
  have "c \<bullet> x \<le> b \<bullet> y" by auto
  with le show False by auto
qed

text \<open>A version of the strong duality theorem which demands
  that both primal and dual problem are solvable. At this point
  we do not use min- or max-operations\<close>
theorem strong_duality_theorem_both_sat:
  fixes A :: "'a :: trivial_conjugatable_linordered_field mat"
  assumes A: "A \<in> carrier_mat nr nc"
    and b: "b \<in> carrier_vec nr"
    and c: "c \<in> carrier_vec nc"
    and primal: "\<exists> x \<in> carrier_vec nc. A *\<^sub>v x \<le> b"
    and dual: "\<exists> y. y \<ge> 0\<^sub>v nr \<and> A\<^sup>T *\<^sub>v y = c"
  shows "\<exists> x y.
       x \<in> carrier_vec nc \<and> A *\<^sub>v x \<le> b \<and>
       y \<ge> 0\<^sub>v nr \<and> A\<^sup>T *\<^sub>v y = c \<and>
       c \<bullet> x = b \<bullet> y"
proof -
  define M_up where "M_up = four_block_mat A (0\<^sub>m nr nr) (mat_of_row (- c)) (mat_of_row b)"
  define M_low where "M_low = four_block_mat (0\<^sub>m nc nc) (A\<^sup>T) (0\<^sub>m nc nc) (- (A\<^sup>T))"
  define M_last where "M_last = append_cols (0\<^sub>m nr nc) (- 1\<^sub>m nr :: 'a mat)"
  define M where "M = (M_up  @\<^sub>r M_low) @\<^sub>r M_last"
  define bc where "bc = ((b @\<^sub>v 0\<^sub>v 1) @\<^sub>v (c @\<^sub>v -c)) @\<^sub>v (0\<^sub>v nr)"
    (* M = ( A   0) bc = (  b)
           (-c   b)      (  0)
           ( 0  At)      (  c)
           ( 0 -At)      ( -c)
           ( 0  -I)      (  0) *)
  let ?nr = "((nr + 1) + (nc + nc)) + nr"
  let ?nc = "nc + nr"
  have M_up: "M_up \<in> carrier_mat (nr + 1) ?nc"
    unfolding M_up_def using A b c by auto
  have M_low: "M_low \<in> carrier_mat (nc + nc) ?nc"
    unfolding M_low_def using A by auto
  have M_last: "M_last \<in> carrier_mat nr ?nc"
    unfolding M_last_def by auto
  have M: "M \<in> carrier_mat ?nr ?nc"
    using carrier_append_rows[OF carrier_append_rows[OF M_up M_low] M_last]
    unfolding M_def by auto
  have bc: "bc \<in> carrier_vec ?nr" unfolding bc_def
    by (intro append_carrier_vec, insert b c, auto)
  have "(\<exists>xy. xy \<in> carrier_vec ?nc \<and> M *\<^sub>v xy \<le> bc)"
  proof (subst gram_schmidt.Farkas_Lemma'[OF M bc], intro allI impI, elim conjE)
    fix ulv
    assume ulv0: "0\<^sub>v ?nr \<le> ulv" and Mulv: "M\<^sup>T *\<^sub>v ulv = 0\<^sub>v ?nc"
    from ulv0[unfolded less_eq_vec_def]
    have ulv: "ulv \<in> carrier_vec ?nr" by auto
    define u1 where "u1 = vec_first ulv ((nr + 1) + (nc + nc))"
    define u2 where "u2 = vec_first u1 (nr + 1)"
    define u3 where "u3 = vec_last u1 (nc + nc)"
    define t where "t = vec_last ulv nr"
    have ulvid: "ulv = u1 @\<^sub>v t" using ulv
      unfolding u1_def t_def by auto
    have t: "t \<in> carrier_vec nr" unfolding t_def by auto
    have u1: "u1 \<in> carrier_vec ((nr + 1) + (nc + nc))"
      unfolding u1_def by auto
    have u1id: "u1 = u2 @\<^sub>v u3" using u1
      unfolding u2_def u3_def by auto
    have u2: "u2 \<in> carrier_vec (nr + 1)" unfolding u2_def by auto
    have u3: "u3 \<in> carrier_vec (nc + nc)" unfolding u3_def by auto
    define v where "v = vec_first u3 nc"
    define w where "w = vec_last u3 nc"
    have u3id: "u3 = v @\<^sub>v w" using u3
      unfolding v_def w_def by auto
    have v: "v \<in> carrier_vec nc" unfolding v_def by auto
    have w: "w \<in> carrier_vec nc" unfolding w_def by auto

    define u where "u = vec_first u2 nr"
    define L where "L = vec_last u2 1"
    have u2id: "u2 = u @\<^sub>v L" using u2
      unfolding u_def L_def by auto
    have u: "u \<in> carrier_vec nr" unfolding u_def by auto
    have L: "L \<in> carrier_vec 1" unfolding L_def by auto
    define vec1 where "vec1 = A\<^sup>T *\<^sub>v u + mat_of_col (- c) *\<^sub>v L"
    have vec1: "vec1 \<in> carrier_vec nc"
      unfolding vec1_def mat_of_col_def using A u c L
      by (meson add_carrier_vec mat_of_row_carrier(1) mult_mat_vec_carrier transpose_carrier_mat uminus_carrier_vec)
    define vec2 where "vec2 = A *\<^sub>v (v - w)"
    have vec2: "vec2 \<in> carrier_vec nr"
      unfolding vec2_def using A v w by auto
    define vec3 where "vec3 = mat_of_col b *\<^sub>v L"
    have vec3: "vec3 \<in> carrier_vec nr"
      using A b L unfolding mat_of_col_def vec3_def
      by (meson add_carrier_vec mat_of_row_carrier(1) mult_mat_vec_carrier transpose_carrier_mat uminus_carrier_vec)
    have Mt: "M\<^sup>T = (M_up\<^sup>T @\<^sub>c M_low\<^sup>T) @\<^sub>c M_last\<^sup>T"
      unfolding M_def append_cols_def by simp
    have "M\<^sup>T *\<^sub>v ulv = (M_up\<^sup>T @\<^sub>c M_low\<^sup>T) *\<^sub>v u1 + M_last\<^sup>T *\<^sub>v t"
      unfolding Mt ulvid
      by (subst mat_mult_append_cols[OF carrier_append_cols _ u1 t],
          insert M_up M_low M_last, auto)
    also have "M_last\<^sup>T = 0\<^sub>m nc nr @\<^sub>r - 1\<^sub>m nr" unfolding M_last_def
      unfolding append_cols_def by (simp, subst transpose_uminus, auto)
    also have "\<dots> *\<^sub>v t = 0\<^sub>v nc @\<^sub>v - t"
      by (subst mat_mult_append[OF _ _ t], insert t, auto)
    also have "(M_up\<^sup>T @\<^sub>c M_low\<^sup>T) *\<^sub>v u1 = (M_up\<^sup>T *\<^sub>v u2) + (M_low\<^sup>T *\<^sub>v u3)"
      unfolding u1id
      by (rule mat_mult_append_cols[OF _ _ u2 u3], insert M_up M_low, auto)
    also have "M_low\<^sup>T = four_block_mat (0\<^sub>m nc nc) (0\<^sub>m nc nc) A (- A)"
      unfolding M_low_def
      by (subst transpose_four_block_mat, insert A, auto)
    also have "\<dots> *\<^sub>v u3 = (0\<^sub>m nc nc *\<^sub>v v + 0\<^sub>m nc nc *\<^sub>v w) @\<^sub>v (A *\<^sub>v v + - A *\<^sub>v w)" unfolding u3id
      by (subst four_block_mat_mult_vec[OF _ _ A _ v w], insert A, auto)
    also have "0\<^sub>m nc nc *\<^sub>v v + 0\<^sub>m nc nc *\<^sub>v w = 0\<^sub>v nc"
      using v w by auto
    also have "A *\<^sub>v v + - A *\<^sub>v w = vec2" unfolding vec2_def using A v w
      by (metis (full_types) carrier_matD(2) carrier_vecD minus_add_uminus_vec mult_mat_vec_carrier mult_minus_distrib_mat_vec uminus_mult_mat_vec)
    also have "M_up\<^sup>T  = four_block_mat A\<^sup>T (mat_of_col (- c)) (0\<^sub>m nr nr) (mat_of_col b)"
      unfolding M_up_def mat_of_col_def
      by (subst transpose_four_block_mat[OF A], insert b c, auto)
    also have "\<dots> *\<^sub>v u2 = vec1 @\<^sub>v vec3"
      unfolding u2id vec1_def vec3_def
      by (subst four_block_mat_mult_vec[OF _ _ _ _ u L], insert A b c u, auto)
    also have "(vec1 @\<^sub>v vec3)
      + (0\<^sub>v nc @\<^sub>v vec2) + (0\<^sub>v nc @\<^sub>v - t) =
      (vec1 @\<^sub>v (vec3 + vec2 - t))"
      apply (subst append_vec_add[of _ nc _ _ nr, OF vec1 _ vec3 vec2])
      subgoal by force
      apply (subst append_vec_add[of _ nc _ _ nr])
      subgoal using vec1 by auto
      subgoal by auto
      subgoal using vec2 vec3 by auto
      subgoal using t by auto
      subgoal using vec1 by auto
      done
    finally have "vec1 @\<^sub>v (vec3 + vec2 - t) = 0\<^sub>v ?nc"
      unfolding Mulv by simp
    also have "\<dots> = 0\<^sub>v nc @\<^sub>v 0\<^sub>v nr" by auto
    finally have "vec1 = 0\<^sub>v nc \<and> vec3 + vec2 - t = 0\<^sub>v nr"
      by (subst (asm) append_vec_eq[OF vec1], auto)
    hence 01: "vec1 = 0\<^sub>v nc" and 02: "vec3 + vec2 - t = 0\<^sub>v nr" by auto
    from 01 have "vec1 + mat_of_col c *\<^sub>v L = mat_of_col c *\<^sub>v L"
      using c L vec1 unfolding mat_of_col_def  by auto
    also have "vec1 + mat_of_col c *\<^sub>v L = A\<^sup>T *\<^sub>v u"
      unfolding vec1_def
      using A u c L unfolding mat_of_col_def mat_of_row_uminus transpose_uminus
      by (subst uminus_mult_mat_vec, auto)
    finally have As: "A\<^sup>T *\<^sub>v u = mat_of_col c *\<^sub>v L" .
    from 02 have "(vec3 + vec2 - t) + t = 0\<^sub>v nr + t"
      by simp
    also have "(vec3 + vec2 - t) + t = vec2 + vec3"
      using vec3 vec2 t by auto
    finally have t23: "t = vec2 + vec3" using t by auto
    have id0: "0\<^sub>v ?nr = ((0\<^sub>v nr @\<^sub>v 0\<^sub>v 1) @\<^sub>v (0\<^sub>v nc @\<^sub>v 0\<^sub>v nc)) @\<^sub>v 0\<^sub>v nr"
      by auto
    from ulv0[unfolded id0 ulvid u1id u2id u3id]
    have "0\<^sub>v nr \<le> u \<and> 0\<^sub>v 1 \<le> L \<and> 0\<^sub>v nc \<le> v \<and> 0\<^sub>v nc \<le> w \<and> 0\<^sub>v nr \<le> t"
      apply (subst (asm) append_vec_le[of _ "(nr + 1) + (nc + nc)"])
      subgoal by (intro append_carrier_vec, auto)
      subgoal by (intro append_carrier_vec u L v w)
      apply (subst (asm) append_vec_le[of _ "(nr + 1)"])
      subgoal by (intro append_carrier_vec, auto)
      subgoal by (intro append_carrier_vec u L v w)
      apply (subst (asm) append_vec_le[OF _ u], force)
      apply (subst (asm) append_vec_le[OF _ v], force)
      by auto
    hence ineqs: "0\<^sub>v nr \<le> u" "0\<^sub>v 1 \<le> L" "0\<^sub>v nc \<le> v" "0\<^sub>v nc \<le> w" "0\<^sub>v nr \<le> t"
      by auto
    have "ulv \<bullet> bc = u \<bullet> b + (v \<bullet> c + w \<bullet> (-c))"
      unfolding ulvid u1id u2id u3id bc_def
      apply (subst scalar_prod_append[OF _ t])
         apply (rule append_carrier_vec[OF append_carrier_vec[OF u L] append_carrier_vec[OF v w]])
        apply (rule append_carrier_vec[OF append_carrier_vec[OF b] append_carrier_vec]; use c in force)
       apply force
      apply (subst scalar_prod_append)
          apply (rule append_carrier_vec[OF u L])
         apply (rule append_carrier_vec[OF v w])
      subgoal by (rule append_carrier_vec, insert b, auto)
      subgoal by (rule append_carrier_vec, insert c, auto)
      apply (subst scalar_prod_append[OF u L b], force)
      apply (subst scalar_prod_append[OF v w c], use c in force)
      apply (insert L t, auto)
      done
    also have "v \<bullet> c + w \<bullet> (-c) = c \<bullet> v + (-c) \<bullet> w"
      by (subst (1 2) comm_scalar_prod, insert w c v, auto)
    also have "\<dots> = c \<bullet> v - (c \<bullet> w)" using c w by simp
    also have "\<dots> = c \<bullet> (v - w)" using c v w
      by (simp add: scalar_prod_minus_distrib)
    finally have ulvbc: "ulv \<bullet> bc = u \<bullet> b + c \<bullet> (v - w)" .
    define lam where "lam = L $ 0"
    from ineqs(2) L have lam0: "lam \<ge> 0" unfolding less_eq_vec_def lam_def by auto
    have As: "A\<^sup>T *\<^sub>v u = lam \<cdot>\<^sub>v c" unfolding As using c L
      unfolding lam_def mat_of_col_def
      by (intro eq_vecI, auto simp: scalar_prod_def)
    have vec3: "vec3 = lam \<cdot>\<^sub>v b" unfolding vec3_def using b L
      unfolding lam_def mat_of_col_def
      by (intro eq_vecI, auto simp: scalar_prod_def)
    note preconds = lam0 ineqs(1,3-)[unfolded t23[unfolded vec2_def vec3]] As
    have "0 \<le> u \<bullet> b + c \<bullet> (v - w)"
    proof (cases "lam > 0")
      case True
      hence "u \<bullet> b = inverse lam * (lam * (b \<bullet> u))"
        using comm_scalar_prod[OF b u] by simp
      also have "\<dots> = inverse lam * ((lam \<cdot>\<^sub>v b) \<bullet> u)"
        using b u by simp
      also have "\<dots> \<ge> inverse lam * (-(A *\<^sub>v (v - w)) \<bullet> u)"
      proof (intro mult_left_mono)
        show "0 \<le> inverse lam" using preconds by auto
        show "-(A *\<^sub>v (v - w)) \<bullet> u \<le> (lam \<cdot>\<^sub>v b) \<bullet> u"
          unfolding scalar_prod_def
          apply (rule sum_mono)
          subgoal for i
            using lesseq_vecD[OF _ preconds(2), of nr i] lesseq_vecD[OF _ preconds(5), of nr i] u v w b A
            by (intro mult_right_mono, auto)
          done
      qed
      also have "inverse lam * (-(A *\<^sub>v (v - w)) \<bullet> u) =
         - (inverse lam * ((A *\<^sub>v (v - w)) \<bullet> u))"
        by (subst scalar_prod_uminus_left, insert A u v w, auto)
      also have "(A *\<^sub>v (v - w)) \<bullet> u = (A\<^sup>T *\<^sub>v u) \<bullet> (v - w)"
        apply (subst transpose_vec_mult_scalar[OF A _ u])
        subgoal using v w by force
        by (rule comm_scalar_prod[OF _ u], insert A v w, auto)
      also have "inverse lam * \<dots> = c \<bullet> (v - w)" unfolding preconds(6)
        using True
        by (subst scalar_prod_smult_left, insert c v w, auto)
      finally show ?thesis by simp
    next
      case False
      with preconds have lam: "lam = 0" by auto
      from primal obtain x0 where x0: "x0 \<in> carrier_vec nc"
        and Ax0b: "A *\<^sub>v x0 \<le> b" by auto
      from dual obtain y0 where y00: "y0 \<ge> 0\<^sub>v nr"
        and Ay0c: "A\<^sup>T *\<^sub>v y0 = c" by auto
      from y00 have y0: "y0 \<in> carrier_vec nr"
        unfolding less_eq_vec_def by auto
      have Au: "A\<^sup>T *\<^sub>v u = 0\<^sub>v nc"
        unfolding preconds lam using c by auto
      have "0 = (A\<^sup>T *\<^sub>v u) \<bullet> x0" unfolding Au using x0 by auto
      also have "\<dots> = u \<bullet> (A *\<^sub>v x0)"
        by (rule transpose_vec_mult_scalar[OF A x0 u])
      also have "\<dots> \<le> u \<bullet> b"
        unfolding scalar_prod_def
        apply (use A x0 b in simp)
        apply (intro sum_mono)
        subgoal for i
          using lesseq_vecD[OF _ preconds(2), of nr i] lesseq_vecD[OF _ Ax0b, of nr i] u v w b A x0
          by (intro mult_left_mono, auto)
        done
      finally have ub: "0 \<le> u \<bullet> b" .
      have "c \<bullet> (v - w) = (A\<^sup>T *\<^sub>v y0) \<bullet> (v - w)" unfolding Ay0c by simp
      also have "\<dots> = y0 \<bullet> (A *\<^sub>v (v - w))"
        by (subst transpose_vec_mult_scalar[OF A _ y0], insert v w, auto)
      also have "\<dots> \<ge> 0"
        unfolding scalar_prod_def
        apply (use A v w in simp)
        apply (intro sum_nonneg)
        subgoal for i
          using lesseq_vecD[OF _ y00, of nr i] lesseq_vecD[OF _ preconds(5)[unfolded lam], of nr i] A y0 v w b
          by (intro mult_nonneg_nonneg, auto)
        done
      finally show ?thesis using ub by auto
    qed
    thus "0 \<le> ulv \<bullet> bc" unfolding ulvbc .
  qed
  then obtain xy where xy: "xy \<in> carrier_vec ?nc" and le: "M *\<^sub>v xy \<le> bc" by auto
  define x where "x = vec_first xy nc"
  define y where "y = vec_last xy nr"
  have xyid: "xy = x @\<^sub>v y" using xy
    unfolding x_def y_def by auto
  have x: "x \<in> carrier_vec nc" unfolding x_def by auto
  have y: "y \<in> carrier_vec nr" unfolding y_def by auto
  have At: "A\<^sup>T \<in> carrier_mat nc nr" using A by auto
  have Ax1: "A *\<^sub>v x @\<^sub>v vec 1 (\<lambda>_. b \<bullet> y - c \<bullet> x) \<in> carrier_vec (nr + 1)"
    using A x by fastforce
  have b0cc: "(b @\<^sub>v 0\<^sub>v 1) @\<^sub>v c @\<^sub>v - c \<in> carrier_vec ((nr + 1) + (nc + nc))"
    using b c
    by (intro append_carrier_vec, auto)
  have "M *\<^sub>v xy = (M_up *\<^sub>v xy @\<^sub>v M_low *\<^sub>v xy) @\<^sub>v (M_last *\<^sub>v xy)"
    unfolding M_def
    unfolding mat_mult_append[OF carrier_append_rows[OF M_up M_low] M_last xy]
    by (simp add: mat_mult_append[OF M_up M_low xy])
  also have "M_low *\<^sub>v xy = (0\<^sub>m nc nc *\<^sub>v x + A\<^sup>T *\<^sub>v y) @\<^sub>v (0\<^sub>m nc nc *\<^sub>v x + - A\<^sup>T *\<^sub>v y)"
    unfolding M_low_def xyid
    by (rule four_block_mat_mult_vec[OF _ At _ _ x y], insert A, auto)
  also have "0\<^sub>m nc nc *\<^sub>v x + A\<^sup>T *\<^sub>v y = A\<^sup>T *\<^sub>v y" using A x y by auto
  also have "0\<^sub>m nc nc *\<^sub>v x + - A\<^sup>T *\<^sub>v y = - A\<^sup>T *\<^sub>v y" using A x y by auto
  also have "M_up *\<^sub>v xy = (A *\<^sub>v x + 0\<^sub>m nr nr *\<^sub>v y) @\<^sub>v
               (mat_of_row (- c) *\<^sub>v x + mat_of_row b *\<^sub>v y)"
    unfolding M_up_def xyid
    by (rule four_block_mat_mult_vec[OF A _ _ _ x y], insert b c, auto)
  also have "A *\<^sub>v x + 0\<^sub>m nr nr *\<^sub>v y = A *\<^sub>v x" using A x y by auto
  also have "mat_of_row (- c) *\<^sub>v x + mat_of_row b *\<^sub>v y =
    vec 1 (\<lambda> _. b \<bullet> y - c \<bullet> x)"
    unfolding mult_mat_vec_def using c x by (intro eq_vecI, auto)
  also have "M_last *\<^sub>v xy = - y"
    unfolding M_last_def xyid using x y
    by (subst mat_mult_append_cols[OF _ _ x y], auto)
  finally have "((A *\<^sub>v x @\<^sub>v vec 1 (\<lambda>_. b \<bullet> y - c \<bullet> x)) @\<^sub>v (A\<^sup>T *\<^sub>v y @\<^sub>v - A\<^sup>T *\<^sub>v y)) @\<^sub>v -y
    = M *\<^sub>v xy" ..
  also have "\<dots> \<le> bc" by fact
  also have "\<dots> = ((b @\<^sub>v 0\<^sub>v 1) @\<^sub>v (c @\<^sub>v -c)) @\<^sub>v 0\<^sub>v nr" unfolding bc_def by auto
  finally have ineqs: "A *\<^sub>v x \<le> b \<and> vec 1 (\<lambda>_. b \<bullet> y - c \<bullet> x) \<le> 0\<^sub>v 1
             \<and> A\<^sup>T *\<^sub>v y \<le> c \<and> - A\<^sup>T *\<^sub>v y \<le> -c \<and> -y \<le> 0\<^sub>v nr"
    apply (subst (asm) append_vec_le[OF _ b0cc])
    subgoal using A x y by (intro append_carrier_vec, auto)
    apply (subst (asm) append_vec_le[OF Ax1], use b in fastforce)
    apply (subst (asm) append_vec_le[OF _ b], use A x in force)
    apply (subst (asm) append_vec_le[OF _ c], use A y in force)
    by auto
  show ?thesis
  proof (intro exI conjI)
    from ineqs show Axb: "A *\<^sub>v x \<le> b" by auto
    from ineqs have "- A\<^sup>T *\<^sub>v y \<le> -c" "A\<^sup>T *\<^sub>v y \<le> c" by auto
    hence "A\<^sup>T *\<^sub>v y \<ge> c" "A\<^sup>T *\<^sub>v y \<le> c" unfolding less_eq_vec_def using A y by auto
    then show Aty: "A\<^sup>T *\<^sub>v y = c" by simp
    from ineqs have "- y \<le> 0\<^sub>v nr" by simp
    then show y0: "0\<^sub>v nr \<le> y" unfolding less_eq_vec_def by auto
    from ineqs have "b \<bullet> y \<le> c \<bullet> x" unfolding less_eq_vec_def by auto
    with weak_duality_theorem[OF A b c x Axb y0 Aty]
    show "c \<bullet> x = b \<bullet> y" by auto
  qed (insert x)
qed

text \<open>A version of the strong duality theorem which demands
  that the primal problem is solvable and the objective function
  is bounded.\<close>
theorem strong_duality_theorem_primal_sat_bounded:
  fixes bound :: "'a :: trivial_conjugatable_linordered_field"
  assumes A: "A \<in> carrier_mat nr nc"
    and b: "b \<in> carrier_vec nr"
    and c: "c \<in> carrier_vec nc"
    and sat: "\<exists> x \<in> carrier_vec nc. A *\<^sub>v x \<le> b"
    and bounded: "\<forall> x \<in> carrier_vec nc. A *\<^sub>v x \<le> b \<longrightarrow> c \<bullet> x \<le> bound"
  shows "\<exists> x y.
       x \<in> carrier_vec nc \<and> A *\<^sub>v x \<le> b \<and>
       y \<ge> 0\<^sub>v nr \<and> A\<^sup>T *\<^sub>v y = c \<and>
       c \<bullet> x = b \<bullet> y"
proof (rule strong_duality_theorem_both_sat[OF A b c sat])
  show "\<exists>y\<ge>0\<^sub>v nr. A\<^sup>T *\<^sub>v y = c"
  proof (rule ccontr)
    assume "\<not> ?thesis"
    hence "\<exists>y. y \<in> carrier_vec nc \<and> 0\<^sub>v nr \<le> A *\<^sub>v y \<and> 0 > y \<bullet> c"
      by (subst (asm) gram_schmidt.Farkas_Lemma[OF _ c], insert A, auto)
    then obtain y where y: "y \<in> carrier_vec nc"
      and Ay0: "A *\<^sub>v y \<ge> 0\<^sub>v nr" and yc0: "y \<bullet> c < 0" by auto
    from sat obtain x where x: "x \<in> carrier_vec nc"
      and Axb: "A *\<^sub>v x \<le> b" by auto
    define diff where "diff = bound + 1 - c \<bullet> x"
    from x Axb bounded have "c \<bullet> x < bound + 1" by auto
    hence diff: "diff > 0" unfolding diff_def by auto
    from yc0 have inv: "inverse (- (y \<bullet> c)) > 0" by auto
    define fact where "fact = diff * (inverse (- (y \<bullet> c)))"
    have fact: "fact > 0" unfolding fact_def using diff inv by (metis mult_pos_pos)
    define z where "z = x - fact \<cdot>\<^sub>v y"
    have "A *\<^sub>v z = A *\<^sub>v x - A *\<^sub>v (fact \<cdot>\<^sub>v y)"
      unfolding z_def using A x y by (meson mult_minus_distrib_mat_vec smult_carrier_vec)
    also have "\<dots> = A *\<^sub>v x - fact \<cdot>\<^sub>v (A *\<^sub>v y)" using A y by auto
    also have "\<dots> \<le> b"
    proof (intro lesseq_vecI[OF _ b])
      show "A *\<^sub>v x - fact \<cdot>\<^sub>v (A *\<^sub>v y) \<in> carrier_vec nr" using A x y by auto
      fix i
      assume i: "i < nr"
      have "(A *\<^sub>v x - fact \<cdot>\<^sub>v (A *\<^sub>v y)) $ i
        = (A *\<^sub>v x) $ i - fact * (A *\<^sub>v y) $ i"
        using i A x y by auto
      also have "\<dots> \<le> b $ i - fact * (A *\<^sub>v y) $ i"
        using lesseq_vecD[OF b Axb i] by auto
      also have "\<dots> \<le> b $ i - 0 * 0" using lesseq_vecD[OF _ Ay0 i] fact A y i
        by (intro diff_left_mono mult_monom, auto)
      finally show "(A *\<^sub>v x - fact \<cdot>\<^sub>v (A *\<^sub>v y)) $ i \<le> b $ i" by simp
    qed
    finally have Azb: "A *\<^sub>v z \<le> b" .
    have z: "z \<in> carrier_vec nc" using x y unfolding z_def by auto
    have "c \<bullet> z = c \<bullet> x - fact * (c \<bullet> y)" unfolding z_def
      using c x y by (simp add: scalar_prod_minus_distrib)
    also have "\<dots> = c \<bullet> x + diff"
      unfolding comm_scalar_prod[OF c y] fact_def using yc0 by simp
    also have "\<dots> = bound + 1" unfolding diff_def by simp
    also have "\<dots> > c \<bullet> z" using bounded Azb z by auto
    finally show False by simp
  qed
qed

text \<open>A version of the strong duality theorem which demands
  that the dual problem is solvable and the objective function
  is bounded.\<close>
theorem strong_duality_theorem_dual_sat_bounded:
  fixes bound :: "'a :: trivial_conjugatable_linordered_field"
  assumes A: "A \<in> carrier_mat nr nc"
    and b: "b \<in> carrier_vec nr"
    and c: "c \<in> carrier_vec nc"
    and sat: "\<exists> y. y \<ge> 0\<^sub>v nr \<and> A\<^sup>T *\<^sub>v y = c"
    and bounded: "\<forall> y. y \<ge> 0\<^sub>v nr \<and> A\<^sup>T *\<^sub>v y = c \<longrightarrow> bound \<le> b \<bullet> y"
  shows "\<exists> x y.
       x \<in> carrier_vec nc \<and> A *\<^sub>v x \<le> b \<and>
       y \<ge> 0\<^sub>v nr \<and> A\<^sup>T *\<^sub>v y = c \<and>
       c \<bullet> x = b \<bullet> y"
proof (rule strong_duality_theorem_both_sat[OF A b c _ sat])
  show "\<exists>x\<in>carrier_vec nc. A *\<^sub>v x \<le> b"
  proof (rule ccontr)
    assume "\<not> ?thesis"
    hence "\<not> (\<exists>x. x \<in> carrier_vec nc \<and> A *\<^sub>v x \<le> b)" by auto
    then obtain y where y0: "y \<ge> 0\<^sub>v nr" and Ay0: "A\<^sup>T *\<^sub>v y = 0\<^sub>v nc" and yb: "y \<bullet> b < 0"
      by (subst (asm) gram_schmidt.Farkas_Lemma'[OF A b], auto)
    from sat obtain x where x0: "x \<ge> 0\<^sub>v nr" and Axc: "A\<^sup>T *\<^sub>v x = c" by auto
    define diff where "diff = b \<bullet> x - (bound - 1)"
    from x0 Axc bounded have "bound \<le> b \<bullet> x" by auto
    hence diff: "diff > 0" unfolding diff_def by auto
    define fact where "fact = - inverse (y \<bullet> b) * diff"
    have fact: "fact > 0" unfolding fact_def using diff yb by (auto intro: mult_neg_pos)
    define z where "z = x + fact \<cdot>\<^sub>v y"
    from x0 have x: "x \<in> carrier_vec nr"
      unfolding less_eq_vec_def by auto
    from y0 have y: "y \<in> carrier_vec nr"
      unfolding less_eq_vec_def by auto
    have "A\<^sup>T *\<^sub>v z = A\<^sup>T *\<^sub>v x + A\<^sup>T *\<^sub>v (fact \<cdot>\<^sub>v y)"
      unfolding z_def using A x y by (simp add: mult_add_distrib_mat_vec)
    also have "\<dots> = A\<^sup>T *\<^sub>v x + fact \<cdot>\<^sub>v (A\<^sup>T *\<^sub>v y)" using A y by auto
    also have "\<dots> = c" unfolding Ay0 Axc using c by auto
    finally have Azc: "A\<^sup>T *\<^sub>v z = c" .
    have z0: "z \<ge> 0\<^sub>v nr" unfolding z_def
      by (intro lesseq_vecI[of _ nr], insert x y lesseq_vecD[OF _ x0, of nr] lesseq_vecD[OF _ y0, of nr] fact,
          auto intro!: add_nonneg_nonneg)
    from bounded Azc z0 have bz: "bound \<le> b \<bullet> z" by auto
    also have "\<dots> = b \<bullet> x + fact * (b \<bullet> y)" unfolding z_def using b x y
      by (simp add: scalar_prod_add_distrib)
    also have "\<dots> = diff + (bound - 1) + fact * (b \<bullet> y)"
      unfolding diff_def by auto
    also have "fact * (b \<bullet> y) = - diff" using yb
      unfolding fact_def comm_scalar_prod[OF y b] by auto
    finally show False by simp
  qed
qed

text \<open>Now the previous three duality theorems are formulated via min/max.\<close>
corollary strong_duality_theorem_min_max:
  fixes A :: "'a :: trivial_conjugatable_linordered_field mat"
  assumes A: "A \<in> carrier_mat nr nc"
    and b: "b \<in> carrier_vec nr"
    and c: "c \<in> carrier_vec nc"
    and primal: "\<exists> x \<in> carrier_vec nc. A *\<^sub>v x \<le> b"
    and dual: "\<exists> y. y \<ge> 0\<^sub>v nr \<and> A\<^sup>T *\<^sub>v y = c"
  shows "Maximum {c \<bullet> x | x. x \<in> carrier_vec nc \<and> A *\<^sub>v x \<le> b}
       = Minimum {b \<bullet> y | y. y \<ge> 0\<^sub>v nr \<and> A\<^sup>T *\<^sub>v y = c}"
    and "has_Maximum {c \<bullet> x | x. x \<in> carrier_vec nc \<and> A *\<^sub>v x \<le> b}"
    and "has_Minimum {b \<bullet> y | y. y \<ge> 0\<^sub>v nr \<and> A\<^sup>T *\<^sub>v y = c}"
proof -
  let ?Prim = "{c \<bullet> x | x. x \<in> carrier_vec nc \<and> A *\<^sub>v x \<le> b}"
  let ?Dual = "{b \<bullet> y | y. y \<ge> 0\<^sub>v nr \<and> A\<^sup>T *\<^sub>v y = c}"
  define Prim where "Prim = ?Prim"
  define Dual where "Dual = ?Dual"
  from strong_duality_theorem_both_sat[OF assms]
  obtain x y where x: "x \<in> carrier_vec nc" and Axb: "A *\<^sub>v x \<le> b"
    and y: "y \<ge> 0\<^sub>v nr" and Ayc: "A\<^sup>T *\<^sub>v y = c"
    and eq: "c \<bullet> x = b \<bullet> y" by auto
  have cxP: "c \<bullet> x \<in> Prim" unfolding Prim_def using x Axb by auto
  have cxD: "c \<bullet> x \<in> Dual" unfolding eq Dual_def using y Ayc by auto
  {
    fix z
    assume "z \<in> Prim"
    from this[unfolded Prim_def] obtain x' where x': "x' \<in> carrier_vec nc"
      and Axb': "A *\<^sub>v x' \<le> b" and z: "z = c \<bullet> x'" by auto
    from weak_duality_theorem[OF A b c x' Axb' y Ayc, folded eq]
    have "z \<le> c \<bullet> x" unfolding z .
  } note cxMax = this
  have max: "Maximum Prim = c \<bullet> x"
    by (intro eqMaximumI cxP cxMax)
  show "has_Maximum ?Prim"
    unfolding Prim_def[symmetric] has_Maximum_def using cxP cxMax by auto
  {
    fix z
    assume "z \<in> Dual"
    from this[unfolded Dual_def] obtain y' where y': "y' \<ge> 0\<^sub>v nr"
      and Ayc': "A\<^sup>T *\<^sub>v y' = c" and z: "z = b \<bullet> y'" by auto
    from weak_duality_theorem[OF A b c x Axb y' Ayc', folded z]
    have "c \<bullet> x \<le> z" .
  } note cxMin = this
  show "has_Minimum ?Dual"
    unfolding Dual_def[symmetric] has_Minimum_def using cxD cxMin by auto
  have min: "Minimum Dual = c \<bullet> x"
    by (intro eqMinimumI cxD cxMin)
  from min max show "Maximum ?Prim = Minimum ?Dual"
    unfolding Dual_def Prim_def by auto
qed

corollary strong_duality_theorem_primal_sat_bounded_min_max:
  fixes bound :: "'a :: trivial_conjugatable_linordered_field"
  assumes A: "A \<in> carrier_mat nr nc"
    and b: "b \<in> carrier_vec nr"
    and c: "c \<in> carrier_vec nc"
    and sat: "\<exists> x \<in> carrier_vec nc. A *\<^sub>v x \<le> b"
    and bounded: "\<forall> x \<in> carrier_vec nc. A *\<^sub>v x \<le> b \<longrightarrow> c \<bullet> x \<le> bound"
  shows "Maximum {c \<bullet> x | x. x \<in> carrier_vec nc \<and> A *\<^sub>v x \<le> b}
       = Minimum {b \<bullet> y | y. y \<ge> 0\<^sub>v nr \<and> A\<^sup>T *\<^sub>v y = c}"
    and "has_Maximum {c \<bullet> x | x. x \<in> carrier_vec nc \<and> A *\<^sub>v x \<le> b}"
    and "has_Minimum {b \<bullet> y | y. y \<ge> 0\<^sub>v nr \<and> A\<^sup>T *\<^sub>v y = c}"
proof -
  let ?Prim = "{c \<bullet> x | x. x \<in> carrier_vec nc \<and> A *\<^sub>v x \<le> b}"
  let ?Dual = "{b \<bullet> y | y. y \<ge> 0\<^sub>v nr \<and> A\<^sup>T *\<^sub>v y = c}"
  from strong_duality_theorem_primal_sat_bounded[OF assms]
  have "\<exists>y\<ge>0\<^sub>v nr. A\<^sup>T *\<^sub>v y = c" by blast
  from strong_duality_theorem_min_max[OF A b c sat this]
  show "Maximum ?Prim = Minimum ?Dual" "has_Maximum ?Prim"  "has_Minimum ?Dual"
    by blast+
qed

corollary strong_duality_theorem_dual_sat_bounded_min_max:
  fixes bound :: "'a :: trivial_conjugatable_linordered_field"
  assumes A: "A \<in> carrier_mat nr nc"
    and b: "b \<in> carrier_vec nr"
    and c: "c \<in> carrier_vec nc"
    and sat: "\<exists> y. y \<ge> 0\<^sub>v nr \<and> A\<^sup>T *\<^sub>v y = c"
    and bounded: "\<forall> y. y \<ge> 0\<^sub>v nr \<and> A\<^sup>T *\<^sub>v y = c \<longrightarrow> bound \<le> b \<bullet> y"
  shows "Maximum {c \<bullet> x | x. x \<in> carrier_vec nc \<and> A *\<^sub>v x \<le> b}
       = Minimum {b \<bullet> y | y. y \<ge> 0\<^sub>v nr \<and> A\<^sup>T *\<^sub>v y = c}"
    and "has_Maximum {c \<bullet> x | x. x \<in> carrier_vec nc \<and> A *\<^sub>v x \<le> b}"
    and "has_Minimum {b \<bullet> y | y. y \<ge> 0\<^sub>v nr \<and> A\<^sup>T *\<^sub>v y = c}"
proof -
  let ?Prim = "{c \<bullet> x | x. x \<in> carrier_vec nc \<and> A *\<^sub>v x \<le> b}"
  let ?Dual = "{b \<bullet> y | y. y \<ge> 0\<^sub>v nr \<and> A\<^sup>T *\<^sub>v y = c}"
  from strong_duality_theorem_dual_sat_bounded[OF assms]
  have "\<exists> x \<in> carrier_vec nc. A *\<^sub>v x \<le> b" by blast
  from strong_duality_theorem_min_max[OF A b c this sat]
  show "Maximum ?Prim = Minimum ?Dual" "has_Maximum ?Prim"  "has_Minimum ?Dual"
    by blast+
qed

end


theory Concrete
imports Main

begin

fun add :: "nat \<Rightarrow> nat \<Rightarrow> nat" where
"add 0 n = n" |
"add (Suc m) n = Suc(add m n)"

theorem add_02[simp]: "add m 0 = m"
  apply(induction m)
  apply(auto)
  done

theorem add_associative[simp]: "add (add x y) z = add x (add y z)"
  apply(induction x)
  apply(auto)
  done

lemma add_comm_sub[simp]: "Suc (add y x) = add y (Suc x)"
  apply(induction y)
  apply(auto)
  done

theorem add_commutative: "add x y = add y x"
  apply(induction x)
  apply(auto)
  done

fun double :: "nat \<Rightarrow> nat" where
"double x = 2 * x"

theorem double_two_additions: "double x = add x x"
  apply(induction x)
  apply(auto)
  done

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

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

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

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

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

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

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

value "1 + (2::nat)"

value "1 + (2::int)"

value "1 -(2::nat)"

value "1 - (2::int)"

fun count :: "'a \<Rightarrow> 'a list \<Rightarrow> nat" where
"count _ Nil = 0" |
"count e (Cons x xs) = 1 + count e xs"

theorem count_lte_length: "count x xs \<le> length xs"
  apply(induction xs)
  apply(auto)
  done

fun snoc :: "'a list \<Rightarrow> 'a \<Rightarrow> 'a list" where
"snoc [] e = [e]" |
"snoc (Cons x xs) e = (Cons x (snoc xs e))"

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

theorem snoc_prepend[simp]: "reverse_snoc (snoc xs a) = a # (reverse_snoc xs)"
  apply(induction xs)
  apply(auto)
  done

theorem rev_rev_snoc: "reverse_snoc (reverse_snoc xs) = xs"
  apply(induction xs)
   apply(auto)
  done

fun sum_upto :: "nat \<Rightarrow> nat" where
"sum_upto 0 = 0" |
"sum_upto x = x + (sum_upto (x - 1))"

theorem sum_formula: "sum_upto n = n * (n + 1) div 2"
  apply(induction n)
   apply(auto)
  done

datatype 'a tree = Tip | Node "'a tree" 'a "'a tree"

fun contents :: "'a tree \<Rightarrow> 'a list" where
"contents Tip = []" |
"contents (Node l v r) = append (contents l) (v # (contents r))"

fun sum_tree :: "nat tree \<Rightarrow> nat" where
"sum_tree Tip = 0" |
"sum_tree (Node l v r) = sum_tree l + v + sum_tree r"

theorem sum_tree_works: "sum_tree t = sum_list (contents t)"
  apply(induction t)
   apply(auto)
  done

value "sum_list [1,2,(3::nat)]"

fun mirror :: "'a tree \<Rightarrow> 'a tree" where
"mirror Tip = Tip" |
"mirror (Node l a r) = Node (mirror r) a (mirror l)"

lemma "mirror(mirror t) = t"
  apply(induction t)
   apply(auto)
  done

fun pre_order :: "'a tree \<Rightarrow> 'a list" where
"pre_order Tip = []" |
"pre_order (Node l a r) = (a # (pre_order l)) @ (pre_order r)"

fun post_order :: "'a tree \<Rightarrow> 'a list" where
"post_order Tip = []" |
"post_order (Node l a r) = (post_order l) @ (post_order r) @ [a]"

fun mirror_2 :: "'a tree \<Rightarrow> 'a tree" where
  "mirror_2 Tip = Tip" |
  "mirror_2 (Node l a r) = Node (mirror_2 r) a (mirror_2 l)"

fun pre_order_2 :: "'a tree \<Rightarrow> 'a list" where
  "pre_order_2 Tip = []" |
  "pre_order_2 (Node l a r) = a # (pre_order_2 l @ pre_order_2 r)"

fun post_order_2 :: "'a tree \<Rightarrow> 'a list" where
  "post_order_2 Tip = []" |
  "post_order_2 (Node l a r) = (post_order_2 l) @ (post_order_2 r) @ [a]"

lemma reversing_stuff: "pre_order (mirror t) = rev (post_order t)"
  apply(induction t)
   apply(auto)
  done

(* 3 *)
(* |-- 4 *)
(* |--  *)

value "rev (post_order ((Node (Node Tip 4 Tip) 3 (Node Tip 7 Tip)) ::nat tree))"
value "pre_order (mirror (Node (Node Tip 4 Tip) 3 (Node Tip 7 Tip))::nat tree)"

value "pre_order (
(Node
  (Node Tip 1 Tip)
  2
  (Node Tip 3 Tip)) :: nat tree)"

value "post_order (
(Node
  (Node Tip 1 Tip)
  2
  (Node Tip 3 Tip)) :: nat tree)"

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

theorem interspersing: "map f (intersperse a xs) = intersperse (f a) (map f xs)"
  apply(induction xs)
   apply(auto)
  done

(* 2 *)
value "Suc(Suc Zero)"
(* 3 *)
value "Suc(Suc (Suc Zero))"

fun my_add :: "nat \<Rightarrow> nat \<Rightarrow> nat" where
"my_add 0 n = n" |
"my_add (Suc m) n = Suc(add m n)"

fun itadd :: "nat \<Rightarrow> nat \<Rightarrow> nat" where
"itadd 0 n = n" |
"itadd (Suc m) n = itadd m (Suc n)"

theorem tail_rec_add: "itadd m n = add m n"
  apply(induction m arbitrary: n)
   apply(auto)
  done

value "intersperse 5 [1,2,3::nat]"

datatype tree0 = Tip | Node "tree0" "tree0"

fun nodes :: "tree0 \<Rightarrow> nat" where
"nodes Tip = 0" |
"nodes (Node l r) = 1 + (nodes l) + (nodes r)"

fun explode :: "nat \<Rightarrow> tree0 \<Rightarrow> tree0" where
"explode 0 t = t" |
"explode (Suc n) t = explode n (Node t t)"

(*
  explode 1 t
   explode 0 (Node t t)

  explode 2 t
    explode 1 (Node t t)
     explode 0 (Node (Node t t) (Node t t))

  explode 3 t
    explode 2 (Node t t)
      explode 1 (Node (Node t t) (Node t t))
        explode 0 (Node (Node (Node t t) (Node t t)) (Node (Node t t) (Node t t)))
*)

value "nodes (Node (Node Tip Tip) (Node Tip Tip))"

value "nodes (explode 4  (Node (Node Tip Tip) (Node Tip Tip)))"

value "explode 0 Tip"

(* by nitpick *)
(* by quickcheck *)
theorem "nodes (explode n t) = (2 ^ n) * (nodes t) + 2^n - 1"
  apply(induction n arbitrary: t)
   apply(auto simp add: algebra_simps)
  done

end


theory Chapter4
imports "HOL-IMP.ASM" Main
begin

inductive star :: "('a \<Rightarrow> 'a \<Rightarrow> bool) \<Rightarrow> 'a \<Rightarrow> 'a \<Rightarrow> bool"  for r where
refl:  "star r x x" |
step:  "r x y \<Longrightarrow> star r y z \<Longrightarrow> star r x z"

(*
\section*{Chapter 4}

\exercise
Start from the data type of binary trees defined earlier:
*)

datatype 'a tree = Tip | Node "'a tree" 'a "'a tree"

(*
An @{typ "int tree"} is ordered if for every @{term "Node l i r"} in the tree,
@{text l} and @{text r} are ordered
and all values in @{text l} are @{text "< i"}
and all values in @{text r} are @{text "> i"}.
Define a function that returns the elements in a tree and one
the tests if a tree is ordered:
*)

fun set :: "'a tree \<Rightarrow> 'a set"  where
  "set Tip = {}"
| "set (Node lt x rt) = (set lt) \<union> {x} \<union> (set rt)"

definition temp :: "int set" where
  "temp = {1,2,3}"

value "{x. x \<in> temp}"
value "(\<forall>y \<in> temp. y \<ge> 2) = False "

fun ord :: "int tree \<Rightarrow> bool"  where
  "ord Tip = True"
| "ord (Node lt x rt) = (\<forall>y \<in> (set lt). y \<ge> x) "

(* Hint: use quantifiers.

Define a function @{text ins} that inserts an element into an ordered @{typ "int tree"}
while maintaining the order of the tree. If the element is already in the tree, the
same tree should be returned.
*)

fun ins :: "int \<Rightarrow> int tree \<Rightarrow> int tree" where
  "ins x Tip = Node Tip x Tip"
| "ins x (Node lt y rt) =
   (if x < y
    then (Node (ins x lt) y rt)
    else (if x = y then (Node lt y rt)
                   else (Node lt y (ins x rt))))"

theorem ins : "set (ins x t) = {x} \<union> set t"
  apply(induction t arbitrary : x)
   apply(auto)
  done

lemma "\<forall>x. \<exists>y. x=y"
  apply(auto)
  done

lemma "A \<subseteq> B \<inter> C \<Longrightarrow> A \<subseteq> B \<union> C"
  by auto  (* is short for apply proof-method done*)

(* fastforce example*)
lemma "(\<forall> xs \<in> A. \<exists> ys. (xs = ys @ ys)) \<Longrightarrow> us \<in> A \<Longrightarrow> \<exists> n. length us = n + n "
  apply fastforce
  done

thm Suc_leD
lemma "Suc (Suc (Suc a)) \<le> b \<Longrightarrow> a \<le> b"
  apply(rule Suc_leD)
  apply(rule Suc_leD)
  apply(rule Suc_leD)
  apply auto
  done

inductive ev :: "nat \<Rightarrow> bool" where
  ev0:  "ev 0"
| evSS: "ev n \<Longrightarrow> ev (n + 2)"

(*
theorem ord_ins: "ord t \<Longrightarrow> ord(ins i t)"
(* your definition/proof here *)
*)
(*
\endexercise

\exercise
Formalize the following definition of palindromes
\begin{itemize}
\item The empty list and a singleton list are palindromes.
\item If @{text xs} is a palindrome, so is @{term "a # xs @ [a]"}.
\end{itemize}
as an inductive predicate
*)

(*
inductive palindrome :: "'a list \<Rightarrow> bool" where
(* your definition/proof here *)

(* and prove *)

lemma "palindrome xs \<Longrightarrow> rev xs = xs"
(* your definition/proof here *)
*)

(*
We could also have defined @{const star} as follows:
*)

inductive star' :: "('a \<Rightarrow> 'a \<Rightarrow> bool) \<Rightarrow> 'a \<Rightarrow> 'a \<Rightarrow> bool" for r where
refl': "star' r x x" |
step': "star' r x y \<Longrightarrow> r y z \<Longrightarrow> star' r x z"

(*
The single @{text r} step is performer after rather than before the @{text star'}
steps. Prove
*)

lemma "star' r x y \<Longrightarrow> star r x y"

lemma "star r x y \<Longrightarrow> star' r x y"
(* your definition/proof here *)

(*
You may need lemmas. Note that rule induction fails
if the assumption about the inductive predicate
is not the first assumption.
exe:iter
Analogous to @{const star}, give an inductive definition of the @{text n}-fold iteration
of a relation @{text r}: @{term "iter r n x y"} should hold if there are @{text x\<^sub>0}, \dots, @{text x\<^sub>n}
such that @{prop"x = x\<^sub>0"}, @{prop"x\<^sub>n = y"} and @{text"r x\<^bsub>i\<^esub> x\<^bsub>i+1\<^esub>"} for
all @{prop"i < n"}:
*)

inductive iter :: "('a \<Rightarrow> 'a \<Rightarrow> bool) \<Rightarrow> nat \<Rightarrow> 'a \<Rightarrow> 'a \<Rightarrow> bool" for r where
(* your definition/proof here *)

(*
Correct and prove the following claim:
*)

lemma "star r x y \<Longrightarrow> iter r n x y"
(* your definition/proof here *)

(*
\endexercise

\exercise\label{exe:cfg}
A context-free grammar can be seen as an inductive definition where each
nonterminal $A$ is an inductively defined predicate on lists of terminal
symbols: $A(w)$ mans that $w$ is in the language generated by $A$.
For example, the production $S \to aSb$ can be viewed as the implication
@{prop"S w \<Longrightarrow> S (a # w @ [b])"} where @{text a} and @{text b} are terminal symbols,
i.e., elements of some alphabet. The alphabet can be defined as a datatype:
*)

datatype alpha = a | b

(*
If you think of @{const a} and @{const b} as ``@{text "("}'' and  ``@{text ")"}'',
the following two grammars both generate strings of balanced parentheses
(where $\varepsilon$ is the empty word):
\[
\begin{array}{r@ {\quad}c@ {\quad}l}
S &\to& \varepsilon \quad\mid\quad aSb \quad\mid\quad SS \\
T &\to& \varepsilon \quad\mid\quad TaTb
\end{array}
\]
Define them as inductive predicates and prove their equivalence:
*)

inductive S :: "alpha list \<Rightarrow> bool" where
(* your definition/proof here *)

inductive T :: "alpha list \<Rightarrow> bool" where
(* your definition/proof here *)

lemma TS: "T w \<Longrightarrow> S w"
(* your definition/proof here *)

lemma ST: "S w \<Longrightarrow> T w"
(* your definition/proof here *)

corollary SeqT: "S w \<longleftrightarrow> T w"
(* your definition/proof here *)

(*
\endexercise
*)
(* your definition/proof here *)
(*
\exercise
In Chapter 3 we defined a recursive evaluation function
@{text "aval ::"} @{typ "aexp \<Rightarrow> state \<Rightarrow> val"}.
Define an inductive evaluation predicate and prove that it agrees with
the recursive function:
*)

inductive aval_rel :: "aexp \<Rightarrow> state \<Rightarrow> val \<Rightarrow> bool" where
(* your definition/proof here *)

lemma aval_rel_aval: "aval_rel a s v \<Longrightarrow> aval a s = v"
(* your definition/proof here *)

lemma aval_aval_rel: "aval a s = v \<Longrightarrow> aval_rel a s v"
(* your definition/proof here *)

corollary "aval_rel a s v \<longleftrightarrow> aval a s = v"
(* your definition/proof here *)

(*
\endexercise

\exercise
Consider the stack machine from Chapter~3
and recall the concept of \concept{stack underflow}
from Exercise~\ref{exe:stack-underflow}.
Define an inductive predicate
*)

inductive ok :: "nat \<Rightarrow> instr list \<Rightarrow> nat \<Rightarrow> bool" where
(* your definition/proof here *)

(*
such that @{text "ok n is n'"} means that with any initial stack of length
@{text n} the instructions @{text "is"} can be executed
without stack underflow and that the final stack has length @{text n'}.

Using the introduction rules for @{const ok},
prove the following special cases: *}

lemma "ok 0 [LOAD x] (Suc 0)"
(* your definition/proof here *)

lemma "ok 0 [LOAD x, LOADI v, ADD] (Suc 0)"
(* your definition/proof here *)

lemma "ok (Suc (Suc 0)) [LOAD x, ADD, ADD, LOAD y] (Suc (Suc 0))"
(* your definition/proof here *)

text {* Prove that @{text ok} correctly computes the final stack size: *}

lemma "\<lbrakk>ok n is n'; length stk = n\<rbrakk> \<Longrightarrow> length (exec is s stk) = n'"
(* your definition/proof here *)

text {*
Lemma @{thm [source] length_Suc_conv} may come in handy.

Prove that instruction sequences generated by @{text comp}
cannot cause stack underflow: \ @{text "ok n (comp a) ?"} \ for
some suitable value of @{text "?"}.
\endexercise
*)

end


(*  Title:      HOL/Isar_Examples/Group.thy
    Author:     Makarius
*)

section \<open>Basic group theory\<close>

theory Group
  imports Main
begin

subsection \<open>Groups and calculational reasoning\<close>

text \<open>
  Groups over signature \<open>(* :: \<alpha> \<Rightarrow> \<alpha> \<Rightarrow> \<alpha>, 1 :: \<alpha>, inverse :: \<alpha> \<Rightarrow> \<alpha>)\<close> are
  defined as an axiomatic type class as follows. Note that the parent class
  \<open>times\<close> is provided by the basic HOL theory.
\<close>

class group = times + one + inverse +
  assumes group_assoc: "(x * y) * z = x * (y * z)"
    and group_left_one: "1 * x = x"
    and group_left_inverse: "inverse x * x = 1"

text \<open>
  The group axioms only state the properties of left one and inverse, the
  right versions may be derived as follows.
\<close>

theorem (in group) group_right_inverse: "x * inverse x = 1"
proof -
  have "x * inverse x = 1 * (x * inverse x)"
    by (simp only: group_left_one)
  also have "\<dots> = 1 * x * inverse x"
    by (simp only: group_assoc)
  also have "\<dots> = inverse (inverse x) * inverse x * x * inverse x"
    by (simp only: group_left_inverse)
  also have "\<dots> = inverse (inverse x) * (inverse x * x) * inverse x"
    by (simp only: group_assoc)
  also have "\<dots> = inverse (inverse x) * 1 * inverse x"
    by (simp only: group_left_inverse)
  also have "\<dots> = inverse (inverse x) * (1 * inverse x)"
    by (simp only: group_assoc)
  also have "\<dots> = inverse (inverse x) * inverse x"
    by (simp only: group_left_one)
  also have "\<dots> = 1"
    by (simp only: group_left_inverse)
  finally show ?thesis .
qed

text \<open>
  With \<open>group_right_inverse\<close> already available, \<open>group_right_one\<close>
  is now established much easier.
\<close>

theorem (in group) group_right_one: "x * 1 = x"
proof -
  have "x * 1 = x * (inverse x * x)"
    by (simp only: group_left_inverse)
  also have "\<dots> = x * inverse x * x"
    by (simp only: group_assoc)
  also have "\<dots> = 1 * x"
    by (simp only: group_right_inverse)
  also have "\<dots> = x"
    by (simp only: group_left_one)
  finally show ?thesis .
qed

text \<open>
  \<^medskip>
  The calculational proof style above follows typical presentations given in
  any introductory course on algebra. The basic technique is to form a
  transitive chain of equations, which in turn are established by simplifying
  with appropriate rules. The low-level logical details of equational
  reasoning are left implicit.

  Note that ``\<open>\<dots>\<close>'' is just a special term variable that is bound
  automatically to the argument\<^footnote>\<open>The argument of a curried infix expression
  happens to be its right-hand side.\<close> of the last fact achieved by any local
  assumption or proven statement. In contrast to \<open>?thesis\<close>, the ``\<open>\<dots>\<close>''
  variable is bound \<^emph>\<open>after\<close> the proof is finished.

  There are only two separate Isar language elements for calculational proofs:
  ``\<^theory_text>\<open>also\<close>'' for initial or intermediate calculational steps, and
  ``\<^theory_text>\<open>finally\<close>'' for exhibiting the result of a calculation. These constructs
  are not hardwired into Isabelle/Isar, but defined on top of the basic
  Isar/VM interpreter. Expanding the \<^theory_text>\<open>also\<close> and \<^theory_text>\<open>finally\<close> derived language
  elements, calculations may be simulated by hand as demonstrated below.
\<close>

theorem (in group) "x * 1 = x"
proof -
  have "x * 1 = x * (inverse x * x)"
    by (simp only: group_left_inverse)

  note calculation = this
    \<comment> \<open>first calculational step: init calculation register\<close>

  have "\<dots> = x * inverse x * x"
    by (simp only: group_assoc)

  note calculation = trans [OF calculation this]
    \<comment> \<open>general calculational step: compose with transitivity rule\<close>

  have "\<dots> = 1 * x"
    by (simp only: group_right_inverse)

  note calculation = trans [OF calculation this]
    \<comment> \<open>general calculational step: compose with transitivity rule\<close>

  have "\<dots> = x"
    by (simp only: group_left_one)

  note calculation = trans [OF calculation this]
    \<comment> \<open>final calculational step: compose with transitivity rule \dots\<close>
  from calculation
    \<comment> \<open>\dots\ and pick up the final result\<close>

  show ?thesis .
qed

text \<open>
  Note that this scheme of calculations is not restricted to plain
  transitivity. Rules like anti-symmetry, or even forward and backward
  substitution work as well. For the actual implementation of \<^theory_text>\<open>also\<close> and
  \<^theory_text>\<open>finally\<close>, Isabelle/Isar maintains separate context information of
  ``transitivity'' rules. Rule selection takes place automatically by
  higher-order unification.
\<close>

subsection \<open>Groups as monoids\<close>

text \<open>
  Monoids over signature \<open>(* :: \<alpha> \<Rightarrow> \<alpha> \<Rightarrow> \<alpha>, 1 :: \<alpha>)\<close> are defined like this.
\<close>

class monoid = times + one +
  assumes monoid_assoc: "(x * y) * z = x * (y * z)"
    and monoid_left_one: "1 * x = x"
    and monoid_right_one: "x * 1 = x"

text \<open>
  Groups are \<^emph>\<open>not\<close> yet monoids directly from the definition. For monoids,
  \<open>right_one\<close> had to be included as an axiom, but for groups both \<open>right_one\<close>
  and \<open>right_inverse\<close> are derivable from the other axioms. With
  \<open>group_right_one\<close> derived as a theorem of group theory (see @{thm
  group_right_one}), we may still instantiate \<open>group \<subseteq> monoid\<close> properly as
  follows.
\<close>

instance group \<subseteq> monoid
  by intro_classes
    (rule group_assoc,
      rule group_left_one,
      rule group_right_one)

text \<open>
  The \<^theory_text>\<open>instance\<close> command actually is a version of \<^theory_text>\<open>theorem\<close>, setting up a
  goal that reflects the intended class relation (or type constructor arity).
  Thus any Isar proof language element may be involved to establish this
  statement. When concluding the proof, the result is transformed into the
  intended type signature extension behind the scenes.
\<close>

subsection \<open>More theorems of group theory\<close>

text \<open>
  The one element is already uniquely determined by preserving an \<^emph>\<open>arbitrary\<close>
  group element.
\<close>

theorem (in group) group_one_equality:
  assumes eq: "e * x = x"
  shows "1 = e"
proof -
  have "1 = x * inverse x"
    by (simp only: group_right_inverse)
  also have "\<dots> = (e * x) * inverse x"
    by (simp only: eq)
  also have "\<dots> = e * (x * inverse x)"
    by (simp only: group_assoc)
  also have "\<dots> = e * 1"
    by (simp only: group_right_inverse)
  also have "\<dots> = e"
    by (simp only: group_right_one)
  finally show ?thesis .
qed

text \<open>
  Likewise, the inverse is already determined by the cancel property.
\<close>

theorem (in group) group_inverse_equality:
  assumes eq: "x' * x = 1"
  shows "inverse x = x'"
proof -
  have "inverse x = 1 * inverse x"
    by (simp only: group_left_one)
  also have "\<dots> = (x' * x) * inverse x"
    by (simp only: eq)
  also have "\<dots> = x' * (x * inverse x)"
    by (simp only: group_assoc)
  also have "\<dots> = x' * 1"
    by (simp only: group_right_inverse)
  also have "\<dots> = x'"
    by (simp only: group_right_one)
  finally show ?thesis .
qed

text \<open>
  The inverse operation has some further characteristic properties.
\<close>

theorem (in group) group_inverse_times: "inverse (x * y) = inverse y * inverse x"
proof (rule group_inverse_equality)
  show "(inverse y * inverse x) * (x * y) = 1"
  proof -
    have "(inverse y * inverse x) * (x * y) =
        (inverse y * (inverse x * x)) * y"
      by (simp only: group_assoc)
    also have "\<dots> = (inverse y * 1) * y"
      by (simp only: group_left_inverse)
    also have "\<dots> = inverse y * y"
      by (simp only: group_right_one)
    also have "\<dots> = 1"
      by (simp only: group_left_inverse)
    finally show ?thesis .
  qed
qed

theorem (in group) inverse_inverse: "inverse (inverse x) = x"
proof (rule group_inverse_equality)
  show "x * inverse x = one"
    by (simp only: group_right_inverse)
qed

theorem (in group) inverse_inject:
  assumes eq: "inverse x = inverse y"
  shows "x = y"
proof -
  have "x = x * 1"
    by (simp only: group_right_one)
  also have "\<dots> = x * (inverse y * y)"
    by (simp only: group_left_inverse)
  also have "\<dots> = x * (inverse x * y)"
    by (simp only: eq)
  also have "\<dots> = (x * inverse x) * y"
    by (simp only: group_assoc)
  also have "\<dots> = 1 * y"
    by (simp only: group_right_inverse)
  also have "\<dots> = y"
    by (simp only: group_left_one)
  finally show ?thesis .
qed

end