(* Author: Alexander Bentkamp, Universität des Saarlandes
*)
section \<open>Matrix Rank\<close>

theory DL_Rank
imports VS_Connect DL_Missing_List
 Determinant
 Missing_VectorSpace
begin

lemma (in vectorspace) full_dim_span:
assumes "S \<subseteq> carrier V"
and "finite S"
and "vectorspace.dim K (span_vs S) = card S"
shows "lin_indpt S"
proof -
  have "vectorspace K (span_vs S)"
    using field.field_axioms vectorspace_def submodule_is_module[OF span_is_submodule[OF assms(1)]] by metis
  have "S \<subseteq> carrier (span_vs S)"  by (simp add: assms(1) in_own_span)
  have "LinearCombinations.module.span K (vs (span S)) S = carrier (vs (span S))"
    using module.span_li_not_depend[OF _ span_is_submodule[OF assms(1)]]
    by (simp add: assms(1) in_own_span)
  have "vectorspace.basis K (vs (span S)) S"
    using vectorspace.dim_gen_is_basis[OF \<open>vectorspace K (span_vs S)\<close> \<open>finite S\<close> \<open>S \<subseteq> carrier (span_vs S)\<close>
     \<open>LinearCombinations.module.span K (vs (span S)) S = carrier (vs (span S))\<close>]  \<open>vectorspace.dim K (span_vs S) = card S\<close>
    by simp
  then have "LinearCombinations.module.lin_indpt K (vs (span S)) S"
    using vectorspace.basis_def[OF \<open>vectorspace K (span_vs S)\<close>] by blast
  then show ?thesis using module.span_li_not_depend[OF _ span_is_submodule[OF assms(1)]]
    by (simp add: assms(1) in_own_span)
qed

lemma (in vectorspace) dim_span:
assumes "S \<subseteq> carrier V"
and "finite S"
and "maximal U (\<lambda>T. T \<subseteq> S \<and> lin_indpt T)"
shows "vectorspace.dim K (span_vs S) = card U"
proof -
  have "lin_indpt U" "U \<subseteq> S" by (metis assms(3) maximal_def)+
  then have "U \<subseteq> span S" using in_own_span[OF assms(1)] by blast
  then have lin_indpt: "LinearCombinations.module.lin_indpt K (span_vs S) U"
    using module.span_li_not_depend(2)[OF \<open>U \<subseteq> span S\<close>] \<open>lin_indpt U\<close> assms(1) span_is_submodule by blast
  have "span U = span S"
  proof (rule ccontr)
    assume "span U \<noteq> span S"
    have "span U \<subseteq> span S" using span_is_monotone \<open>U\<subseteq>S\<close> by metis
    then have "\<not> S \<subseteq> span U" by (meson \<open>U \<subseteq> S\<close> \<open>span U \<noteq> span S\<close> assms(1) span_is_submodule
      span_is_subset subset_antisym subset_trans)
    then obtain s where "s\<in>S" "s \<notin> span U" by blast
    then have "lin_indpt (U\<union>{s})" using lindep_span
      by (meson \<open>U \<subseteq> S\<close> \<open>lin_indpt U\<close> assms(1) lin_dep_iff_in_span rev_subsetD span_mem subset_trans)
    have "s\<notin>U" using \<open>U \<subseteq> S\<close> \<open>s \<notin> span U\<close> assms(1) span_mem by auto
    then have "(U\<union>{s}) \<subseteq> S \<and> lin_indpt (U\<union>{s})" using \<open>U \<subseteq> S\<close> \<open>lin_indpt (U \<union> {s})\<close> \<open>s \<in> S\<close> by auto
    then have "\<not>maximal U (\<lambda>T. T \<subseteq> S \<and> lin_indpt T)"
      unfolding maximal_def using Un_subset_iff \<open>s \<notin> U\<close> insert_subset  order_refl by auto
    then show False using assms by metis
  qed
  then have span:"LinearCombinations.module.span K (vs (span S)) U = span S"
    using module.span_li_not_depend[OF \<open>U \<subseteq> span S\<close>]
    by (simp add: LinearCombinations.module.span_is_submodule assms(1) module_axioms)
  have "vectorspace K (vs (span S))"
    using field.field_axioms vectorspace_def submodule_is_module[OF span_is_submodule[OF assms(1)]] by metis
  then have "vectorspace.basis K (vs (span S)) U" using vectorspace.basis_def[OF \<open>vectorspace K (vs (span S))\<close>]
    by (simp add: span \<open>U \<subseteq> span S\<close> lin_indpt)
  then show ?thesis
    using \<open>U \<subseteq> S\<close> \<open>vectorspace K (vs (span S))\<close> assms(2) infinite_super vectorspace.dim_basis by blast
qed

definition (in vec_space) rank ::"'a mat \<Rightarrow> nat"
where "rank A = vectorspace.dim class_ring (span_vs (set (cols A)))"

lemma (in vec_space) rank_card_indpt:
assumes "A \<in> carrier_mat n nc"
assumes "maximal S (\<lambda>T. T \<subseteq> set (cols A) \<and> lin_indpt T)"
shows "rank A = card S"
proof -
  have "set (cols A) \<subseteq> carrier_vec n" using cols_dim assms(1) by blast
  have "finite (set (cols A))" by blast
  show ?thesis using dim_span[OF \<open>set (cols A) \<subseteq> carrier_vec n\<close> \<open>finite (set (cols A))\<close> assms(2)]
    unfolding rank_def by blast
qed

lemma maximal_exists_superset:
  assumes "finite S"
  assumes maxc: "\<And>A. P A \<Longrightarrow> A \<subseteq> S" and "P B"
  shows "\<exists>A. finite A \<and> maximal A P \<and> B \<subseteq> A"
proof -
  have "finite (S-B)" using assms(1) assms(3) infinite_super maxc by blast
  then show ?thesis using \<open>P B\<close>
  proof (induction "S-B" arbitrary:B rule: finite_psubset_induct)
    case (psubset B)
    then show ?case
    proof (cases "maximal B P")
      case True
      then show ?thesis using order_refl psubset.hyps by (metis assms(1) maxc psubset.prems rev_finite_subset)
    next
      case False
      then obtain B' where "B \<subset> B'" "P B'" using maximal_def psubset.prems by (metis dual_order.order_iff_strict)
      then have "B' \<subseteq> S" "B \<subseteq> S" using maxc \<open>P B\<close> by auto
      then have "S - B' \<subset> S - B" using \<open>B \<subset> B'\<close> by blast
      then show ?thesis using psubset(2)[OF \<open>S - B' \<subset> S - B\<close> \<open>P B'\<close>] using \<open>B \<subset> B'\<close> by fast
    qed
  qed
qed

lemma (in vec_space) rank_ge_card_indpt:
assumes "A \<in> carrier_mat n nc"
assumes "U \<subseteq> set (cols A)"
assumes "lin_indpt U"
shows "rank A \<ge> card U"
proof -
  obtain S where "maximal S (\<lambda>T. T \<subseteq> set (cols A) \<and> lin_indpt T)" "U\<subseteq>S" "finite S"
    using maximal_exists_superset[of "set (cols A)" "(\<lambda>T. T \<subseteq> set (cols A) \<and> lin_indpt T)" U]
    using List.finite_set assms(2) assms(3) maximal_exists_superset by blast
  then show ?thesis
    unfolding rank_card_indpt[OF \<open>A \<in> carrier_mat n nc\<close> \<open>maximal S (\<lambda>T. T \<subseteq> set (cols A) \<and> lin_indpt T)\<close>]
    using card_mono by blast
qed

lemma (in vec_space) lin_indpt_full_rank:
assumes "A \<in> carrier_mat n nc"
assumes "distinct (cols A)"
assumes "lin_indpt (set (cols A))"
shows "rank A = nc"
proof -
  have "maximal (set (cols A)) (\<lambda>T. T \<subseteq> set (cols A) \<and> lin_indpt T)"
    by (simp add: assms(3) maximal_def subset_antisym)
  then have "rank A = card (set (cols A))" using assms(1) vec_space.rank_card_indpt by blast
  then show ?thesis using assms(1) assms(2) distinct_card by fastforce
qed

lemma (in vec_space) rank_le_nc:
assumes "A \<in> carrier_mat n nc"
shows "rank A \<le> nc"
proof -
  obtain S where "maximal S (\<lambda>T. T \<subseteq> set (cols A) \<and> lin_indpt T)"
    using maximal_exists[of "(\<lambda>T. T \<subseteq> set (cols A) \<and> lin_indpt T)" "card (set (cols A))" "{}"]
    by (meson List.finite_set card_mono empty_iff empty_subsetI finite_lin_indpt2 rev_finite_subset)
  then have "card S \<le> card (set (cols A))" by (simp add: card_mono maximal_def)
  then have "card S \<le> nc"
    using assms(1) cols_length card_length carrier_matD(2) by (metis dual_order.trans)
  then show ?thesis
    using rank_card_indpt[OF \<open>A \<in> carrier_mat n nc\<close> \<open>maximal S (\<lambda>T. T \<subseteq> set (cols A) \<and> lin_indpt T)\<close>]
    by simp
qed

lemma (in vec_space) full_rank_lin_indpt:
assumes "A \<in> carrier_mat n nc"
assumes "rank A = nc"
assumes "distinct (cols A)"
shows "lin_indpt (set (cols A))"
proof -
  have 1:"set (cols A) \<subseteq> carrier_vec n" using assms(1) cols_dim by blast
  have 2:"finite (set (cols A))" by simp
  have "card (set (cols A)) = nc"
    using assms(1) assms(3) distinct_card by fastforce
  have 3:"vectorspace.dim class_ring (span_vs (set (cols A))) = card (set (cols A))"
    using \<open>rank A = nc\<close>[unfolded rank_def]
    using assms(1) assms(3) distinct_card by fastforce
  show ?thesis using full_dim_span[OF 1 2 3] .
qed

lemma (in vec_space) mat_mult_eq_lincomb:
assumes "A \<in> carrier_mat n nc"
assumes "distinct (cols A)"
shows "A *\<^sub>v (vec nc (\<lambda>i. a (col A i))) = lincomb a (set (cols A))"
proof (rule eq_vecI)
  have "finite (set (cols A))" using assms(1) by simp
  then show "dim_vec (A *\<^sub>v (vec nc (\<lambda>i. a (col A i)))) = dim_vec (lincomb a (set (cols A)))"
    using assms cols_dim vec_space.lincomb_dim by (metis dim_mult_mat_vec carrier_matD(1))
  fix i assume "i < dim_vec (lincomb a (set (cols A)))"
  then have "i < n" using \<open>dim_vec (A *\<^sub>v (vec nc (\<lambda>i. a (col A i)))) = dim_vec (lincomb a (set (cols A)))\<close> assms by auto
  have "set (cols A) \<subseteq> carrier_vec n" using cols_dim \<open>A \<in> carrier_mat n nc\<close> carrier_matD(1) by blast
  have "bij_betw (nth (cols A)) {..<length (cols A)} (set (cols A))"
    unfolding bij_betw_def by (rule conjI, simp add: inj_on_nth \<open>distinct (cols A)\<close>;
    metis subset_antisym in_set_conv_nth lessThan_iff rev_image_eqI subsetI
    image_subsetI lessThan_iff nth_mem)
  then have " (\<Sum>x\<in>set (cols A). a x * x $ i) =
    (\<Sum>j\<in>{..<length (cols A)}. a (cols A ! j) * (cols A ! j) $ i)"
    using bij_betw_imp_surj_on bij_betw_imp_inj_on by (metis (no_types, lifting) sum.reindex_cong)
  also have "... = (\<Sum>j\<in>{..<length (cols A)}. a (col A j) * (cols A ! j) $ i)"
    using assms(1) assms(2) find_first_unique[OF \<open>distinct (cols A)\<close>] \<open>i < n\<close> by auto
  also have "... = (\<Sum>j\<in>{..<length (cols A)}. (cols A ! j) $ i * a (col A j))" by (metis mult_commute_abs)
  also have "... = (\<Sum>j\<in>{..<length (cols A)}. row A i $ j * a (col A j))" using \<open>i < n\<close> assms(1) assms(2) by auto
  finally show "(A *\<^sub>v (vec nc (\<lambda>i. a (col A i)))) $ i = lincomb a (set (cols A)) $ i"
    unfolding lincomb_index[OF \<open>i < n\<close> \<open>set (cols A) \<subseteq> carrier_vec n\<close>]
    unfolding mult_mat_vec_def scalar_prod_def
    using \<open>i < n\<close> assms(1) atLeast0LessThan lessThan_def carrier_matD(1) index_vec sum.cong by auto
qed

lemma (in vec_space) lincomb_eq_mat_mult:
assumes "A \<in> carrier_mat n nc"
assumes "v \<in> carrier_vec nc"
assumes "distinct (cols A)"
shows "lincomb (\<lambda>a. v $ find_first a (cols A)) (set (cols A)) = (A *\<^sub>v v)"
proof -
  have "\<And>i. i < nc \<Longrightarrow> find_first (col A i) (cols A) = i"
    using assms(1) assms(3) find_first_unique by fastforce
  then have "vec nc (\<lambda>i. v $ find_first (col A i) (cols A)) = v"
    using assms(2) by auto
  then show ?thesis
    using mat_mult_eq_lincomb[where a = "(\<lambda>a. v $ find_first a (cols A))", OF assms(1) assms(3)] by auto
qed

lemma (in vec_space) lin_depI:
assumes "A \<in> carrier_mat n nc"
assumes "v \<in> carrier_vec nc" "v \<noteq> 0\<^sub>v nc" "A *\<^sub>v v = 0\<^sub>v n"
assumes "distinct (cols A)"
shows "lin_dep (set (cols A))"
proof -
  have 1: "finite (set (cols A))" by simp
  have 2: "set (cols A) \<subseteq> set (cols A)" by auto
  have 3: "(\<lambda>a. v $ find_first a (cols A)) \<in> set (cols A) \<rightarrow> UNIV" by simp
  obtain i where "v $ i \<noteq> 0" "i < nc"
    using \<open>v \<noteq> 0\<^sub>v nc\<close>
    by (metis assms(2) dim_vec carrier_vecD vec_eq_iff zero_vec_def index_zero_vec(1))
  then have "i < dim_col A" using assms(1) by blast
  have 4:"col A i \<in> set (cols A)"
    using cols_nth[OF \<open>i < dim_col A\<close>] \<open>i < dim_col A\<close> in_set_conv_nth by fastforce
  have 5:"v $ find_first (col A i) (cols A) \<noteq> 0"
    using find_first_unique[OF \<open>distinct (cols A)\<close>] cols_nth[OF \<open>i < dim_col A\<close>] \<open>i < nc\<close> \<open>v $ i \<noteq> 0\<close>
    assms(1) by auto
  have 6:"lincomb (\<lambda>a. v $ find_first a (cols A)) (set (cols A)) = 0\<^sub>v n"
    using assms(1) assms(2) assms(4) assms(5) lincomb_eq_mat_mult by auto
  show ?thesis using lin_dep_crit[OF 1 2 _ 4 5 6] by metis
qed

lemma (in vec_space) lin_depE:
assumes "A \<in> carrier_mat n nc"
assumes "lin_dep (set (cols A))"
assumes "distinct (cols A)"
obtains v where "v \<in> carrier_vec nc" "v \<noteq> 0\<^sub>v nc" "A *\<^sub>v v = 0\<^sub>v n"
proof -
  have "finite (set (cols A))" by simp
  obtain a w where "a \<in> set (cols A) \<rightarrow> UNIV" "lincomb a (set (cols A)) = 0\<^sub>v n" "w \<in> set (cols A)" "a w \<noteq> 0"
    using finite_lin_dep[OF \<open>finite (set (cols A))\<close> \<open>lin_dep (set (cols A))\<close>]
    using assms(1) cols_dim carrier_matD(1) by blast
  define v where "v = vec nc (\<lambda>i. a (col A i))"
  have 1:"v \<in> carrier_vec nc" by (simp add: v_def)
  have 2:"v \<noteq> 0\<^sub>v nc"
  proof -
    obtain i where "w = col A i" "i < length (cols A)"
      by (metis \<open>w \<in> set (cols A)\<close> cols_length cols_nth in_set_conv_nth)
    have "v $ i \<noteq> 0"
      unfolding v_def
      using \<open>a w \<noteq> 0\<close>[unfolded \<open>w = col A i\<close>] index_vec[OF \<open>i < length (cols A)\<close>]
      assms(1) cols_length carrier_matD(2) by (metis (no_types) \<open>A \<in> carrier_mat n nc\<close>
      \<open>\<And>f. vec (length (cols A)) f $ i = f i\<close> \<open>a (col A i) \<noteq> 0\<close> cols_length carrier_matD(2))
    then show ?thesis using \<open>i < length (cols A)\<close> assms(1) by auto
  qed
  have 3:"A *\<^sub>v v = 0\<^sub>v n" unfolding v_def
    using \<open>lincomb a (set (cols A)) = 0\<^sub>v n\<close> mat_mult_eq_lincomb[OF \<open>A \<in> carrier_mat n nc\<close> \<open>distinct (cols A)\<close>] by auto
  show thesis using 1 2 3 by (simp add: that)
