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

section\<open>Miscellaneous file for the QR algorithm\<close>

theory Miscellaneous_QR
imports
 Gauss_Jordan.Examples_Gauss_Jordan_Abstract
begin

text\<open>These two lemmas maybe should be in the file \<open>Code_Matrix.thy\<close> of the Gauss-Jordan
  development.\<close>

lemma [code abstract]: "vec_nth (a - b) =  (%i. a$i - b$i)" by (metis vector_minus_component)
lemma [code abstract]: "vec_nth (c *\<^sub>R x) = (\<lambda>i. c *\<^sub>R (x$i))" by auto

text\<open>This lemma maybe should be in the file \<open>Mod_Type.thy\<close> of the Gauss-Jordan
  development.\<close>

lemma from_nat_le:
  fixes i::"'a::{mod_type}"
  assumes i: "to_nat i< k"
  and k: "k<CARD('a)"
  shows "i < from_nat k"
  by (metis (full_types) from_nat_mono from_nat_to_nat_id i k)

text\<open>Some properties about orthogonal matrices.\<close>

lemma orthogonal_mult:
  assumes "orthogonal a b"
  shows "orthogonal (x *\<^sub>R a) (y *\<^sub>R b)"
  using assms unfolding orthogonal_def by simp

lemma orthogonal_matrix_is_orthogonal:
  fixes A::"real^'n^'n"
  assumes o: "orthogonal_matrix A"
  shows "(pairwise orthogonal (columns A))"
proof (unfold pairwise_def columns_def, auto)
  fix i j
  assume column_i_not_j: "column i A \<noteq> column j A"
  hence i_not_j: "i \<noteq> j" by auto
  have "0 = (mat 1) $ i $ j" by (metis i_not_j mat_1_fun)
  also have "... = (transpose A ** A) $ i $ j" using o unfolding orthogonal_matrix by simp
  also have "... = row i (transpose A) \<bullet> column j A" unfolding matrix_matrix_mult_inner_mult by simp
  also have "... = column i A \<bullet> column j A" unfolding row_transpose ..
  finally show "orthogonal (column i A) (column j A)" unfolding orthogonal_def ..
qed

lemma orthogonal_matrix_norm:
  fixes A::"real^'n^'n"
  assumes o: "orthogonal_matrix A"
  shows "norm (column i A) = 1"
proof -
  have "1 = (transpose A ** A) $ i $ i" using o unfolding orthogonal_matrix by (simp add: mat_1_fun)
  also have "... = (column i A) \<bullet> (column i A)" unfolding matrix_matrix_mult_inner_mult row_transpose ..
  finally show "norm (column i A) = 1" using norm_eq_1 by auto
qed

lemma orthogonal_matrix_card:
  fixes A::"real^'n^'n"
  assumes o: "orthogonal_matrix A"
  shows "card (columns A) = ncols A"
proof (rule ccontr)
  assume card_not_ncols: "card (columns A) \<noteq> ncols A"
  have "\<exists>i j. column i A = column j A \<and> i\<noteq>j"
  proof (rule ccontr, auto)
    assume col_eq: "\<forall>i j. column i A = column j A \<longrightarrow> i = j"
    have "card (columns A) = card {i. i \<in> (UNIV::'n set)}"
      by (rule bij_betw_same_card[symmetric, of "\<lambda>i. column i A"],
        auto simp add: bij_betw_def columns_def inj_on_def col_eq)
    also have "... = ncols A" unfolding ncols_def by simp
    finally show False using card_not_ncols by contradiction
  qed
  from this obtain i j where col_eq: "column i A = column j A" and i_not_j: "i \<noteq> j" by auto
  have "0 = (mat 1) $ i $ j" using mat_1_fun i_not_j by metis
  also have "... = (transpose A ** A) $ i $ j" using o unfolding orthogonal_matrix by simp
  also have "... = column i A \<bullet> column j A" unfolding matrix_matrix_mult_inner_mult row_transpose ..
  show False
    by (metis calculation col_eq mat_1_fun matrix_matrix_mult_inner_mult
      o orthogonal_matrix zero_neq_one)
qed

lemma orthogonal_matrix_intro:
  fixes A::"real^'n^'n"
  assumes p: "(pairwise orthogonal (columns A))"
  and n: "\<forall>i. norm (column i A) = 1"
  and c: "card (columns A) = ncols A" (*We need that premise to avoid the case that column i A = column j A when i \<noteq> j*)
  shows "orthogonal_matrix A"
proof (unfold orthogonal_matrix vec_eq_iff, clarify, unfold mat_1_fun, auto)
  fix ia
  have "(transpose A ** A) $ ia $ ia = column ia A \<bullet> column ia A"
    unfolding matrix_matrix_mult_inner_mult unfolding row_transpose ..
  also have "... = 1" using n norm_eq_1 by blast
  finally show "(transpose A ** A) $ ia $ ia = 1" .
  fix i
  assume i_not_ia: "i \<noteq> ia"
  have column_i_not_ia: "column i A \<noteq> column ia A"
  proof (rule ccontr, simp)
    assume col_i_ia: "column i A = column ia A"
    have rw: "(\<lambda>i. column i A)` (UNIV-{ia}) = {column i A|i. i\<noteq>ia}" unfolding columns_def by auto
    have "card (columns A) = card ({column i A|i. i\<noteq>ia})"
      by (rule bij_betw_same_card[of id], unfold bij_betw_def columns_def)
         (auto, metis col_i_ia i_not_ia)
    also have "... = card ((\<lambda>i. column i A)` (UNIV-{ia}))" unfolding rw ..
    also have "... \<le> card (UNIV - {ia})" by (metis card_image_le finite_code)
    also have "... < CARD ('n)" by simp
    finally show False using c unfolding ncols_def by simp
  qed
  hence oia: "orthogonal (column i A) (column ia A)"
    using p unfolding pairwise_def unfolding columns_def by auto
  have "(transpose A ** A) $ i $ ia = column i A \<bullet> column ia A"
    unfolding matrix_matrix_mult_inner_mult unfolding row_transpose ..
  also have "... = 0" using oia unfolding orthogonal_def .
  finally show "(transpose A ** A) $ i $ ia = 0" .
qed

lemma orthogonal_matrix2:
  fixes A::"real^'n^'n"
  shows "orthogonal_matrix A = ((pairwise orthogonal (columns A)) \<and> (\<forall>i. norm (column i A) = 1) \<and>
  (card (columns A) = ncols A))"
  using orthogonal_matrix_intro[of A]
    orthogonal_matrix_is_orthogonal[of A]
    orthogonal_matrix_norm[of A]
    orthogonal_matrix_card[of A]
  by auto

lemma orthogonal_matrix': "orthogonal_matrix (Q:: real ^'n^'n) \<longleftrightarrow>  Q ** transpose Q= mat 1"
  by (metis matrix_left_right_inverse orthogonal_matrix_def)

lemma orthogonal_matrix_intro2:
  fixes A::"real^'n^'n"
  assumes p: "(pairwise orthogonal (rows A))"
  and n: "\<forall>i. norm (row i A) = 1"
  and c: "card (rows A) = nrows A" (*We need that premise to avoid the case that row i A = row j A when i \<noteq> j*)
  shows "orthogonal_matrix A"