qed

lemma (in vec_space) non_distinct_low_rank:
assumes "A \<in> carrier_mat n n"
and "\<not> distinct (cols A)"
shows "rank A < n"
proof -
  obtain S where "maximal S (\<lambda>T. T \<subseteq> set (cols A) \<and> lin_indpt T)"
    using maximal_exists[of "(\<lambda>T. T \<subseteq> set (cols A) \<and> lin_indpt T)" "card (set (cols A))" "{}"]
    by (meson List.finite_set card_mono empty_iff empty_subsetI finite_lin_indpt2 rev_finite_subset)
  then have "card S \<le> card (set (cols A))" by (simp add: card_mono maximal_def)
  then have "card S < n"
    using assms(1) cols_length card_length \<open>\<not> distinct (cols A)\<close> card_distinct carrier_matD(2) nat_less_le
    by (metis dual_order.antisym dual_order.trans)
  then show ?thesis
    using rank_card_indpt[OF \<open>A \<in> carrier_mat n n\<close> \<open>maximal S (\<lambda>T. T \<subseteq> set (cols A) \<and> lin_indpt T)\<close>]
    by simp
qed

text \<open>The theorem "det non-zero $\longleftrightarrow$ full rank" is practically proven in det\_0\_iff\_vec\_prod\_zero\_field,
but without an actual definition of the rank.\<close>

lemma (in vec_space) det_zero_low_rank:
assumes "A \<in> carrier_mat n n"
and "det A = 0"
shows "rank A < n"
proof (rule ccontr)
  assume "\<not> rank A < n"
  then have "rank A = n" using rank_le_nc assms le_neq_implies_less by blast
  obtain v where "v \<in> carrier_vec n" "v \<noteq> 0\<^sub>v n" "A *\<^sub>v v = 0\<^sub>v n"
    using det_0_iff_vec_prod_zero_field[OF assms(1)] assms(2) by blast
  then show False
  proof (cases "distinct (cols A)")
    case True
    then have "lin_indpt (set (cols A))" using full_rank_lin_indpt using \<open>rank A = n\<close> assms(1) by auto
    then show False using lin_depI[OF assms(1) \<open>v \<in> carrier_vec n\<close> \<open>v \<noteq> 0\<^sub>v n\<close> \<open>A *\<^sub>v v = 0\<^sub>v n\<close>] True by blast
  next
    case False
    then show False using non_distinct_low_rank \<open>rank A = n\<close> \<open>\<not> rank A < n\<close> assms(1) by blast
  qed
qed

lemma det_identical_cols:
  assumes A: "A \<in> carrier_mat n n"
    and ij: "i \<noteq> j"
    and i: "i < n" and j: "j < n"
    and r: "col A i = col A j"
  shows "det A = 0"
  using det_identical_rows det_transpose
  by (metis A i ij j carrier_matD(2) transpose_carrier_mat r row_transpose)

lemma (in vec_space) low_rank_det_zero:
assumes "A \<in> carrier_mat n n"
and "det A \<noteq> 0"
shows "rank A = n"
proof -
  have "distinct (cols A)"
  proof (rule ccontr)
    assume "\<not> distinct (cols A)"
    then obtain i j where "i\<noteq>j" "(cols A) ! i = (cols A) ! j" "i<length (cols A)" "j<length (cols A)"
      using distinct_conv_nth by blast
    then have "col A i = col A j" "i<n" "j<n" using assms(1) by auto
    then have "det A = 0"  using det_identical_cols using \<open>i \<noteq> j\<close> assms(1) by blast
    then show False using \<open>det A \<noteq> 0\<close> by auto
  qed
  have "\<And>v. v \<in> carrier_vec n \<Longrightarrow> v \<noteq> 0\<^sub>v n \<Longrightarrow> A *\<^sub>v v \<noteq> 0\<^sub>v n"
    using det_0_iff_vec_prod_zero_field[OF assms(1)] assms(2) by auto
  then have "lin_indpt (set (cols A))" using lin_depE[OF assms(1) _ \<open>distinct (cols A)\<close>] by auto
  then show ?thesis using lin_indpt_full_rank[OF assms(1) \<open>distinct (cols A)\<close>] by metis
qed

lemma (in vec_space) det_rank_iff:
assumes "A \<in> carrier_mat n n"
shows "det A \<noteq> 0 \<longleftrightarrow> rank A = n"
  using assms det_zero_low_rank low_rank_det_zero by force

section "Subadditivity of rank"

text \<open>Subadditivity is the property of rank, that rank (A + B) <= rank A + rank B.\<close>

lemma (in Module.module) lincomb_add:
assumes "finite (b1 \<union> b2)"
assumes "b1 \<union> b2 \<subseteq> carrier M"
assumes "x1 = lincomb a1 b1" "a1\<in> (b1\<rightarrow>carrier R)"
assumes "x2 = lincomb a2 b2" "a2\<in> (b2\<rightarrow>carrier R)"
assumes "x = x1 \<oplus>\<^bsub>M\<^esub> x2"
shows "lincomb (\<lambda>v. (\<lambda>v. if v \<in> b1 then a1 v else \<zero>) v \<oplus> (\<lambda>v. if v \<in> b2 then a2 v else \<zero>) v) (b1 \<union> b2) = x"
proof -
  have "finite (b1 \<union> (b2-b1))" "finite (b2 \<union> (b1-b2))"
       "b1 \<union> (b2 - b1) \<subseteq> carrier M" "b2 \<union> (b1-b2) \<subseteq> carrier M"
       "b1 \<inter> (b2 - b1) = {}" "b2 \<inter> (b1 - b2) = {}"
       "(\<lambda>b. \<zero>\<^bsub>R\<^esub>) \<in> b2 - b1 \<rightarrow> carrier R" "(\<lambda>b. \<zero>\<^bsub>R\<^esub>) \<in> b1 - b2 \<rightarrow> carrier R"
    using \<open>finite (b1 \<union> b2)\<close> \<open>b1 \<union> b2 \<subseteq> carrier M\<close> \<open>a2\<in> (b2\<rightarrow>carrier R)\<close> by auto
  have "lincomb (\<lambda>b. \<zero>\<^bsub>R\<^esub>) (b2 - b1) = \<zero>\<^bsub>M\<^esub>" "lincomb (\<lambda>b. \<zero>\<^bsub>R\<^esub>) (b1 - b2) = \<zero>\<^bsub>M\<^esub>"
    unfolding lincomb_def using M.finsum_all0 assms(2) lmult_0 subset_iff
    by (metis (no_types, lifting) Un_Diff_cancel2 inf_sup_aci(5) le_sup_iff)+
  then have "x1 = lincomb (\<lambda>v. if v \<in> b1 then a1 v else \<zero>) (b1 \<union> b2)"
            "x2 = lincomb (\<lambda>v. if v \<in> b2 then a2 v else \<zero>) (b1 \<union> b2)"
    using lincomb_union2[OF \<open>finite (b1 \<union> (b2-b1))\<close> \<open>b1 \<union> (b2 - b1) \<subseteq> carrier M\<close> \<open>b1 \<inter> (b2 - b1) = {}\<close> \<open>a1\<in> (b1\<rightarrow>carrier R)\<close> \<open>(\<lambda>b. \<zero>\<^bsub>R\<^esub>) \<in> b2 - b1 \<rightarrow> carrier R\<close>]
          lincomb_union2[OF \<open>finite (b2 \<union> (b1-b2))\<close> \<open>b2 \<union> (b1-b2) \<subseteq> carrier M\<close> \<open>b2 \<inter> (b1 - b2) = {}\<close> \<open>a2\<in> (b2\<rightarrow>carrier R)\<close> \<open>(\<lambda>b. \<zero>\<^bsub>R\<^esub>) \<in> b1 - b2 \<rightarrow> carrier R\<close>]
    using assms(2) assms(3) assms(4)  assms(5)  assms(6) by (simp_all add:Un_commute)
  have "(\<lambda>v. if v \<in> b1 then a1 v else \<zero>) \<in> (b1 \<union> b2) \<rightarrow> carrier R"
       "(\<lambda>v. if v \<in> b2 then a2 v else \<zero>) \<in> (b1 \<union> b2) \<rightarrow> carrier R" using assms(4) assms(6) by auto
  show "lincomb (\<lambda>v. (\<lambda>v. if v \<in> b1 then a1 v else \<zero>) v \<oplus> (\<lambda>v. if v \<in> b2 then a2 v else \<zero>) v) (b1 \<union> b2) = x"
    using lincomb_sum[OF \<open>finite (b1 \<union> b2)\<close> \<open>b1 \<union> b2 \<subseteq> carrier M\<close>
    \<open>(\<lambda>v. if v \<in> b1 then a1 v else \<zero>) \<in> (b1 \<union> b2) \<rightarrow> carrier R\<close> \<open>(\<lambda>v. if v \<in> b2 then a2 v else \<zero>) \<in> (b1 \<union> b2) \<rightarrow> carrier R\<close>]
    \<open>x1 = lincomb (\<lambda>v. if v \<in> b1 then a1 v else \<zero>) (b1 \<union> b2)\<close> \<open>x2 = lincomb (\<lambda>v. if v \<in> b2 then a2 v else \<zero>) (b1 \<union> b2)\<close> assms(7) by blast
qed

lemma (in vectorspace) dim_subadditive:
assumes "subspace K W1 V"
and "vectorspace.fin_dim K (vs W1)"
assumes "subspace K W2 V"
and "vectorspace.fin_dim K (vs W2)"
shows "vectorspace.dim K (vs (subspace_sum W1 W2)) \<le> vectorspace.dim K (vs W1) + vectorspace.dim K (vs W2)"
proof -
  have "vectorspace K (vs W1)" "vectorspace K (vs W2)" "submodule K W1 V" "submodule K W2 V"
    by (simp add: \<open>subspace K W1 V\<close> \<open>subspace K W2 V\<close> subspace_is_vs)+
  obtain b1 b2 where "vectorspace.basis K (vs W1) b1" "vectorspace.basis K (vs W2) b2" "finite b1" "finite b2"
    using vectorspace.finite_basis_exists[OF \<open>vectorspace K (vs W1)\<close> \<open>vectorspace.fin_dim K (vs W1)\<close>]
    using vectorspace.finite_basis_exists[OF \<open>vectorspace K (vs W2)\<close> \<open>vectorspace.fin_dim K (vs W2)\<close>]
    by blast
  then have "LinearCombinations.module.gen_set K (vs W1) b1" "LinearCombinations.module.gen_set K (vs W2) b2"
    using \<open>vectorspace K (vs W1)\<close> \<open>vectorspace K (vs W2)\<close> vectorspace.basis_def by blast+
  then have "span b1 = W1" "span b2 = W2"
    using module.span_li_not_depend(1) \<open>submodule K W1 V\<close>  \<open>submodule K W2 V\<close>
    \<open>vectorspace K (vs W1)\<close> \<open>vectorspace.basis K (vs W1) b1\<close> \<open>vectorspace K (vs W2)\<close>
    \<open>vectorspace.basis K (vs W2) b2\<close> vectorspace.basis_def by force+
  have "W1 \<subseteq> carrier V" "W2 \<subseteq> carrier V" using \<open>subspace K W1 V\<close> \<open>subspace K W2 V\<close> subspace_def submodule_def by metis+
  have "b1 \<subseteq> carrier V"
    using \<open>vectorspace.basis K (vs W1) b1\<close> \<open>vectorspace K (vs W1)\<close> vectorspace.basis_def
    \<open>W1 \<subseteq> carrier V\<close> by fastforce
  have "b2 \<subseteq> carrier V"
    using \<open>vectorspace.basis K (vs W2) b2\<close> \<open>vectorspace K (vs W2)\<close> vectorspace.basis_def
    \<open>W2 \<subseteq> carrier V\<close> by fastforce
  have "finite (b1 \<union> b2)" "b1 \<union> b2 \<subseteq> carrier V"
    by (simp_all add: \<open>finite b1\<close> \<open>finite b2\<close> \<open>b2 \<subseteq> carrier V\<close> \<open>b1 \<subseteq> carrier V\<close>)
  have "subspace_sum W1 W2 \<subseteq> span (b1\<union>b2)"
  proof (rule subsetI)
    fix x assume "x \<in> subspace_sum W1 W2"
    obtain x1 x2 where  "x1 \<in> W1" "x2 \<in> W2" "x = x1 \<oplus>\<^bsub>V\<^esub> x2"
      using imageE[OF \<open>x \<in> subspace_sum W1 W2\<close>[unfolded submodule_sum_def]]
      by (metis (no_types, lifting) BNF_Def.Collect_case_prodD split_def)
    obtain a1 where "x1 = lincomb a1 b1" "a1\<in> (b1\<rightarrow>carrier K)"
      using \<open>span b1 = W1\<close> finite_span[OF \<open>finite b1\<close> \<open>b1 \<subseteq> carrier V\<close>] \<open>x1 \<in> W1\<close> by auto
    obtain a2 where "x2 = lincomb a2 b2" "a2\<in> (b2\<rightarrow>carrier K)"
      using \<open>span b2 = W2\<close> finite_span[OF \<open>finite b2\<close> \<open>b2 \<subseteq> carrier V\<close>] \<open>x2 \<in> W2\<close> by auto
    obtain a where "x = lincomb a (b1 \<union> b2)" using lincomb_add[OF \<open>finite (b1 \<union> b2)\<close> \<open>b1 \<union> b2 \<subseteq> carrier V\<close>
      \<open>x1 = lincomb a1 b1\<close> \<open>a1\<in> (b1\<rightarrow>carrier K)\<close>  \<open>x2 = lincomb a2 b2\<close> \<open>a2\<in> (b2\<rightarrow>carrier K)\<close> \<open>x = x1 \<oplus>\<^bsub>V\<^esub> x2\<close>] by blast
    then show "x \<in> span (b1 \<union> b2)" using finite_span[OF \<open>finite (b1 \<union> b2)\<close> \<open>(b1 \<union> b2) \<subseteq> carrier V\<close>]
      using \<open>b1 \<subseteq> carrier V\<close> \<open>b2 \<subseteq> carrier V\<close> \<open>span b1 = W1\<close> \<open>span b2 = W2\<close> \<open>x \<in> subspace_sum W1 W2\<close> span_union_is_sum by auto
  qed
  have "b1 \<subseteq> W1" "b2 \<subseteq> W2"
    using \<open>vectorspace K (vs W1)\<close> \<open>vectorspace K (vs W2)\<close> \<open>vectorspace.basis K (vs W1) b1\<close>
    \<open>vectorspace.basis K (vs W2) b2\<close> vectorspace.basis_def local.carrier_vs_is_self by blast+
  then have "b1\<union>b2 \<subseteq> subspace_sum W1 W2" using \<open>submodule K W1 V\<close> \<open>submodule K W2 V\<close> in_sum
    by (metis assms(1) assms(3) dual_order.trans sup_least vectorspace.vsum_comm vectorspace_axioms)
  have "subspace_sum W1 W2 = LinearCombinations.module.span K (vs (subspace_sum W1 W2)) (b1\<union>b2)"
  proof (rule subset_antisym)
    have "submodule K (subspace_sum W1 W2) V" by (simp add: \<open>submodule K W1 V\<close> \<open>submodule K W2 V\<close> sum_is_submodule)
    show "subspace_sum W1 W2 \<subseteq> LinearCombinations.module.span K (vs (subspace_sum W1 W2)) (b1\<union>b2)"
      using module.span_li_not_depend(1)[OF \<open>b1\<union>b2 \<subseteq> subspace_sum W1 W2\<close> \<open>submodule K (subspace_sum W1 W2) V\<close>]
      by (simp add: \<open>subspace_sum W1 W2 \<subseteq> span (b1 \<union> b2)\<close>)
    show "subspace_sum W1 W2 \<supseteq> LinearCombinations.module.span K (vs (subspace_sum W1 W2)) (b1\<union>b2)"
      using \<open>b1\<union>b2 \<subseteq> subspace_sum W1 W2\<close> by (metis (full_types) LinearCombinations.module.span_is_subset2
      LinearCombinations.module.submodule_is_module \<open>submodule K (subspace_sum W1 W2) V\<close> local.carrier_vs_is_self submodule_def)
  qed
  have "vectorspace K (vs (subspace_sum W1 W2))" using assms(1) assms(3) subspace_def sum_is_subspace vectorspace.subspace_is_vs by blast
  then have "vectorspace.dim K (vs (subspace_sum W1 W2)) \<le> card (b1 \<union> b2)"
    using vectorspace.gen_ge_dim[OF \<open>vectorspace K (vs (subspace_sum W1 W2))\<close> \<open>finite (b1 \<union> b2)\<close>]
    \<open>b1 \<union> b2 \<subseteq> subspace_sum W1 W2\<close>
    \<open>subspace_sum W1 W2 = LinearCombinations.module.span K (vs (subspace_sum W1 W2)) (b1 \<union> b2)\<close>
    local.carrier_vs_is_self by blast
  also have "... \<le> card b1 + card b2" by (simp add: card_Un_le)
  also have "... = vectorspace.dim K (vs W1) + vectorspace.dim K (vs W2)"
    by (metis \<open>finite b1\<close> \<open>finite b2\<close> \<open>vectorspace K (vs W1)\<close> \<open>vectorspace K (vs W2)\<close>
    \<open>vectorspace.basis K (vs W1) b1\<close> \<open>vectorspace.basis K (vs W2) b2\<close> vectorspace.dim_basis)
  finally show ?thesis by auto
qed

lemma (in Module.module) nested_submodules:
assumes "submodule R W M"
assumes "submodule R X M"
assumes "X \<subseteq> W"
shows "submodule R X (md W)"
  unfolding submodule_def
  using \<open>X \<subseteq> W\<close> submodule_is_module[OF \<open>submodule R W M\<close>] using \<open>submodule R X M\<close>[unfolded submodule_def] by auto

lemma (in vectorspace) nested_subspaces:
assumes "subspace K W V"
assumes "subspace K X V"
assumes "X \<subseteq> W"
shows "subspace K X (vs W)"
  using assms nested_submodules subspace_def subspace_is_vs by blast

lemma (in vectorspace) subspace_dim:
assumes "subspace K X V" "fin_dim" "vectorspace.fin_dim K (vs X)"
shows "vectorspace.dim K (vs X) \<le> dim"
proof -
  have "vectorspace K (vs X)" using assms(1) subspace_is_vs by auto
  then obtain b where "vectorspace.basis K (vs X) b" using vectorspace.finite_basis_exists
    using assms(3) by blast
  then have "b \<subseteq> carrier V" "LinearCombinations.module.lin_indpt K (vs X) b"
    using vectorspace.basis_def[OF \<open>vectorspace K (vs X)\<close>] \<open>subspace K X V\<close>[unfolded subspace_def submodule_def] by auto
  then have "lin_indpt b"
    by (metis LinearCombinations.module.span_li_not_depend(2) \<open>vectorspace K (vs X)\<close> \<open>vectorspace.basis K (vs X) b\<close>
    assms(1) is_module local.carrier_vs_is_self submodule_def vectorspace.basis_def)
  show ?thesis using li_le_dim(2)[OF \<open>fin_dim\<close> \<open>b \<subseteq> carrier V\<close> \<open>lin_indpt b\<close>]
    using \<open>b \<subseteq> carrier V\<close> \<open>lin_indpt b\<close> \<open>vectorspace K (vs X)\<close> \<open>vectorspace.basis K (vs X) b\<close> assms(2)
    fin_dim_li_fin vectorspace.dim_basis by fastforce
qed

lemma (in vectorspace) fin_dim_subspace_sum:
assumes "subspace K W1 V"
assumes "subspace K W2 V"
assumes "vectorspace.fin_dim K (vs W1)" "vectorspace.fin_dim K (vs W2)"
shows "vectorspace.fin_dim K (vs (subspace_sum W1 W2))"
proof -
  obtain b1 where "finite b1" "b1 \<subseteq> W1" "LinearCombinations.module.gen_set K (vs W1) b1"
    using assms vectorspace.fin_dim_def subspace_is_vs by force
  obtain b2 where "finite b2" "b2 \<subseteq> W2" "LinearCombinations.module.gen_set K (vs W2) b2"
    using assms vectorspace.fin_dim_def subspace_is_vs by force
  have 1:"finite (b1 \<union> b2)" by (simp add: \<open>finite b1\<close> \<open>finite b2\<close>)
  have 2:"b1 \<union> b2 \<subseteq> subspace_sum W1 W2"
    by (metis (no_types, lifting) \<open>b1 \<subseteq> W1\<close> \<open>b2 \<subseteq> W2\<close> assms(1) assms(2)
    le_sup_iff subset_Un_eq vectorspace.in_sum_vs vectorspace.vsum_comm vectorspace_axioms)
  have 3:"LinearCombinations.module.gen_set K (vs (subspace_sum W1 W2)) (b1 \<union> b2)"
  proof (rule subset_antisym)
    have 0:"LinearCombinations.module.span K (vs (subspace_sum W1 W2)) (b1 \<union> b2) = span (b1 \<union> b2)"
      using span_li_not_depend(1)[OF \<open>b1 \<union> b2 \<subseteq> subspace_sum W1 W2\<close>] sum_is_subspace[OF assms(1) assms(2)] by auto
    then show "LinearCombinations.module.span K (vs (subspace_sum W1 W2)) (b1 \<union> b2) \<subseteq> carrier (vs (subspace_sum W1 W2))"
      using \<open>b1 \<union> b2 \<subseteq> subspace_sum W1 W2\<close> span_is_subset sum_is_subspace[OF assms(1) assms(2)] by auto
    show "carrier (vs (subspace_sum W1 W2)) \<subseteq> LinearCombinations.module.span K (vs (subspace_sum W1 W2)) (b1 \<union> b2)"
     unfolding 0
    proof
      fix x assume assumption:"x \<in> carrier (vs (subspace_sum W1 W2))"
      then have "x\<in>subspace_sum W1 W2" by auto
      then obtain x1 x2 where "x = x1 \<oplus>\<^bsub>V\<^esub> x2" "x1\<in>W1" "x2\<in>W2"
        using imageE[OF \<open>x \<in> subspace_sum W1 W2\<close>[unfolded submodule_sum_def]]
        by (metis (no_types, lifting) BNF_Def.Collect_case_prodD split_def)
      have "x1\<in>span b1"  "x2\<in>span b2"
        using \<open>LinearCombinations.module.span K (vs W1) b1 = carrier (vs W1)\<close> \<open>b1 \<subseteq> W1\<close> \<open>x1 \<in> W1\<close>
              \<open>LinearCombinations.module.span K (vs W2) b2 = carrier (vs W2)\<close> \<open>b2 \<subseteq> W2\<close> \<open>x2 \<in> W2\<close>
        assms(1) assms(2) span_li_not_depend(1) by auto
      then have "x1\<in>span (b1 \<union> b2)" "x2\<in>span (b1 \<union> b2)" by (meson le_sup_iff subsetD span_is_monotone subsetI)+
      then show "x \<in> span (b1 \<union> b2)" unfolding \<open>x = x1 \<oplus>\<^bsub>V\<^esub> x2\<close>
        by (meson \<open>b1 \<union> b2 \<subseteq> subspace_sum W1 W2\<close> assms(1) assms(2) is_module submodule.subset
        subset_trans sum_is_submodule vectorspace.span_add1 vectorspace_axioms)
    qed
  qed
  show ?thesis using 1 2 3 vectorspace.fin_dim_def
    by (metis assms(1) assms(2) local.carrier_vs_is_self subspace_def sum_is_subspace vectorspace.subspace_is_vs)
qed

lemma (in vec_space) rank_subadditive:
assumes "A \<in> carrier_mat n nc"
assumes "B \<in> carrier_mat n nc"
shows "rank (A + B) \<le> rank A + rank B"
proof -
  define W1 where "W1 = span (set (cols A))"
  define W2 where "W2 = span (set (cols B))"
  have "set (cols (A + B)) \<subseteq> subspace_sum W1 W2"
  proof
    fix x assume "x \<in> set (cols (A + B))"
    obtain i where "x = col (A + B) i" "i < length (cols (A + B))"
      using \<open>x \<in> set (cols (A + B))\<close> nth_find_first cols_nth find_first_le by (metis cols_length)
    then have "x = col A i + col B i" using \<open>i < length (cols (A + B))\<close> assms(1) assms(2) by auto
    have "col A i \<in> span (set (cols A))" "col B i \<in> span (set (cols B))"
      using \<open>i < length (cols (A + B))\<close> assms(1) assms(2) in_set_conv_nth
      by (metis cols_dim cols_length cols_nth carrier_matD(1) carrier_matD(2) index_add_mat(3) span_mem)+
    then show "x \<in> subspace_sum W1 W2"
      unfolding W1_def W2_def \<open>x = col A i + col B i\<close> submodule_sum_def by blast
  qed
  have "subspace class_ring (subspace_sum W1 W2) V"
    by (metis W1_def W2_def assms(1) assms(2) cols_dim carrier_matD(1) span_is_submodule subspace_def sum_is_submodule vec_vs)
  then have "span (set (cols (A + B))) \<subseteq> subspace_sum W1 W2"
    by (simp add: \<open>set (cols (A + B)) \<subseteq> subspace_sum W1 W2\<close> span_is_subset)
  have "subspace class_ring (span (set (cols (A + B)))) V" by (metis assms(2) cols_dim add_carrier_mat carrier_matD(1) span_is_subspace)
  have subspace:"subspace class_ring (span (set (cols (A + B)))) (vs (subspace_sum W1 W2))"
    using nested_subspaces[OF \<open>subspace class_ring (subspace_sum W1 W2) V\<close> \<open>subspace class_ring (span (set (cols (A + B)))) V\<close>
    \<open>span (set (cols (A + B))) \<subseteq> subspace_sum W1 W2\<close>] .
  have "vectorspace.fin_dim class_ring (vs W1)" "vectorspace.fin_dim class_ring (vs W2)"
       "subspace class_ring W1 V" "subspace class_ring W2 V"
    using span_is_subspace W1_def W2_def assms(1) assms(2) cols_dim carrier_matD fin_dim_span_cols by auto
  then have fin_dim: "vectorspace.fin_dim class_ring (vs (subspace_sum W1 W2))" using fin_dim_subspace_sum by auto
  have "vectorspace.fin_dim class_ring (span_vs (set (cols (A + B))))" using assms(2) add_carrier_mat vec_space.fin_dim_span_cols by blast
  then have "rank (A + B) \<le> vectorspace.dim class_ring (vs (subspace_sum W1 W2))" unfolding rank_def
    using vectorspace.subspace_dim[OF subspace_is_vs[OF \<open>subspace class_ring (subspace_sum W1 W2) V\<close>] subspace fin_dim] by auto
  also have "vectorspace.dim class_ring (vs (subspace_sum W1 W2)) \<le> rank A + rank B" unfolding rank_def
    using W1_def W2_def \<open>subspace class_ring W1 V\<close> \<open>subspace class_ring W2 V\<close> \<open>vectorspace.fin_dim class_ring (vs W1)\<close>
    \<open>vectorspace.fin_dim class_ring (vs W2)\<close> subspace_def vectorspace.dim_subadditive by blast
  finally show ?thesis by auto
qed

lemma (in vec_space) span_zero: "span {zero V} = {zero V}"
  by (metis (no_types, lifting) empty_subsetI in_own_span span_is_submodule span_is_subset
  span_is_subset2 subset_antisym vectorspace.span_empty vectorspace_axioms)

lemma (in vec_space) dim_zero_vs: "vectorspace.dim class_ring (span_vs {}) = 0"
proof -
  have "vectorspace class_ring (span_vs {})" using field.field_axioms span_is_submodule submodule_is_module vectorspace_def by auto
  have "{} \<subseteq> carrier_vec n \<and> lin_indpt {}"
    by (metis (no_types) empty_subsetI fin_dim finite_basis_exists subset_li_is_li vec_vs vectorspace.basis_def)
  then have "vectorspace.basis class_ring (span_vs {}) {}" using vectorspace.basis_def
    by (simp add: \<open>vectorspace class_ring (vs (span {}))\<close> span_is_submodule span_li_not_depend(1) span_li_not_depend(2) vectorspace.basis_def)
  then show ?thesis using \<open>vectorspace class_ring (vs (span {}))\<close> vectorspace.dim_basis by fastforce
qed

lemma (in vec_space) rank_0I: "rank (0\<^sub>m n nc) = 0"
proof -
  have "set (cols (0\<^sub>m n nc)) \<subseteq> {0\<^sub>v n}"
    by (metis col_zero cols_length cols_nth in_set_conv_nth insertCI index_zero_mat(3) subsetI)
  have "set (cols (0\<^sub>m n nc::'a mat)) = {} \<or> set (cols (0\<^sub>m n nc)) = {0\<^sub>v n::'a vec}"
    by (meson \<open>set (cols (0\<^sub>m n nc)) \<subseteq> {0\<^sub>v n}\<close> subset_singletonD)
  then have "span (set (cols (0\<^sub>m n nc))) = {0\<^sub>v n}"
    by (metis (no_types) span_empty span_zero vectorspace.span_empty vectorspace_axioms)
  then show ?thesis unfolding rank_def \<open>span (set (cols (0\<^sub>m n nc))) = {0\<^sub>v n}\<close>
    using span_empty dim_zero_vs by simp
qed

lemma (in vec_space) rank_le_1_product_entries:
fixes f g::"nat \<Rightarrow> 'a"
assumes "A \<in> carrier_mat n nc"
assumes "\<And>r c. r<dim_row A \<Longrightarrow> c<dim_col A \<Longrightarrow> A $$ (r,c) = f r * g c"
shows "rank A \<le> 1"
proof -
  have "set (cols A) \<subseteq> span {vec n f}"
  proof
    fix v assume "v \<in> set (cols A)"
    then obtain c where "c < dim_col A" "v = col A c" by (metis cols_length cols_nth in_set_conv_nth)
    have "g c \<cdot>\<^sub>v vec n f = v"
    proof (rule eq_vecI)
      show "dim_vec (g c \<cdot>\<^sub>v Matrix.vec n f) = dim_vec v" using \<open>v = col A c\<close> assms(1) by auto
      fix r assume "r < dim_vec v"
      then have "r < dim_vec (Matrix.vec n f)" using \<open>dim_vec (g c \<cdot>\<^sub>v Matrix.vec n f) = dim_vec v\<close> by auto
      then have "r < n" "r < dim_row A"using index_smult_vec(2) \<open>A \<in> carrier_mat n nc\<close> by auto
      show "(g c \<cdot>\<^sub>v Matrix.vec n f) $ r = v $ r"
        unfolding \<open>v = col A c\<close> col_def index_smult_vec(1)[OF \<open>r < dim_vec (Matrix.vec n f)\<close>]
        index_vec[OF \<open>r < n\<close>] index_vec[OF \<open>r < dim_row A\<close>] by (simp add: \<open>c < dim_col A\<close> \<open>r < dim_row A\<close> assms(2))
    qed
    then show "v \<in> span {vec n f}" using submodule.smult_closed[OF span_is_submodule]
      using UNIV_I empty_subsetI insert_subset span_self dim_vec module_vec_simps(4) by auto
  qed
  have "vectorspace class_ring (vs (span {Matrix.vec n f}))" using span_is_subspace[THEN subspace_is_vs, of "{vec n f}"] by auto
  have "submodule class_ring (span {Matrix.vec n f}) V" by (simp add: span_is_submodule)
  have "subspace class_ring(span (set (cols A))) (vs (span {Matrix.vec n f}))"
    using vectorspace.span_is_subspace[OF \<open>vectorspace class_ring (vs (span {Matrix.vec n f}))\<close>, of "set (cols A)", unfolded
    span_li_not_depend(1)[OF \<open>set (cols A) \<subseteq> span {vec n f}\<close> \<open>submodule class_ring (span {Matrix.vec n f}) V\<close>]]
    \<open>set (cols A) \<subseteq> span {vec n f}\<close> by auto
  have fin_dim:"vectorspace.fin_dim class_ring (vs (span {Matrix.vec n f}))"
       "vectorspace.fin_dim class_ring (vs (span {Matrix.vec n f})\<lparr>carrier := span (set (cols A))\<rparr>)"
    using fin_dim_span fin_dim_span_cols \<open>A \<in> carrier_mat n nc\<close> by auto
  have "vectorspace.dim class_ring (vs (span {Matrix.vec n f})) \<le> 1"
    using vectorspace.dim_le1I[OF \<open>vectorspace class_ring (vs (span {Matrix.vec n f}))\<close>]
    span_mem span_li_not_depend(1)[OF _ \<open>submodule class_ring (span {Matrix.vec n f}) V\<close>] by simp
  then show ?thesis unfolding rank_def using  "vectorspace.subspace_dim"[OF
    \<open>vectorspace class_ring (vs (span {Matrix.vec n f}))\<close> \<open>subspace class_ring (span (set (cols A))) (vs (span {Matrix.vec n f}))\<close>
    fin_dim(1) fin_dim(2)] by simp