proof (unfold orthogonal_matrix' vec_eq_iff, clarify, unfold mat_1_fun, auto)
  fix ia
  have "(A ** transpose A) $ ia $ ia = row ia A \<bullet> row ia A"
    unfolding matrix_matrix_mult_inner_mult unfolding column_transpose ..
  also have "... = 1" using n norm_eq_1 by blast
  finally show "(A ** transpose A) $ ia $ ia = 1" .
  fix i
  assume i_not_ia: "i \<noteq> ia"
  have row_i_not_ia: "row i A \<noteq> row ia A"
  proof (rule ccontr, simp)
    assume row_i_ia:"row i A = row ia A"
    have rw: "(\<lambda>i. row i A)` (UNIV-{ia}) = {row i A|i. i\<noteq>ia}" unfolding rows_def by auto
    have "card (rows A) = card ({row i A|i. i\<noteq>ia})"
      by (rule bij_betw_same_card[of id], unfold bij_betw_def rows_def)
         (auto, metis row_i_ia i_not_ia)
    also have "... = card ((\<lambda>i. row i A)` (UNIV-{ia}))" unfolding rw ..
    also have "... \<le> card (UNIV - {ia})" by (metis card_image_le finite_code)
    also have "... < CARD ('n)" by simp
    finally show False using c unfolding nrows_def by simp
  qed
  hence oia: "orthogonal (row i A) (row ia A)"
    using p unfolding pairwise_def unfolding rows_def by auto
  have "(A ** transpose A) $ i $ ia = row i A \<bullet> row ia A"
    unfolding matrix_matrix_mult_inner_mult unfolding column_transpose ..
  also have "... = 0" using oia unfolding orthogonal_def .
  finally show "(A ** transpose A) $ i $ ia = 0" .
qed

lemma is_basis_imp_full_rank:
  fixes A::"'a::{field}^'cols::{mod_type}^'rows::{mod_type}"
  assumes b: "is_basis (columns A)"
  and c: "card (columns A) = ncols A"
  shows "rank A = ncols A"
proof -
  have "rank A = col_rank A" unfolding rank_col_rank ..
  also have "... = vec.dim (col_space A)" unfolding col_rank_def ..
  also have "... = card (columns A)"
    by (metis b col_space_def independent_is_basis vec.dim_eq_card_independent vec.dim_span)
  also have "... = ncols A" using c .
  finally show ?thesis .
qed

lemma card_columns_le_ncols:
  "card (columns A) \<le> ncols A"
proof -
  have columns_rw: "columns A = (\<lambda>i. column i A)` UNIV" unfolding columns_def by auto
  show ?thesis unfolding columns_rw ncols_def by (rule card_image_le, auto)
qed

lemma full_rank_imp_is_basis:
  fixes A::"'a::{field}^'n::{mod_type}^'n::{mod_type}"
  assumes r: "rank A = ncols A"
  shows "is_basis (columns A) \<and> card (columns A) = ncols A"
proof (rule conjI, unfold is_basis_def, rule conjI)
  have "rank A = col_rank A" unfolding rank_col_rank ..
  also have "... = vec.dim (col_space A)" unfolding col_rank_def ..
  also have "... = card (columns A)"
    by (metis (full_types) antisym_conv calculation card_columns_le_ncols col_space_def
        finite_columns r vec.dim_le_card vec.dim_span vec.span_superset)
  finally have *: "rank A = card (columns A)" .
  then show c_eq: "card (columns A) = ncols A" unfolding r ..
  show "vec.independent (columns A)"
    by (metis * vec.card_eq_dim_span_indep col_rank_def
      col_space_def finite_columns rank_col_rank)
  thus "vec.span (columns A) = (UNIV::('a^'n::{mod_type}) set)"
    using independent_is_basis[of "columns A"] c_eq unfolding is_basis_def ncols_def by simp
qed

lemma full_rank_imp_is_basis2:
  fixes A::"'a::{field}^'n::{mod_type}^'m::{mod_type}"
  assumes r: "rank A = ncols A"
  shows "vec.independent (columns A) \<and> vec.span (columns A) = col_space A
        \<and> card (columns A) = ncols A"
proof -
  have "rank A = col_rank A" unfolding rank_col_rank ..
  also have "... = vec.dim (col_space A)" unfolding col_rank_def ..
  also have "... = card (columns A)"
    by (metis (full_types) antisym_conv calculation card_columns_le_ncols col_space_def
        finite_columns r vec.dim_le_card vec.dim_span vec.span_superset)
  finally have *: "rank A = card (columns A)" .
  then have c_eq: "card (columns A) = ncols A" unfolding r ..
  moreover have "vec.independent (columns A)"
    by (metis * vec.card_eq_dim_span_indep
      col_rank_def col_space_def finite_columns rank_col_rank)
  moreover have "vec.span (columns A) = col_space A" by (metis col_space_def)
  ultimately show ?thesis by simp
qed

corollary full_rank_eq_is_basis:
  fixes A::"'a::{field}^'n::{mod_type}^'n::{mod_type}"
  shows "(is_basis (columns A) \<and> (card (columns A) = ncols A)) = (rank A = ncols A)"
  using full_rank_imp_is_basis is_basis_imp_full_rank by blast

lemma full_col_rank_imp_independent_columns:
  fixes A::"'a::{field}^'n::{mod_type}^'m::{mod_type}"
  assumes "rank A = ncols A"
  shows "vec.independent (columns A)"
  by (metis assms full_rank_imp_is_basis2)

lemma matrix_vector_right_distrib_minus:
  fixes A::"'a::{ring_1}^'n^'m"
  shows "A *v (b - c) = (A *v b) - (A *v c)"
proof -
  have "A *v (b - c) = A *v (b + - c)" by (metis diff_minus_eq_add minus_minus)
  also have "... = (A *v b) + (A *v (- c))" unfolding matrix_vector_right_distrib ..
  also have "... = (A *v b) - (A *v c)"
    by (metis (no_types, hide_lams) add.commute add_minus_cancel
        matrix_vector_right_distrib uminus_add_conv_diff)
  finally show ?thesis .
qed

lemma inv_matrix_vector_mul_left:
  assumes i: "invertible A"
  shows "(A *v x = A *v y) = (x=y)"
  by (metis i invertible_def matrix_vector_mul_assoc matrix_vector_mul_lid)

lemma norm_mult_vec:
  fixes a::"(real,'b::finite) vec"
  shows "norm (x \<bullet> x) = norm x * norm x"
  by (metis inner_real_def norm_cauchy_schwarz_eq norm_mult)

lemma norm_equivalence:
  fixes A::"real^'n^'m"
  shows "((transpose A) *v (A *v x) = 0) \<longleftrightarrow> (A *v x = 0)"
proof -
  have "A *v x = 0" if "transpose A *v (A *v x) = 0"
  proof -
    have eq: "(x v* (transpose A)) = (A *v x)"
      by (metis transpose_transpose transpose_vector)
    have eq_0: "0 = (x v* (transpose A)) * (A *v x)"
      by auto (metis that dot_lmul_matrix inner_eq_zero_iff inner_zero_left mult_not_zero transpose_vector)
    hence "0 = norm ((x v* (transpose A)) * (A *v x))" by auto
    also have "... = norm ((A *v x)*(A *v x))" unfolding eq ..
    also have "... = norm ((A *v x) \<bullet> (A *v x))"
      by (metis eq_0 that dot_lmul_matrix eq inner_zero_right norm_zero)
    also have "... = norm (A *v x)^2" unfolding norm_mult_vec[of "(A *v x)"] power2_eq_square ..
    finally show "A *v x = 0"
      by simp
  qed
  then show ?thesis
    by auto
qed

lemma invertible_transpose_mult:
  fixes A::"real^'cols::{mod_type}^'rows::{mod_type}"
  assumes r: "rank A = ncols A"
  shows "invertible (transpose A ** A)"
proof -
  have null_eq: "null_space A = null_space (transpose A ** A)"
  proof (auto)
    fix x assume x: "x \<in> null_space A"
    show "x \<in> null_space (transpose A ** A)" using x unfolding null_space_def
      by (metis (lifting, full_types) matrix_vector_mul_assoc matrix_vector_mult_0_right mem_Collect_eq)
  next
    fix x assume x: "x \<in> null_space (transpose A ** A)"
    show "x \<in> null_space A"
      by (metis is_solution_def matrix_vector_mul_assoc mem_Collect_eq
        norm_equivalence null_space_eq_solution_set solution_set_def x)
  qed
  have "rank A = vec.dim (UNIV::(real^'cols::{mod_type}) set) - vec.dim (null_space A)"
    using rank_nullity_theorem_matrices[of A]
    unfolding rank_eq_dim_col_space'[of A, symmetric]
    by (simp only: add.commute diff_add_inverse2 ncols_def vec_dim_card)
  also have "... = vec.dim (UNIV::(real^'cols::{mod_type}) set) - vec.dim (null_space (transpose A ** A))"
    unfolding null_eq ..
  also have "... = rank (transpose A ** A)"
    by (metis add.commute diff_add_inverse2 ncols_def rank_eq_dim_col_space
        rank_nullity_theorem_matrices vec_dim_card)
  finally have r_A: "rank A = rank (transpose A ** A)" .
  show ?thesis using full_rank_implies_invertible r unfolding ncols_def nrows_def r_A .
qed

lemma matrix_inv_mult:
  fixes A::"'a::{semiring_1}^'n^'n"
  and B::"'a::{semiring_1}^'n^'n"
  assumes "invertible A" and "invertible B"
  shows "matrix_inv (A ** B) = matrix_inv B ** matrix_inv A"
proof (rule matrix_inv_unique[of "A**B"])
  show "A ** B ** (matrix_inv B ** matrix_inv A) = mat 1"
    by (metis assms(1) assms(2) matrix_inv_right matrix_mul_assoc matrix_mul_lid)
  show " matrix_inv B ** matrix_inv A ** (A ** B) = mat 1"
    by (metis assms(1) assms(2) matrix_inv_left matrix_mul_assoc matrix_mul_lid)
qed

lemma invertible_transpose:
  fixes A::"'a::{field}^'n^'n"
  assumes "invertible A"
  shows "invertible (transpose A)"
  by (metis invertible_det_nz assms det_transpose)

text\<open>The following lemmas are generalizations of some parts of the library. They should be
  in the file \<open>Generalizations.thy\<close> of the Gauss-Jordan AFP entry.\<close>

context vector_space
begin
lemma span_eq: "(span S = span T) = (S \<subseteq> span T \<and> T \<subseteq> span S)"
  using span_superset[unfolded subset_eq] using span_mono[of T "span S"] span_mono[of S "span T"]
  by (auto simp add: span_span)
end

lemma basis_orthogonal:
  fixes B :: "'a::real_inner set"
  assumes fB: "finite B"
  shows "\<exists>C. finite C \<and> card C \<le> card B \<and> span C
        = span B \<and> pairwise orthogonal C"
  (is " \<exists>C. ?P B C")
  using fB
proof (induct rule: finite_induct)
  case empty
  then show ?case
    apply (rule exI[where x="{}"])
    apply (auto simp add: pairwise_def)
    done
next
  case (insert a B)
  note fB = \<open>finite B\<close> and aB = \<open>a \<notin> B\<close>
  from \<open>\<exists>C. finite C \<and> card C \<le> card B \<and> span C = span B \<and> pairwise orthogonal C\<close>
  obtain C where C: "finite C" "card C \<le> card B"
    "span C = span B" "pairwise orthogonal C" by blast
  let ?a = "a - sum (\<lambda>x. (x \<bullet> a / (x \<bullet> x)) *\<^sub>R x) C"
  let ?C = "insert ?a C"
  from C(1) have fC: "finite ?C"
    by simp
  from fB aB C(1,2) have cC: "card ?C \<le> card (insert a B)"
    by (simp add: card_insert_if)
  {
    fix x k
    have th0: "\<And>(a::'a) b c. a - (b - c) = c + (a - b)"
      by (simp add: field_simps)
    have "x - k *\<^sub>R (a - (\<Sum>x\<in>C. (x \<bullet> a / (x \<bullet> x)) *\<^sub>R x)) \<in> span C
      \<longleftrightarrow> x - k *\<^sub>R a \<in> span C"
      apply (simp only: scaleR_right_diff_distrib th0)
      apply (rule span_add_eq)
      apply (rule span_mul)
      apply (rule span_sum)
      apply (rule span_mul)
      apply (rule span_base)
      apply assumption
      done
  }
  then have SC: "span ?C = span (insert a B)"
    unfolding set_eq_iff span_breakdown_eq C(3)[symmetric] by auto
  {
    fix y
    assume yC: "y \<in> C"
    then have Cy: "C = insert y (C - {y})"
      by blast
    have fth: "finite (C - {y})"
      using C by simp
    have "orthogonal ?a y"
      unfolding orthogonal_def
      unfolding inner_diff inner_sum_left right_minus_eq
      unfolding sum.remove [OF \<open>finite C\<close> \<open>y \<in> C\<close>]
      apply (clarsimp simp add: inner_commute[of y a])
      apply (rule sum.neutral)
      apply clarsimp
      apply (rule C(4)[unfolded pairwise_def orthogonal_def, rule_format])
      using \<open>y \<in> C\<close> by auto
  }
  with \<open>pairwise orthogonal C\<close> have CPO: "pairwise orthogonal ?C"
    by (rule pairwise_orthogonal_insert)
  from fC cC SC CPO have "?P (insert a B) ?C"
    by blast
  then show ?case by blast
qed

lemma op_vec_scaleR: "(*s) = (*\<^sub>R)"
  by (force simp: scalar_mult_eq_scaleR)

end


theory Conf
imports Store
begin

section \<open>Configurations, Subsumption and Symbolic Execution\<close>

text \<open>In this section, we first introduce most elements related to our modeling of program
behaviors. We first define the type of configurations, on which symbolic execution performs, and
define the various concepts we will rely upon in the following and state and prove properties about
them. Then, we introduce symbolic execution. After giving a number of basic properties about
symbolic execution, we prove that symbolic execution is monotonic with respect to the subsumption
relation, which is a crucial point in order to prove the main theorems of \verb?RB.thy?. Moreover,
Isabelle/HOL requires the actual formalization of a number of facts one would not worry when
implementing or writing a sketch proof. Here, we will need to prove that there exist successors of
the configurations on which symbolic execution is performed. Although this seems quite obvious in
practice, proofs of such facts will be needed a number of times in the following theories. Finally,
we define the feasibility of a sequence of labels.\<close>

subsection \<open>Basic Definitions and Properties\<close>

subsubsection\<open>Configurations\<close>

text \<open>Configurations are pairs @{term "(store,pred)"} where:
\begin{itemize}
  \item @{term "store"} is a store mapping program variable to symbolic variables,
  \item @{term "pred"} is a set of boolean expressions over program variables whose conjunction is
the actual path predicate.
\end{itemize}\<close>

record ('v,'d) conf =
  store :: "'v store"
  pred  :: "('v symvar,'d) bexp set"

subsubsection \<open>Symbolic variables of a configuration.\<close>

text \<open>The set of symbolic variables of a configuration is the union of the set of symbolic
variables of its store component with the set of variables of its path predicate.\<close>

definition symvars ::
  "('v,'d) conf \<Rightarrow> 'v symvar set"
where
  "symvars c = Store.symvars (store c) \<union> Bexp.vars (conjunct (pred c))"

subsubsection \<open>Freshness.\<close>

text \<open>A symbolic variable is said to be fresh for a configuration if it is not an element of its
set of symbolic variables.\<close>

definition fresh_symvar ::
  "'v symvar \<Rightarrow> ('v,'d) conf \<Rightarrow> bool"
where
  "fresh_symvar sv c = (sv \<notin> symvars c)"

subsubsection \<open>Satisfiability\<close>

text \<open>A configuration is said to be satisfiable if its path predicate is satisfiable.\<close>

abbreviation sat ::
  "('v,'d) conf \<Rightarrow> bool"
where
  "sat c \<equiv> Bexp.sat (conjunct (pred c))"

subsubsection \<open>States of a configuration\<close>

text \<open>Configurations represent sets of program states. The set of program states represented by a
configuration, or simply its set of program states, is defined as the set of program states such that
consistent symbolic states wrt.\ the store component of the configuration satisfies its path
predicate.\<close>

definition states ::
  "('v,'d) conf \<Rightarrow> ('v,'d) state set"
where
 "states c = {\<sigma>. \<exists> \<sigma>\<^sub>s\<^sub>y\<^sub>m. consistent \<sigma> \<sigma>\<^sub>s\<^sub>y\<^sub>m (store c) \<and> conjunct (pred c) \<sigma>\<^sub>s\<^sub>y\<^sub>m}"

text \<open>A configuration is satisfiable if and only if its set of states is not empty.\<close>

lemma sat_eq :
  "sat c = (states c \<noteq> {})"
using consistentI2 by (simp add : sat_def states_def) fast

subsubsection \<open>Subsumption\<close>

text \<open>A configuration @{term "c\<^sub>2"} is subsumed by a configuration @{term "c\<^sub>1"} if the set of
states of @{term "c\<^sub>2"} is a subset of the set of states of @{term "c\<^sub>1"}.\<close>

definition subsums ::
  "('v,'d) conf \<Rightarrow> ('v,'d) conf \<Rightarrow> bool" (infixl "\<sqsubseteq>" 55)
where
  "c\<^sub>2 \<sqsubseteq> c\<^sub>1 \<equiv> (states c\<^sub>2 \<subseteq> states c\<^sub>1)"

text \<open>The subsumption relation is reflexive and transitive.\<close>

lemma subsums_refl :
  "c \<sqsubseteq> c"
by (simp only : subsums_def)

lemma subsums_trans :
  "c1 \<sqsubseteq> c2 \<Longrightarrow> c2 \<sqsubseteq> c3 \<Longrightarrow> c1 \<sqsubseteq> c3"
unfolding subsums_def by simp

text \<open>However, it is not anti-symmetric. This is due to the fact that different configurations
can have the same sets of program states. However, the following lemma trivially follows the
definition of subsumption.\<close>

lemma
  assumes "c1 \<sqsubseteq> c2"
  assumes "c2 \<sqsubseteq> c1"
  shows   "states c1 = states c2"
using assms by (simp add : subsums_def)

text \<open>A satisfiable configuration can only be subsumed by satisfiable configurations.\<close>

lemma sat_sub_by_sat :
  assumes "sat c\<^sub>2"
  and     "c\<^sub>2 \<sqsubseteq> c\<^sub>1"
  shows   "sat c\<^sub>1"
using assms sat_eq[of c\<^sub>1] sat_eq[of c\<^sub>2]
by (simp add : subsums_def) fast

text \<open>On the other hand, an unsatisfiable configuration can only subsume unsatisfiable
configurations.\<close>

lemma unsat_subs_unsat :
  assumes "\<not> sat c1"
  assumes "c2 \<sqsubseteq> c1"
  shows   "\<not> sat c2"
using assms sat_eq[of c1] sat_eq[of c2]
by (simp add : subsums_def)

subsubsection \<open>Semantics of a configuration\<close>

text \<open>The semantics of a configuration @{term "c"} is a boolean expression @{term "e"} over
program states associating \emph{true} to a program state if it is a state of @{term "c"}. In
practice, given two configurations @{term "c\<^sub>1"} and @{term "c\<^sub>2"}, it is not possible to enumerate
their sets of states to establish the inclusion in order to detect a subsumption. We detect the
subsumption of the former by the latter by asking a constraint solver if @{term "sem c\<^sub>1"} entails
@{term "sem c\<^sub>2"}. The following theorem shows that the way we detect subsumption in practice is
correct.\<close>

definition sem ::
  "('v,'d) conf \<Rightarrow> ('v,'d) bexp"
where
 "sem c = (\<lambda> \<sigma>. \<sigma> \<in> states c)"

theorem
  "c\<^sub>2 \<sqsubseteq> c\<^sub>1 \<longleftrightarrow> sem c\<^sub>2 \<Turnstile>\<^sub>B sem c\<^sub>1"
unfolding subsums_def sem_def subset_iff entails_def by (rule refl)

subsubsection \<open>Abstractions\<close>

text \<open>Abstracting a configuration consists in removing a given expression from its @{term "pred"}
component, i.e.\ weakening its path predicate. This definition of abstraction motivates the fact
that the @{term "pred"} component of configurations has been defined as a set of boolean expressions
instead of a boolean expression.\<close>

definition abstract ::
  "('v,'d) conf \<Rightarrow> ('v,'d) conf \<Rightarrow> bool"
where
  "abstract c c\<^sub>a \<equiv> c \<sqsubseteq> c\<^sub>a"

subsubsection \<open>Entailment\<close>

text \<open>A configuration \emph{entails} a boolean expression if its semantics entails this expression.
This is equivalent to say that this expression holds for any state of this configuration.\<close>

abbreviation entails ::
  "('v,'d) conf \<Rightarrow> ('v,'d) bexp \<Rightarrow> bool" (infixl "\<Turnstile>\<^sub>c" 55)
where
  "c \<Turnstile>\<^sub>c \<phi> \<equiv> sem c \<Turnstile>\<^sub>B \<phi>"

lemma
  "sem c \<Turnstile>\<^sub>B e \<longleftrightarrow> (\<forall> \<sigma> \<in> states c. e \<sigma>)"
by (auto simp add : states_def sem_def entails_def)

end


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

section\<open>Defining an Initial Algebra by Quotienting a Free Algebra\<close>

theory QuoDataType imports MainRLT begin

subsection\<open>Defining the Free Algebra\<close>

text\<open>Messages with encryption and decryption as free constructors.\<close>
datatype
     freemsg = NONCE  nat
             | MPAIR  freemsg freemsg
             | CRYPT  nat freemsg
             | DECRYPT  nat freemsg

text\<open>The equivalence relation, which makes encryption and decryption inverses
provided the keys are the same.

The first two rules are the desired equations. The next four rules
make the equations applicable to subterms. The last two rules are symmetry
and transitivity.\<close>

inductive_set
  msgrel :: "(freemsg * freemsg) set"
  and msg_rel :: "[freemsg, freemsg] => bool"  (infixl "\<sim>" 50)
  where
    "X \<sim> Y == (X,Y) \<in> msgrel"
  | CD:    "CRYPT K (DECRYPT K X) \<sim> X"
  | DC:    "DECRYPT K (CRYPT K X) \<sim> X"
  | NONCE: "NONCE N \<sim> NONCE N"
  | MPAIR: "\<lbrakk>X \<sim> X'; Y \<sim> Y'\<rbrakk> \<Longrightarrow> MPAIR X Y \<sim> MPAIR X' Y'"
  | CRYPT: "X \<sim> X' \<Longrightarrow> CRYPT K X \<sim> CRYPT K X'"
  | DECRYPT: "X \<sim> X' \<Longrightarrow> DECRYPT K X \<sim> DECRYPT K X'"
  | SYM:   "X \<sim> Y \<Longrightarrow> Y \<sim> X"
  | TRANS: "\<lbrakk>X \<sim> Y; Y \<sim> Z\<rbrakk> \<Longrightarrow> X \<sim> Z"

text\<open>Proving that it is an equivalence relation\<close>

lemma msgrel_refl: "X \<sim> X"
  by (induct X) (blast intro: msgrel.intros)+

theorem equiv_msgrel: "equiv UNIV msgrel"
proof -
  have "refl msgrel" by (simp add: refl_on_def msgrel_refl)
  moreover have "sym msgrel" by (simp add: sym_def, blast intro: msgrel.SYM)
  moreover have "trans msgrel" by (simp add: trans_def, blast intro: msgrel.TRANS)
  ultimately show ?thesis by (simp add: equiv_def)
qed

subsection\<open>Some Functions on the Free Algebra\<close>

subsubsection\<open>The Set of Nonces\<close>

text\<open>A function to return the set of nonces present in a message.  It will
be lifted to the initial algebra, to serve as an example of that process.\<close>
primrec freenonces :: "freemsg \<Rightarrow> nat set" where
  "freenonces (NONCE N) = {N}"
| "freenonces (MPAIR X Y) = freenonces X \<union> freenonces Y"
| "freenonces (CRYPT K X) = freenonces X"
| "freenonces (DECRYPT K X) = freenonces X"

text\<open>This theorem lets us prove that the nonces function respects the
equivalence relation.  It also helps us prove that Nonce
  (the abstract constructor) is injective\<close>
theorem msgrel_imp_eq_freenonces: "U \<sim> V \<Longrightarrow> freenonces U = freenonces V"
  by (induct set: msgrel) auto

subsubsection\<open>The Left Projection\<close>

text\<open>A function to return the left part of the top pair in a message.  It will
be lifted to the initial algebra, to serve as an example of that process.\<close>
primrec freeleft :: "freemsg \<Rightarrow> freemsg" where
  "freeleft (NONCE N) = NONCE N"
| "freeleft (MPAIR X Y) = X"
| "freeleft (CRYPT K X) = freeleft X"
| "freeleft (DECRYPT K X) = freeleft X"

text\<open>This theorem lets us prove that the left function respects the
equivalence relation.  It also helps us prove that MPair
  (the abstract constructor) is injective\<close>
theorem msgrel_imp_eqv_freeleft:
     "U \<sim> V \<Longrightarrow> freeleft U \<sim> freeleft V"
  by (induct set: msgrel) (auto intro: msgrel.intros)

subsubsection\<open>The Right Projection\<close>

text\<open>A function to return the right part of the top pair in a message.\<close>
primrec freeright :: "freemsg \<Rightarrow> freemsg" where
  "freeright (NONCE N) = NONCE N"
| "freeright (MPAIR X Y) = Y"
| "freeright (CRYPT K X) = freeright X"
| "freeright (DECRYPT K X) = freeright X"

text\<open>This theorem lets us prove that the right function respects the
equivalence relation.  It also helps us prove that MPair
  (the abstract constructor) is injective\<close>
theorem msgrel_imp_eqv_freeright:
     "U \<sim> V \<Longrightarrow> freeright U \<sim> freeright V"
  by (induct set: msgrel) (auto intro: msgrel.intros)

subsubsection\<open>The Discriminator for Constructors\<close>

text\<open>A function to distinguish nonces, mpairs and encryptions\<close>
primrec freediscrim :: "freemsg \<Rightarrow> int" where
  "freediscrim (NONCE N) = 0"
| "freediscrim (MPAIR X Y) = 1"
| "freediscrim (CRYPT K X) = freediscrim X + 2"
| "freediscrim (DECRYPT K X) = freediscrim X - 2"

text\<open>This theorem helps us prove \<^term>\<open>Nonce N \<noteq> MPair X Y\<close>\<close>
theorem msgrel_imp_eq_freediscrim:
     "U \<sim> V \<Longrightarrow> freediscrim U = freediscrim V"
  by (induct set: msgrel) auto

subsection\<open>The Initial Algebra: A Quotiented Message Type\<close>

definition "Msg = UNIV//msgrel"

typedef msg = Msg
  morphisms Rep_Msg Abs_Msg
  unfolding Msg_def by (auto simp add: quotient_def)

text\<open>The abstract message constructors\<close>
definition
  Nonce :: "nat \<Rightarrow> msg" where
  "Nonce N = Abs_Msg(msgrel``{NONCE N})"

definition
  MPair :: "[msg,msg] \<Rightarrow> msg" where
   "MPair X Y =
       Abs_Msg (\<Union>U \<in> Rep_Msg X. \<Union>V \<in> Rep_Msg Y. msgrel``{MPAIR U V})"

definition
  Crypt :: "[nat,msg] \<Rightarrow> msg" where
   "Crypt K X =
       Abs_Msg (\<Union>U \<in> Rep_Msg X. msgrel``{CRYPT K U})"

definition
  Decrypt :: "[nat,msg] \<Rightarrow> msg" where
   "Decrypt K X =
       Abs_Msg (\<Union>U \<in> Rep_Msg X. msgrel``{DECRYPT K U})"

text\<open>Reduces equality of equivalence classes to the \<^term>\<open>msgrel\<close> relation:
  \<^term>\<open>(msgrel `` {x} = msgrel `` {y}) = ((x,y) \<in> msgrel)\<close>\<close>
lemmas equiv_msgrel_iff = eq_equiv_class_iff [OF equiv_msgrel UNIV_I UNIV_I]

declare equiv_msgrel_iff [simp]

text\<open>All equivalence classes belong to set of representatives\<close>

lemma inj_on_Abs_Msg: "inj_on Abs_Msg Msg"
apply (rule inj_on_inverseI)
apply (erule Abs_Msg_inverse)
done

text\<open>Reduces equality on abstractions to equality on representatives\<close>
declare inj_on_Abs_Msg [THEN inj_on_eq_iff, simp]

declare Abs_Msg_inverse [simp]

subsubsection\<open>Characteristic Equations for the Abstract Constructors\<close>

lemma MPair: "MPair (Abs_Msg(msgrel``{U})) (Abs_Msg(msgrel``{V})) =
              Abs_Msg (msgrel``{MPAIR U V})"
proof -
  have "(\<lambda>U V. msgrel `` {MPAIR U V}) respects2 msgrel"
    by (auto simp add: congruent2_def msgrel.MPAIR)
  thus ?thesis
    by (simp add: MPair_def UN_equiv_class2 [OF equiv_msgrel equiv_msgrel])
qed

lemma Crypt: "Crypt K (Abs_Msg(msgrel``{U})) = Abs_Msg (msgrel``{CRYPT K U})"
proof -
  have "(\<lambda>U. msgrel `` {CRYPT K U}) respects msgrel"
    by (auto simp add: congruent_def msgrel.CRYPT)
  thus ?thesis
    by (simp add: Crypt_def UN_equiv_class [OF equiv_msgrel])
qed

lemma Decrypt:
     "Decrypt K (Abs_Msg(msgrel``{U})) = Abs_Msg (msgrel``{DECRYPT K U})"
proof -
  have "(\<lambda>U. msgrel `` {DECRYPT K U}) respects msgrel"
    by (auto simp add: congruent_def msgrel.DECRYPT)
  thus ?thesis
    by (simp add: Decrypt_def UN_equiv_class [OF equiv_msgrel])
qed

text\<open>Case analysis on the representation of a msg as an equivalence class.\<close>
lemma eq_Abs_Msg [case_names Abs_Msg, cases type: msg]:
     "(!!U. z = Abs_Msg(msgrel``{U}) ==> P) ==> P"
apply (rule Rep_Msg [of z, unfolded Msg_def, THEN quotientE])
apply (drule arg_cong [where f=Abs_Msg])
apply (auto simp add: Rep_Msg_inverse intro: msgrel_refl)
done

text\<open>Establishing these two equations is the point of the whole exercise\<close>
theorem CD_eq [simp]: "Crypt K (Decrypt K X) = X"
by (cases X, simp add: Crypt Decrypt CD)

theorem DC_eq [simp]: "Decrypt K (Crypt K X) = X"
by (cases X, simp add: Crypt Decrypt DC)

subsection\<open>The Abstract Function to Return the Set of Nonces\<close>

definition
  nonces :: "msg \<Rightarrow> nat set" where
   "nonces X = (\<Union>U \<in> Rep_Msg X. freenonces U)"

lemma nonces_congruent: "freenonces respects msgrel"
by (auto simp add: congruent_def msgrel_imp_eq_freenonces)

text\<open>Now prove the four equations for \<^term>\<open>nonces\<close>\<close>

lemma nonces_Nonce [simp]: "nonces (Nonce N) = {N}"
by (simp add: nonces_def Nonce_def
              UN_equiv_class [OF equiv_msgrel nonces_congruent])

lemma nonces_MPair [simp]: "nonces (MPair X Y) = nonces X \<union> nonces Y"
apply (cases X, cases Y)
apply (simp add: nonces_def MPair
                 UN_equiv_class [OF equiv_msgrel nonces_congruent])
done

lemma nonces_Crypt [simp]: "nonces (Crypt K X) = nonces X"
apply (cases X)
apply (simp add: nonces_def Crypt
                 UN_equiv_class [OF equiv_msgrel nonces_congruent])
done

lemma nonces_Decrypt [simp]: "nonces (Decrypt K X) = nonces X"
apply (cases X)
apply (simp add: nonces_def Decrypt
                 UN_equiv_class [OF equiv_msgrel nonces_congruent])
done

subsection\<open>The Abstract Function to Return the Left Part\<close>

definition
  left :: "msg \<Rightarrow> msg" where
   "left X = Abs_Msg (\<Union>U \<in> Rep_Msg X. msgrel``{freeleft U})"

lemma left_congruent: "(\<lambda>U. msgrel `` {freeleft U}) respects msgrel"
by (auto simp add: congruent_def msgrel_imp_eqv_freeleft)

text\<open>Now prove the four equations for \<^term>\<open>left\<close>\<close>

lemma left_Nonce [simp]: "left (Nonce N) = Nonce N"
by (simp add: left_def Nonce_def
              UN_equiv_class [OF equiv_msgrel left_congruent])

lemma left_MPair [simp]: "left (MPair X Y) = X"
apply (cases X, cases Y)
apply (simp add: left_def MPair
                 UN_equiv_class [OF equiv_msgrel left_congruent])
done

lemma left_Crypt [simp]: "left (Crypt K X) = left X"
apply (cases X)
apply (simp add: left_def Crypt
                 UN_equiv_class [OF equiv_msgrel left_congruent])
done

lemma left_Decrypt [simp]: "left (Decrypt K X) = left X"
apply (cases X)
apply (simp add: left_def Decrypt
                 UN_equiv_class [OF equiv_msgrel left_congruent])
done

subsection\<open>The Abstract Function to Return the Right Part\<close>

definition
  right :: "msg \<Rightarrow> msg" where
   "right X = Abs_Msg (\<Union>U \<in> Rep_Msg X. msgrel``{freeright U})"

lemma right_congruent: "(\<lambda>U. msgrel `` {freeright U}) respects msgrel"
by (auto simp add: congruent_def msgrel_imp_eqv_freeright)

text\<open>Now prove the four equations for \<^term>\<open>right\<close>\<close>

lemma right_Nonce [simp]: "right (Nonce N) = Nonce N"
by (simp add: right_def Nonce_def
              UN_equiv_class [OF equiv_msgrel right_congruent])

lemma right_MPair [simp]: "right (MPair X Y) = Y"
apply (cases X, cases Y)
apply (simp add: right_def MPair
                 UN_equiv_class [OF equiv_msgrel right_congruent])
done

lemma right_Crypt [simp]: "right (Crypt K X) = right X"
apply (cases X)
apply (simp add: right_def Crypt
                 UN_equiv_class [OF equiv_msgrel right_congruent])
done

lemma right_Decrypt [simp]: "right (Decrypt K X) = right X"
apply (cases X)
apply (simp add: right_def Decrypt
                 UN_equiv_class [OF equiv_msgrel right_congruent])
done

subsection\<open>Injectivity Properties of Some Constructors\<close>

lemma NONCE_imp_eq: "NONCE m \<sim> NONCE n \<Longrightarrow> m = n"
by (drule msgrel_imp_eq_freenonces, simp)

text\<open>Can also be proved using the function \<^term>\<open>nonces\<close>\<close>
lemma Nonce_Nonce_eq [iff]: "(Nonce m = Nonce n) = (m = n)"
by (auto simp add: Nonce_def msgrel_refl dest: NONCE_imp_eq)

lemma MPAIR_imp_eqv_left: "MPAIR X Y \<sim> MPAIR X' Y' \<Longrightarrow> X \<sim> X'"
by (drule msgrel_imp_eqv_freeleft, simp)

lemma MPair_imp_eq_left:
  assumes eq: "MPair X Y = MPair X' Y'" shows "X = X'"
proof -
  from eq
  have "left (MPair X Y) = left (MPair X' Y')" by simp
  thus ?thesis by simp
qed

lemma MPAIR_imp_eqv_right: "MPAIR X Y \<sim> MPAIR X' Y' \<Longrightarrow> Y \<sim> Y'"
by (drule msgrel_imp_eqv_freeright, simp)

lemma MPair_imp_eq_right: "MPair X Y = MPair X' Y' \<Longrightarrow> Y = Y'"
apply (cases X, cases X', cases Y, cases Y')
apply (simp add: MPair)
apply (erule MPAIR_imp_eqv_right)
done

theorem MPair_MPair_eq [iff]: "(MPair X Y = MPair X' Y') = (X=X' & Y=Y')"
by (blast dest: MPair_imp_eq_left MPair_imp_eq_right)

lemma NONCE_neqv_MPAIR: "NONCE m \<sim> MPAIR X Y \<Longrightarrow> False"
by (drule msgrel_imp_eq_freediscrim, simp)

theorem Nonce_neq_MPair [iff]: "Nonce N \<noteq> MPair X Y"
apply (cases X, cases Y)
apply (simp add: Nonce_def MPair)
apply (blast dest: NONCE_neqv_MPAIR)
done

text\<open>Example suggested by a referee\<close>
theorem Crypt_Nonce_neq_Nonce: "Crypt K (Nonce M) \<noteq> Nonce N"
by (auto simp add: Nonce_def Crypt dest: msgrel_imp_eq_freediscrim)

text\<open>...and many similar results\<close>
theorem Crypt2_Nonce_neq_Nonce: "Crypt K (Crypt K' (Nonce M)) \<noteq> Nonce N"
by (auto simp add: Nonce_def Crypt dest: msgrel_imp_eq_freediscrim)

theorem Crypt_Crypt_eq [iff]: "(Crypt K X = Crypt K X') = (X=X')"
proof
  assume "Crypt K X = Crypt K X'"
  hence "Decrypt K (Crypt K X) = Decrypt K (Crypt K X')" by simp
  thus "X = X'" by simp
next
  assume "X = X'"
  thus "Crypt K X = Crypt K X'" by simp
qed

theorem Decrypt_Decrypt_eq [iff]: "(Decrypt K X = Decrypt K X') = (X=X')"
proof
  assume "Decrypt K X = Decrypt K X'"
  hence "Crypt K (Decrypt K X) = Crypt K (Decrypt K X')" by simp
  thus "X = X'" by simp
next
  assume "X = X'"
  thus "Decrypt K X = Decrypt K X'" by simp
qed

lemma msg_induct [case_names Nonce MPair Crypt Decrypt, cases type: msg]:
  assumes N: "\<And>N. P (Nonce N)"
      and M: "\<And>X Y. \<lbrakk>P X; P Y\<rbrakk> \<Longrightarrow> P (MPair X Y)"
      and C: "\<And>K X. P X \<Longrightarrow> P (Crypt K X)"
      and D: "\<And>K X. P X \<Longrightarrow> P (Decrypt K X)"
  shows "P msg"
proof (cases msg)
  case (Abs_Msg U)
  have "P (Abs_Msg (msgrel `` {U}))"
  proof (induct U)
    case (NONCE N)
    with N show ?case by (simp add: Nonce_def)
  next
    case (MPAIR X Y)
    with M [of "Abs_Msg (msgrel `` {X})" "Abs_Msg (msgrel `` {Y})"]
    show ?case by (simp add: MPair)
  next
    case (CRYPT K X)
    with C [of "Abs_Msg (msgrel `` {X})"]
    show ?case by (simp add: Crypt)
  next
    case (DECRYPT K X)
    with D [of "Abs_Msg (msgrel `` {X})"]
    show ?case by (simp add: Decrypt)
  qed
  with Abs_Msg show ?thesis by (simp only:)
qed

subsection\<open>The Abstract Discriminator\<close>

text\<open>However, as \<open>Crypt_Nonce_neq_Nonce\<close> above illustrates, we don't
need this function in order to prove discrimination theorems.\<close>

definition
  discrim :: "msg \<Rightarrow> int" where
   "discrim X = the_elem (\<Union>U \<in> Rep_Msg X. {freediscrim U})"

lemma discrim_congruent: "(\<lambda>U. {freediscrim U}) respects msgrel"
by (auto simp add: congruent_def msgrel_imp_eq_freediscrim)

text\<open>Now prove the four equations for \<^term>\<open>discrim\<close>\<close>

lemma discrim_Nonce [simp]: "discrim (Nonce N) = 0"
by (simp add: discrim_def Nonce_def
              UN_equiv_class [OF equiv_msgrel discrim_congruent])

lemma discrim_MPair [simp]: "discrim (MPair X Y) = 1"
apply (cases X, cases Y)
apply (simp add: discrim_def MPair
                 UN_equiv_class [OF equiv_msgrel discrim_congruent])
done

lemma discrim_Crypt [simp]: "discrim (Crypt K X) = discrim X + 2"
apply (cases X)
apply (simp add: discrim_def Crypt
                 UN_equiv_class [OF equiv_msgrel discrim_congruent])
done

lemma discrim_Decrypt [simp]: "discrim (Decrypt K X) = discrim X - 2"
apply (cases X)
apply (simp add: discrim_def Decrypt
                 UN_equiv_class [OF equiv_msgrel discrim_congruent])
done

end


header{* Miscellaneous and contributed lemmas *}

theory Ugraph_Misc
imports
  Limits
  Probability
  "../Girth_Chromatic/Girth_Chromatic_Misc"
begin

lemma setsum_square:
  fixes a :: "'i \<Rightarrow> 'a :: {monoid_mult, semiring_0}"
  shows "(\<Sum>i \<in> I. a i)^2 = (\<Sum>i \<in> I. \<Sum>j \<in> I. a i * a j)"
  by (simp only: setsum_product power2_eq_square)

lemma setsum_split:
  "finite I \<Longrightarrow>
  (\<Sum>i \<in> I. if p i then f i else g i) = (\<Sum>i | i \<in> I \<and> p i. f i) + (\<Sum>i | i \<in> I \<and> \<not>p i. g i)"
  by (simp add: setsum.If_cases Int_def)

lemma setsum_split2:
  assumes "finite I"
  shows "(\<Sum>i | i \<in> I \<and> P i. if Q i then f i else g i) = (\<Sum>i | i \<in> I \<and> P i \<and> Q i. f i) + (\<Sum>i | i \<in> I \<and> P i \<and> \<not>Q i. g i)"
proof (subst setsum.If_cases)
  show "finite {i \<in> I. P i}"
    using assms by simp

  have "{i \<in> I. P i} \<inter> Collect Q = {i \<in> I. P i \<and> Q i}" "{i \<in> I. P i} \<inter> - Collect Q =  {i \<in> I. P i \<and> \<not> Q i}"
    by auto
  thus "setsum f ({i \<in> I. P i} \<inter> Collect Q) + setsum g ({i \<in> I. P i} \<inter> - Collect Q) = setsum f {i \<in> I. P i \<and> Q i} + setsum g {i \<in> I. P i \<and> \<not> Q i}"
    by presburger
qed

lemma setsum_upper:
  fixes f :: "'i \<Rightarrow> 'a :: {ordered_cancel_ab_semigroup_add, comm_monoid_add}"
  assumes "finite I" "\<And>i. i \<in> I \<Longrightarrow> 0 \<le> f i"
  shows "(\<Sum>i | i \<in> I \<and> P i. f i) \<le> setsum f I"
proof -
  have "setsum f I = (\<Sum>i \<in> I. if P i then f i else f i)"
    by simp
  hence "setsum f I = (\<Sum>i | i \<in> I \<and> P i. f i) + (\<Sum>i | i \<in> I \<and> \<not>P i. f i)"
    by (simp only: setsum_split[OF `finite I`])
  moreover have "0 \<le> (\<Sum>i | i \<in> I \<and> \<not>P i. f i)"
    by (rule setsum_nonneg) (simp add: assms)
  ultimately show ?thesis
    by (metis (full_types) add.comm_neutral add_left_mono)
qed

lemma setsum_lower:
  fixes f :: "'i \<Rightarrow> 'a :: {ordered_cancel_ab_semigroup_add, comm_monoid_add}"
  assumes "finite I" "i \<in> I" "\<And>i. i \<in> I \<Longrightarrow> 0 \<le> f i" "x < f i"
  shows "x < setsum f I"
proof -
  have "0 + x < setsum f (I - {i}) + f i"
    using assms by (intro add_le_less_mono setsum_nonneg) auto
  also have "setsum f (I - {i}) + f i = setsum f I"
    using assms by (simp add: setsum.remove ac_simps)
  finally show ?thesis by simp
qed

lemma setsum_lower_or_eq:
  fixes f :: "'i \<Rightarrow> 'a :: {ordered_cancel_ab_semigroup_add, comm_monoid_add}"
  assumes "finite I" "i \<in> I" "\<And>i. i \<in> I \<Longrightarrow> 0 \<le> f i" "x \<le> f i"
  shows "x \<le> setsum f I"
proof -
  have "0 + x \<le> setsum f (I - {i}) + f i"
    using assms by (metis Diff_iff add_mono setsum_nonneg)
  also have "setsum f (I - {i}) + f i = setsum f I"
    using assms by (simp add: setsum.remove ac_simps)
  finally show ?thesis by simp
qed

lemma setsum_left_div_distrib:
  fixes f :: "'i \<Rightarrow> real"
  shows "(\<Sum>i \<in> I. f i / x) = setsum f I / x"
proof -
  have "(\<Sum>i \<in> I. f i / x) = (\<Sum>i \<in> I. f i * (1 / x))"
    by simp
  also have "\<dots> = setsum f I * (1 / x)"
    by (rule setsum_left_distrib[symmetric])
  also have "\<dots> = setsum f I / x"
    by simp
  finally show ?thesis
    .
qed

lemma powr_mono3:
  assumes "0 < x" "x < 1" "b \<le> a"
  shows "x powr a \<le> x powr b"
proof -
  have "x powr a = 1 / x powr -a"
    by (simp add: powr_minus_divide)
  also have "\<dots> = (1 / x) powr -a"
    using assms by (simp add: powr_divide)
  also have "\<dots> \<le> (1 / x) powr -b"
    using assms by (simp add: powr_mono)
  also have "\<dots> = 1 / x powr -b"
    using assms by (simp add: powr_divide)
  also have "\<dots> = x powr b"
    by (simp add: powr_minus_divide)
  finally show ?thesis
    .
qed

lemma card_union: "finite A \<Longrightarrow> finite B \<Longrightarrow> card (A \<union> B) = card A + card B - card (A \<inter> B)"
by (metis card_Un_Int[symmetric] diff_add_inverse2)

lemma card_1_element:
  assumes "card E = 1"
  shows "\<exists>a. E = {a}"
proof -
  from assms obtain a where "a \<in> E"
    by force
  let ?E' = "E - {a}"

  have "finite ?E'"
    using assms card_ge_0_finite by force
  hence "card (insert a ?E') = 1 + card ?E'"
    using card_insert by fastforce
  moreover have "E = insert a ?E'"
    using `a \<in> E` by blast
  ultimately have "card E = 1 + card ?E'"
    by simp
  hence "card ?E' = 0"
    using assms by simp
  hence "?E' = {}"
    using `finite ?E'` by simp
  thus ?thesis
    using `a \<in> E` by blast
qed

lemma card_2_elements:
  assumes "card E = 2"
  shows "\<exists>a b. E = {a, b} \<and> a \<noteq> b"
proof -
  from assms obtain a where "a \<in> E"
    by force
  let ?E' = "E - {a}"

  have "finite ?E'"
    using assms card_ge_0_finite by force
  hence "card (insert a ?E') = 1 + card ?E'"
    using card_insert by fastforce
  moreover have "E = insert a ?E'"
    using `a \<in> E` by blast
  ultimately have "card E = 1 + card ?E'"
    by simp
  hence "card ?E' = 1"
    using assms by simp
  then obtain b where "?E' = {b}"
    using card_1_element by blast
  hence "E = {a, b}"
    using `a \<in> E` by blast
  moreover have "a \<noteq> b"
    using `?E' = {b}` by blast
  ultimately show ?thesis
    by blast
qed

lemma bij_lift:
  assumes "bij_betw f A B"
  shows "bij_betw (\<lambda>e. f ` e) (Pow A) (Pow B)"
proof -
  have f: "inj_on f A" "f ` A = B"
    using assms unfolding bij_betw_def by simp_all
  have "inj_on (\<lambda>e. f ` e) (Pow A)"
    unfolding inj_on_def by clarify (metis f(1) inv_into_image_cancel)
  moreover have "(\<lambda>e. f ` e) ` (Pow A) = (Pow B)"
    by (metis f(2) image_Pow_surj)
  ultimately show ?thesis
    unfolding bij_betw_def by simp
qed

lemma card_inj_subs: "inj_on f A \<Longrightarrow> B \<subseteq> A \<Longrightarrow> card (f ` B) = card B"
by (metis card_image subset_inj_on)

lemma image_comp_cong: "(\<And>a. a \<in> A \<Longrightarrow> f a = f (g a)) \<Longrightarrow> f ` A = f ` (g ` A)"
by (auto simp: image_iff)

abbreviation less_fun :: "(nat \<Rightarrow> real) \<Rightarrow> (nat \<Rightarrow> real) \<Rightarrow> bool" (infix "\<lless>" 50) where
"f \<lless> g \<equiv> (\<lambda>n. f n / g n) ----> 0"

context
  fixes f :: "nat \<Rightarrow> real"
begin

  lemma LIMSEQ_power_zero: "f ----> 0 \<Longrightarrow> 0 < n  \<Longrightarrow> (\<lambda>x. f x ^ n :: real) ----> 0"
  by (metis less_not_refl3 power_eq_0_iff tendsto_power)

  lemma LIMSEQ_cong:
    assumes "f ----> x" "\<forall>\<^sup>\<infinity>n. f n = g n"
    shows "g ----> x"
  by (rule real_tendsto_sandwich[where f = f and h = f, OF eventually_elim1[OF assms(2)] eventually_elim1[OF assms(2)]]) (auto simp: assms(1))
  print_statement Lim_transform_eventually

  lemma LIMSEQ_le_zero:
    assumes "g ----> 0" "\<forall>\<^sup>\<infinity>n. 0 \<le> f n" "\<forall>\<^sup>\<infinity>n. f n \<le> g n"
    shows "f ----> 0"
  by (rule real_tendsto_sandwich[OF assms(2) assms(3) tendsto_const assms(1)])

  lemma LIMSEQ_const_mult:
    assumes "f ----> a"
    shows "(\<lambda>x. c * f x) ----> c * a"
  by (rule tendsto_mult[OF tendsto_const[where k = c] assms])

  lemma LIMSEQ_const_div:
    assumes "f ----> a" "c \<noteq> 0"
    shows "(\<lambda>x. f x / c) ----> a / c"
  using LIMSEQ_const_mult[where c = "1/c"] assms by simp

end

lemma less_fun_bounds:
  assumes "f' \<lless> g'" "\<forall>\<^sup>\<infinity>n. f n \<le> f' n" "\<forall>\<^sup>\<infinity>n. g' n \<le> g n" "\<forall>\<^sup>\<infinity>n. 0 \<le> f n" "\<forall>\<^sup>\<infinity>n. 0 < g n" "\<forall>\<^sup>\<infinity>n. 0 < g' n"
  shows "f \<lless> g"
proof (rule real_tendsto_sandwich)
  show "\<forall>\<^sup>\<infinity>n. 0 \<le> f n / g n"
    using assms(4,5) by eventually_elim simp
next
  show "\<forall>\<^sup>\<infinity>n. f n / g n \<le> f' n / g' n"
    using assms(2-) by eventually_elim (simp only: quot_bounds)
qed (auto intro: assms(1))

lemma less_fun_const_quot:
  assumes "f \<lless> g" "c \<noteq> 0"
  shows "(\<lambda>n. b * f n) \<lless> (\<lambda>n. c * g n)"
proof -
  have "(\<lambda>n. (b * (f n / g n)) / c) ----> (b * 0) / c"
    using assms by (rule LIMSEQ_const_div[OF LIMSEQ_const_mult])
  hence "(\<lambda>n. (b * (f n / g n)) / c) ----> 0"
    by simp
  with eventually_sequentiallyI show ?thesis
    by (rule Lim_transform_eventually) simp

qed

lemma partition_set_of_intersecting_sets_by_card:
  assumes "finite A"
  shows "{B. A \<inter> B \<noteq> {}} = (\<Union>n \<in> {1..card A}. {B. card (A \<inter> B) = n})"
proof (rule set_eqI, rule iffI)
  fix B
  assume "B \<in> {B. A \<inter> B \<noteq> {}}"
  hence "0 < card (A \<inter> B)"
    using assms by auto
  moreover have "card (A \<inter> B) \<le> card A"
    using assms by (simp add: card_mono)
  ultimately have "card (A \<inter> B) \<in> {1..card A}"
    by simp
  thus "B \<in> (\<Union>n \<in> {1..card A}. {B. card (A \<inter> B) = n})"
    by blast
qed force

lemma card_set_of_intersecting_sets_by_card:
  assumes "A \<subseteq> I" "finite I" "k \<le> n" "n \<le> card I" "k \<le> card A"
  shows "card {B. B \<subseteq> I \<and> card B = n \<and> card (A \<inter> B) = k} = (card A choose k) * ((card I - card A) choose (n - k))"
proof -
  note finite_A = finite_subset[OF assms(1,2)]

  have "card {B. B \<subseteq> I \<and> card B = n \<and> card (A \<inter> B) = k} = card ({K. K \<subseteq> A \<and> card K = k} \<times> {B'. B' \<subseteq> I - A \<and> card B' = n - k})" (is "card ?lhs = card ?rhs")
    proof (rule bij_betw_same_card[symmetric])
      let ?f = "\<lambda>(K, B'). K \<union> B'"
      have "inj_on ?f ?rhs"
        by (blast intro: inj_onI)
      moreover have "?f ` ?rhs = ?lhs"
        proof (rule set_eqI, rule iffI)
          fix B
          assume "B \<in> ?f ` ?rhs"
          then obtain K B' where K: "K \<subseteq> A" "card K = k" "B' \<subseteq> I - A" "card B' = n - k" "K \<union> B' = B"
            by blast
          show "B \<in> ?lhs"
            proof safe
              fix x assume "x \<in> B" thus "x \<in> I"
                using K `A \<subseteq> I` by blast
            next
              have "card B = card K + card B' - card (K \<inter> B')"
                using K assms by (metis card_union finite_A finite_subset finite_Diff)
              moreover have "K \<inter> B' = {}"
                using K assms by blast
              ultimately show "card B = n"
                using K assms by simp
            next
              have "A \<inter> B = K"
                using K assms(1) by blast
              thus "card (A \<inter> B) = k"
                using K by simp
            qed
        next
          fix B
          assume "B \<in> ?lhs"
          hence B: "B \<subseteq> I" "card B = n" "card (A \<inter> B) = k"
            by auto
          let ?K = "A \<inter> B"
          let ?B' = "B - A"
          have "?K \<subseteq> A" "card ?K = k" "?B' \<subseteq> I - A"
            using B by auto
          moreover have "card ?B' = n - k"
            using B finite_A assms(1) by (metis Int_commute card_Diff_subset_Int finite_Un inf.left_idem le_iff_inf sup_absorb2)
          ultimately have "(?K, ?B') \<in> ?rhs"
            by blast
          moreover have "B = ?f (?K, ?B')"
            by auto
          ultimately show "B \<in> ?f ` ?rhs"
            by blast
        qed
      ultimately show "bij_betw ?f ?rhs ?lhs"
        unfolding bij_betw_def ..
    qed
  also have "\<dots> = (\<Sum>K | K \<subseteq> A \<and> card K = k. card {B'. B' \<subseteq> I - A \<and> card B' = n - k})"
    proof (rule card_SigmaI, safe)
      show "finite {K. K \<subseteq> A \<and> card K = k}"
        by (blast intro: finite_subset[where B = "Pow A"] finite_A)
    next
      fix K
      assume "K \<subseteq> A"
      thus "finite {B'. B' \<subseteq> I - A \<and> card B' = n - card K}"
        using assms by auto
    qed
  also have "\<dots> = card {K. K \<subseteq> A \<and> card K = k} * card {B'. B' \<subseteq> I - A \<and> card B' = n - k}"
    by simp
  also have "\<dots> = (card A choose k) * (card (I - A) choose (n - k))"
    by (simp only: n_subsets[OF finite_A] n_subsets[OF finite_Diff[OF assms(2)]])
  also have "\<dots> = (card A choose k) * ((card I - card A) choose (n - k))"
    by (simp only: card_Diff_subset[OF finite_A assms(1)])
  finally show ?thesis
    .
qed

lemma card_dep_pair_set:
  assumes "finite A" "\<And>a. a \<subseteq> A \<Longrightarrow> finite (f a)"
  shows "card {(a, b). a \<subseteq> A \<and> card a = n \<and> b \<subseteq> f a \<and> card b = g a} = (\<Sum>a | a \<subseteq> A \<and> card a = n. card (f a) choose g a)" (is "card ?S = ?C")
proof -
  have S: "?S = Sigma {a. a \<subseteq> A \<and> card a = n} (\<lambda>a. {b. b \<subseteq> f a \<and> card b = g a})" (is "_ = Sigma ?A ?B")
    by auto

  have "card (Sigma ?A ?B) = (\<Sum>a \<in> {a. a \<subseteq> A \<and> card a = n}. card (?B a))"
    proof (rule card_SigmaI, safe)
      show "finite ?A"
        by (rule finite_subset[OF _ finite_Collect_subsets[OF assms(1)]]) blast
    next
      fix a
      assume "a \<subseteq> A"
      hence "finite (f a)"
        by (fact assms(2))
      thus "finite (?B a)"
        by (rule finite_subset[rotated, OF finite_Collect_subsets]) blast
    qed
  also have "\<dots> = ?C"
    proof (rule setsum.cong)
      fix a
      assume "a \<in> {a. a \<subseteq> A \<and> card a = n}"
      hence "finite (f a)"
        using assms(2) by blast
      thus "card (?B a) = card (f a) choose g a"
        by (fact n_subsets)
    qed simp
  finally have "card (Sigma ?A ?B) = ?C"
    .

  thus ?thesis
    by (subst S)
qed

lemma setprod_cancel_nat:
  --"Contributed by Manuel Eberl"
  fixes f::"'a \<Rightarrow> nat"
  assumes "B \<subseteq> A" and "finite A" and "\<forall>x\<in>B. f x \<noteq> 0"
  shows "setprod f A / setprod f B = setprod f (A - B)" (is "?A / ?B = ?C")
proof-
  from setprod.subset_diff[OF assms(1,2)] have "?A = ?C * ?B" by auto
  moreover have "?B \<noteq> 0" using assms by (simp add: finite_subset)
  ultimately show ?thesis by simp
qed

lemma setprod_id_cancel_nat:
  --"Contributed by Manuel Eberl"
  fixes A::"nat set"
  assumes "B \<subseteq> A" and "finite A" and "0 \<notin> B"
  shows "\<Prod>A / \<Prod>B = \<Prod>(A-B)"
  using assms(1-2) by (rule setprod_cancel_nat) (metis assms(3))

lemma (in prob_space) integrable_squareD:
  --"Contributed by Johannes Hölzl"
  fixes X :: "_ \<Rightarrow> real"
  assumes "integrable M (\<lambda>x. (X x)^2)" "X \<in> borel_measurable M"
  shows "integrable M X"
proof -
  have "integrable M (\<lambda>x. max 1 ((X x)^2))"
    using assms by auto
  then show "integrable M X"
  proof (rule integrable_bound[OF _ _ always_eventually[OF allI]])
    fix x show "norm (X x) \<le> norm (max 1 ((X x)^2))"
      using real_abs_le_square_iff[of 1 "X x"] power_increasing[of 1 2 "abs (X x)"]
      by (auto split: split_max)
  qed fact
qed

end


theory Exercise7p4
imports
  Bigstep_sseefried
  Star
begin

(* sseefried: For some reason this does not evaluate number literals i.e. of form N n *)
inductive astep :: "aexp \<times> state \<Rightarrow> aexp \<Rightarrow> bool" (infix "\<leadsto>" 50) where
    "(V x, s) \<leadsto> N (s x)"
  | "(Plus (N i) (N j),s) \<leadsto> N (i + j)"
  | "(a1, s) \<leadsto> N i  \<Longrightarrow> (Plus a1 a2, s) \<leadsto> Plus (N i) a2"
  | "(a2, s) \<leadsto> N j  \<Longrightarrow> (Plus (N i) a2, s) \<leadsto> N (i + j)"

(* The following command tells it to generate code for the predicate  and thus make the
   predicate available in the "values" command, which is similar to value, but works on
   inductive definitions and computes a set of possible results.
 *)
code_pred astep .

values "{ s. (Plus (V ''x'') (V ''y'') , ((\<lambda>_. 0) (''x'' := 2)) (''y'' := 3)) \<leadsto> s }"

lemmas astep_induct = astep.induct[split_format (complete)]

lemma "(a,s) \<leadsto> a' \<Longrightarrow> aval a s = aval a' s"
proof (induction rule: astep_induct)
  fix x s
  show " aval (V x) s = aval (N (s x)) s" by auto
next
  fix i j s
  show "aval (Plus (N i) (N j)) s = aval (N (i + j)) s" by auto
next
  fix i a1 a2 s
  assume "(a1, s) \<leadsto> N i"
     and "aval a1 s = aval (N i) s"
  thus "aval (Plus a1 a2) s = aval (Plus (N i) a2) s" by auto
next
  fix a2 s j i
  assume "(a2, s) \<leadsto> N j"
     and "aval a2 s = aval (N j) s"
  thus   "aval (Plus (N i) a2) s = aval (N (i + j)) s" by auto
qed

(* Bonus. Create a relation like "star" for this *)

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

code_pred star' .

abbreviation
  asteps :: "aexp \<times> state \<Rightarrow> aexp \<Rightarrow> bool" (infix "\<leadsto>*" 55)
where "as \<leadsto>* a' \<equiv> star' astep as a'"

values "{ s. (Plus (V ''x'') (V ''y'') , <''x'' := 2, ''y'' := 3>) \<leadsto>* s }"

end


theory Chapter12_4
imports "HOL-IMP.VCG" "HOL-IMP.Hoare_Examples" "Short_Theory"
begin

text{*
\exercise
Let @{term "asum i"} be the annotated command \texttt{y := 0; W}
where \texttt{W} is defined in Example~12.7. Prove
*}
(* your definition of asum here *)

lemma "\<turnstile> {\<lambda>s. s ''x'' = i} strip(asum i) {\<lambda>s. s ''y'' = sum i}"
(* your definition/proof here *)

text{*
with the help of corollary @{thm[source] vc_sound'}.
\endexercise

\exercise
Solve exercises \ref{exe:Hoare:sumeq} to \ref{exe:Hoare:sqrt} using the VCG:
for every Hoare triple @{prop"\<turnstile> {P} c {Q}"} from one of those exercises
define an annotated version @{text C} of @{text c} and prove
@{prop"\<turnstile> {P} strip C {Q}"} with the help of %Corollary~\ref{cor:vc_sound}
corollary @{thm[source] vc_sound'}.
*}

text{*
\endexercise

\exercise
Having two separate functions @{const pre} and @{const vc} is inefficient.
When computing @{const vc} one often needs to compute @{const pre} too,
leading to multiple traversals of many subcommands. Define an optimised function
*}
fun prevc :: "acom \<Rightarrow> assn \<Rightarrow> assn \<times> bool" where
(* your definition/proof here *)

text{* that traverses the command only once. Prove *}

lemma "prevc C Q = (pre C Q, vc C Q)"
(* your definition/proof here *)

text{*
\endexercise

\exercise
Design a VCG that computes post rather than preconditions.
Start by solving Exercise~\ref{exe:fwdassign}. Now modify theory
@{short_theory "VCG"} as follows. Instead of @{const pre} define a function
*}

fun post :: "acom \<Rightarrow> assn \<Rightarrow> assn" where
(* your definition/proof here *)

text{*
such that (with the execption of loops) @{term "post C P"} is the strongest
postcondition of @{text C} w.r.t.\ the precondition @{text P} (see also
Exercise~\ref{exe:sp}). Now modify @{const vc} such that is uses
@{const post} instead of @{const pre} and prove its soundness
and completeness.
*}

fun vc :: "acom \<Rightarrow> assn \<Rightarrow> bool" where
(* your definition/proof here *)

lemma vc_sound: "vc C P \<Longrightarrow> \<turnstile> {P} strip C {post C P}"
(* your definition/proof here *)

lemma vc_complete: "\<turnstile> {P} c {Q}
  \<Longrightarrow> \<exists>C. strip C = c \<and> vc C P \<and> (\<forall>s. post C P s \<longrightarrow> Q s)"
(* your definition/proof here *)

text {*
\endexercise
*}

end