qed

end


section\<open>Values\<close>

text\<open>Our EFSM implementation can currently handle integers and strings. Here we define a sum type
which combines these. We also define an arithmetic in terms of values such that EFSMs do not need
to be strongly typed.\<close>

theory Value
imports Trilean
begin

text_raw\<open>\snip{valuetype}{1}{2}{%\<close>
datatype "value" = Num int | Str String.literal
text_raw\<open>}%endsnip\<close>

fun is_Num :: "value \<Rightarrow> bool" where
  "is_Num (Num _) = True" |
  "is_Num (Str _) = False"

text_raw\<open>\snip{maybeIntArith}{1}{2}{%\<close>
fun maybe_arith_int :: "(int \<Rightarrow> int \<Rightarrow> int) \<Rightarrow> value option \<Rightarrow> value option \<Rightarrow> value option" where
  "maybe_arith_int f (Some (Num x)) (Some (Num y)) = Some (Num (f x y))" |
  "maybe_arith_int _ _ _ = None"
text_raw\<open>}%endsnip\<close>

lemma maybe_arith_int_not_None:
  "maybe_arith_int f a b \<noteq> None = (\<exists>n n'. a = Some (Num n) \<and> b = Some (Num n'))"
  using maybe_arith_int.elims maybe_arith_int.simps(1) by blast

lemma maybe_arith_int_Some:
  "maybe_arith_int f a b = Some (Num x) = (\<exists>n n'. a = Some (Num n) \<and> b = Some (Num n') \<and> f n n' = x)"
  using maybe_arith_int.elims maybe_arith_int.simps(1) by blast

lemma maybe_arith_int_None:
  "(maybe_arith_int f a1 a2 = None) = (\<nexists>n n'. a1 = Some (Num n) \<and> a2 = Some (Num n'))"
  using maybe_arith_int_not_None by blast

lemma maybe_arith_int_Not_Num:
  "(\<forall>n. maybe_arith_int f a1 a2 \<noteq> Some (Num n)) = (maybe_arith_int f a1 a2 = None)"
  by (metis maybe_arith_int.elims option.distinct(1))

lemma maybe_arith_int_never_string: "maybe_arith_int f a b \<noteq> Some (Str x)"
  using maybe_arith_int.elims by blast

definition "value_plus = maybe_arith_int (+)"

lemma value_plus_symmetry: "value_plus x y = value_plus y x"
  apply (induct x y rule: maybe_arith_int.induct)
  by (simp_all add: value_plus_def)

definition "value_minus = maybe_arith_int (-)"

lemma value_minus_never_string: "value_minus a b \<noteq> Some (Str x)"
  by (simp add: maybe_arith_int_never_string value_minus_def)

definition "value_times = maybe_arith_int (*)"

lemma value_times_never_string: "value_times a b \<noteq> Some (Str x)"
  by (simp add: maybe_arith_int_never_string value_times_def)

fun MaybeBoolInt :: "(int \<Rightarrow> int \<Rightarrow> bool) \<Rightarrow> value option \<Rightarrow> value option \<Rightarrow> trilean" where
  "MaybeBoolInt f (Some (Num a)) (Some (Num b)) = (if f a b then true else false)" |
  "MaybeBoolInt _ _ _ = invalid"

lemma MaybeBoolInt_not_num_1:
  "\<forall>n. r \<noteq> Some (Num n) \<Longrightarrow> MaybeBoolInt f n r = invalid"
  using MaybeBoolInt.elims by blast

definition value_gt :: "value option \<Rightarrow> value option \<Rightarrow> trilean"  where
  "value_gt a b \<equiv> MaybeBoolInt (>) a b"

fun value_eq :: "value option \<Rightarrow> value option \<Rightarrow> trilean" where
  "value_eq None _ = invalid" |
  "value_eq _ None = invalid" |
  "value_eq (Some a) (Some b) = (if a = b then true else false)"

lemma value_eq_true: "(value_eq a b = true) = (\<exists>x y. a = Some x \<and> b = Some y \<and> x = y)"
  by (cases a; cases b, auto)

lemma value_eq_false: "(value_eq a b = false) = (\<exists>x y. a = Some x \<and> b = Some y \<and> x \<noteq> y)"
  by (cases a; cases b, auto)

lemma value_gt_true_Some: "value_gt a b = true \<Longrightarrow> (\<exists>x. a = Some x) \<and> (\<exists>y. b = Some y)"
  by (cases a; cases b, auto simp: value_gt_def)

lemma value_gt_true: "(value_gt a b = true) = (\<exists>x y. a = Some (Num x) \<and> b = Some (Num y) \<and> x > y)"
  apply (cases a)
  using value_gt_true_Some apply blast
  apply (cases b)
  using value_gt_true_Some apply blast
  subgoal for aa bb by (cases aa; cases bb, auto simp: value_gt_def)
  done

lemma value_gt_false_Some: "value_gt a b = false \<Longrightarrow> (\<exists>x. a = Some x) \<and> (\<exists>y. b = Some y)"
  by (cases a; cases b, auto simp: value_gt_def)

end


theory Closure
  imports "../03Debruijn/Debruijn"
begin

datatype closure =
  CConst nat
  | CLam ty "closure list" dexpr

datatype cframe =
  CApp1 "closure list" dexpr
  | CApp2 closure
  | CReturn "closure list"

datatype closure_state =
  CSE "cframe list" "closure list"  dexpr
  | CSC "cframe list" closure

fun latest_environment :: "cframe list \<rightharpoonup> closure list" where
  "latest_environment [] = None"
| "latest_environment (CApp1 cs e # s) = latest_environment s"
| "latest_environment (CApp2 c # s) = latest_environment s"
| "latest_environment (CReturn cs # s) = Some cs"

inductive typecheck_closure :: "closure \<Rightarrow> ty \<Rightarrow> bool" (infix ":\<^sub>c\<^sub>l" 50)
      and typecheck_closure_list :: "closure list \<Rightarrow> ty list \<Rightarrow> bool" (infix ":\<^sub>c\<^sub>l\<^sub>s" 50) where
  tcc_const [simp]: "CConst k :\<^sub>c\<^sub>l Base"
| tcc_lam [simp]: "cs :\<^sub>c\<^sub>l\<^sub>s ts \<Longrightarrow> insert_at 0 t\<^sub>1 ts \<turnstile>\<^sub>d e : t\<^sub>2 \<Longrightarrow> CLam t\<^sub>1 cs e :\<^sub>c\<^sub>l Arrow t\<^sub>1 t\<^sub>2"
| tcc_nil [simp]: "[] :\<^sub>c\<^sub>l\<^sub>s []"
| tcc_cons [simp]: "c :\<^sub>c\<^sub>l t \<Longrightarrow> cs :\<^sub>c\<^sub>l\<^sub>s ts \<Longrightarrow> c # cs :\<^sub>c\<^sub>l\<^sub>s t # ts"

inductive_cases [elim]:"CConst k :\<^sub>c\<^sub>l t"
inductive_cases [elim]: "CLam t\<^sub>1 cs e :\<^sub>c\<^sub>l t"
inductive_cases [elim]: "[] :\<^sub>c\<^sub>l\<^sub>s ts"
inductive_cases [elim]: "c # cs :\<^sub>c\<^sub>l\<^sub>s ts"

inductive typecheck_cstack :: "cframe list \<Rightarrow> ty \<Rightarrow> ty \<Rightarrow> bool" (infix ":\<^sub>c _ \<rightarrow>" 50) where
  tcc_snil [simp]: "[] :\<^sub>c t \<rightarrow> t"
| tcc_scons_app1 [simp]: "cs :\<^sub>c\<^sub>l\<^sub>s ts \<Longrightarrow> ts \<turnstile>\<^sub>d e : t\<^sub>1 \<Longrightarrow> s :\<^sub>c t\<^sub>2 \<rightarrow> t \<Longrightarrow>
    latest_environment s = Some cs \<Longrightarrow> CApp1 cs e # s :\<^sub>c Arrow t\<^sub>1 t\<^sub>2 \<rightarrow> t"
| tcc_scons_app2 [simp]: "c :\<^sub>c\<^sub>l Arrow t\<^sub>1 t\<^sub>2 \<Longrightarrow> s :\<^sub>c t\<^sub>2 \<rightarrow> t \<Longrightarrow> latest_environment s = Some cs \<Longrightarrow>
    CApp2 c # s :\<^sub>c t\<^sub>1 \<rightarrow> t"
| tcc_scons_ret [simp]: "cs :\<^sub>c\<^sub>l\<^sub>s ts \<Longrightarrow> s :\<^sub>c t' \<rightarrow> t \<Longrightarrow> CReturn cs # s :\<^sub>c t' \<rightarrow> t"

inductive_cases [elim]: "[] :\<^sub>c t' \<rightarrow> t"
inductive_cases [elim]: "CApp1 cs e # s :\<^sub>c t' \<rightarrow> t"
inductive_cases [elim]: "CApp2 c # s :\<^sub>c t' \<rightarrow> t"
inductive_cases [elim]: "CReturn cs # s :\<^sub>c t' \<rightarrow> t"

inductive typecheck_closure_state :: "closure_state \<Rightarrow> ty \<Rightarrow> bool" (infix ":\<^sub>c" 50) where
  tcc_state_ev [simp]: "s :\<^sub>c t' \<rightarrow> t \<Longrightarrow> cs :\<^sub>c\<^sub>l\<^sub>s ts \<Longrightarrow> latest_environment s = Some cs \<Longrightarrow>
    ts \<turnstile>\<^sub>d e : t' \<Longrightarrow> CSE s cs e :\<^sub>c t"
| tcc_state_ret [simp]: "s :\<^sub>c t' \<rightarrow> t \<Longrightarrow> c :\<^sub>c\<^sub>l t' \<Longrightarrow> CSC s c :\<^sub>c t"

inductive_cases [elim]: "CSE s cs e :\<^sub>c t"
inductive_cases [elim]: "CSC s c :\<^sub>c t"

inductive evalc :: "closure_state \<Rightarrow> closure_state \<Rightarrow> bool" (infix "\<leadsto>\<^sub>c" 50) where
  evc_var [simp]: "lookup cs x = Some c \<Longrightarrow> CSE s cs (DVar x) \<leadsto>\<^sub>c CSC s c"
| evc_con [simp]: "CSE s cs (DConst k) \<leadsto>\<^sub>c CSC s (CConst k)"
| evc_lam [simp]: "CSE s cs (DLam t e) \<leadsto>\<^sub>c CSC s (CLam t cs e)"
| evc_app [simp]: "CSE s cs (DApp e\<^sub>1 e\<^sub>2) \<leadsto>\<^sub>c CSE (CApp1 cs e\<^sub>2 # s) cs e\<^sub>1"
| retc_app1 [simp]: "CSC (CApp1 cs e\<^sub>2 # s) c\<^sub>1 \<leadsto>\<^sub>c CSE (CApp2 c\<^sub>1 # s) cs e\<^sub>2"
| retc_app2 [simp]: "CSC (CApp2 (CLam t cs e\<^sub>1) # s) c\<^sub>2 \<leadsto>\<^sub>c CSE (CReturn (c\<^sub>2 # cs) # s) (c\<^sub>2 # cs) e\<^sub>1"
| retc_ret [simp]: "CSC (CReturn cs # s) c \<leadsto>\<^sub>c CSC s c"

lemma canonical_basec [dest]: "c :\<^sub>c\<^sub>l Base \<Longrightarrow> \<exists>k. c = CConst k"
  by (induction c Base rule: typecheck_closure_typecheck_closure_list.inducts(1)) simp_all

lemma canonical_arrowc [dest]: "c :\<^sub>c\<^sub>l Arrow t\<^sub>1 t\<^sub>2 \<Longrightarrow>
    \<exists>cs ts e. c = CLam t\<^sub>1 cs e \<and> (cs :\<^sub>c\<^sub>l\<^sub>s ts) \<and> (insert_at 0 t\<^sub>1 ts \<turnstile>\<^sub>d e : t\<^sub>2)"
  by (induction c "Arrow t\<^sub>1 t\<^sub>2" rule: typecheck_closure_typecheck_closure_list.inducts(1)) auto

lemma  "c :\<^sub>c\<^sub>l t \<Longrightarrow> True"
  and [simp]: "cs :\<^sub>c\<^sub>l\<^sub>s \<Gamma> \<Longrightarrow> lookup \<Gamma> x = Some t \<Longrightarrow> \<exists>c. lookup cs x = Some c \<and> c :\<^sub>c\<^sub>l t"
proof (induction c t and cs \<Gamma> arbitrary: and x
       rule: typecheck_closure_typecheck_closure_list.inducts)
  case (tcc_cons c t cs ts)
  thus ?case by (induction x) simp_all
qed simp_all

lemma [simp]: "s :\<^sub>c t' \<rightarrow> t \<Longrightarrow> c :\<^sub>c\<^sub>l t' \<Longrightarrow> s = [] \<or> (\<exists>\<Sigma>'. CSC s c \<leadsto>\<^sub>c \<Sigma>')"
proof (induction s t' t rule: typecheck_cstack.induct)
  case (tcc_scons_app1 cs ts e\<^sub>2 t\<^sub>1 s t\<^sub>2 t)
  moreover hence "CSC (CApp1 cs e\<^sub>2 # s) c \<leadsto>\<^sub>c CSE (CApp2 c # s) cs e\<^sub>2" by simp
  ultimately show ?case by fastforce
next
  case (tcc_scons_app2 c\<^sub>1 t\<^sub>1 t\<^sub>2 s t)
  then obtain cs ts e where "c\<^sub>1 = CLam t\<^sub>1 cs e \<and> (cs :\<^sub>c\<^sub>l\<^sub>s ts) \<and> (insert_at 0 t\<^sub>1 ts \<turnstile>\<^sub>d e : t\<^sub>2)"
    by blast
  moreover hence "CSC (CApp2 (CLam t\<^sub>1 cs e) # s) c \<leadsto>\<^sub>c CSE (CReturn (c # cs) # s) (c # cs) e" by simp
  ultimately show ?case by fastforce
next
  case (tcc_scons_ret cs ts s t' t)
  have "CSC (CReturn cs # s) c \<leadsto>\<^sub>c CSC s c" by simp
  thus ?case by fastforce
qed simp_all

theorem progressc: "\<Sigma> :\<^sub>c t \<Longrightarrow> (\<exists>c. \<Sigma> = CSC [] c) \<or> (\<exists>\<Sigma>'. \<Sigma> \<leadsto>\<^sub>c \<Sigma>')"
  by (induction \<Sigma> t rule: typecheck_closure_state.induct) simp_all

theorem preservationc [simp]: "\<Sigma> \<leadsto>\<^sub>c \<Sigma>' \<Longrightarrow> \<Sigma> :\<^sub>c t \<Longrightarrow> \<Sigma>' :\<^sub>c t"
proof (induction \<Sigma> \<Sigma>' rule: evalc.induct)
  case (evc_var cs x c s)
  then obtain t' ts where X: "s :\<^sub>c t' \<rightarrow> t" and "(cs :\<^sub>c\<^sub>l\<^sub>s ts) \<and> lookup ts x = Some t'" by blast
  then obtain c' where "lookup cs x = Some c' \<and> c' :\<^sub>c\<^sub>l t'" by fastforce
  with evc_var X show ?case by simp
next
  case (evc_app s cs e\<^sub>1 e\<^sub>2)
  then obtain t\<^sub>1 t\<^sub>2 ts where "(s :\<^sub>c t\<^sub>2 \<rightarrow> t) \<and> (ts \<turnstile>\<^sub>d e\<^sub>2 : t\<^sub>1)"
   and X: "(cs :\<^sub>c\<^sub>l\<^sub>s ts) \<and> latest_environment s = Some cs \<and> (ts \<turnstile>\<^sub>d e\<^sub>1 : Arrow t\<^sub>1 t\<^sub>2)" by blast
  hence "CApp1 cs e\<^sub>2 # s :\<^sub>c Arrow t\<^sub>1 t\<^sub>2 \<rightarrow> t"  by fastforce
  with X show ?case by fastforce
next
  case (retc_app1 cs e\<^sub>2 s c\<^sub>1)
  then obtain ts t\<^sub>1 t\<^sub>2 where X: "(cs :\<^sub>c\<^sub>l\<^sub>s ts) \<and> latest_environment s = Some cs \<and> (ts \<turnstile>\<^sub>d e\<^sub>2 : t\<^sub>1)"
   and "(s :\<^sub>c t\<^sub>2 \<rightarrow> t) \<and> (c\<^sub>1 :\<^sub>c\<^sub>l Arrow t\<^sub>1 t\<^sub>2)" by blast
  hence "CApp2 c\<^sub>1 # s :\<^sub>c t\<^sub>1 \<rightarrow> t" by fastforce
  with X show ?case by fastforce
next
  case (retc_app2 t\<^sub>1 cs e\<^sub>1 s c\<^sub>2)
  then obtain ts t\<^sub>2 where X: "s :\<^sub>c t\<^sub>2 \<rightarrow> t" and Y: "insert_at 0 t\<^sub>1 ts \<turnstile>\<^sub>d e\<^sub>1 : t\<^sub>2"
   and "(cs :\<^sub>c\<^sub>l\<^sub>s ts) \<and> (c\<^sub>2 :\<^sub>c\<^sub>l t\<^sub>1)" by blast
  hence Z: "c\<^sub>2 # cs :\<^sub>c\<^sub>l\<^sub>s insert_at 0 t\<^sub>1 ts" by (induction ts) simp_all
  with X have "CReturn (c\<^sub>2 # cs) # s :\<^sub>c t\<^sub>2 \<rightarrow> t" by simp
  with Y Z show ?case by fastforce
qed fastforce+

lemma [simp]: "iter (\<leadsto>\<^sub>c) \<Sigma> \<Sigma>' \<Longrightarrow> \<Sigma> :\<^sub>c t \<Longrightarrow> \<Sigma>' :\<^sub>c t"
  by (induction \<Sigma> \<Sigma>' rule: iter.induct) simp_all

theorem determinismc: "\<Sigma> \<leadsto>\<^sub>c \<Sigma>' \<Longrightarrow> \<Sigma> \<leadsto>\<^sub>c \<Sigma>'' \<Longrightarrow> \<Sigma>' = \<Sigma>''"
proof (induction \<Sigma> \<Sigma>' rule: evalc.induct)
  case (evc_var cs x c s)
  from evc_var(2, 1) show ?case by (induction "CSE s cs (DVar x)" \<Sigma>'' rule: evalc.induct) simp_all
next
  case (evc_con s cs k)
  thus ?case by (induction "CSE s cs (DConst k)" \<Sigma>'' rule: evalc.induct) simp_all
next
  case (evc_lam s cs t e)
  thus ?case by (induction "CSE s cs (DLam t e)" \<Sigma>'' rule: evalc.induct) simp_all
next
  case (evc_app s cs e\<^sub>1 e\<^sub>2)
  thus ?case by (induction "CSE s cs (DApp e\<^sub>1 e\<^sub>2)" \<Sigma>'' rule: evalc.induct) simp_all
next
  case (retc_app1 cs e\<^sub>2 s c\<^sub>1)
  thus ?case by (induction "CSC (CApp1 cs e\<^sub>2 # s) c\<^sub>1" \<Sigma>'' rule: evalc.induct) simp_all
next
  case (retc_app2 t cs e\<^sub>1 s c\<^sub>2)
  thus ?case by (induction "CSC (CApp2 (CLam t cs e\<^sub>1) # s) c\<^sub>2" \<Sigma>'' rule: evalc.induct) simp_all
next
  case (retc_ret cs s c)
  thus ?case by (induction "CSC (CReturn cs # s) c" \<Sigma>'' rule: evalc.induct) simp_all
qed

end


(* This Isabelle theory is produced using the TIP tool offered at the following website:
     https://github.com/tip-org/tools
   This file was originally provided as part of TIP benchmark at the following website:
     https://github.com/tip-org/benchmarks
   Yutaka Nagashima at CIIRC, CTU changed the TIP output theory file slightly
   to make it compatible with Isabelle2017.
\:w
   Some proofs were added by Yutaka Nagashima.*)
  theory TIP_nat_pow_le_factorial
imports "../../Test_Base"
begin

datatype Nat = Z | S "Nat"

fun plus :: "Nat => Nat => Nat" where
"plus (Z) y = y"
| "plus (S z) y = S (plus z y)"

fun times :: "Nat => Nat => Nat" where
"times (Z) y = Z"
| "times (S z) y = plus y (times z y)"

fun lt :: "Nat => Nat => bool" where
"lt x (Z) = False"
| "lt (Z) (S z) = True"
| "lt (S n) (S z) = lt n z"

fun formulapow :: "Nat => Nat => Nat" where
"formulapow x (Z) = S Z"
| "formulapow x (S z) = times x (formulapow x z)"

fun factorial :: "Nat => Nat" where
"factorial (Z) = S Z"
| "factorial (S y) = times (S y) (factorial y)"

theorem property0 :
  "lt
     (formulapow (S (S Z)) (plus (S (S (S (S Z)))) n))
     (factorial (plus (S (S (S (S Z)))) n))"
  oops

end


(* This Isabelle theory is produced using the TIP tool offered at the following website:
     https://github.com/tip-org/tools
   This file was originally provided as part of TIP benchmark at the following website:
     https://github.com/tip-org/benchmarks
   Yutaka Nagashima at CIIRC, CTU changed the TIP output theory file slightly
   to make it compatible with Isabelle2017.
\:w
   Some proofs were added by Yutaka Nagashima.*)
  theory TIP_int_mul_comm
imports "../../Test_Base"
begin

datatype Sign = Pos | Neg

datatype Nat = Z | S "Nat"

datatype Integer = P "Nat" | N "Nat"

fun toInteger :: "Sign => Nat => Integer" where
"toInteger (Pos) y = P y"
| "toInteger (Neg) (Z) = P Z"
| "toInteger (Neg) (S z) = N z"

fun sign :: "Integer => Sign" where
"sign (P y) = Pos"
| "sign (N z) = Neg"

fun pred :: "Nat => Nat" where
"pred (S y) = y"

fun plus :: "Nat => Nat => Nat" where
"plus (Z) y = y"
| "plus (S z) y = S (plus z y)"

fun times2 :: "Nat => Nat => Nat" where
"times2 (Z) y = Z"
| "times2 (S z) y = plus y (times2 z y)"

fun opposite :: "Sign => Sign" where
"opposite (Pos) = Neg"
| "opposite (Neg) = Pos"

fun timesSign :: "Sign => Sign => Sign" where
"timesSign (Pos) y = y"
| "timesSign (Neg) y = opposite y"

fun absVal :: "Integer => Nat" where
"absVal (P n) = n"
| "absVal (N m) = plus (S Z) m"

fun times :: "Integer => Integer => Integer" where
"times x y =
   toInteger
     (timesSign (sign x) (sign y)) (times2 (absVal x) (absVal y))"

theorem property0 :
  "((times x y) = (times y x))"
  oops

end


theory VDMToolkitTest
imports VDMToolkit
begin

text \<open> VDM maps auxiliary functions \<close>

(* dom exists already *)
thm dom_def
find_theorems "dom _"

subsection \<open> Map translations: enumeration, comprehension \<close>

(* map values are given as *)
value "[ (0::nat) \<mapsto> (7::nat), 1  \<mapsto> 5 ]"
value "[ (0::int) \<mapsto> (1::int), 1  \<mapsto> 5 ] 0"
value "the ([ (0::int) \<mapsto> (1::int), 1  \<mapsto> 5 ] 0)"

value "the (Some b)"
value "Map.empty(A \<mapsto> 0)"
value "Map.empty(A := Some 0)"
value "[A \<mapsto> 0]"
value "[A \<mapsto> 0, B \<mapsto> 1]"

(*
value "the None"
value "Map.empty"
value "the ([ (1::int) \<mapsto> (1::int), 2  \<mapsto> 1, 3 \<mapsto> 2 ] (4::int)) + (3::int)"
value "the ([ (0::nat) \<mapsto> (0::nat), 1  \<mapsto> 5 ] (4::nat))"
*)
lemma "the ([ (1::int) \<mapsto> (1::int), 2  \<mapsto> 1, 3 \<mapsto> 2 ] (4::int)) + (3::int) = A" apply simp oops
lemma "the ([ (1::int) \<mapsto> (1::int), 2  \<mapsto> 1, 3 \<mapsto> 2 ] 2) + 3 = 4" by simp

find_theorems "the _"

text \<open> Not always it's possible to see their values as
   maps encodings are more complex. You could use
   Isabelle prover as a debugger
 \<close>

lemma "dom [ A \<mapsto> 0, B \<mapsto> 1] = LOOK_HERE" apply simp oops

value "Map.empty(A \<mapsto> 0)"
value "Map.empty(A := Some 0)"
value "[A \<mapsto> 0]"
value "[A \<mapsto> 0, B \<mapsto> 1]"

lemma "dom [ A \<mapsto> 0, B \<mapsto> 1] = LOOK_HERE" apply simp oops
lemma "ran [ A \<mapsto> (0::nat), B \<mapsto> 1] = {0,1}" apply simp oops

(* rng also exists as ran *)
thm ran_def
find_theorems "ran _"

lemma "ran [ A \<mapsto> (0::nat), B \<mapsto> 1] = {0,1}" apply simp oops

subsection \<open>Map comprehension examples, pitfalls and proof scenarios\<close>

(*On the explicit (narrower/declared) type, add inv_VDMNat1
  v98: map nat to nat1 = { d \<mapsto> r | d in set {1,2,3}, r in set {2,4,6} & r = d*2 } *)
definition
  ex1 :: "VDMNat \<rightharpoonup> VDMNat1"
  where
  "ex1 \<equiv> mapCompSetBound {1,2,3::VDMNat} {2,4,6::VDMNat} inv_VDMNat inv_VDMNat1 domid rngid (\<lambda> d r . r = d*2)"

lemmas ex1_defs = ex1_def mapCompSetBound_defs inv_VDMNat1_def inv_VDMNat_def

lemma ex1_none: "x \<notin> dom ex1  \<Longrightarrow> ex1 x = None"
  by (simp add: domIff)

lemma ex1_dom: "dom ex1 = {1,2,3}"
  unfolding dom_def ex1_defs
  by (simp split:if_splits, safe)

lemma ex1_rng:"rng ex1 = {2,4,6}"
  unfolding rng_defs ex1_defs
  apply (simp split:if_splits)
  apply (intro equalityI subsetI, simp_all)
  (* apply (elim exE conjE impE)*) (* this will be fiddly! *)
  apply (elim exE conjE disjE, simp_all)
     apply (fastforce, fastforce, fastforce)
  by (smt (z3) semiring_norm(83) the_equality verit_eq_simplify(14) zero_le_numeral)

(*@TODO add invariant failure to undefined tests! *)

lemma ex1_map: "x \<in> dom ex1 \<Longrightarrow> ex1 x = Some (2*x)"
  unfolding ex1_defs
  apply (simp split:if_splits, safe, force+)
  thm option.discI
  by (metis option.discI)

(*On the implicit (wider/presumed) type, add inv_VDMNat; these funny binds are tricky!
  v98 = { x+y |-> 10 | x in set {1,2,3}, y in set {4,5,6} } *)
definition
  ex2 :: "VDMNat \<rightharpoonup> VDMNat"
  where
  "ex2 \<equiv> mapCompSetBound {1,2,3::VDMNat} {4,5,6::VDMNat} inv_VDMNat inv_VDMNat (\<lambda> x . (\<lambda> y . x+y)) (rngcnst 10) truecnst"

lemmas ex2_defs = ex2_def mapCompSetBound_defs inv_VDMNat_def

lemma ex2_none: "x \<notin> dom ex2  \<Longrightarrow> ex2 x = None"
  by (simp add: domIff)

lemma ex2_dom: "dom ex2 = {5,6,7,8,9}"
  unfolding ex2_defs
  apply (simp split:if_splits)
  oops

definition
  ex2' :: "VDMNat \<rightharpoonup> VDMNat"
  where
  "ex2' \<equiv> mapCompSetBound { x + y | x y . x \<in> {1,2,3::VDMNat} \<and> y \<in> {4,5,6::VDMNat} } {10::VDMNat}
                inv_VDMNat inv_VDMNat domid (rngcnst 10) truecnst"

lemmas ex2'_defs = ex2'_def mapCompSetBound_defs inv_VDMNat_def truecnst_def domid_def

lemma ex2'_none: "x \<notin> dom ex2'  \<Longrightarrow> ex2' x = None"
  unfolding ex2'_defs
  by (simp add: domIff)

lemma ex2'_dom: "dom ex2' = {5,6,7,8,9}"
  unfolding ex2'_defs
  apply (simp split:if_splits, safe) oops

lemma ex2'_dom_finite: "finite { x + y | x y . x \<in> {1,2,3::VDMNat} \<and> y \<in> {4,5,6::VDMNat} }"
  by (simp add: finite_image_set2)

lemma ex2'_dom_clearer: "{ x + y | x y . x \<in> {1,2,3::VDMNat} \<and> y \<in> {4,5,6::VDMNat} } = {5..9::VDMNat}"
  apply (safe, simp_all)
  by presburger

lemma ex2'_dom_inv: "inv_SetElems ((\<le>) (0::VDMNat)) {5..(9::VDMNat)}"
  unfolding inv_SetElems_def
  by (safe,simp)

lemma ex2'_dom_inv': "inv_SetElems inv_VDMNat {5..9}"
  unfolding inv_SetElems_def inv_VDMNat_def
  by (safe,simp)

lemma ex2'_dom: "dom ex2' = {5,6,7,8,9}"
  unfolding ex2'_def mapCompSetBound_def inv_VDMSet'_def inv_VDMSet_def truecnst_def
  apply (simp only: ex2'_dom_finite ex2'_dom_clearer, simp split:if_splits add: ex2'_dom_inv' inv_VDMNat_def)
  unfolding domid_def rngcnst_def inv_True_def inv_VDMNat_def
  apply (safe, simp_all)
  thm option.distinct
  by (smt (z3) option.distinct(1))

lemma ex2'_rng:"rng ex2' = {10}"
  unfolding rng_defs ex2'_def mapCompSetBound_def inv_VDMSet'_def inv_VDMSet_def truecnst_def
  apply (simp only: ex2'_dom_finite ex2'_dom_clearer, simp split:if_splits add: ex2'_dom_inv' inv_VDMNat_def)
  by (safe, simp_all, force+)

lemma ex2'_map: "x \<in> dom ex2' \<Longrightarrow> ex2' x = Some 10"
  unfolding ex2'_defs (* don't expand inv_VDMNat *)
  apply (simp split:if_splits)
  (* complex domain patterns lead to loads of cases Jeez! no safe *)
  apply (intro conjI impI, force) oops

lemma ex2'_map: "x \<in> dom ex2' \<Longrightarrow> ex2' x = Some 10"
  unfolding ex2'_def mapCompSetBound_def domid_def rngcnst_def truecnst_def inv_True_def
  apply (simp split:if_splits)
  (* complex domain patterns lead to loads of cases Jeez! no safe *)
  apply (intro conjI impI)
  find_theorems intro name:the
     apply (rule the_equality, simp add: inv_VDMNat_def, blast)
  apply (simp add: inv_VDMSet'_def inv_VDMSet_def inv_VDMNat_def) (* clearly true by contradiction, but finite is struggling *)
  oops

lemma l_finite_setcomp_finite[simp]: "finite S \<Longrightarrow> finite T \<Longrightarrow> finite { P x y | x y . x \<in> S \<and> y \<in> T }"
  by (simp add: finite_image_set2)

thm finite_image_set2 finite_subset
lemma ex2'_map: "x \<in> dom ex2' \<Longrightarrow> ex2' x = Some 10"
  unfolding ex2'_defs
  apply (insert l_finite_setcomp_finite[of _ _ "\<lambda> x y . x+y"]) (* lemma above not quite in right shape *)
  oops

lemma ex2'_map: "x \<in> dom ex2' \<Longrightarrow> ex2' x = Some 10"
  unfolding ex2'_def mapCompSetBound_def domid_def rngcnst_def truecnst_def inv_True_def
  apply (simp split:if_splits)
  apply (intro conjI impI)
     apply (rule the_equality, simp add: inv_VDMNat_def, blast)
  (*apply (smt (z3) Collect_cong atLeastAtMost_iff ex2'_dom_clearer ex2'_dom_finite mem_Collect_eq) *)(* horrible! *)
  apply (elim impE)
     apply (simp add: inv_VDMSet'_def inv_VDMSet_def inv_VDMNat_def inv_SetElems_def)
  apply (rule conjI)
  using ex2'_dom_finite apply force
     apply fastforce
  oops

lemma l_invVDMSet_finite[simp]: "finite S \<Longrightarrow> inv_SetElems inv_T S \<Longrightarrow> inv_VDMSet' inv_T S"
  by (simp add: inv_VDMSet'_def)

lemma ex2'_map: "x \<in> dom ex2' \<Longrightarrow> ex2' x = Some 10"
  unfolding ex2'_def mapCompSetBound_def domid_def rngcnst_def truecnst_def inv_True_def
  apply (simp split:if_splits)
  apply (intro conjI impI, simp)
     apply (rule the_equality, simp add: inv_VDMNat_def, blast)
    apply (erule impE)
  using ex2'_dom_clearer ex2'_dom_inv' apply auto[1]
  using inv_VDMNat_def apply auto[1]
   apply (smt (verit, del_insts) atLeastAtMost_iff ex2'_dom_clearer l_map_dom_ran)
(*  by (smt (z3) Collect_cong atLeastAtMost_iff ex2'_dom_clearer ex2'_dom_finite finite.emptyI finite.insertI inv_SetElems_def inv_VDMNat_def l_invVDMSet_finite mem_Collect_eq singletonD) *)
  apply (erule impE)
  using ex2'_dom_clearer ex2'_dom_inv' apply force
  by (simp add: inv_VDMNat_def)

(* more direct binds even if with range expressions it's fine. UNIV isn't finite! DUH
   = { x |-> x+5 | x in set {1,2,3,4} & x > 2 } *)
definition
  ex3 :: "VDMNat \<rightharpoonup> VDMNat"
  where
  "ex3 \<equiv> mapCompSetBound {1,2,3,4::VDMNat} UNIV inv_VDMNat inv_VDMNat domid (\<lambda> x . (\<lambda> y . x + 5)) (\<lambda> x . (\<lambda> y . x > 2))"

lemmas ex3_defs = ex3_def mapCompSetBound_defs inv_VDMNat_def

lemma ex3_none: "x \<notin> dom ex3  \<Longrightarrow> ex3 x = None"
  by (simp add: domIff)

lemma ex3_dom: "dom ex3 = {5,6,7,8,9}"
  unfolding ex3_defs
  apply (simp split:if_splits, safe)
  (* Nice example of how it goes "wrong" with undefined! *)
  oops

lemma ex3_dom: "dom ex3 = {1,2,3,4}"
  unfolding ex3_defs
  apply (simp split:if_splits, safe) oops
  (* Nice example of how it goes "wrong" with undefined! *)

lemma ex3_dom: "dom ex3 = {3,4}"
  unfolding ex3_defs
  apply (simp split:if_splits, safe) oops
  (* Nice example of how it goes "wrong" with undefined! *)

(* more direct binds even if with range expressions it's fine.
   = { x |-> x+5 | x in set {1,2,3,4} & x > 2 } *)
definition
  ex3' :: "VDMNat \<rightharpoonup> VDMNat"
  where
  "ex3' \<equiv> mapCompSetBound {1,2,3,4::VDMNat} { x + 5 | x . x \<in> {1,2,3,4::VDMNat} } inv_VDMNat inv_VDMNat domid (\<lambda> x . (\<lambda> y . x + 5)) (\<lambda> x . (\<lambda> y . x > 2))"

lemmas ex3'_defs = ex3'_def mapCompSetBound_defs inv_VDMNat_def

lemma ex3'_none: "x \<notin> dom ex3'  \<Longrightarrow> ex3' x = None"
  by (simp add: domIff)

lemma ex3'_dom: "dom ex3' = {3,4}"
  unfolding ex3'_def mapCompSetBound_defs inv_SetElems_def inv_VDMNat_def
  apply (simp split:if_splits)
  apply (intro equalityI subsetI, simp_all add: dom_def split:if_splits)
  by fastforce+

lemma ex3'_dom': "dom ex3' = {3,4}"
  unfolding ex3'_defs
  apply (simp split:if_splits)
  apply (intro equalityI subsetI, simp_all add: dom_def split:if_splits)
  using inv_SetElems_def by fastforce+

lemma ex3'_rng: "rng ex3' = {8,9}"
  unfolding ex3'_defs inv_SetElems_def
  apply (simp split:if_splits)
  apply (intro equalityI subsetI)
   apply (simp_all, safe, simp_all)
       apply (rule+, force, force, force, force, force, force, force)
  apply (rule_tac x=3 in exI, force)
  by (rule_tac x=4 in exI, force)

lemma ex3'_map: "x \<in> dom ex3' \<Longrightarrow> ex3' x = Some (x+5)"
  unfolding ex3'_defs
  apply (simp split:if_splits, safe, force)
          apply (linarith, force)
  using inv_SetElems_def apply fastforce
  using inv_SetElems_def apply fastforce
  using inv_SetElems_def apply fastforce
  using inv_SetElems_def apply fastforce
  using inv_SetElems_def apply fastforce
  using inv_SetElems_def apply fastforce
  using inv_SetElems_def by fastforce

(* okay: dead simple ones
   = { x |-> 5 | x in set {1,2,3,4} } *)
definition
  ex4 :: "VDMNat \<rightharpoonup> VDMNat"
  where
  "ex4 \<equiv> mapCompSetBound {1,2,3,4::VDMNat} { 5::VDMNat } inv_VDMNat inv_VDMNat domid (rngcnst 5) truecnst"

lemmas ex4_defs = ex4_def mapCompSetBound_defs inv_VDMNat_def

lemma ex4_none: "x \<notin> dom ex4  \<Longrightarrow> ex4 x = None"
  by (simp add: domIff)

lemma ex4_dom: "dom ex4 = {1,2,3,4}"
  unfolding ex4_def mapCompSetBound_defs inv_SetElems_def inv_VDMNat_def
  apply (simp split:if_splits)
  by (intro equalityI subsetI, simp_all add: dom_def split:if_splits)

lemma ex4_rng: "rng ex4 = {5}"
  unfolding ex4_defs inv_SetElems_def
  apply (simp split:if_splits)
  apply (intro equalityI subsetI, force, simp)
  by (rule_tac x=1 in exI, fastforce)

lemma ex4_map: "x \<in> dom ex4  \<Longrightarrow> ex4 x = Some 5"
  unfolding ex4_defs
  apply (simp split:if_splits, safe, force+)
  by (meson option.distinct(1))
(* for simple domain binds, you get simple enough proofs *)

(* s1: set of real = {1,2,3}, is_(s1, set of int)? *)
lemma "isTest' {1,2,3::VDMReal}
        (vdmset_of_t vdmint_of_real)
        (inv_VDMSet' inv_VDMInt)"
  unfolding isTest'_def vdmset_of_t_def total_coercion_def
  apply simp
  unfolding inv_VDMSet'_def inv_VDMSet_def inv_VDMInt_def inv_SetElems_def
  apply (simp, safe)
  unfolding vdmint_of_real_def is_VDMRealWhole_def
  by (simp_all add: vdm_narrow_real_def)

(* s1: set of real = {1,2,3}, is_(s1, set of nat)? *)
lemma "isTest' {1,2,3::VDMReal}
        (vdmset_of_t vdmint_of_real)
        (inv_VDMSet' inv_VDMNat)"
  unfolding isTest'_def vdmset_of_t_def total_coercion_def
  apply simp
  unfolding inv_VDMSet'_def inv_VDMSet_def inv_VDMNat_def inv_SetElems_def
  apply (simp, safe)
  unfolding vdmint_of_real_def is_VDMRealWhole_def
  by (simp_all add: vdm_narrow_real_def)

lemma "\<not> isTest' (-10)
        (\<lambda> x . if inv_VDMNat x then Some x else None)
        inv_VDMNat"
  unfolding isTest'_def inv_VDMNat_def by simp

lemma "isTest' [1,2,3::VDMNat]
        (\<lambda> x . Some { x$i | i . i \<in> inds x })
        (inv_VDMSet' inv_VDMNat)"
  unfolding isTest'_def
  apply simp
  unfolding inv_VDMSet'_def inv_VDMSet_def inv_VDMNat_def inv_SetElems_def
  apply (simp, safe)
  unfolding applyVDMSeq_def inv_VDMNat1_def len_def
  apply simp
  by (simp add: nth_Cons')

end


theory T16
imports Main
begin
lemma "(
(\<forall> x::nat. \<forall> y::nat. meet(x, y) = meet(y, x)) &
(\<forall> x::nat. \<forall> y::nat. join(x, y) = join(y, x)) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. meet(x, meet(y, z)) = meet(meet(x, y), z)) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. join(x, join(y, z)) = join(join(x, y), z)) &
(\<forall> x::nat. \<forall> y::nat. meet(x, join(x, y)) = x) &
(\<forall> x::nat. \<forall> y::nat. join(x, meet(x, y)) = x) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. mult(x, join(y, z)) = join(mult(x, y), mult(x, z))) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. mult(join(x, y), z) = join(mult(x, z), mult(y, z))) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. meet(x, over(join(mult(x, y), z), y)) = x) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. meet(y, undr(x, join(mult(x, y), z))) = y) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. join(mult(over(x, y), y), x) = x) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. join(mult(y, undr(y, x)), x) = x) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. mult(meet(x, y), z) = meet(mult(x, z), mult(y, z))) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. undr(x, join(y, z)) = join(undr(x, y), undr(x, z))) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. over(x, meet(y, z)) = join(over(x, y), over(x, z))) &
(\<forall> x::nat. \<forall> y::nat. invo(join(x, y)) = meet(invo(x), invo(y))) &
(\<forall> x::nat. \<forall> y::nat. invo(meet(x, y)) = join(invo(x), invo(y))) &
(\<forall> x::nat. invo(invo(x)) = x)
) \<longrightarrow>
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. mult(x, meet(y, z)) = meet(mult(x, y), mult(x, z)))
"
nitpick[card nat=7,timeout=86400]
oops
end


(* This Isabelle theory is produced using the TIP tool offered at the following website:
     https://github.com/tip-org/tools
   This file was originally provided as part of TIP benchmark at the following website:
     https://github.com/tip-org/benchmarks
   Yutaka Nagashima at CIIRC, CTU changed the TIP output theory file slightly
   to make it compatible with Isabelle2017.
\:w
   Some proofs were added by Yutaka Nagashima.*)
  theory TIP_relaxedprefix_is_prefix_4
imports "../../Test_Base"
begin

datatype 'a list = nil2 | cons2 "'a" "'a list"

datatype It = A | B | C

fun x :: "'a list => 'a list => 'a list" where
"x (nil2) z = z"
| "x (cons2 z2 xs) z = cons2 z2 (x xs z)"

fun isPrefix :: "It list => It list => bool" where
"isPrefix (nil2) z = True"
| "isPrefix (cons2 z2 x2) (nil2) = False"
| "isPrefix (cons2 z2 x2) (cons2 x3 x4) =
     ((z2 = x3) & (isPrefix x2 x4))"

fun isRelaxedPrefix :: "It list => It list => bool" where
"isRelaxedPrefix (nil2) z = True"
| "isRelaxedPrefix (cons2 z2 (nil2)) z = True"
| "isRelaxedPrefix (cons2 z2 (cons2 x3 x4)) (nil2) = False"
| "isRelaxedPrefix (cons2 z2 (cons2 x3 x4)) (cons2 x5 x6) =
     (if (z2 = x5) then isRelaxedPrefix (cons2 x3 x4) x6 else
        isPrefix (cons2 x3 x4) (cons2 x5 x6))"

theorem property0 :
  "isRelaxedPrefix (cons2 y xs) (x xs ys)"
  oops

end


(* This Isabelle theory is produced using the TIP tool offered at the following website:
     https://github.com/tip-org/tools
   This file was originally provided as part of TIP benchmark at the following website:
     https://github.com/tip-org/benchmarks
   Yutaka Nagashima at CIIRC, CTU changed the TIP output theory file slightly
   to make it compatible with Isabelle2017.*)
  theory TIP_sort_MSortBUSorts
  imports "../../Test_Base"
begin

datatype 'a list = nil2 | cons2 "'a" "'a list"

fun ordered :: "int list => bool" where
  "ordered (nil2) = True"
| "ordered (cons2 y (nil2)) = True"
| "ordered (cons2 y (cons2 y2 xs)) =
     ((y <= y2) & (ordered (cons2 y2 xs)))"

fun map :: "('a => 'b) => 'a list => 'b list" where
  "map f (nil2) = nil2"
| "map f (cons2 y xs) = cons2 (f y) (map f xs)"

fun lmerge :: "int list => int list => int list" where
  "lmerge (nil2) y = y"
| "lmerge (cons2 z x2) (nil2) = cons2 z x2"
| "lmerge (cons2 z x2) (cons2 x3 x4) =
     (if z <= x3 then cons2 z (lmerge x2 (cons2 x3 x4)) else
        cons2 x3 (lmerge (cons2 z x2) x4))"

fun pairwise :: "(int list) list => (int list) list" where
  "pairwise (nil2) = nil2"
| "pairwise (cons2 xs (nil2)) = cons2 xs (nil2)"
| "pairwise (cons2 xs (cons2 ys xss)) =
     cons2 (lmerge xs ys) (pairwise xss)"

(*fun did not finish the proof*)
function mergingbu :: "(int list) list => int list" where
  "mergingbu (nil2) = nil2"
| "mergingbu (cons2 xs (nil2)) = xs"
| "mergingbu (cons2 xs (cons2 z x2)) =
     mergingbu (pairwise (cons2 xs (cons2 z x2)))"
  by pat_completeness auto

fun msortbu :: "int list => int list" where
  "msortbu x = mergingbu (map (% (y :: int) => cons2 y (nil2)) x)"

theorem property0 :
  "ordered (msortbu xs)"
  oops

end


theory extensions
  imports base
begin

named_theorems extDefs

subsection \<open>Defends\<close>

(*The set of elements (e.g. arguments) that the set S defends (wrt. 'attack' relation R)*)
definition defends :: \<open>'a Set \<Rightarrow> 'a Rel \<Rightarrow> 'a Set \<Rightarrow> 'a Set\<close> ("defends\<^sup>_")
  where \<open>defends\<^sup>\<A> \<equiv> \<lambda>R S a. \<forall>b. \<A> b \<longrightarrow> R b a \<longrightarrow> (\<exists>z. \<A> z \<and> S z \<and> R z b)\<close>

(* The function 'defends' corresponds to the so-called 'characteristic function'
   in the literature of an argumentation frameworks (e.g. [BCG 2011] Def. 11). *)

(* 'defends' is monotone (i.e. order preserving wrt. set inclusion). *)
lemma defends_mono': "MONO (defends\<^sup>\<A> R)" unfolding MONO_def by (smt (verit) defends_def subset_def)
lemma defends_mono: "MONO\<^sup>\<A> (defends\<^sup>\<A> R)" unfolding MONO_rel_def defends_def by (smt (verit) subset_rel_def)

(* We can now verify that 'defends' has both a least and a greatest fixed point (in different formulations). *)
lemma defends_leastFP': \<open>\<exists>S. (\<subseteq>)-least (fp (defends\<^sup>\<A> R)) S\<close> by (simp add: defends_mono' wKTl)
lemma defends_greatestFP': \<open>\<exists>S. (\<subseteq>)-greatest (fp (defends\<^sup>\<A> R)) S\<close> by (simp add: defends_mono' wKTg)

(*Some syntactic sugar for max/min & least/greatest wrt. relativized subset relation*)
abbreviation max_rel ("'(\<subseteq>\<^sub>_')-max") where "max_rel A \<equiv> maximal (\<lambda>X Y. X \<subseteq>\<^sub>A Y)"
abbreviation min_rel ("'(\<subseteq>\<^sub>_')-min") where "min_rel A \<equiv> minimal (\<lambda>X Y. X \<subseteq>\<^sub>A Y)"
abbreviation least_rel ("'(\<subseteq>\<^sub>_')-least") where "least_rel A \<equiv> least (\<lambda>X Y. X \<subseteq>\<^sub>A Y)"
abbreviation greatest_rel ("'(\<subseteq>\<^sub>_')-greatest") where "greatest_rel A \<equiv> greatest (\<lambda>X Y. X \<subseteq>\<^sub>A Y)"

lemma defends_leastFP:  \<open>\<exists>S. (\<subseteq>\<^sub>\<A>)-least (fp\<^sup>\<A> (defends\<^sup>\<A> R)) S\<close> by (simp add: defends_mono wKTl_relw)
lemma defends_greatestFP:  \<open>\<exists>S. (\<subseteq>\<^sub>\<A>)-greatest (fp\<^sup>\<A> (defends\<^sup>\<A> R)) S\<close> by (simp add: defends_mono wKTg_relw)

subsection \<open>Basic Principles\<close>

(* A set S of arguments is said to be conflict-free if there are no arguments A and B in S
  such that A attacks B ([Dung 1995] Def. 5 and [BCG 2011] Def. 12). *)
definition conflictfree :: \<open>'a Set \<Rightarrow> 'a Rel \<Rightarrow> ('a Set)Set\<close> ("conflictfree\<^sup>_")
  where \<open>conflictfree\<^sup>\<A> \<equiv> \<lambda>att S. \<forall>a b. (\<A> a \<and> \<A> b) \<longrightarrow> (S a \<and> S b) \<longrightarrow> \<not>(att a b)\<close>

(* A set of arguments S is admissible if it is conflict-free and each argument in S is
  defended by S ([Dung 1995] Def. 6(2) and [BCG 2011] Def. 13). *)
definition admissible :: \<open>'a Set \<Rightarrow> 'a Rel \<Rightarrow> ('a Set)Set\<close> ("admissible\<^sup>_")
  where \<open>admissible\<^sup>\<A> \<equiv> \<lambda>att S. conflictfree\<^sup>\<A> att S \<and> (\<forall>a. \<A> a \<longrightarrow> S a \<longrightarrow> defends\<^sup>\<A> att S a)\<close>

subsection \<open>Extension-based Semantics\<close>

(***********************************************************)
(* Complete extensions.                                    *)
(***********************************************************)

(* An admissible set S of arguments is called a complete extension if each argument,
  which is defended by S, belongs to S ([Dung 1995] Def. 23). *)
definition completeExt :: \<open>'a Set \<Rightarrow> 'a Rel \<Rightarrow> ('a Set)Set\<close> ("completeExt\<^sup>_")
  where \<open>completeExt\<^sup>\<A> \<equiv> \<lambda>att S. admissible\<^sup>\<A> att S \<and> (\<forall>a. \<A> a \<longrightarrow> defends\<^sup>\<A> att S a \<longrightarrow> S a)\<close>

(* Alternatively, complete extensions can be defined as conflict-free fixed points of defends (see [Dung 1995] Lemma 24)*)
lemma completeExt_def2: \<open>completeExt\<^sup>\<A> = (\<lambda>att S. conflictfree\<^sup>\<A> att S \<and> fp\<^sup>\<A> (defends\<^sup>\<A> att) S)\<close>
  unfolding admissible_def completeExt_def eqset_rel_def2 subset_rel_def by blast

(* The grounded extension of an argumentation framework AF is a minimal complete extension ([BCG 2011] Def. 21). *)
definition groundedExt :: \<open>'a Set \<Rightarrow> 'a Rel \<Rightarrow> ('a Set)Set\<close> ("groundedExt\<^sup>_")
  where \<open>groundedExt\<^sup>\<A> \<equiv> \<lambda>att S. (\<subseteq>\<^sub>\<A>)-min (completeExt\<^sup>\<A> att) S\<close>

(* Alternatively, grounded extensions can be defined as least complete extensions*)
lemma groundedExt_def2: \<open>groundedExt\<^sup>\<A> = (\<lambda>att S. (\<subseteq>\<^sub>\<A>)-least (completeExt\<^sup>\<A> att) S)\<close>
  unfolding groundedExt_def completeExt_def2 using defends_leastFP oops (*TODO prove*)

(* Alternatively, according to Dung, the grounded extension of an argumentation framework AF is
   the least fixed point of defends ([Dung 1995] Def. 20). *)
lemma groundedExt_def3: \<open>groundedExt\<^sup>\<A> = (\<lambda>att S. (\<subseteq>\<^sub>\<A>)-least (fp\<^sup>\<A> (defends\<^sup>\<A> att)) S)\<close>
  oops (*TODO prove*)

(* A preferred extension of an argumentation framework AF is a maximal (with respect to set inclusion)
  complete extension of AF. *)
definition preferredExt :: \<open>'a Set \<Rightarrow> 'a Rel \<Rightarrow> ('a Set)Set\<close> ("preferredExt\<^sup>_")
  where \<open>preferredExt\<^sup>\<A> \<equiv> \<lambda>att S. (\<subseteq>\<^sub>\<A>)-max (completeExt\<^sup>\<A> att) S\<close>

(* Alternatively, preferred extensions can be defined as maximal admissible sets ([Dung 1995] Def. 7)*)
lemma preferredExt_def2: \<open>preferredExt\<^sup>\<A> = (\<lambda>att S. (\<subseteq>\<^sub>\<A>)-max (admissible\<^sup>\<A> att) S)\<close>
  oops (*TODO prove*)

(***********************************************************)
(* Ideal extensions.                                       *)
(***********************************************************)

(* An ideal set is an admissible set that is subset of every preferred extension*)
definition idealSet :: \<open>'a Set \<Rightarrow> 'a Rel \<Rightarrow> ('a Set)Set\<close> ("idealSet\<^sup>_")
  where \<open>idealSet\<^sup>\<A> \<equiv> \<lambda>att S. admissible\<^sup>\<A> att S \<and> (\<forall>E. preferredExt\<^sup>\<A> att E \<longrightarrow> S \<subseteq>\<^sub>\<A> E)\<close>

(* An ideal extension of an argumentation framework AF is the (unique)
  maximal (i.e greatest) ideal set. ([BCG 2011] Def. 30 and paragraph below). *)
definition idealExt :: \<open>'a Set \<Rightarrow> 'a Rel \<Rightarrow> ('a Set)Set\<close> ("idealExt\<^sup>_")
  where \<open>idealExt\<^sup>\<A> \<equiv> \<lambda>att S. (\<subseteq>\<^sub>\<A>)-greatest (idealSet\<^sup>\<A> att) S\<close>

(*or alternatively*)
lemma idealExt_def2: \<open>idealExt\<^sup>\<A> = (\<lambda>att S. (\<subseteq>\<^sub>\<A>)-max (idealSet\<^sup>\<A> att) S)\<close>
  oops (*TODO prove*)

(***********************************************************)
(* Stable extensions.                                      *)
(***********************************************************)

(* We define the range of a set of arguments S as the union of S with the set
  of its attacked arguments. *)
definition range :: \<open>'a Set \<Rightarrow> 'a Rel \<Rightarrow> 'a Set \<Rightarrow> 'a Set\<close> ("range\<^sup>_")
  where \<open>range\<^sup>\<A> att \<equiv> \<lambda>S. S \<union> (\<lambda>b. (\<exists>a. \<A> a \<and> S a \<and> att a b))\<close>

(* A stable extension of an argumentation framework AF is a conflict-free extension E
   such that E \<union> E\<^sup>+ = Args ([BCG 2011] Def. 25). *)
definition stableExt :: \<open>'a Set \<Rightarrow> 'a Rel \<Rightarrow> ('a Set)Set\<close> ("stableExt\<^sup>_")
  where \<open>stableExt\<^sup>\<A> \<equiv> \<lambda>att S. (conflictfree\<^sup>\<A> att S) \<and> \<A> \<subseteq> range\<^sup>\<A> att S\<close>

(* A semi-stable extension of an argumentation framework AF is a complete extension E
   such that E \<union> E\<^sup>+ is maximal among all complete extensions. ([BCG 2011] Def. 27). *)
definition semistableExt :: \<open>'a Set \<Rightarrow> 'a Rel \<Rightarrow> ('a Set)Set\<close> ("semistableExt\<^sup>_")
  where \<open>semistableExt\<^sup>\<A> \<equiv> \<lambda>att S. maximal (\<lambda>X Y. (range\<^sup>\<A> att X) \<subseteq>\<^sub>\<A> (range\<^sup>\<A> att Y)) (completeExt\<^sup>\<A> att) S\<close>

(***********************************************************)
(* Stage extensions.                                       *)
(***********************************************************)

(* A stage extension of an argumentation framework AF is a conflict-free extension E
   such that E \<union> E\<^sup>+ is maximal among all conflict-free extensions. ([BCG 2011] Def. 32). *)
definition stageExt :: \<open>'a Set \<Rightarrow> 'a Rel \<Rightarrow> ('a Set)Set\<close> ("stageExt\<^sup>_")
  where \<open>stageExt\<^sup>\<A> \<equiv> \<lambda>att S. maximal (\<lambda>X Y. (range\<^sup>\<A> att X) \<subseteq>\<^sub>\<A> (range\<^sup>\<A> att Y)) (conflictfree\<^sup>\<A> att) S\<close>

end


theory Sets
  imports "../Algebra/PartialQuantales"
begin

section {* Resource Predicates *}

text {* A resource predicate is a set on a partial monoid. *}

text {* The powerset lifting of a partial semigroup form a quantale *}

instantiation "set" :: (partial_semigroup) near_quantale_pmult
begin
definition "P \<oplus> Q \<equiv> {x \<oplus> y | x y. x ## y \<and> x \<in> P \<and> y \<in> Q}"
definition "(P :: 'a set) ## Q \<equiv> True"
declare pmult_defined_set_def[simp]

lemma [simp]: "(P :: 'a set) \<oplus> Q ## R"
  by (simp add: pmult_set_def)

instance
  apply (default, auto simp: pmult_set_def)
  apply (metis partial_semigroup_class.pmult_assoc partial_semigroup_class.pmult_def)
  by (metis partial_semigroup_class.pmult_assoc partial_semigroup_class.pmult_def)
end

instance "set" :: (partial_semigroup) pre_quantale_pmult
  by default (auto simp: pmult_set_def)

instance "set" :: (partial_semigroup) quantale_pmult
  by default (auto simp: pmult_set_def)

text {* Unit, commutativity and distributivity are also lifted. *}

instantiation "set" :: (partial_monoid) near_quantale_pmult_unital
begin
definition "1' \<equiv> {1'}"
instance
  by default (auto simp: pmult_set_def pmult_one_set_def pmult_oner pmult_onel)
end

instance "set" :: (partial_ab_semigroup) comm_quantale_pmult
  apply (default, auto simp: pmult_set_def)
  apply (metis pmult_ab_assoc pmult_def_eq)
  by (metis pmult_ab_assoc pmult_def_eq pmult_comm pmult_comm_def)+

instance "set" :: (partial_monoid) quantale_pmult_unital ..

instance "set" :: (partial_comm_monoid) comm_quantale_pmult_unital ..

instance "set" :: (partial_semigroup) distrib_quantale_pmult ..

instance "set" :: (partial_comm_monoid) distrib_comm_quantale_pmult_unital ..

end


(*  Title:      HOL/MicroJava/BV/SemilatAlg.thy
    Author:     Gerwin Klein
    Copyright   2002 Technische Universitaet Muenchen
*)

section \<open>More on Semilattices\<close>

theory SemilatAlg
imports Typing_Framework
begin

definition lesubstep_type :: "(nat \<times> 's) set \<Rightarrow> 's ord \<Rightarrow> (nat \<times> 's) set \<Rightarrow> bool"
    ("(_ /{\<sqsubseteq>\<^bsub>_\<^esub>} _)" [50, 0, 51] 50)
  where "A {\<sqsubseteq>\<^bsub>r\<^esub>} B \<equiv> \<forall>(p,\<tau>) \<in> A. \<exists>\<tau>'. (p,\<tau>') \<in> B \<and> \<tau> \<sqsubseteq>\<^sub>r \<tau>'"

notation (ASCII)
  lesubstep_type  ("(_ /{<='__} _)" [50, 0, 51] 50)

primrec pluslussub :: "'a list \<Rightarrow> ('a \<Rightarrow> 'a \<Rightarrow> 'a) \<Rightarrow> 'a \<Rightarrow> 'a"  ("(_ /\<Squnion>\<^bsub>_\<^esub> _)" [65, 0, 66] 65)
where
  "pluslussub [] f y = y"
| "pluslussub (x#xs) f y = pluslussub xs f (x \<squnion>\<^sub>f y)"
(*<*)
notation (ASCII)
  pluslussub  ("(_ /++'__ _)" [65, 1000, 66] 65)
(*>*)

definition bounded :: "'s step_type \<Rightarrow> nat \<Rightarrow> bool"
where
  "bounded step n \<longleftrightarrow> (\<forall>p<n. \<forall>\<tau>. \<forall>(q,\<tau>') \<in> set (step p \<tau>). q<n)"

definition pres_type :: "'s step_type \<Rightarrow> nat \<Rightarrow> 's set \<Rightarrow> bool"
where
  "pres_type step n A \<longleftrightarrow> (\<forall>\<tau>\<in>A. \<forall>p<n. \<forall>(q,\<tau>') \<in> set (step p \<tau>). \<tau>' \<in> A)"

definition mono :: "'s ord \<Rightarrow> 's step_type \<Rightarrow> nat \<Rightarrow> 's set \<Rightarrow> bool"
where
  "mono r step n A \<longleftrightarrow>
    (\<forall>\<tau> p \<tau>'. \<tau> \<in> A \<and> p<n \<and> \<tau> \<sqsubseteq>\<^sub>r \<tau>' \<longrightarrow> set (step p \<tau>) {\<sqsubseteq>\<^bsub>r\<^esub>} set (step p \<tau>'))"

lemma [iff]: "(A {\<sqsubseteq>\<^bsub>r\<^esub>} {}) = (A = {})"
  (*<*) by (cases "A={}") (auto simp add: lesubstep_type_def) (*>*)

lemma lesubstep_union:
  "\<lbrakk> A\<^sub>1 {\<sqsubseteq>\<^bsub>r\<^esub>} B\<^sub>1; A\<^sub>2 {\<sqsubseteq>\<^bsub>r\<^esub>} B\<^sub>2 \<rbrakk> \<Longrightarrow> A\<^sub>1 \<union> A\<^sub>2 {\<sqsubseteq>\<^bsub>r\<^esub>} B\<^sub>1 \<union> B\<^sub>2"
  (*<*) by (auto simp add: lesubstep_type_def) (*>*)

lemma pres_typeD:
  "\<lbrakk> pres_type step n A; s\<in>A; p<n; (q,s')\<in>set (step p s) \<rbrakk> \<Longrightarrow> s' \<in> A"
(*<*) by (unfold pres_type_def, blast) (*>*)

lemma monoD:
  "\<lbrakk> mono r step n A; p < n; s\<in>A; s \<sqsubseteq>\<^sub>r t \<rbrakk> \<Longrightarrow> set (step p s) {\<sqsubseteq>\<^bsub>r\<^esub>} set (step p t)"
(*<*) by (unfold mono_def, blast) (*>*)

lemma boundedD:
  "\<lbrakk> bounded step n; p < n; (q,t) \<in> set (step p xs) \<rbrakk> \<Longrightarrow> q < n"
(*<*) by (unfold bounded_def, blast) (*>*)

lemma lesubstep_type_refl [simp, intro]:
  "(\<And>x. x \<sqsubseteq>\<^sub>r x) \<Longrightarrow> A {\<sqsubseteq>\<^bsub>r\<^esub>} A"
(*<*) by (unfold lesubstep_type_def) auto (*>*)

lemma lesub_step_typeD:
  "A {\<sqsubseteq>\<^bsub>r\<^esub>} B \<Longrightarrow> (x,y) \<in> A \<Longrightarrow> \<exists>y'. (x, y') \<in> B \<and> y \<sqsubseteq>\<^sub>r y'"
(*<*) by (unfold lesubstep_type_def) blast (*>*)

lemma list_update_le_listI [rule_format]:
  "set xs \<subseteq> A \<longrightarrow> set ys \<subseteq> A \<longrightarrow> xs [\<sqsubseteq>\<^sub>r] ys \<longrightarrow> p < size xs \<longrightarrow>
   x \<sqsubseteq>\<^sub>r ys!p \<longrightarrow> semilat(A,r,f) \<longrightarrow> x\<in>A \<longrightarrow>
   xs[p := x \<squnion>\<^sub>f xs!p] [\<sqsubseteq>\<^sub>r] ys"
(*<*)
  apply (simp only: Listn.le_def lesub_def semilat_def)
  apply (simp add: list_all2_conv_all_nth nth_list_update)
  done
(*>*)

lemma plusplus_closed: assumes "Semilat A r f" shows
  "\<And>y. \<lbrakk> set x \<subseteq> A; y \<in> A\<rbrakk> \<Longrightarrow> x \<Squnion>\<^bsub>f\<^esub> y \<in> A"
(*<*)
proof (induct x)
  interpret Semilat A r f by fact
  show "\<And>y. y \<in> A \<Longrightarrow> [] \<Squnion>\<^bsub>f\<^esub> y \<in> A" by simp
  fix y x xs
  assume y: "y \<in> A" and xxs: "set (x#xs) \<subseteq> A"
  assume IH: "\<And>y. \<lbrakk> set xs \<subseteq> A; y \<in> A\<rbrakk> \<Longrightarrow> xs \<Squnion>\<^bsub>f\<^esub> y \<in> A"
  from xxs obtain x: "x \<in> A" and xs: "set xs \<subseteq> A" by simp
  from x y have "x \<squnion>\<^bsub>f\<^esub> y \<in> A" ..
  with xs have "xs \<Squnion>\<^bsub>f\<^esub> (x \<squnion>\<^bsub>f\<^esub> y) \<in> A" by (rule IH)
  thus "x#xs \<Squnion>\<^bsub>f\<^esub> y \<in> A" by simp
qed
(*>*)

lemma (in Semilat) pp_ub2:
 "\<And>y. \<lbrakk> set x \<subseteq> A; y \<in> A\<rbrakk> \<Longrightarrow> y \<sqsubseteq>\<^bsub>r\<^esub> x \<Squnion>\<^bsub>f\<^esub> y"
(*<*)
proof (induct x)
  from semilat show "\<And>y. y \<sqsubseteq>\<^bsub>r\<^esub> [] \<Squnion>\<^bsub>f\<^esub> y" by simp

  fix y a l assume y:  "y \<in> A" and "set (a#l) \<subseteq> A"
  then obtain a: "a \<in> A" and x: "set l \<subseteq> A" by simp
  assume "\<And>y. \<lbrakk>set l \<subseteq> A; y \<in> A\<rbrakk> \<Longrightarrow> y \<sqsubseteq>\<^bsub>r\<^esub> l \<Squnion>\<^bsub>f\<^esub> y"
  from this and x have IH: "\<And>y. y \<in> A \<Longrightarrow> y \<sqsubseteq>\<^bsub>r\<^esub> l \<Squnion>\<^bsub>f\<^esub> y" .

  from a y have "y \<sqsubseteq>\<^bsub>r\<^esub> a \<squnion>\<^bsub>f\<^esub> y" ..
  also from a y have "a \<squnion>\<^bsub>f\<^esub> y \<in> A" ..
  hence "(a \<squnion>\<^bsub>f\<^esub> y) \<sqsubseteq>\<^bsub>r\<^esub> l \<Squnion>\<^bsub>f\<^esub> (a \<squnion>\<^bsub>f\<^esub> y)" by (rule IH)
  finally have "y \<sqsubseteq>\<^bsub>r\<^esub> l \<Squnion>\<^bsub>f\<^esub> (a \<squnion>\<^bsub>f\<^esub> y)" .
  thus "y \<sqsubseteq>\<^bsub>r\<^esub> (a#l) \<Squnion>\<^bsub>f\<^esub> y" by simp
qed
(*>*)

  fix y s ls
  assume "set (s#ls) \<subseteq> A"
  then obtain s: "s \<in> A" and ls: "set ls \<subseteq> A" by simp
  assume y: "y \<in> A"

  assume "\<And>y. \<lbrakk>set ls \<subseteq> A; y \<in> A; x \<in> set ls\<rbrakk> \<Longrightarrow> x \<sqsubseteq>\<^bsub>r\<^esub> ls \<Squnion>\<^bsub>f\<^esub> y"
  from this and ls have IH: "\<And>y. x \<in> set ls \<Longrightarrow> y \<in> A \<Longrightarrow> x \<sqsubseteq>\<^bsub>r\<^esub> ls \<Squnion>\<^bsub>f\<^esub> y" .

  assume "x \<in> set (s#ls)"
  then obtain xls: "x = s \<or> x \<in> set ls" by simp
  moreover {
    assume xs: "x = s"
    from s y have "s \<sqsubseteq>\<^bsub>r\<^esub> s \<squnion>\<^bsub>f\<^esub> y" ..
    also from s y have "s \<squnion>\<^bsub>f\<^esub> y \<in> A" ..
    with ls have "(s \<squnion>\<^bsub>f\<^esub> y) \<sqsubseteq>\<^bsub>r\<^esub> ls \<Squnion>\<^bsub>f\<^esub> (s \<squnion>\<^bsub>f\<^esub> y)" by (rule pp_ub2)
    finally have "s \<sqsubseteq>\<^bsub>r\<^esub> ls \<Squnion>\<^bsub>f\<^esub> (s \<squnion>\<^bsub>f\<^esub> y)" .
    with xs have "x \<sqsubseteq>\<^bsub>r\<^esub> ls \<Squnion>\<^bsub>f\<^esub> (s \<squnion>\<^bsub>f\<^esub> y)" by simp
  }
  moreover {
    assume "x \<in> set ls"
    hence "\<And>y. y \<in> A \<Longrightarrow> x \<sqsubseteq>\<^bsub>r\<^esub> ls \<Squnion>\<^bsub>f\<^esub> y" by (rule IH)
    moreover from s y have "s \<squnion>\<^bsub>f\<^esub> y \<in> A" ..
    ultimately have "x \<sqsubseteq>\<^bsub>r\<^esub> ls \<Squnion>\<^bsub>f\<^esub> (s \<squnion>\<^bsub>f\<^esub> y)" .
  }
  ultimately
  have "x \<sqsubseteq>\<^bsub>r\<^esub> ls \<Squnion>\<^bsub>f\<^esub> (s \<squnion>\<^bsub>f\<^esub> y)" by blast
  thus "x \<sqsubseteq>\<^bsub>r\<^esub> (s#ls) \<Squnion>\<^bsub>f\<^esub> y" by simp
qed
(*>*)

lemma (in Semilat) pp_lub:
  assumes z: "z \<in> A"
  shows
  "\<And>y. y \<in> A \<Longrightarrow> set xs \<subseteq> A \<Longrightarrow> \<forall>x \<in> set xs. x \<sqsubseteq>\<^bsub>r\<^esub> z \<Longrightarrow> y \<sqsubseteq>\<^bsub>r\<^esub> z \<Longrightarrow> xs \<Squnion>\<^bsub>f\<^esub> y \<sqsubseteq>\<^bsub>r\<^esub> z"
(*<*)
proof (induct xs)
  fix y assume "y \<sqsubseteq>\<^bsub>r\<^esub> z" thus "[] \<Squnion>\<^bsub>f\<^esub> y \<sqsubseteq>\<^bsub>r\<^esub> z" by simp
next
  fix y l ls assume y: "y \<in> A" and "set (l#ls) \<subseteq> A"
  then obtain l: "l \<in> A" and ls: "set ls \<subseteq> A" by auto
  assume "\<forall>x \<in> set (l#ls). x \<sqsubseteq>\<^bsub>r\<^esub> z"
  then obtain lz: "l \<sqsubseteq>\<^bsub>r\<^esub> z" and lsz: "\<forall>x \<in> set ls. x \<sqsubseteq>\<^bsub>r\<^esub> z" by auto
  assume "y \<sqsubseteq>\<^bsub>r\<^esub> z" with lz have "l \<squnion>\<^bsub>f\<^esub> y \<sqsubseteq>\<^bsub>r\<^esub> z" using l y z ..
  moreover
  from l y have "l \<squnion>\<^bsub>f\<^esub> y \<in> A" ..
  moreover
  assume "\<And>y. y \<in> A \<Longrightarrow> set ls \<subseteq> A \<Longrightarrow> \<forall>x \<in> set ls. x \<sqsubseteq>\<^bsub>r\<^esub> z \<Longrightarrow> y \<sqsubseteq>\<^bsub>r\<^esub> z
          \<Longrightarrow> ls \<Squnion>\<^bsub>f\<^esub> y \<sqsubseteq>\<^bsub>r\<^esub> z"
  ultimately
  have "ls \<Squnion>\<^bsub>f\<^esub> (l \<squnion>\<^bsub>f\<^esub> y) \<sqsubseteq>\<^bsub>r\<^esub> z" using ls lsz by -
  thus "(l#ls) \<Squnion>\<^bsub>f\<^esub> y \<sqsubseteq>\<^bsub>r\<^esub> z" by simp
qed
(*>*)

lemma ub1': assumes "Semilat A r f"
shows "\<lbrakk>\<forall>(p,s) \<in> set S. s \<in> A; y \<in> A; (a,b) \<in> set S\<rbrakk>
  \<Longrightarrow> b \<sqsubseteq>\<^bsub>r\<^esub> map snd [(p', t') \<leftarrow> S. p' = a] \<Squnion>\<^bsub>f\<^esub> y"
(*<*)
proof -
  interpret Semilat A r f by fact
  let "b \<sqsubseteq>\<^bsub>r\<^esub> ?map \<Squnion>\<^bsub>f\<^esub> y" = ?thesis

  assume "y \<in> A"
  moreover
  assume "\<forall>(p,s) \<in> set S. s \<in> A"
  hence "set ?map \<subseteq> A" by auto
  moreover
  assume "(a,b) \<in> set S"
  hence "b \<in> set ?map" by (induct S, auto)
  ultimately
  show ?thesis by - (rule pp_ub1)
qed
(*>*)

lemma plusplus_empty:
  "\<forall>s'. (q, s') \<in> set S \<longrightarrow> s' \<squnion>\<^bsub>f\<^esub> ss ! q = ss ! q \<Longrightarrow>
   (map snd [(p', t') \<leftarrow> S. p' = q] \<Squnion>\<^bsub>f\<^esub> ss ! q) = ss ! q"
(*<*)
apply (induct S)
apply auto
done
(*>*)

end


theory ASM
  imports "HOL-IMP.AExp"
begin

type_synonym val = int
type_synonym vname = string
datatype instr = LOADI val | LOAD vname | ADD
type_synonym stack = "val list"
type_synonym state = "vname \<Rightarrow> val"

fun exec1 :: "instr \<Rightarrow> state \<Rightarrow> stack \<Rightarrow> stack option" where
"exec1 (LOADI n) _ stk = Some(n # stk)" |
"exec1 (LOAD x) s stk = Some(s(x) # stk)" |
"exec1 ADD _ (j # i # stk) = Some((i + j) # stk)" |
"exec1 ADD _ [v] = None" |
"exec1 ADD _ [] = None"

fun exec :: "instr list \<Rightarrow> state \<Rightarrow> stack \<Rightarrow> stack option" where
"exec [] _ stk = Some stk" |
"exec (i#is) s stk =
  (case (exec1 i s stk) of
    Some res \<Rightarrow> exec is s res |
    None \<Rightarrow> None)"

fun comp :: "aexp \<Rightarrow> instr list" where
"comp (N n) = [LOADI n]" |
"comp (V x) = [LOAD x]" |
"comp (Plus e1 e2) = comp e1 @ comp e2 @ [ADD]"

fun aval :: "aexp \<Rightarrow> state \<Rightarrow> val" where
  "aval (N n) s = n" |
  "aval (V x) s = s x" |
  "aval (Plus a1 a2) s = aval a1 s + aval a2 s"

lemma exec_append: "exec is1 s stk = Some new_stk \<Longrightarrow> exec (is1 @ is2) s stk = exec is2 s new_stk"
  apply(induction is1 arbitrary: stk)
  apply(auto split: option.split)
  done

lemma "exec (comp a) s stk = Some ((aval a s) # stk)"
  apply(induction a arbitrary: stk)
  apply(auto simp add: exec_append)
  done

end


(* This Isabelle theory is produced using the TIP tool offered at the following website:
     https://github.com/tip-org/tools
   This file was originally provided as part of TIP benchmark at the following website:
     https://github.com/tip-org/benchmarks
   Yutaka Nagashima at CIIRC, CTU changed the TIP output theory file slightly
   to make it compatible with Isabelle2017.
\:w
   Some proofs were added by Yutaka Nagashima.*)
  theory TIP_sort_nat_SSortPermutes
  imports "../../Test_Base"
begin

datatype 'a list = nil2 | cons2 "'a" "'a list"

datatype Nat = Z | S "Nat"

fun le :: "Nat => Nat => bool" where
  "le (Z) y = True"
| "le (S z) (Z) = False"
| "le (S z) (S x2) = le z x2"

fun ssortminimum1 :: "Nat => Nat list => Nat" where
  "ssortminimum1 x (nil2) = x"
| "ssortminimum1 x (cons2 y1 ys1) =
     (if le y1 x then ssortminimum1 y1 ys1 else ssortminimum1 x ys1)"

fun elem :: "'a => 'a list => bool" where
  "elem x (nil2) = False"
| "elem x (cons2 z xs) = ((z = x) | (elem x xs))"

fun deleteBy :: "('a => ('a => bool)) => 'a => 'a list =>
                 'a list" where
  "deleteBy x y (nil2) = nil2"
| "deleteBy x y (cons2 y2 ys) =
     (if (x y) y2 then ys else cons2 y2 (deleteBy x y ys))"

fun isPermutation :: "'a list => 'a list => bool" where
  "isPermutation (nil2) (nil2) = True"
| "isPermutation (nil2) (cons2 z x2) = False"
| "isPermutation (cons2 x3 xs) y =
     ((elem x3 y) &
        (isPermutation
           xs (deleteBy (% (x4 :: 'a) => % (x5 :: 'a) => (x4 = x5)) x3 y)))"

(*fun did not finish the proof*)
function ssort :: "Nat list => Nat list" where
  "ssort (nil2) = nil2"
| "ssort (cons2 y ys) =
     (let m :: Nat = ssortminimum1 y ys
     in cons2
          m
          (ssort
             (deleteBy
                (% (z :: Nat) => % (x2 :: Nat) => (z = x2)) m (cons2 y ys))))"
  by pat_completeness auto

theorem property0 :
  "isPermutation (ssort xs) xs"
  oops

end