theory Integer_Polyhedron
  imports Faces
    Linear_Inequalities.Integer_Hull
    Missing_Sums
begin

context gram_schmidt
begin

lemma all_elem_fulfill_empty:
  assumes "(A', b') = sub_system A b {}"
  shows "A' *\<^sub>v x = b'"
proof
  have "A' = submatrix A {} UNIV"
    by (metis assms fst_conv sub_system_fst)
  then have "dim_row A' = 0"
    by (simp add: dim_submatrix(1))
  have "b' = vec_of_list (nths (list_of_vec b) {})"
    by (metis assms snd_conv sub_system_snd)
  then have "dim_vec b' = 0"
    by fastforce
  show "dim_vec (A' *\<^sub>v x) = dim_vec b'"
    by (simp add: \<open>dim_row A' = 0\<close> \<open>dim_vec b' = 0\<close>)
  show "\<And>i. i < dim_vec b' \<Longrightarrow>
         (A' *\<^sub>v x) $ i = b' $ i"
    using \<open>dim_vec b' = 0\<close> by linarith
qed

lemma subsyst_with_max_ineq:
  fixes A :: "'a :: trivial_conjugatable_linordered_field mat"
  assumes A: "A \<in> carrier_mat nr n"
  assumes b: "b \<in> carrier_vec nr"
  defines "P \<equiv> polyhedron A b"
  assumes "P \<noteq> {}"
  obtains A' b' I'  where "((A', b') = sub_system A b I')"
    "{x. A' *\<^sub>v x = b' \<and> x \<in> P} \<noteq> {}"
    "dim_vec b' = Max {dim_vec d| C d I. (C, d) = sub_system A b I \<and>
                                                {x. C *\<^sub>v x = d \<and> x \<in> P} \<noteq> {}}"
proof-
  have "dim_vec b = nr" using b by auto
  let ?M = "{dim_vec d| C d I. (C, d) = sub_system A b I \<and> {x. C *\<^sub>v x = d \<and> x \<in> P} \<noteq> {}}"
  have "finite ?M"
    using subset_set_of_sub_dims_finite[of ?M A b] by blast
  let ?emp_A = "fst (sub_system A b {})"
  let ?emp_b = "snd (sub_system A b {})"
  have "{x. ?emp_A *\<^sub>v x = ?emp_b \<and> x \<in> P} = P"
    by (smt (verit, ccfv_SIG) Collect_cong P_def all_elem_fulfill_empty mem_Collect_eq
        polyhedron_def prod.collapse)
  then have "dim_vec ?emp_b \<in> ?M" using assms(4)
    by (smt (verit, best) Collect_cong mem_Collect_eq prod.collapse)
  then have "?M \<noteq> {}"
    by blast
  then have "Max ?M \<in> ?M \<and> (\<forall>a \<in> ?M. a \<le> (Max ?M))"
    using eq_Max_iff[of ?M] `?M \<noteq> {}` `finite ?M`
    by auto
  then show ?thesis
    using that by force
qed

lemma submatrix_same_I_interesect_rows:
  shows "submatrix A I UNIV = submatrix A (I \<inter> {0..<dim_row A}) UNIV"
proof
  show 1:"dim_row (submatrix A I UNIV) = dim_row (submatrix A (I \<inter> {0..<dim_row A}) UNIV)"
    using dim_submatrix
    by (smt (verit) Collect_cong Int_iff atLeastLessThan_iff less_nat_zero_code
        linorder_le_less_linear)
  show 2:"dim_col (submatrix A I UNIV) = dim_col (submatrix A (I \<inter> {0..<dim_row A}) UNIV)"
    using dim_submatrix
    by (smt (verit) Collect_cong Int_iff atLeastLessThan_iff less_nat_zero_code
        linorder_le_less_linear)
  show "\<And>i j. i < dim_row (submatrix A (I \<inter> {0..<dim_row A}) UNIV) \<Longrightarrow>
           j < dim_col (submatrix A (I \<inter> {0..<dim_row A}) UNIV) \<Longrightarrow>
           submatrix A I UNIV $$ (i, j) = submatrix A (I \<inter> {0..<dim_row A}) UNIV $$ (i, j)"
  proof -
    fix i j
    assume asmi:"i < dim_row (submatrix A (I \<inter> {0..<dim_row A}) UNIV)"
    assume asmj:"j < dim_col (submatrix A (I \<inter> {0..<dim_row A}) UNIV)"
    have 2:"submatrix A I UNIV $$ (i, j) = A $$ (pick I i, pick UNIV j)" using submatrix_index
      by (metis (no_types, lifting) 1 asmi asmj dim_submatrix(1) dim_submatrix(2))
    have 3:"{a. a < dim_row A \<and> a \<in> I} = (I \<inter> {0..<dim_row A})"
      by fastforce
    have "i < card {a. a < dim_row A \<and> a \<in> I}"
      by (metis 1 asmi dim_submatrix(1))
    then have "pick (I  \<inter> {0..<dim_row A}) i= pick I i"
      using pick_reduce_set[of i "dim_row A" I] 3
      by presburger
    then show " submatrix A I UNIV $$ (i, j) = submatrix A (I \<inter> {0..<dim_row A}) UNIV $$ (i, j)"
      by (metis (no_types, lifting) asmi asmj 2 dim_submatrix(1) dim_submatrix(2) submatrix_index)
  qed
qed

lemma nths_intersect_length_same:
  shows "(nths l I) = (nths l {a. a < (length l) \<and> a \<in> I})"
proof -
  have "\<forall> p \<in> set (zip l [0..<length l]). snd p \<in> I \<longleftrightarrow> snd p \<in> {a. a < length l \<and> a \<in> I}"
    using zip_snd by force
  then have "filter (\<lambda>p. snd p \<in> I) (zip l [0..<length l]) =
            filter (\<lambda>p. snd p \<in> {a. a < length l \<and> a \<in> I}) (zip l [0..<length l])"
    by (metis (mono_tags, lifting) filter_cong)
  then show ?thesis
    unfolding nths_def by argo
qed

lemma same_subsyst_I_intersect_rows:
  assumes A: "A \<in> carrier_mat nr n"
  assumes b: "b \<in> carrier_vec nr"
  shows "sub_system A b I = sub_system A b (I \<inter> {0..<nr})"
proof
  have "submatrix A I UNIV = submatrix A (I \<inter> {0..<dim_row A}) UNIV"
    using submatrix_same_I_interesect_rows by blast

  then show  "fst (sub_system A b I) = fst (sub_system A b (I \<inter> {0..<nr}))"
    using A
    by (metis carrier_matD(1) sub_system_fst)
  have "(nths (list_of_vec b) I) = (nths (list_of_vec b) {a. a < dim_vec b \<and> a \<in> I})"
    using nths_intersect_length_same
    by (metis  Matrix.length_list_of_vec)
  then have "vec_of_list (nths (list_of_vec b) I) =
      vec_of_list (nths (list_of_vec b) (I\<inter> {0..<dim_vec b}))"
    by (smt (verit, best) Collect_cong Int_iff Matrix.length_list_of_vec atLeastLessThan_iff
        nths_intersect_length_same zero_order(1))
  then show "snd (sub_system A b I) = snd (sub_system A b (I \<inter> {0..<nr}))"
    by (metis b carrier_vecD sub_system_snd)
qed

lemma obtain_I_for_subface:
  fixes A :: "'a :: trivial_conjugatable_linordered_field mat"
  assumes A: "A \<in> carrier_mat nr n"
  assumes b: "b \<in> carrier_vec nr"
  defines "P \<equiv> polyhedron A b"
  assumes "((A', b') = sub_system A b I)"
  assumes "F = {x. A' *\<^sub>v x = b' \<and> x \<in> P}"
  assumes "face P F"
  assumes "face P F'"
  assumes "F' \<subset> F"
  obtains C d I' where "((C, d) = sub_system A b I')"
    "F' = {x. C *\<^sub>v x = d \<and> x \<in> P}" "(I \<inter> {0..<nr}) \<subset> (I' \<inter> {0..<nr})"
proof -
  obtain C d J where C_d:"((C, d) = sub_system A b J)"
    "F' = {x. C *\<^sub>v x = d \<and> x \<in> P}" using char_face1
    using A P_def assms(7) b by blast
  obtain C' d' where  C'_d':"((C', d') = sub_system A b (J \<union> I))"
    by (metis surj_pair)
  have "dim_row A = dim_vec b" using A b
    by (metis carrier_matD(1) carrier_vecD)
  have "{x. C *\<^sub>v x = d \<and> x \<in> P} = {x. C' *\<^sub>v x = d' \<and> x \<in> P}"
  proof(safe)
    {
      fix x
      assume "x \<in> P" "d = C *\<^sub>v x"
      have "x \<in> F"
        using C_d(2) \<open>d = C *\<^sub>v x\<close> \<open>x \<in> P\<close> assms(8) by blast
      then have "A' *\<^sub>v x = b'" using assms(5) by auto
      then have "\<forall>i < dim_row A'. row A' i \<bullet> x = b' $ i"
        by (metis index_mult_mat_vec)
      then have "\<forall>i \<in> I \<inter> {0..<dim_row A}.  (row A i) \<bullet> x = (b $ i)"
        using subsystem_fulfills_P[of A b A' b' I "\<lambda> p q. p \<bullet> x = q"] assms(4)
          `dim_row A = dim_vec b`  by blast
      have "\<forall>i < dim_row C. row C i \<bullet> x = d $ i" using `d = C *\<^sub>v x`
        by (metis index_mult_mat_vec)
      then have "\<forall>i \<in> J \<inter> {0..<dim_row A}.  (row A i) \<bullet> x = (b $ i)"
        using subsystem_fulfills_P[of A b C d J "\<lambda> p q. p \<bullet> x = q"] C_d
          `dim_row A = dim_vec b`  by blast
      then have "\<forall>i \<in> (I \<union> J) \<inter> {0..<dim_row A}. (row A i) \<bullet> x = (b $ i)"
        by (metis Int_Un_distrib2 Un_iff \<open>\<forall>i\<in>I \<inter> {0..<dim_row A}. row A i \<bullet> x = b $ i\<close>)
      then have "\<forall>i < dim_row C'. row C' i \<bullet> x = d' $ i"
        using subsystem_fulfills_P'[of A b C' d' _ "\<lambda> p q. p \<bullet> x = q"] C'_d'
        using \<open>dim_row A = dim_vec b\<close> by blast
      then show "C' *\<^sub>v x = d'"
        by (meson C'_d' \<open>dim_row A = dim_vec b\<close> dims_subsyst_same' eq_for_all_index_then_eq)
    }
    fix x
    assume "x \<in> P" "d' = C' *\<^sub>v x"
    then have "\<forall>i < dim_row C'. row C' i \<bullet> x = d' $ i"
      by (metis index_mult_mat_vec)
    then have "\<forall>i \<in> (I \<union> J) \<inter> {0..<dim_row A}. (row A i) \<bullet> x = (b $ i)"
      using subsystem_fulfills_P[of A b C' d' _ "\<lambda> p q. p \<bullet> x = q"] C'_d'
      using \<open>dim_row A = dim_vec b\<close> by blast
    then have "\<forall>i \<in> J \<inter> {0..<dim_row A}.  (row A i) \<bullet> x = (b $ i)" by auto
    then have "\<forall>i < dim_row C. row C i \<bullet> x = d $ i"
      using subsystem_fulfills_P'[of A b C d J "\<lambda> p q. p \<bullet> x = q"] C_d
        `dim_row A = dim_vec b`  by blast
    then show "C *\<^sub>v x = d"
      by (meson C_d \<open>dim_row A = dim_vec b\<close> dims_subsyst_same' eq_for_all_index_then_eq)
  qed
  then have "F' = {x. C' *\<^sub>v x = d' \<and> x \<in> P}" using C_d by auto
  have "(I \<inter> {0..<nr}) \<subseteq> ((J \<union> I) \<inter> {0..<nr})"
    by blast
  have "(I \<inter> {0..<nr}) \<noteq> ((J \<union> I) \<inter> {0..<nr})"
  proof
    assume "I \<inter> {0..<nr} = (J \<union> I) \<inter> {0..<nr}"
    then have "sub_system A b I = sub_system A b (J \<union> I)"
      by (metis A b gram_schmidt.same_subsyst_I_intersect_rows)
    then have "{x. A' *\<^sub>v x = b' \<and> x \<in> P} = {x. C *\<^sub>v x = d \<and> x \<in> P}"
      by (metis (no_types, lifting) Pair_inject \<open>(C', d') = sub_system A b (J \<union> I)\<close>
          \<open>{x. C *\<^sub>v x = d \<and> x \<in> P} = {x. C' *\<^sub>v x = d' \<and> x \<in> P}\<close> assms(4))
    then show False using assms(8)
      using C_d(2) assms(5) by blast
  qed
  then have "(I \<inter> {0..<nr}) \<subset> ((J \<union> I) \<inter> {0..<nr})"
    by blast
  then show ?thesis using C'_d' `F' = {x. C' *\<^sub>v x = d' \<and> x \<in> P}`
    using that by presburger
qed

lemma less_I_less_dims_subsystem:
  assumes A: "A \<in> carrier_mat nr n"
  assumes b: "b \<in> carrier_vec nr"
  assumes "(I \<inter> {0..<nr}) \<subset> (J \<inter> {0..<nr})"
  assumes "((A', b') = sub_system A b I)"
  assumes  "((C, d) = sub_system A b J)"
  shows "dim_row A' < dim_row C"
    "dim_vec b' < dim_vec d"
proof -
  have "sub_system A b I = sub_system A b (I \<inter> {0..<nr})"
    using same_subsyst_I_intersect_rows A b
    by blast
  then have "dim_row A' = card (I \<inter> {0..<nr})" using I_subsys_same_card(2)
    by (metis (mono_tags, lifting) A assms(4) b carrier_matD(1) carrier_vecD dims_subsyst_same'
        inf.cobounded2 snd_conv)
  have "sub_system A b J = sub_system A b (J \<inter> {0..<nr})"
    using same_subsyst_I_intersect_rows A b
    by blast
  then have "dim_row C = card (J \<inter> {0..<nr})" using I_subsys_same_card(2)
    by (metis (mono_tags, lifting) A assms(5) b carrier_matD(1) carrier_vecD dims_subsyst_same'
        inf.cobounded2 snd_conv)
  have "finite (J \<inter> {0..<nr})"
    by blast
  then have "card (I \<inter> {0..<nr}) < card (J \<inter> {0..<nr})"
    by (meson assms(3) psubset_card_mono)
  then show "dim_row A' < dim_row C"
    using \<open>dim_row A' = card (I \<inter> {0..<nr})\<close> \<open>dim_row C = card (J \<inter> {0..<nr})\<close> by presburger
  have "dim_row A' = dim_vec b'"
    by (metis A assms(4) b carrier_matD(1) carrier_vecD dims_subsyst_same')
  have "dim_row C = dim_vec d"
    by (metis A assms(5) b carrier_matD(1) carrier_vecD dims_subsyst_same')
  then show "dim_vec b' < dim_vec d"
    using \<open>dim_row A' < dim_row C\<close> \<open>dim_row A' = dim_vec b'\<close> by presburger
qed

lemma append_rows_index_same:
  fixes A :: "'a :: trivial_conjugatable_linordered_field mat"
  assumes A: "A \<in> carrier_mat nr1 n"
  assumes "B \<in> carrier_mat nr2 n"
  shows "\<forall> i < dim_row A. (row (A @\<^sub>r B)i) = row A i"
  by (metis A append_rows_nth(1) assms(2) carrier_matD(1))

lemma append_rows_index_same':
  fixes A :: "'a :: trivial_conjugatable_linordered_field mat"
  assumes A: "A \<in> carrier_mat nr1 n"
  assumes "B \<in> carrier_mat nr2 n"
  shows "\<lbrakk> i \<ge> nr1; i < nr1 + nr2 \<rbrakk> \<Longrightarrow> (row (A @\<^sub>r B)i) = row B (i - nr1)"
  by (metis A append_rows_nth(2) assms(2))

lemma face_trans:
  fixes A :: "'a :: trivial_conjugatable_linordered_field mat"
  assumes A: "A \<in> carrier_mat nr n"
  assumes b: "b \<in> carrier_vec nr"
  defines "P \<equiv> polyhedron A b"
  assumes "face P F"
  assumes "face F F'"
  shows "face P F'"
proof -
  obtain A' b' I' where A'_b':"((A', b') = sub_system A b I')
                              \<and> F = {x. A' *\<^sub>v x = b' \<and> x \<in> P}"
    using char_face1[of A nr b F] assms(1-4)
    unfolding P_def
    by (metis (full_types))
  then obtain C d  where C_d:"C = (A @\<^sub>r(A' @\<^sub>r (-A')))" "d = (b @\<^sub>v (b' @\<^sub>v (-b')))"
    "F = polyhedron C d"
    "dim_row (A @\<^sub>r (A' @\<^sub>r (-A'))) = dim_vec (b @\<^sub>v(b' @\<^sub>v (-b')))"
    "dim_col (A @\<^sub>r(A' @\<^sub>r (-A'))) = n"
    using face_is_polyhedron''2[of A nr b A' b' I' F]
    by (smt (verit) A Collect_cong P_def b gram_schmidt.polyhedron_def mem_Collect_eq)

  then obtain C' d' J where C'_d': "((C', d') = sub_system C d J)
                              \<and> F' = {x. C' *\<^sub>v x = d' \<and> x \<in> F}"
    using char_face1[of C _ d F'] assms(1-5)
    unfolding `F = polyhedron C d`
    by (smt (verit, best) carrier_matI carrier_vec_dim_vec)
  obtain A'' b'' where A''_b'': "((A'', b'') = sub_system A b (I' \<union> J))"
    by (metis surj_pair)
  have "dim_row A'' = dim_vec b''"
    by (metis A A''_b'' b carrier_matD(1) carrier_vecD dims_subsyst_same')
  have "dim_row A \<le> dim_row C" using C_d
    by (metis A add_lessD1 b carrier_matD(1) carrier_vecD index_append_vec(2)
        linorder_le_less_linear order_less_irrefl)
  have "\<forall> i < dim_row A. (row C i) = row A i"
    using C_d(1) append_rows_index_same[of A nr "A' @\<^sub>r - A'" _]
    by (metis (no_types, lifting) A A'_b' b carrier_matI face_is_polyhedron'(3))
  have "\<forall> i < dim_vec b. d $ i = b $ i"
    unfolding C_d(2)
    by (meson index_append_vec(1) trans_less_add1)
  then have 3:"\<forall> i < dim_row A. (row C i) = row A i \<and> d $ i = b $ i"
    by (metis A \<open>\<forall>i<dim_row A. row C i = row A i\<close> b carrier_matD(1) carrier_vecD)
  have "dim_row A' = dim_vec b'"
    by (metis A A'_b' b carrier_matD(1) carrier_vecD dims_subsyst_same')
  have "dim_col A' = n" using A'_b' dim_col_subsyst_mat
    by (metis A carrier_matD(2) fst_conv)
  then have "dim_col (A' @\<^sub>r - A') = n"
    using A A'_b' b face_is_polyhedron'(3) by blast
  then have "A' @\<^sub>r - A' \<in> carrier_mat (dim_row (A' @\<^sub>r - A')) n"
    by blast
  have "dim_row C = nr + dim_row (A' @\<^sub>r - A')"
    using A A'_b' C_d(1) C_d(4) b face_is_polyhedron'(2) by force
  have 1:"\<forall> i. (i \<ge> nr \<and> i < dim_row C) \<longrightarrow> (row C i) = row  (A' @\<^sub>r - A') (i - nr)"
    using C_d(1) append_rows_index_same'[of A nr "A' @\<^sub>r - A'" "dim_row (A' @\<^sub>r - A')"]
      `A' @\<^sub>r - A' \<in> carrier_mat (dim_row (A' @\<^sub>r - A')) n` A
    by (metis \<open>dim_row C = nr + dim_row (A' @\<^sub>r - A')\<close>)
  have "\<forall> i. i > nr \<and> i < dim_vec d \<longrightarrow> d $ i =  (b' @\<^sub>v (-b')) $ (i - nr)"
    unfolding C_d(2)
    using b by auto
  then have 5:"\<forall> i \<in> {nr..<dim_row C}. (row C i) = row  (A' @\<^sub>r - A') (i - nr)
            \<and> d $ i =  (b' @\<^sub>v (-b')) $ (i - nr)"
    by (metis C_d(1) C_d(2) C_d(4) 1 atLeastLessThan_iff b carrier_vecD index_append_vec(1)
        index_append_vec(2) order_le_imp_less_or_eq)
  have " \<forall> x \<in> F. A' *\<^sub>v x = b' "using A'_b' by auto
  then have "\<forall> x \<in> F. \<forall>i < dim_row A'. row A' i \<bullet> x = b' $ i"
    using index_mult_mat_vec
    by metis
  then have 2:"\<forall> x \<in> F. \<forall>i \<in> I' \<inter> {0..<dim_row A}.  (row A i) \<bullet> x = (b $ i)"
    using subsystem_fulfills_P[of A b A' b' I' "\<lambda> p q. p \<bullet> _ = q"] C_d
    using C'_d'
    by (metis (no_types, lifting) A A'_b' b carrier_matD(1) carrier_vecD)
  have "\<forall>x \<in> F. dim_vec x = dim_col A'"
  proof
    fix x
    assume "x \<in> F"
    then have "x \<in> P"
      using assms(4) face_subset_polyhedron by blast
    then have "x \<in> carrier_vec n" unfolding P_def polyhedron_def by blast
    have "dim_col A' = n" using A'_b' dim_col_subsyst_mat
      by (metis A carrier_matD(2) fst_conv)
    then show "dim_vec x = dim_col A'"
      using \<open>x \<in> carrier_vec n\<close> carrier_vecD by blast
  qed
  then have "\<forall> x \<in> F. A' *\<^sub>v x \<le> b' \<and> (-A') *\<^sub>v x \<le> - b'"
    using `\<forall> x \<in> F. A' *\<^sub>v x = b'` eq_system_is_leq_system by blast
  then have "\<forall> x \<in> F. (A' @\<^sub>r (-A')) *\<^sub>v x = (b' @\<^sub>v (-b'))" using append_rows_le
    by (smt (verit) \<open>\<forall>x\<in>F. A' *\<^sub>v x = b'\<close> \<open>\<forall>x\<in>F. dim_vec x = dim_col A'\<close> carrier_matI
        carrier_vec_dim_vec index_uminus_mat(3) mat_mult_append uminus_mult_mat_vec)
  have "dim_row C = dim_vec d"
    using C_d(1) C_d(2) C_d(4) by blast
  have "dim_row C' = dim_vec d'" using C'_d'
    using \<open>dim_row C = dim_vec d\<close> dims_subsyst_same' by blast
  have "{x. C' *\<^sub>v x = d' \<and> x \<in> F} = {x. A'' *\<^sub>v x = b'' \<and> x \<in> P}"
  proof(safe)
    {
      fix x
      assume "x \<in> F" "d' = C' *\<^sub>v x"
      have "\<forall>i < dim_row C'. row C' i \<bullet> x = d' $ i" using `d' = C' *\<^sub>v x`
        by (metis index_mult_mat_vec)
      then have "\<forall>i \<in> J \<inter> {0..<dim_row C}.  (row C i) \<bullet> x = (d $ i)"
        using subsystem_fulfills_P[of C d C' d' J "\<lambda> p q. p \<bullet> x = q"] C_d
        using C'_d' by blast
      then have "\<forall>i \<in> J \<inter> {0..<dim_row A}.  (row C i) \<bullet> x = (d $ i)"
        by (metis IntD1 IntD2 IntI \<open>dim_row A \<le> dim_row C\<close> atLeastLessThan_iff inf.absorb_iff2
            inf.strict_boundedE)
      have "\<forall>i \<in> J \<inter> {0..<dim_row A}.  (row A i) \<bullet> x = (b $ i)"
        using `\<forall> i < dim_row A. (row C i) = row A i \<and> d $ i = b $ i`
        by (metis IntD2 \<open>\<forall>i\<in>J \<inter> {0..<dim_row A}. row C i \<bullet> x = d $ i\<close> atLeastLessThan_iff)
      then have "\<forall> i < dim_row A''. (row A'' i) \<bullet> x =  (b'' $ i)"
        using subsystem_fulfills_P'[of A b A'' b'' _ "\<lambda> p q. p \<bullet> x = q"]
        using A A''_b'' b carrier_vecD
        by (metis IntD1 IntD2 IntI Un_iff 2 \<open>x \<in> F\<close> carrier_matD(1))
      then show " A'' *\<^sub>v x = b''"
        using eq_for_all_index_then_eq[of A'' b'' x] `dim_row A'' = dim_vec b''` by auto
    }
    show "\<And>x.  x \<in> F \<Longrightarrow> d' = C' *\<^sub>v x \<Longrightarrow> x \<in> P"
      using assms(4) gram_schmidt.face_subset_polyhedron by blast
    {
      fix x
      assume "x \<in> P" "b'' = A'' *\<^sub>v x"
      then have "\<forall> i < dim_row A''. (row A'' i) \<bullet> x =  (b'' $ i)"
        by (metis index_mult_mat_vec)
      then have 4:"\<forall>i \<in> (J \<union> I') \<inter> {0..<dim_row A}.  (row A i) \<bullet> x = (b $ i)"
        using subsystem_fulfills_P[of A b A'' b'' _ "\<lambda> p q. p \<bullet> x = q"]
        using A A''_b'' b carrier_vecD by blast
      then have 6:"\<forall>i \<in> J \<inter> {0..<dim_row A}.  (row C i) \<bullet> x = (d $ i)"
        by (metis IntD1 IntD2 IntI Un_Int_eq(4) 3 atLeastLessThan_iff sup_commute)
      have "\<forall>i \<in> I' \<inter> {0..<dim_row A}.  (row A i) \<bullet> x = (b $ i)"
        by (metis IntD1 IntD2 IntI Un_Int_eq(1) 4 sup_commute)
      then have "\<forall> i < dim_row A'. (row A' i) \<bullet> x =  (b' $ i)"
        using subsystem_fulfills_P'[of A b A' b' I' "\<lambda> p q. p \<bullet> x = q"]
          A'_b'
        using A b carrier_vecD by blast
      then have "A' *\<^sub>v x = b'"
        using eq_for_all_index_then_eq[of A' b' x] `dim_row A' = dim_vec b'` by auto
      have "dim_vec x = dim_col A'"
      proof -
        have "x \<in> carrier_vec n"
          using `x \<in> P`unfolding P_def polyhedron_def by blast
        have "dim_col A' = n" using A'_b' dim_col_subsyst_mat
          by (metis A carrier_matD(2) fst_conv)
        then show "dim_vec x = dim_col A'"
          using \<open>x \<in> carrier_vec n\<close> carrier_vecD by blast
      qed
      then have "A' *\<^sub>v x \<le> b' \<and> (-A') *\<^sub>v x \<le> - b'"
        using eq_system_is_leq_system `A' *\<^sub>v x = b'` by blast
      then have "(A' @\<^sub>r (-A')) *\<^sub>v x = (b' @\<^sub>v (-b'))"
        by (smt (verit) \<open>A' *\<^sub>v x = b'\<close> \<open>dim_vec x = dim_col A'\<close> carrier_matI carrier_vec_dim_vec
            index_uminus_mat(3) mat_mult_append uminus_mult_mat_vec)
      then have "\<forall>i \<in> {dim_row A..<dim_row C}.  (row C i) \<bullet> x = (d $ i)"
        by (metis A 5 \<open>dim_row C = nr + dim_row (A' @\<^sub>r - A')\<close> add.commute atLeastLessThan_iff
            carrier_matD(1) index_mult_mat_vec less_diff_conv2)
      then have "\<forall>i \<in> J \<inter> {0..<dim_row C}.  (row C i) \<bullet> x = (d $ i)"
        by (metis IntD1 IntD2 IntI 6 atLeastLessThan_iff le_neq_implies_less nat_le_linear)
      then have "\<forall> i < dim_row C'. (row C' i) \<bullet> x =  (d' $ i)"
        using subsystem_fulfills_P'[of C d C' d' J "\<lambda> p q. p \<bullet> x = q"] C'_d'
        using C_d by blast
      then show " C' *\<^sub>v x = d'"
        using eq_for_all_index_then_eq[of C' d' x] `dim_row C' = dim_vec d'` by auto
      show "x \<in> F" using  A'_b' `A' *\<^sub>v x = b'` `x \<in> P` by blast
    }
  qed
  have "F' = {x. A'' *\<^sub>v x = b'' \<and> x \<in> P}"
    using C'_d' \<open>{x. C' *\<^sub>v x = d' \<and> x \<in> F} = {x. A'' *\<^sub>v x = b'' \<and> x \<in> P}\<close> by fastforce
  then show ?thesis using char_face2[of A nr b A'' b'' "(I' \<union> J)" F']
    using A A''_b'' P_def assms(5) b face_non_empty by presburger
qed

lemma subsyst_with_max_ineq_is_min_face:
  fixes A :: "'a :: trivial_conjugatable_linordered_field mat"
  assumes A: "A \<in> carrier_mat nr n"
  assumes b: "b \<in> carrier_vec nr"
  defines "P \<equiv> polyhedron A b"
  assumes "((A', b') = sub_system A b I)"
  assumes "{x. A' *\<^sub>v x = b' \<and> x \<in> P} \<noteq> {}"
  assumes "dim_vec b' = Max {dim_vec d| C d I. (C, d) = sub_system A b I \<and>
                                                {x. C *\<^sub>v x = d \<and> x \<in> P} \<noteq> {}}"
  shows "min_face P {x. A' *\<^sub>v x = b' \<and> x \<in> P}"
proof
  show "face P {x. A' *\<^sub>v x = b' \<and> x \<in> P}"
    using char_face2[of A nr b A' b' I "{x. A' *\<^sub>v x = b' \<and> x \<in> P}"]
    unfolding P_def
    using A P_def assms(4) assms(5) b by blast
  show " \<not> (\<exists>F'\<subset>{x. A' *\<^sub>v x = b' \<and> x \<in> P}. face P F')"
  proof
    assume "\<exists>F'\<subset>{x. A' *\<^sub>v x = b' \<and> x \<in> P}. face P F'"
    obtain F' where F':"F'\<subset>{x. A' *\<^sub>v x = b' \<and> x \<in> P} \<and> face P F'"
      using \<open>\<exists>F'\<subset>{x. A' *\<^sub>v x = b' \<and> x \<in> P}. face P F'\<close> by presburger
    then obtain C d I' where C_d:"((C, d) = sub_system A b I')
                              \<and> F' = {x. C *\<^sub>v x = d \<and> x \<in> P}" "(I \<inter> {0..<nr}) \<subset> (I' \<inter> {0..<nr})"
      using obtain_I_for_subface[of A nr b A' b' I "{x. A' *\<^sub>v x = b' \<and> x \<in> P}" F']
      using A b P_def `face P {x. A' *\<^sub>v x = b' \<and> x \<in> P}` assms(4)
      by force
    then have "dim_vec b' < dim_vec d"
      using less_I_less_dims_subsystem[of A nr b I I' A' b' C d]
            A assms(4) b by blast
    have 1:"dim_vec d \<in> {dim_vec d| C d I. (C, d) = sub_system A b I \<and>
                                                {x. C *\<^sub>v x = d \<and> x \<in> P} \<noteq> {}}"
      by (smt (verit, best) Collect_cong C_d F' face_non_empty mem_Collect_eq)
    have "dim_vec b = nr" using b by auto
    let ?M = "{dim_vec d| C d I. (C, d) = sub_system A b I \<and> {x. C *\<^sub>v x = d \<and> x \<in> P} \<noteq> {}}"
    have "finite ?M"
      using subset_set_of_sub_dims_finite[of ?M A b] by blast
    have "?M \<noteq> {}" using 1
      by blast
    then have "Max ?M \<in> ?M \<and> (\<forall>a \<in> ?M. a \<le> (Max ?M))"
      using eq_Max_iff[of ?M] `?M \<noteq> {}` `finite ?M`
      by auto
    then have "dim_vec d \<le> dim_vec b'"
      using eq_Max_iff
      using "1" assms(6) by auto
    then show False
      using \<open>dim_vec b' < dim_vec d\<close> linorder_not_less by blast
  qed
qed

lemma obtain_min_face_polyhedron:
  fixes A :: "'a :: trivial_conjugatable_linordered_field mat"
  assumes A: "A \<in> carrier_mat nr n"
  assumes b: "b \<in> carrier_vec nr"
  defines "P \<equiv> polyhedron A b"
  assumes "P \<noteq> {}"
  obtains F where "min_face P F"
proof -
  obtain A' b' I'  where "((A', b') = sub_system A b I')"
    "{x. A' *\<^sub>v x = b' \<and> x \<in> P} \<noteq> {}"
    "dim_vec b' = Max {dim_vec d| C d I. (C, d) = sub_system A b I \<and>
                                                {x. C *\<^sub>v x = d \<and> x \<in> P} \<noteq> {}}"
    using  subsyst_with_max_ineq[of A nr b] assms
    by blast
  then have "min_face P {x. A' *\<^sub>v x = b' \<and> x \<in> P}"
    using subsyst_with_max_ineq_is_min_face[of A nr b A' b' I'] assms by fast
  then show ?thesis
    by (simp add: that)
qed

lemma face_contains_min_face:
  fixes A :: "'a :: trivial_conjugatable_linordered_field mat"
  assumes A: "A \<in> carrier_mat nr n"
  assumes b: "b \<in> carrier_vec nr"
  defines "P \<equiv> polyhedron A b"
  assumes "face P F"
  shows "\<exists> F'. F' \<subseteq> F \<and> min_face P F'"
proof -
  obtain C d where C_d:"F = polyhedron C d" "dim_row C = dim_vec d" "dim_col C = n"
    using A P_def assms(4) b face_is_polyhedron by metis
  have "F \<noteq> {}"
    using assms(4) face_non_empty by auto
  obtain F' where "min_face F F'"
    using obtain_min_face_polyhedron[of C "dim_row C" d] C_d
    by (metis \<open>F \<noteq> {}\<close> carrier_mat_triv carrier_vec_dim_vec)
  have "face P F'"
    using A P_def \<open>min_face F F'\<close> assms(4) b min_face_elim(1) face_trans by presburger
  have "\<not> (\<exists>S\<subset>F'. face F S)"
    by (simp add: \<open>min_face F F'\<close> min_face_elim(2))
  then have "\<not> (\<exists>S\<subset>F'. face P S)"
    by (meson \<open>min_face F F'\<close> assms(4) face_subset_polyhedron subset_is_face min_face_elim(1)
        psubset_imp_subset subset_trans)
  then have "min_face P F'"
    using \<open>face P F'\<close> by blast
  then show ?thesis
    by (meson \<open>min_face F F'\<close> face_subset_polyhedron min_face_elim(1))
qed

lemma int_all_min_faces_then_int_all_faces:
  fixes A :: "'a :: trivial_conjugatable_linordered_field mat"
  assumes A: "A \<in> carrier_mat nr n"
  assumes b: "b \<in> carrier_vec nr"
  defines "P \<equiv> polyhedron A b"
  assumes "\<forall> F. min_face P F \<longrightarrow> (\<exists> x \<in> F. x \<in> \<int>\<^sub>v)"
  shows "\<forall> F. face P F \<longrightarrow> (\<exists> x \<in> F. x \<in> \<int>\<^sub>v)"
proof safe
  fix F
  assume "face P F"
  then obtain F' where "F' \<subseteq> F \<and> min_face P F'"
    using face_contains_min_face assms by metis
  then show "\<exists> x \<in> F. x \<in> \<int>\<^sub>v"
    by (meson assms(4) subset_iff)
qed

lemma int_all_faces_then_int_all_min_faces:
  fixes A :: "'a :: trivial_conjugatable_linordered_field mat"
  assumes A: "A \<in> carrier_mat nr n"
  assumes b: "b \<in> carrier_vec nr"
  defines "P \<equiv> polyhedron A b"
  assumes "\<forall> F. face P F \<longrightarrow> (\<exists> x \<in> F. x \<in> \<int>\<^sub>v)"
  shows "\<forall> F. min_face P F \<longrightarrow> (\<exists> x \<in> F. x \<in> \<int>\<^sub>v)"
  using assms(4) min_face_elim(1)
  by presburger

lemma int_all_min_faces_iff_int_all_faces:
  fixes A :: "'a :: trivial_conjugatable_linordered_field mat"
  assumes A: "A \<in> carrier_mat nr n"
  assumes b: "b \<in> carrier_vec nr"
  defines "P \<equiv> polyhedron A b"
  shows "(\<forall> F. min_face P F \<longrightarrow> (\<exists> x \<in> F. x \<in> \<int>\<^sub>v)) \<longleftrightarrow> (\<forall> F. face P F \<longrightarrow> (\<exists> x \<in> F. x \<in> \<int>\<^sub>v))"
  using int_all_min_faces_then_int_all_faces[of A nr b]
    int_all_faces_then_int_all_min_faces[of A nr b]  assms
  by blast

text \<open>a ==> b\<close>

lemma lin_comb_in_hyp:
  fixes y :: "'a :: trivial_conjugatable_linordered_field vec"
  assumes "P \<subseteq> carrier_vec n"
  assumes "y \<in> P"
  assumes "z \<in> P"
  assumes "support_hyp P \<alpha> \<beta>"
  assumes "\<beta> = \<alpha> \<bullet> (l \<cdot>\<^sub>v y + (1 - l) \<cdot>\<^sub>v z)"
  assumes "l > 0 \<and> l < 1"
  shows "\<alpha> \<bullet> y = \<beta>"
proof -
  have "\<alpha> \<in> carrier_vec n"
    using assms(4) unfolding support_hyp_def by auto
  have " \<beta> = \<alpha> \<bullet> (l \<cdot>\<^sub>v y) + \<alpha> \<bullet> ((1 - l) \<cdot>\<^sub>v z)"
    using scalar_prod_add_distrib[of \<alpha> n "l \<cdot>\<^sub>v y" "(1 - l) \<cdot>\<^sub>v z"] `\<alpha> \<in> carrier_vec n`
      assms(1-3) assms(5) by blast
  then have 1: "l * (\<alpha> \<bullet> y) + (1 - l) * (\<alpha> \<bullet> z) = \<beta>"
    using \<open>\<alpha> \<in> carrier_vec n\<close> assms(1-3) in_mono by fastforce
  have "\<alpha> \<bullet> y \<le> \<beta>"
    using assms(2) assms(4) support_hyp_is_valid(1) valid_ineqE by blast
  have "\<alpha> \<bullet> z \<le> \<beta>"
    using assms(3) assms(4) support_hyp_is_valid(1) valid_ineqE by blast
  show "\<alpha> \<bullet> y = \<beta>"
  proof(cases "\<alpha> \<bullet> z = \<beta>")
    case True
    then show ?thesis
      using  assms(6) 1
      by (simp add: left_diff_distrib)
  next
    case False
    have "\<alpha> \<bullet> z < \<beta>"
      by (simp add: False \<open>\<alpha> \<bullet> z \<le> \<beta>\<close> order.strict_iff_order)
    then have "(1 - l) * (\<alpha> \<bullet> z) < (1 - l) * \<beta>" using assms(6)
      by auto
    have "l * (\<alpha> \<bullet> y) \<le> l * \<beta>"
      by (simp add: \<open>0 < l \<and> l < 1\<close> \<open>\<alpha> \<bullet> y \<le> \<beta>\<close>)
    then have "l * (\<alpha> \<bullet> y) + (1 - l) * (\<alpha> \<bullet> z) < l * \<beta> + (1 - l) * \<beta>"
      using \<open>(1 - l) * (\<alpha> \<bullet> z) < (1 - l) * \<beta>\<close> add_mono_thms_linordered_field(4) by blast
    then have "l * (\<alpha> \<bullet> y) + (1 - l) * (\<alpha> \<bullet> z) < \<beta>" by algebra
    then show ?thesis using 1 by blast
  qed
qed

lemma P_int_then_face_int:
  fixes A :: "'a :: trivial_conjugatable_linordered_field mat"
  assumes "P \<subseteq> carrier_vec n"
  assumes "P = integer_hull P"
  shows "(\<forall> F. face P F \<longrightarrow> (\<exists> x \<in> F. x \<in> \<int>\<^sub>v))"
proof
  fix F
  show " face P F \<longrightarrow> (\<exists>x\<in>F. x \<in> \<int>\<^sub>v)"
  proof
    assume "face P F"
    obtain x where "x \<in> F"
      using \<open>face P F\<close> face_non_empty by fastforce
    show "\<exists>x\<in>F. x \<in> \<int>\<^sub>v"
    proof(cases "x \<in> \<int>\<^sub>v")
      case True
      then show ?thesis using `x \<in> F`
        by blast
    next
      case False
      obtain \<alpha> \<beta>  where \<alpha>_\<beta>:"P \<noteq> {} \<and>  F = P \<inter> {x |x. \<alpha> \<bullet> x = \<beta>} \<and> support_hyp P \<alpha> \<beta> "
        using \<open>face P F\<close> face_def by auto
      obtain y z l where lin_comb_x:"y \<in> P \<inter> \<int>\<^sub>v" "z \<in> P" "x = l \<cdot>\<^sub>v y + (1 - l) \<cdot>\<^sub>v z" "l > 0 \<and> l < 1"
        using elem_of_P_is_lin_comb[of P x]
        using assms gram_schmidt.polyhedron_def False \<open>x \<in> F\<close>
        using \<open>face P F\<close> face_subset_polyhedron by blast
      have "\<alpha> \<bullet> y = \<beta>"
        using lin_comb_in_hyp[of P y z \<alpha> \<beta> l]
          \<alpha>_\<beta> lin_comb_x `P \<subseteq> carrier_vec n` \<open>x \<in> F\<close> by fastforce
      then have "y \<in> F" using `y \<in> P \<inter> \<int>\<^sub>v`  \<alpha>_\<beta> by blast
      then show ?thesis
        using \<open>y \<in> P \<inter> \<int>\<^sub>v\<close> by blast
    qed
  qed
qed

text\<open>b \<Longrightarrow> f\<close>

lemma int_face_then_max_suphyp_int:
  fixes A :: "'a :: trivial_conjugatable_linordered_field mat"
  assumes "P \<subseteq> carrier_vec n"
  assumes "(\<forall> F. face P F \<longrightarrow> (\<exists> x \<in> F. x \<in> \<int>\<^sub>v))"
  shows "\<forall> \<alpha> \<in> carrier_vec n. has_Maximum { \<alpha> \<bullet> x | x. x \<in> P} \<longrightarrow>
   (\<exists>x. x \<in> P \<and> \<alpha> \<bullet> x = Maximum { \<alpha> \<bullet> x | x. x \<in> P}  \<and> x \<in> \<int>\<^sub>v)"
proof(safe)
  fix \<alpha> :: "'a vec"
  assume "\<alpha> \<in> carrier_vec n" "has_Maximum {\<alpha> \<bullet> x |x. x \<in> P}"
  let ?\<beta> = "Maximum { \<alpha> \<bullet> x | x. x \<in> P}"

  have "?\<beta> \<in>  { \<alpha> \<bullet> x | x. x \<in> P}"
    apply(rule has_MaximumD \<open>has_Maximum {\<alpha> \<bullet> x |x. x \<in> P}\<close>)
    by (simp add: \<open>has_Maximum {\<alpha> \<bullet> x |x. x \<in> P}\<close>)
  have "support_hyp P \<alpha> ?\<beta>" unfolding support_hyp_def
    using \<open>\<alpha> \<in> carrier_vec n\<close> \<open>has_Maximum {\<alpha> \<bullet> x |x. x \<in> P}\<close> by blast
  have "face P (P \<inter> {y |y. \<alpha> \<bullet> y = ?\<beta>})"
    unfolding face_def
    apply(auto)
    using \<open>Maximum {\<alpha> \<bullet> x |x. x \<in> P} \<in> {\<alpha> \<bullet> x |x. x \<in> P}\<close> apply blast
    using \<open>support_hyp P \<alpha> (Maximum {\<alpha> \<bullet> x |x. x \<in> P})\<close> by blast
  then show "\<exists>x. x \<in> P \<and> \<alpha> \<bullet> x = Maximum { \<alpha> \<bullet> x | x. x \<in> P}  \<and> x \<in> \<int>\<^sub>v" using assms(1-2)
    by blast
qed

text \<open>f ==> a\<close>

lemma int_hull_subset:
  fixes A :: "'a :: trivial_conjugatable_linordered_field mat"
  assumes A: "A \<in> carrier_mat nr n"
  assumes b: "b \<in> carrier_vec nr"
  defines "P \<equiv> polyhedron A b"
  shows "integer_hull P \<subseteq> P"
  by (metis A Int_subset_iff P_def b convex_def convex_hull_mono
      integer_hull_def order_refl polyhedra_are_convex)

lemma not_in_int_hull_not_int:
  fixes A :: "'a :: trivial_conjugatable_linordered_field mat"
  assumes A: "A \<in> carrier_mat nr n"
  assumes b: "b \<in> carrier_vec nr"
  defines "P \<equiv> polyhedron A b"
  assumes "y \<in> P - integer_hull P"
  shows "y \<notin> \<int>\<^sub>v"
proof
  assume " y \<in> \<int>\<^sub>v"
  then have "y \<in> P \<inter>  \<int>\<^sub>v" using assms(4) by auto
  have "P \<inter> \<int>\<^sub>v \<subseteq> carrier_vec n" using P_def unfolding polyhedron_def
    by blast
  then have "y \<in> integer_hull P"
    unfolding integer_hull_def using set_in_convex_hull[of "P \<inter> \<int>\<^sub>v"]
    using \<open>y \<in> P \<inter> \<int>\<^sub>v\<close> by blast
  then show False using assms(4)
    by blast
qed

lemma exists_eq_in_P_for_outside_elem:
  fixes A :: "'a :: trivial_conjugatable_linordered_field mat"
  assumes A: "A \<in> carrier_mat nr n"
  assumes b: "b \<in> carrier_vec nr"
  defines "P \<equiv> polyhedron A b"
  assumes "y \<notin> P"
  assumes "y \<in> carrier_vec n"
  shows "\<exists>j. j < nr \<and> (row A j) \<bullet> y >  b $ j"
proof(rule ccontr)
  assume "\<not> (\<exists>j<nr. b $ j < row A j \<bullet> y)"
  then have 1: "\<forall>j<dim_row A.  row A j \<bullet> y \<le> b $ j"
    by (metis A carrier_matD(1) leI)
  have 2: "dim_row A = dim_vec b"
    using A b carrier_vecD by blast
  have "A *\<^sub>v y \<le> b" using leq_for_all_index_then_eq 1 2
    by blast
  have "y \<in> P"
    unfolding P_def polyhedron_def
    using \<open>A *\<^sub>v y \<le> b\<close> assms(5) by blast
  then show False
    by (simp add: assms(4))
qed

lemma eq_in_P_has_max:
  fixes A :: "'a  mat"
  fixes b:: "'a vec"
  assumes A: "A \<in> carrier_mat nr n"
  assumes b: "b \<in> carrier_vec nr"
  defines "P \<equiv> polyhedron A b"
  assumes "i < nr"
  assumes "P \<noteq> {}"
  shows "has_Maximum { row A i \<bullet> x | x. x \<in> P}"
proof -
  have "\<forall> x \<in> P. row A i \<bullet> x \<le> b $ i"
    using P_def unfolding polyhedron_def
      mult_mat_vec_def
    apply  (auto simp:  less_eq_vec_def)
    using assms(4) b by force
  then have "valid_ineq P (row A i) (b $ i)" unfolding valid_ineq_def
    using A assms(4) row_carrier_vec by blast
  then show ?thesis
    using A P_def assms(5) b valid_ineq_dual(2) by auto
qed

end
end


(*
  Theory: PDF_Values.thy
  Author: Manuel Eberl

  Defines the values and types in the PDF language and the corresponding stock measure spaces.
  Additionally, some functions and lemmas for lifting functions on the HOL types (int, real, \<dots>)
  to PDF values are provided.
*)

section \<open>Source Language Values\<close>

theory PDF_Values
imports Density_Predicates
begin

subsection \<open>Values and stock measures\<close>

datatype pdf_type =  UNIT | BOOL | INTEG | REAL | PRODUCT pdf_type pdf_type

datatype val = UnitVal
  | BoolVal (extract_bool: bool)
  | IntVal (extract_int: int)
  | RealVal (extract_real: real)
  | PairVal (extract_fst: val) (extract_snd: val)  ("<|_, _|>"  [0, 61] 1000)
where
  "extract_bool UnitVal = False"
| "extract_bool (IntVal i) = False"
| "extract_bool (RealVal r) = False"
| "extract_bool (PairVal x y) = False"
| "extract_int UnitVal = 0"
| "extract_int (BoolVal b) = 0"
| "extract_int (RealVal r) = 0"
| "extract_int (PairVal x y) = 0"
| "extract_real UnitVal = 0"
| "extract_real (BoolVal b) = 0"
| "extract_real (IntVal i) = 0"
| "extract_real (PairVal x y) = 0"

primrec extract_pair' where
  "extract_pair' f s <| x, y |> = (f x, s y)"

definition map_int_pair where
  "map_int_pair f g x = (case x of <| IntVal a, IntVal b |> \<Rightarrow> f a b | _ \<Rightarrow> g x)"

definition map_real_pair where
  "map_real_pair f g x = (case x of <| RealVal a, RealVal b |> \<Rightarrow> f a b | _ \<Rightarrow> g x)"

abbreviation "TRUE \<equiv> BoolVal True"
abbreviation "FALSE \<equiv> BoolVal False"

type_synonym vname = "nat"
type_synonym state = "vname \<Rightarrow> val"

lemma map_int_pair[simp]: "map_int_pair f g <| IntVal i, IntVal j |> = f i j"
  by (simp add: map_int_pair_def)

lemma map_int_pair_REAL[simp]: "map_int_pair f g <| RealVal i, RealVal j |> = g <| RealVal i, RealVal j |>"
  by (simp add: map_int_pair_def)

lemma map_real_pair[simp]: "map_real_pair f g <| RealVal i, RealVal j |> = f i j"
  by (simp add: map_real_pair_def)

abbreviation "extract_pair \<equiv> extract_pair' id id"
abbreviation "extract_real_pair \<equiv> extract_pair' extract_real extract_real"
abbreviation "extract_int_pair \<equiv> extract_pair' extract_int extract_int"

definition "RealPairVal \<equiv> \<lambda>(x,y). <|RealVal x, RealVal y|>"

definition "IntPairVal \<equiv> \<lambda>(x,y). <|IntVal x, IntVal y|>"

lemma inj_RealPairVal: "inj RealPairVal" by (auto simp: RealPairVal_def intro!: injI)
lemma inj_IntPairVal: "inj IntPairVal" by (auto simp: IntPairVal_def intro!: injI)

fun val_type :: "val \<Rightarrow> pdf_type" where
  "val_type (BoolVal b) = BOOL"
| "val_type (IntVal i) = INTEG"
| "val_type UnitVal = UNIT"
| "val_type (RealVal r) = REAL"
| "val_type (<|v1 , v2|>) = (PRODUCT (val_type v1) (val_type v2))"

lemma val_type_eq_REAL: "val_type x = REAL \<longleftrightarrow> x \<in> RealVal`UNIV"
  by (cases x) auto

lemma val_type_eq_INTEG: "val_type x = INTEG \<longleftrightarrow> x \<in> IntVal`UNIV"
  by (cases x) auto

definition "type_universe t = {v. val_type v = t}"

lemma type_universe_nonempty[simp]: "type_universe t \<noteq> {}"
  by (induction t) (auto intro: val_type.simps simp: type_universe_def)

lemma val_in_type_universe[simp]:
    "v \<in> type_universe (val_type v)"
  by (simp add: type_universe_def)

lemma IntVal_in_type_universe[simp]: "IntVal v \<in> type_universe INTEG"
  by (simp add: type_universe_def)

lemma type_universe_type[simp]:
    "w \<in> type_universe t \<longleftrightarrow> val_type w = t"
  by (simp add: type_universe_def)

lemma type_universe_REAL: "type_universe REAL = RealVal ` UNIV"
  apply (auto simp add: set_eq_iff image_iff)
  apply (case_tac x)
  apply auto
  done

lemma type_universe_eq_imp_type_eq:
  assumes "type_universe t1 = type_universe t2"
  shows "t1 = t2"
proof-
  from type_universe_nonempty obtain v where A: "v \<in> type_universe t1" by blast
  hence "t1 = val_type v" by simp
  also from A and assms have "v \<in> type_universe t2" by simp
  hence "val_type v = t2" by simp
  finally show ?thesis .
qed

lemma type_universe_eq_iff[simp]: "type_universe t1 = type_universe t2 \<longleftrightarrow> t1 = t2"
  by (blast intro: type_universe_eq_imp_type_eq)

primrec stock_measure :: "pdf_type \<Rightarrow> val measure" where
  "stock_measure UNIT = count_space {UnitVal}"
| "stock_measure INTEG = count_space (range IntVal)"
| "stock_measure BOOL = count_space (range BoolVal)"
| "stock_measure REAL = embed_measure lborel RealVal"
| "stock_measure (PRODUCT t1 t2) =
       embed_measure (stock_measure t1 \<Otimes>\<^sub>M stock_measure t2) (\<lambda>(a, b). <|a, b|>)"

declare [[coercion stock_measure]]

lemma sigma_finite_stock_measure[simp]: "sigma_finite_measure (stock_measure t)"
  by (induction t)
     (auto intro!: sigma_finite_measure_count_space_countable sigma_finite_pair_measure
                   sigma_finite_embed_measure injI sigma_finite_lborel)

lemma val_case_stock_measurable:
  assumes "t = UNIT \<Longrightarrow> c \<in> space M"
  assumes "\<And>b. t = BOOL \<Longrightarrow> g b \<in> space M"
  assumes "\<And>i. t = INTEG \<Longrightarrow> h i \<in> space M"
  assumes "t = REAL \<Longrightarrow> j \<in> measurable borel M"
  assumes *: "\<And>t1 t2. t = PRODUCT t1 t2 \<Longrightarrow> case_prod k \<in> measurable (stock_measure t1 \<Otimes>\<^sub>M stock_measure t2) M"
  shows "(\<lambda>x. case x of UnitVal \<Rightarrow> c | BoolVal b \<Rightarrow> g b | IntVal i \<Rightarrow> h i | RealVal r \<Rightarrow> j r
                | PairVal y z \<Rightarrow> k y z) \<in> measurable t M"
proof (cases t)
  case (PRODUCT t1 t2) with *[of t1 t2] show ?thesis
    by (auto intro!: measurable_embed_measure1 simp: split_beta')
qed (auto intro!: measurable_embed_measure1 assms)

lemma space_stock_measure[simp]: "space (stock_measure t) = type_universe t"
  by (induction t)
     (auto simp add: type_universe_def space_pair_measure space_embed_measure
           simp del: type_universe_type elim: val_type.elims)

lemma type_universe_stock_measure[measurable]: "type_universe t \<in> sets (stock_measure t)"
  using sets.top[of "stock_measure t"] by simp

lemma inj_RealVal[simp]: "inj RealVal" by (auto intro!: inj_onI)
lemma inj_IntVal[simp]: "inj IntVal" by (auto intro!: inj_onI)
lemma inj_BoolVal[simp]: "inj BoolVal" by (auto intro!: inj_onI)
lemma inj_PairVal[simp]: "inj (\<lambda>(x, y). <| x ,  y |>)" by (auto intro: injI)

lemma measurable_PairVal[measurable]:
  fixes t1 t2 :: pdf_type
  shows "case_prod PairVal \<in> measurable (t1 \<Otimes>\<^sub>M t2) (PRODUCT t1 t2)"
  using measurable_embed_measure2[measurable] by simp

lemma measurable_RealVal[measurable]: "RealVal \<in> measurable borel REAL"
  using measurable_embed_measure2[measurable] by simp

lemma nn_integral_BoolVal:
  assumes "\<And>x. f (BoolVal x) \<ge> 0"
  shows "(\<integral>\<^sup>+x. f x \<partial>BOOL) = f (BoolVal True) + f (BoolVal False)"
proof-
  have A: "range BoolVal = {BoolVal True, BoolVal False}" by auto
  from assms show ?thesis
    by (subst stock_measure.simps, subst A, subst nn_integral_count_space_finite)
       (simp_all add: max_def A)
qed

lemma nn_integral_RealVal:
  "f \<in> borel_measurable REAL \<Longrightarrow> (\<integral>\<^sup>+x. f x \<partial>REAL) = (\<integral>\<^sup>+x. f (RealVal x) \<partial>lborel)"
  unfolding stock_measure.simps using measurable_embed_measure2[measurable]
  by (subst embed_measure_eq_distr, simp_all add: nn_integral_distr)

lemma nn_integral_IntVal: "(\<integral>\<^sup>+x. f x \<partial>INTEG) = (\<integral>\<^sup>+x. f (IntVal x) \<partial>count_space UNIV)"
  using measurable_embed_measure1[measurable (raw)]
  unfolding stock_measure.simps embed_measure_count_space[OF inj_IntVal, symmetric]
  by (subst embed_measure_eq_distr[OF inj_IntVal], simp add: nn_integral_distr space_embed_measure)

lemma nn_integral_PairVal:
  "f \<in> borel_measurable (PRODUCT t1 t2) \<Longrightarrow>
    (\<integral>\<^sup>+x. f x \<partial>PRODUCT t1 t2) = (\<integral>\<^sup>+x. f (PairVal (fst x) (snd x)) \<partial>(t1 \<Otimes>\<^sub>M t2))"
  unfolding stock_measure.simps
  by (subst nn_integral_embed_measure) (simp_all add: split_beta' inj_on_def)

lemma BOOL_E: "\<lbrakk>val_type v = BOOL; \<And>b. v = BoolVal b \<Longrightarrow> P\<rbrakk> \<Longrightarrow> P"
  by (cases v) auto

lemma PROD_E: "\<lbrakk>val_type v = PRODUCT t1 t2 ;
     \<And>a b. val_type a = t1 \<Longrightarrow> val_type b = t2 \<Longrightarrow> v = <| a, b |> \<Longrightarrow> P\<rbrakk> \<Longrightarrow> P"
  by (cases v) auto

lemma REAL_E: "\<lbrakk>val_type v = REAL; \<And>b. v = RealVal b \<Longrightarrow> P\<rbrakk> \<Longrightarrow> P"
  by (cases v) auto

lemma INTEG_E: "\<lbrakk>val_type v = INTEG; \<And>i. v = IntVal i \<Longrightarrow> P\<rbrakk> \<Longrightarrow> P"
  by (cases v) auto

lemma measurable_extract_pair'[measurable (raw)]:
  fixes t1 t2 :: pdf_type
  assumes [measurable]: "f \<in> measurable t1 M"
  assumes [measurable]: "g \<in> measurable t2 N"
  assumes h: "h \<in> measurable K (PRODUCT t1 t2)"
  shows "(\<lambda>x. extract_pair' f g (h x)) \<in> measurable K (M \<Otimes>\<^sub>M N)"
  by (rule measurable_compose[OF h[unfolded stock_measure.simps] measurable_embed_measure1])
     (simp add: split_beta')

lemma measurable_extract_pair[measurable]: "extract_pair \<in> measurable (PRODUCT t1 t2) (t1 \<Otimes>\<^sub>M t2)"
  by measurable

lemma measurable_extract_real[measurable]: "extract_real \<in> measurable REAL borel"
  apply simp
  apply measurable
  apply (rule measurable_embed_measure1)
  apply simp
  done

lemma measurable_extract_int[measurable]: "extract_int \<in> measurable INTEG (count_space UNIV)"
  by simp measurable

lemma measurable_extract_real_pair[measurable]:
  "extract_real_pair \<in> measurable (PRODUCT REAL REAL) (borel \<Otimes>\<^sub>M borel)"
  by measurable

lemma measurable_extract_real_pair'[measurable]:
  "extract_real_pair \<in> measurable (PRODUCT REAL REAL) borel"
  by (subst borel_prod[symmetric]) measurable

lemma measurable_extract_bool[measurable]: "extract_bool \<in> measurable BOOL (count_space UNIV)"
  by simp

lemma map_int_pair_measurable[measurable]:
  assumes f: "case_prod f \<in> measurable (count_space UNIV \<Otimes>\<^sub>M count_space UNIV) M"
  shows "map_int_pair f g \<in> measurable (PRODUCT INTEG INTEG) M"
proof (subst measurable_cong)
  fix w assume "w \<in> space (PRODUCT INTEG INTEG)"
  then show "map_int_pair f g w = (case_prod f o extract_int_pair) w"
    by (auto simp: space_embed_measure space_pair_measure)
next
  show "(\<lambda>(x, y). f x y) \<circ> extract_int_pair \<in> measurable (stock_measure (PRODUCT INTEG INTEG)) M"
    using measurable_extract_int_pair f by (rule measurable)
qed

lemma map_int_pair_measurable_REAL[measurable]:
  assumes "g \<in> measurable (PRODUCT REAL REAL) M"
  shows "map_int_pair f g \<in> measurable (PRODUCT REAL REAL) M"
proof (subst measurable_cong)
  fix w assume "w \<in> space (PRODUCT REAL REAL)"
  then show "map_int_pair f g w = g w"
    by (auto simp: space_embed_measure space_pair_measure map_int_pair_def)
qed fact

lemma map_real_pair_measurable[measurable]:
  assumes f: "case_prod f \<in> measurable (borel \<Otimes>\<^sub>M borel) M"
  shows "map_real_pair f g \<in> measurable (PRODUCT REAL REAL) M"
proof (subst measurable_cong)
  fix w assume "w \<in> space (PRODUCT REAL REAL)"
  then show "map_real_pair f g w = (case_prod f o extract_real_pair) w"
    by (auto simp: space_embed_measure space_pair_measure)
next
  show "(\<lambda>(x, y). f x y) \<circ> extract_real_pair \<in> measurable (stock_measure (PRODUCT REAL REAL)) M"
    using measurable_extract_real_pair f by (rule measurable)
qed

lemma count_space_BoolVal_prod[simp]: "BOOL \<Otimes>\<^sub>M BOOL = count_space (range BoolVal \<times> range BoolVal)"
  by (auto intro!: pair_measure_countable)

lemma measurable_stock_measure_val_type:
  assumes "f \<in> measurable M (stock_measure t)" "x \<in> space M"
  shows "val_type (f x) = t"
  using assms by (auto dest!: measurable_space)

lemma singleton_in_stock_measure[simp]: "val_type v = t \<Longrightarrow> {v} \<in> sets t"
proof (induction v arbitrary: t)
  case (PairVal v1 v2)
  have A: "{<|v1, v2|>} = (\<lambda>(v1,v2). <|v1,v2|>) ` ({v1}\<times>{v2})" by simp
  from pair_measureI[OF PairVal.IH, OF refl refl] PairVal.prems[symmetric] show ?case
    by (simp only: val_type.simps stock_measure.simps A in_sets_embed_measure)
qed (auto simp: sets_embed_measure)

lemma emeasure_stock_measure_singleton_finite[simp]:
    "emeasure (stock_measure (val_type v)) {v} \<noteq> \<infinity>"
proof (induction v)
  case (RealVal r)
  have A: "{RealVal r} = RealVal ` {r}" by simp
  have "RealVal ` {r} \<in> sets (embed_measure lborel RealVal)"
      by (rule in_sets_embed_measure) simp
  thus ?case by (simp only: A val_type.simps stock_measure.simps emeasure_embed_measure
                            inj_RealVal inj_vimage_image_eq) simp
next
  case (PairVal v1 v2)
    let ?M = "\<lambda>x. stock_measure (val_type x)"
    interpret sigma_finite_measure "stock_measure (val_type v2)"
      by (rule sigma_finite_stock_measure)
    have A: "{<|v1, v2|>} = (\<lambda>(v1,v2). <|v1,v2|>) ` ({v1}\<times>{v2})" by simp
    have B: "{v1}\<times>{v2} \<in> ?M v1 \<Otimes>\<^sub>M ?M v2"
      by (intro pair_measureI singleton_in_stock_measure) simp_all
    hence "emeasure (?M (<|v1,v2|>)) {<|v1,v2|>} = emeasure (?M v1) {v1} * emeasure (?M v2) {v2}"
      by (simp only: stock_measure.simps val_type.simps A emeasure_embed_measure_image inj_PairVal
                     inj_vimage_image_eq emeasure_pair_measure_Times singleton_in_stock_measure B)
    with PairVal.IH show ?case by (simp add: ennreal_mult_eq_top_iff)
qed simp_all

subsection \<open>Measures on states\<close>

definition state_measure :: "vname set \<Rightarrow> (vname \<Rightarrow> pdf_type) \<Rightarrow> state measure" where
  "state_measure V \<Gamma> \<equiv> \<Pi>\<^sub>M y\<in>V. \<Gamma> y"

lemma state_measure_nonempty[simp]: "space (state_measure V \<Gamma>) \<noteq> {}"
  by (simp add: state_measure_def space_PiM PiE_eq_empty_iff)

lemma space_state_measure: "space (state_measure V \<Gamma>) = (\<Pi>\<^sub>E y\<in>V. type_universe (\<Gamma> y))"
  by (simp add: state_measure_def space_PiM PiE_eq_empty_iff)

lemma state_measure_var_type:
    "\<sigma> \<in> space (state_measure V \<Gamma>) \<Longrightarrow> x \<in> V \<Longrightarrow> val_type (\<sigma> x) = \<Gamma> x"
  by (auto simp: state_measure_def space_PiM dest!: PiE_mem)

lemma merge_in_state_measure:
  "x \<in> space (state_measure A \<Gamma>) \<Longrightarrow> y \<in> space (state_measure B \<Gamma>) \<Longrightarrow>
      merge A B (x, y) \<in> space (state_measure (A\<union>B) \<Gamma>)" unfolding state_measure_def
  by (rule measurable_space, rule measurable_merge) (simp add: space_pair_measure)

lemma measurable_merge_stock[measurable (raw)]:
  "f \<in> N \<rightarrow>\<^sub>M state_measure V \<Gamma> \<Longrightarrow> g \<in> N \<rightarrow>\<^sub>M state_measure V' \<Gamma> \<Longrightarrow>
    (\<lambda>x. merge V V' (f x, g x)) \<in> N \<rightarrow>\<^sub>M state_measure (V \<union> V') \<Gamma>"
  by (auto simp: state_measure_def)

lemma comp_in_state_measure:
    assumes "\<sigma> \<in> space (state_measure V \<Gamma>)"
    shows "\<sigma> \<circ> f \<in> space (state_measure (f -` V) (\<Gamma> \<circ> f))"
  using assms by (auto simp: state_measure_def space_PiM)

lemma sigma_finite_state_measure[intro]:
    "finite V \<Longrightarrow> sigma_finite_measure (state_measure V \<Gamma>)" unfolding state_measure_def
  by (auto intro!: product_sigma_finite.sigma_finite simp: product_sigma_finite_def)

subsection \<open>Equalities of measure embeddings\<close>

lemma embed_measure_RealPairVal:
   "stock_measure (PRODUCT REAL REAL) = embed_measure lborel RealPairVal"
proof-
  have [simp]: "(\<lambda>(x, y). <| x ,  y |>) \<circ> (\<lambda>(x, y). (RealVal x, RealVal y)) = RealPairVal"
    unfolding RealPairVal_def by auto
  have "stock_measure (PRODUCT REAL REAL) =
            embed_measure (embed_measure lborel (\<lambda>(x, y). (RealVal x, RealVal y))) (case_prod PairVal)"
    by (auto simp: embed_measure_prod sigma_finite_lborel lborel_prod)
  also have "... = embed_measure lborel RealPairVal"
    by (subst embed_measure_comp) (auto intro!: injI)
  finally show ?thesis .
qed

lemma embed_measure_IntPairVal:
  "stock_measure (PRODUCT INTEG INTEG) = count_space (range IntPairVal)"
proof-
  have [simp]: "(\<lambda>(x, y). <| x ,  y |>) ` (range IntVal \<times> range IntVal) = range IntPairVal"
    by (auto simp: IntPairVal_def)
  show ?thesis
    using count_space_IntVal_prod by (auto simp: embed_measure_prod embed_measure_count_space)
qed

subsection \<open>Monadic operations on values\<close>

definition "return_val x = return (stock_measure (val_type x)) x"

lemma sets_return_val[measurable_cong]: "sets (return_val x) = sets (stock_measure (val_type x))"
    by (simp add: return_val_def)

lemma measurable_return_val[simp]:
    "return_val \<in> measurable (stock_measure t) (subprob_algebra (stock_measure t))"
  unfolding return_val_def[abs_def]
  apply (subst measurable_cong)
  apply (subst type_universe_type[THEN iffD1])
  apply simp
  apply (rule refl)
  apply (rule return_measurable)
  done

lemma bind_return_val:
  assumes "space M \<noteq> {}" "f \<in> measurable M (stock_measure t')"
  shows "M \<bind> (\<lambda>x. return_val (f x)) = distr M (stock_measure t') f"
  using assms
  by (subst bind_return_distr[symmetric])
     (auto simp: return_val_def intro!: bind_cong dest: measurable_stock_measure_val_type)

lemma bind_return_val':
  assumes "val_type x = t" "f \<in> measurable (stock_measure t) (stock_measure t')"
  shows "return_val x \<bind> (\<lambda>x. return_val (f x)) = return_val (f x)"
proof-
  have "return_val x \<bind> (\<lambda>x. return_val (f x)) = return (stock_measure t') (f x)"
    apply (subst bind_return_val, unfold return_val_def, simp)
    apply (insert assms, simp cong: measurable_cong_sets) []
    apply (subst distr_return, simp_all add: assms type_universe_def
                                        del: type_universe_type)
    done
  also from assms(2) have "f x \<in> space (stock_measure t')"
    by (rule measurable_space)
       (simp add: assms(1) type_universe_def del: type_universe_type)
  hence "return (stock_measure t') (f x) = return_val (f x)"
    by (simp add: return_val_def)
  finally show ?thesis .
qed

lemma bind_return_val'':
  assumes "f \<in> measurable (stock_measure (val_type x)) (subprob_algebra M)"
  shows "return_val x \<bind> f = f x"
unfolding return_val_def by (subst bind_return[OF assms]) simp_all

lemma bind_assoc_return_val:
  assumes sets_M: "sets M = sets (stock_measure t)"
  assumes Mf: "f \<in> measurable (stock_measure t) (stock_measure t')"
  assumes Mg: "g \<in> measurable (stock_measure t') (stock_measure t'')"
  shows "(M \<bind> (\<lambda>x. return_val (f x))) \<bind> (\<lambda>x. return_val (g x)) =
             M \<bind> (\<lambda>x. return_val (g (f x)))"
proof-
  have "(M \<bind> (\<lambda>x. return_val (f x))) \<bind> (\<lambda>x. return_val (g x)) =
           M \<bind> (\<lambda>x. return_val (f x) \<bind> (\<lambda>x. return_val (g x)))"
    apply (subst bind_assoc)
    apply (rule measurable_compose[OF _ measurable_return_val])
    apply (subst measurable_cong_sets[OF sets_M refl], rule Mf)
    apply (rule measurable_compose[OF Mg measurable_return_val], rule refl)
    done
  also have "... = M \<bind> (\<lambda>x. return_val (g (f x)))"
    apply (intro bind_cong refl)
    apply (subst (asm) sets_eq_imp_space_eq[OF sets_M])
    apply (drule measurable_space[OF Mf])
    apply (subst bind_return_val'[where t = t' and t' = t''])
    apply (simp_all add: Mg)
    done
  finally show ?thesis .
qed

lemma bind_return_val_distr:
  assumes sets_M: "sets M = sets (stock_measure t)"
  assumes Mf: "f \<in> measurable (stock_measure t) (stock_measure t')"
  shows "M \<bind> return_val \<circ> f = distr M (stock_measure t') f"
proof-
  have "M \<bind> return_val \<circ> f = M \<bind> return (stock_measure t') \<circ> f"
    apply (intro bind_cong refl)
    apply (subst (asm) sets_eq_imp_space_eq[OF sets_M])
    apply (drule measurable_space[OF Mf])
    apply (simp add: return_val_def o_def)
    done
  also have "... = distr M (stock_measure t') f"
    apply (rule bind_return_distr)
    apply (simp add: sets_eq_imp_space_eq[OF sets_M])
    apply (subst measurable_cong_sets[OF sets_M refl], rule Mf)
    done
  finally show ?thesis .
qed

subsection \<open>Lifting of functions\<close>

definition lift_RealVal where
  "lift_RealVal f \<equiv> \<lambda> RealVal v \<Rightarrow> RealVal (f v) | _ \<Rightarrow> RealVal (f 0)"
definition lift_IntVal where
  "lift_IntVal f \<equiv> \<lambda> IntVal v \<Rightarrow> IntVal (f v) | _ \<Rightarrow> IntVal (f 0)"
definition lift_RealIntVal where
  "lift_RealIntVal f g \<equiv> \<lambda> IntVal v \<Rightarrow> IntVal (f v) | RealVal v \<Rightarrow> RealVal (g v)"

definition lift_RealIntVal2 where
  "lift_RealIntVal2 f g \<equiv>
    map_int_pair (\<lambda>a b. IntVal (f a b))
    (map_real_pair (\<lambda>a b. RealVal (g a b))
      id)"

definition  lift_Comp where
  "lift_Comp f g \<equiv> map_int_pair (\<lambda>a b. BoolVal (f a b))
    (map_real_pair (\<lambda>a b. BoolVal (g a b))
      (\<lambda>_. FALSE))"

lemma lift_RealVal_eq: "lift_RealVal f (RealVal x) = RealVal (f x)"
  by (simp add: lift_RealVal_def)

lemma lift_RealIntVal_Real:
  "x \<in> space (stock_measure REAL) \<Longrightarrow> lift_RealIntVal f g x = lift_RealVal g x"
  by (auto simp: space_embed_measure lift_RealIntVal_def lift_RealVal_def)

lemma lift_RealIntVal_Int:
  "x \<in> space (stock_measure INTEG) \<Longrightarrow> lift_RealIntVal f g x = lift_IntVal f x"
  by (auto simp: space_embed_measure lift_RealIntVal_def lift_IntVal_def)

declare stock_measure.simps[simp del]

lemma measurable_lift_RealVal[measurable]:
  assumes [measurable]: "f \<in> borel_measurable borel"
  shows "lift_RealVal f \<in> measurable REAL REAL"
  unfolding lift_RealVal_def
  by (auto intro!: val_case_stock_measurable)

lemma measurable_lift_IntVal[simp]: "lift_IntVal f \<in> range IntVal \<rightarrow> range IntVal"
  by (auto simp: lift_IntVal_def)

lemma measurable_lift_IntVal'[measurable]: "lift_IntVal f \<in> measurable INTEG INTEG"
  unfolding lift_IntVal_def
  by (auto intro!: val_case_stock_measurable)

lemma split_apply: "(case x of (a, b) \<Rightarrow> f a b) y = (case x of (a, b) \<Rightarrow> f a b y)"
  by (cases x) simp

lemma measurable_lift_Comp_RealVal[measurable]:
  assumes [measurable]: "Measurable.pred (borel \<Otimes>\<^sub>M borel) (case_prod g)"
  shows "lift_Comp f g \<in> measurable (PRODUCT REAL REAL) BOOL"
  unfolding lift_Comp_def by measurable

lemma measurable_lift_Comp_IntVal[simp]:
  "lift_Comp f g \<in> measurable (PRODUCT INTEG INTEG) BOOL"
  unfolding lift_Comp_def
  by (auto intro!: val_case_stock_measurable)

lemma measurable_lift_RealIntVal_IntVal[simp]: "lift_RealIntVal f g \<in> range IntVal \<rightarrow> range IntVal"
  by (auto simp: embed_measure_count_space lift_RealIntVal_def)

lemma measurable_lift_RealIntVal_IntVal'[measurable]:
   "lift_RealIntVal f g \<in> measurable INTEG INTEG"
  by (auto simp: lift_RealIntVal_def intro!: val_case_stock_measurable)

lemma measurable_lift_RealIntVal_RealVal[measurable]:
  assumes [measurable]: "g \<in> borel_measurable borel"
  shows "lift_RealIntVal f g \<in> measurable REAL REAL"
  unfolding lift_RealIntVal_def
  by (auto intro!: val_case_stock_measurable)

lemma measurable_lift_RealIntVal2_IntVal[measurable]:
  "lift_RealIntVal2 f g \<in> measurable (PRODUCT INTEG INTEG) INTEG"
  unfolding lift_RealIntVal2_def
  by (auto intro!: val_case_stock_measurable)

lemma measurable_lift_RealIntVal2_RealVal[measurable]:
  assumes [measurable]: "case_prod g \<in> borel_measurable (borel \<Otimes>\<^sub>M borel)"
  shows "lift_RealIntVal2 f g \<in> measurable (PRODUCT REAL REAL) REAL"
  unfolding lift_RealIntVal2_def by measurable

lemma distr_lift_RealVal:
  fixes f
  assumes Mf[measurable]: "f \<in> borel_measurable borel"
  assumes pdens: "has_subprob_density M (stock_measure REAL) \<delta>"
  assumes dens': "\<And>M \<delta>. has_subprob_density M lborel \<delta> \<Longrightarrow> has_density (distr M borel f) lborel (g \<delta>)"
  defines "N \<equiv> distr M (stock_measure REAL) (lift_RealVal f)"
  shows "has_density N (stock_measure REAL) (g (\<lambda>x. \<delta> (RealVal x)) \<circ> extract_real)"
proof (rule has_densityI)
  from assms(2) have dens: "has_density M (stock_measure REAL) \<delta>"
    unfolding has_subprob_density_def by simp
  from dens have sets_M[measurable_cong]: "sets M = sets REAL" by (auto dest: has_densityD)

  note measurable_embed_measure1[measurable del]

  have "N = distr M (stock_measure REAL) (lift_RealVal f)" by (simp add: N_def)
  also have "\<dots> = distr M (stock_measure REAL) (RealVal \<circ> f \<circ> extract_real)"
    using sets_eq_imp_space_eq[OF sets_M]
    by (intro distr_cong) (auto simp: lift_RealVal_def stock_measure.simps space_embed_measure)
  also have "... = distr (distr (distr M lborel extract_real) borel f) (stock_measure REAL) RealVal"
    by (subst distr_distr)
       (simp_all add: distr_distr[OF _ measurable_comp[OF _ Mf]] comp_assoc)
  also have dens'': "has_density (distr (distr M lborel extract_real) borel f) lborel (g (\<delta> \<circ> RealVal))"
    by (intro dens' has_subprob_density_embed_measure'') (insert pdens, simp_all add: extract_real_def stock_measure.simps)
  hence "distr (distr M lborel extract_real) borel f = density lborel (g (\<delta> \<circ> RealVal))"
    by (rule has_densityD)
  also have "distr ... (stock_measure REAL) RealVal = embed_measure ... RealVal" (is "_ = ?M")
    by (subst embed_measure_eq_distr[OF inj_RealVal], intro distr_cong)
       (simp_all add: sets_embed_measure stock_measure.simps)
  also have "... = density (embed_measure lborel RealVal) (g (\<lambda>x. \<delta> (RealVal x)) \<circ> extract_real)"
    using dens''[unfolded o_def]
    apply (subst density_embed_measure', simp, simp add: extract_real_def)
    apply (erule has_densityD, simp add: o_def)
    done
  finally show "N = density (stock_measure REAL) (g (\<lambda>x. \<delta> (RealVal x)) \<circ> extract_real)"
    by (simp add: stock_measure.simps)

  from dens''[unfolded o_def, THEN has_densityD(1)]  measurable_extract_real
  show "g (\<lambda>x. \<delta> (RealVal x)) \<circ> extract_real \<in> borel_measurable (stock_measure REAL)"
    by (intro measurable_comp) auto
qed (subst space_stock_measure, simp)

lemma distr_lift_IntVal:
  fixes f
  assumes pdens: "has_density M (stock_measure INTEG) \<delta>"
  assumes dens': "\<And>M \<delta>. has_density M (count_space UNIV) \<delta> \<Longrightarrow>
                            has_density (distr M (count_space UNIV) f) (count_space UNIV) (g \<delta>)"
  defines "N \<equiv> distr M (stock_measure INTEG) (lift_IntVal f)"
  shows "has_density N (stock_measure INTEG) (g (\<lambda>x. \<delta> (IntVal x)) \<circ> extract_int)"
proof (rule has_densityI)
  let ?R = "count_space UNIV" and ?S = "count_space (range IntVal)"
  have Mf: "f \<in> measurable ?R ?R" by simp
  from assms(1) have dens: "has_density M (stock_measure INTEG) \<delta>"
    unfolding has_subprob_density_def by simp
  from dens have sets_M[measurable_cong]: "sets M = sets INTEG" by (auto dest!: has_densityD(2))

  have "N = distr M (stock_measure INTEG) (lift_IntVal f)" by (simp add: N_def)
  also have "\<dots> = distr M (stock_measure INTEG) (IntVal \<circ> f \<circ> extract_int)"
    using sets_eq_imp_space_eq[OF sets_M]
    by (intro distr_cong) (auto simp: space_embed_measure lift_IntVal_def stock_measure.simps)
  also have "\<dots> = distr (distr (distr M ?R extract_int) ?R f) (stock_measure INTEG) IntVal"
    by (subst distr_distr) (simp_all add: distr_distr[OF _ measurable_comp[OF _ Mf]] comp_assoc)
  also have dens'': "has_density (distr (distr M ?R extract_int) ?R f) ?R (g (\<delta> \<circ> IntVal))"
    by (intro dens' has_density_embed_measure'')
       (insert dens, simp_all add: extract_int_def embed_measure_count_space stock_measure.simps)
  hence "distr (distr M ?R extract_int) ?R f = density ?R (g (\<delta> \<circ> IntVal))"
    by (rule has_densityD)
  also have "distr ... (stock_measure INTEG) IntVal = embed_measure ... IntVal" (is "_ = ?M")
    by (subst embed_measure_eq_distr[OF inj_IntVal], intro distr_cong)
       (auto simp: sets_embed_measure subset_image_iff stock_measure.simps)
  also have "... = density (embed_measure ?R IntVal) (g (\<lambda>x. \<delta> (IntVal x)) \<circ> extract_int)"
    using dens''[unfolded o_def]
    apply (subst density_embed_measure', simp, simp add: extract_int_def)
    apply (erule has_densityD, simp add: o_def)
    done
  finally show "N = density (stock_measure INTEG) (g (\<lambda>x. \<delta> (IntVal x)) \<circ> extract_int)"
    by (simp add: embed_measure_count_space stock_measure.simps)

  from dens''[unfolded o_def]
    show "g (\<lambda>x. \<delta> (IntVal x)) \<circ> extract_int \<in> borel_measurable (stock_measure INTEG)"
    by (simp add: embed_measure_count_space stock_measure.simps)
qed (subst space_stock_measure, simp)

lemma distr_lift_RealPairVal:
  fixes f f' g
  assumes Mf[measurable]: "case_prod f \<in> borel_measurable borel"
  assumes pdens: "has_subprob_density M (stock_measure (PRODUCT REAL REAL)) \<delta>"
  assumes dens': "\<And>M \<delta>. has_subprob_density M lborel \<delta> \<Longrightarrow> has_density (distr M borel (case_prod f)) lborel (g \<delta>)"
  defines "N \<equiv> distr M (stock_measure REAL) (lift_RealIntVal2 f' f)"
  shows "has_density N (stock_measure REAL) (g (\<lambda>x. \<delta> (RealPairVal x)) \<circ> extract_real)"
proof (rule has_densityI)
  from assms(2) have dens: "has_density M (stock_measure (PRODUCT REAL REAL)) \<delta>"
    unfolding has_subprob_density_def by simp
  have sets_M[measurable_cong]: "sets M = sets (stock_measure (PRODUCT REAL REAL))"
    by (auto simp: has_subprob_densityD[OF pdens])

  have "N = distr M (stock_measure REAL) (lift_RealIntVal2 f' f)" by (simp add: N_def)
  also have "... = distr M (stock_measure REAL) (RealVal \<circ> case_prod f \<circ> extract_real_pair)"
    using sets_eq_imp_space_eq[OF sets_M]
    by (intro distr_cong) (auto simp: lift_RealIntVal2_def space_embed_measure space_pair_measure stock_measure.simps)
  also have "... = distr (distr (distr M lborel extract_real_pair) borel (case_prod f)) REAL RealVal"
    by (subst distr_distr) (simp_all add: distr_distr[OF _ measurable_comp[OF _ Mf]] comp_assoc)
  also have dens'': "has_density (distr (distr M lborel extract_real_pair) borel (case_prod f)) lborel
                      (g (\<delta> \<circ> RealPairVal))" using inj_RealPairVal embed_measure_RealPairVal
    by (intro dens' has_subprob_density_embed_measure'')
       (insert pdens, simp_all add: RealPairVal_def split: prod.split)
  hence "distr (distr M lborel extract_real_pair) borel (case_prod f) =
             density lborel (g (\<delta> \<circ> RealPairVal))" by (rule has_densityD)
  also have "distr ... (stock_measure REAL) RealVal = embed_measure ... RealVal" (is "_ = ?M")
    by (subst embed_measure_eq_distr[OF inj_RealVal], intro distr_cong)
       (simp_all add: sets_embed_measure stock_measure.simps)
  also have "... = density (embed_measure lborel RealVal) (g (\<lambda>x. \<delta> (RealPairVal x)) \<circ> extract_real)"
    using dens''[unfolded o_def]
    by (subst density_embed_measure', simp, simp add: extract_real_def)
       (erule has_densityD, simp add: o_def)
  finally show "N = density (stock_measure REAL) (g (\<lambda>x. \<delta> (RealPairVal x)) \<circ> extract_real)"
    by (simp add: stock_measure.simps)

  from dens''[unfolded o_def]
    show "g (\<lambda>x. \<delta> (RealPairVal x)) \<circ> extract_real \<in> borel_measurable (stock_measure REAL)"
    by (intro measurable_comp)
       (rule measurable_extract_real, subst measurable_lborel2[symmetric], erule has_densityD)
qed (subst space_stock_measure, simp)

lemma distr_lift_IntPairVal:
  fixes f f'
  assumes pdens: "has_density M (stock_measure (PRODUCT INTEG INTEG)) \<delta>"
  assumes dens': "\<And>M \<delta>. has_density M (count_space UNIV) \<delta> \<Longrightarrow>
                            has_density (distr M (count_space UNIV) (case_prod f))
                                        (count_space UNIV) (g \<delta>)"
  defines "N \<equiv> distr M (stock_measure INTEG) (lift_RealIntVal2 f f')"
  shows "has_density N (stock_measure INTEG) (g (\<lambda>x. \<delta> (IntPairVal x)) \<circ> extract_int)"
proof (rule has_densityI)
  let ?R = "count_space UNIV" and ?S = "count_space (range IntVal)"
  and ?T = "count_space (range IntPairVal)" and ?tp = "PRODUCT INTEG INTEG"
  have Mf: "f \<in> measurable ?R ?R" by simp
  have MIV: "IntVal \<in> measurable ?R ?S" by simp
  from assms(1) have dens: "has_density M (stock_measure ?tp) \<delta>"
    unfolding has_subprob_density_def by simp
  from dens have "M = density (stock_measure ?tp) \<delta>" by (rule has_densityD)
  hence sets_M: "sets M = sets ?T" by (subst embed_measure_IntPairVal[symmetric]) auto
  hence [simp]: "space M = space ?T" by (rule sets_eq_imp_space_eq)
  from sets_M have [simp]: "measurable M = measurable (count_space (range IntPairVal))"
    by (intro ext measurable_cong_sets) simp_all

  have "N = distr M (stock_measure INTEG) (lift_RealIntVal2 f f')" by (simp add: N_def)

  also have "... = distr M (stock_measure INTEG) (IntVal \<circ> case_prod f \<circ> extract_int_pair)"
    by (intro distr_cong) (auto simp: lift_RealIntVal2_def space_embed_measure space_pair_measure IntPairVal_def)
  also have "... = distr (distr (distr M (count_space UNIV) extract_int_pair)
                        (count_space UNIV) (case_prod f)) (stock_measure INTEG) IntVal"
    apply (subst distr_distr[of _ ?R, symmetric], simp, simp)
    apply (subst distr_distr[symmetric], subst stock_measure.simps, rule MIV,
           simp_all add: assms(1) cong: distr_cong)
    done
  also have dens'': "has_density (distr (distr M (count_space UNIV) extract_int_pair) ?R (case_prod f)) ?R
                      (g (\<delta> \<circ> IntPairVal))" using inj_IntPairVal embed_measure_IntPairVal
    by (intro dens' has_density_embed_measure'')
       (insert dens, simp_all add: extract_int_def embed_measure_count_space IntPairVal_def split: prod.split)
  hence "distr (distr M (count_space UNIV) extract_int_pair) ?R (case_prod f) =
             density ?R (g (\<delta> \<circ> IntPairVal))" by (rule has_densityD)
  also have "distr ... (stock_measure INTEG) IntVal = embed_measure ... IntVal" (is "_ = ?M")
    by (subst embed_measure_eq_distr[OF inj_IntVal], intro distr_cong)
       (auto simp: sets_embed_measure subset_image_iff stock_measure.simps)
  also have "... = density (embed_measure ?R IntVal) (g (\<lambda>x. \<delta> (IntPairVal x)) \<circ> extract_int)"
    using dens''[unfolded o_def]
    by (subst density_embed_measure', simp, simp add: extract_int_def)
       (erule has_densityD, simp add: o_def)
  finally show "N = density (stock_measure INTEG) (g (\<lambda>x. \<delta> (IntPairVal x)) \<circ> extract_int)"
    by (simp add: embed_measure_count_space stock_measure.simps)

  from dens''[unfolded o_def]
    show "g (\<lambda>x. \<delta> (IntPairVal x)) \<circ> extract_int \<in> borel_measurable (stock_measure INTEG)"
    by (simp add: embed_measure_count_space stock_measure.simps)
qed (subst space_stock_measure, simp)

end


theory SINVAR_TaintingTrusted
imports "../TopoS_Helper"
begin

subsection {* SecurityInvariant Tainting with Untainting-Feature for IFS *}

context
begin
  qualified datatype taints_raw = TaintsUntaints_Raw (taints_raw: "string set") (untaints_raw: "string set")

  text{*The @{const untaints_raw} set must be a subset of @{const taints_raw}.
        Otherwise, there can be entries in the untaints set, which do not affect anything.
        This is certainly undesirable.
        In addition, a unique default parameter cannot exist if we allow such dead entries.*}
  qualified typedef taints = "{ts::taints_raw. untaints_raw ts \<subseteq> taints_raw ts}"
    morphisms raw_of_taints Abs_taints
  proof
    show "TaintsUntaints_Raw {} {} \<in> {ts. untaints_raw ts \<subseteq> taints_raw ts}" by simp
  qed

  setup_lifting type_definition_taints

  lemma taints_eq_iff:
    "tsx = tsy \<longleftrightarrow> raw_of_taints tsx = raw_of_taints tsy"
    by (simp add: raw_of_taints_inject)

  definition taints :: "taints \<Rightarrow> string set" where
    "taints ts \<equiv> taints_raw (raw_of_taints ts)"
  definition untaints :: "taints \<Rightarrow> string set" where
    "untaints ts \<equiv> untaints_raw (raw_of_taints ts)"

  lemma taints_wellformedness: "untaints ts \<subseteq> taints ts"
    using raw_of_taints taints_def untaints_def by auto

  text \<open>Constructor for @{typ "taints"}:\<close>

  definition TaintsUntaints :: "string set \<Rightarrow> string set \<Rightarrow> taints" where
    "TaintsUntaints ts uts = Abs_taints (TaintsUntaints_Raw (ts \<union> uts) uts)"

  lemma raw_of_taints_TaintsUntaints:
    "raw_of_taints (TaintsUntaints ts uts) = (TaintsUntaints_Raw (ts \<union> uts) uts)"
    by (simp add: TaintsUntaints_def Abs_taints_inverse)

  lemma taints_TaintsUntaints[code]: "taints (TaintsUntaints ts uts) = ts \<union> uts"
    by(simp add: taints_def raw_of_taints_TaintsUntaints)
  lemma untaints_TaintsUntaints[code]: "untaints (TaintsUntaints ts uts) = uts"
    by(simp add: untaints_def raw_of_taints_TaintsUntaints)

  text{*The things in the first set are tainted, those in the second set are untainted.
    For example, a machine produces @{term "''foo''"}:
      @{term "TaintsUntaints {''foo''} {}"}

    For example, a machine consumes @{term "''foo''"} and @{term "''bar''"}, combines them in a
    way that they are no longer critical and outputs @{term "''baz''"}:
      @{term "TaintsUntaints {''foo'', ''bar'', ''baz''} {''foo'', ''bar''}"}
      abbreviated: @{term "TaintsUntaints {''baz''} {''foo'', ''bar''}"}
      *}
  lemma "TaintsUntaints {''foo'', ''bar'', ''baz''} {''foo'', ''bar''} =
         TaintsUntaints {''baz''} {''foo'', ''bar''}"
    apply(simp add: taints_eq_iff raw_of_taints_TaintsUntaints)
    by blast

  qualified definition default_node_properties :: "taints"
    where  "default_node_properties \<equiv> TaintsUntaints {} {}"

  qualified definition sinvar :: "'v graph \<Rightarrow> ('v \<Rightarrow> taints) \<Rightarrow> bool" where
    "sinvar G nP \<equiv> \<forall> (v1,v2) \<in> edges G.
        taints (nP v1) - untaints (nP v1) \<subseteq> taints (nP v2)"

  text{*Information Flow Security*}
  qualified definition receiver_violation :: "bool" where "receiver_violation \<equiv> True"

  private

end

code_datatype TaintsUntaints

value[code] "TaintsUntaints {''foo''} {''bar''}"

value[code] "taints (TaintsUntaints {''foo''} {''bar''})"

end


theory LetSimple2
imports "../Nominal2"
begin

atom_decl name

nominal_datatype trm =
  Var "name"
| App "trm" "trm"
| Let as::"assn" t::"trm"   binds "bn as" in t
and assn =
  Assn "name" "trm"
binder
  bn
where
 "bn (Assn x t) = [atom x]"

print_theorems

thm bn_raw.simps
thm permute_bn_raw.simps
thm trm_assn.perm_bn_alpha
thm trm_assn.permute_bn

thm trm_assn.fv_defs
thm trm_assn.eq_iff
thm trm_assn.bn_defs
thm trm_assn.bn_inducts
thm trm_assn.perm_simps
thm trm_assn.induct
thm trm_assn.inducts
thm trm_assn.distinct
thm trm_assn.supp
thm trm_assn.fresh
thm trm_assn.exhaust
thm trm_assn.strong_exhaust
thm trm_assn.perm_bn_simps

thm alpha_bn_raw.cases
thm trm_assn.alpha_refl
thm trm_assn.alpha_sym
thm trm_assn.alpha_trans

lemmas alpha_bn_cases[consumes 1] = alpha_bn_raw.cases[quot_lifted]

lemma alpha_bn_refl: "alpha_bn x x"
  by(rule trm_assn.alpha_refl)

lemma alpha_bn_sym: "alpha_bn x y \<Longrightarrow> alpha_bn y x"
  by (rule trm_assn.alpha_sym)

lemma alpha_bn_trans: "alpha_bn x y \<Longrightarrow> alpha_bn y z \<Longrightarrow> alpha_bn x z"
  using trm_assn.alpha_trans by metis

lemma fv_bn_finite[simp]:
  "finite (fv_bn as)"
apply(case_tac as rule: trm_assn.exhaust(2))
apply(simp add: trm_assn.supp finite_supp)
done

lemma k: "A \<Longrightarrow> A \<and> A" by blast

section {* definition with helper functions *}

function
  apply_assn
where
  "apply_assn f (Assn x t) = (f t)"
apply(case_tac x)
apply(simp)
apply(case_tac b rule: trm_assn.exhaust(2))
apply(blast)
apply(simp)
done

termination
  by lexicographic_order

function
  apply_assn2
where
  "apply_assn2 f (Assn x t) = Assn x (f t)"
apply(case_tac x)
apply(simp)
apply(case_tac b rule: trm_assn.exhaust(2))
apply(blast)
apply(simp)
done

termination
  by lexicographic_order

lemma [eqvt]:
  shows "p \<bullet> (apply_assn f as) = apply_assn (p \<bullet> f) (p \<bullet> as)"
apply(induct f as rule: apply_assn.induct)
apply(simp)
apply(perm_simp)
apply(rule)
done

lemma [eqvt]:
  shows "p \<bullet> (apply_assn2 f as) = apply_assn2 (p \<bullet> f) (p \<bullet> as)"
apply(induct f as rule: apply_assn.induct)
apply(simp)
apply(perm_simp)
apply(rule)
done

nominal_function
    height_trm :: "trm \<Rightarrow> nat"
where
  "height_trm (Var x) = 1"
| "height_trm (App l r) = max (height_trm l) (height_trm r)"
| "height_trm (Let as b) = max (apply_assn height_trm as) (height_trm b)"
  apply (simp only: eqvt_def height_trm_graph_def)
  apply (rule, perm_simp)
  apply(rule)
  apply(rule TrueI)
  apply (case_tac x rule: trm_assn.exhaust(1))
  apply (auto simp add: alpha_bn_refl)[3]
  apply (drule_tac x="assn" in meta_spec)
  apply (drule_tac x="trm" in meta_spec)
  apply(simp add: alpha_bn_refl)
  apply(simp_all)[5]
  apply(simp)
  apply(erule conjE)+
  apply(erule alpha_bn_cases)
  apply(simp)
  apply (subgoal_tac "height_trm_sumC b = height_trm_sumC ba")
  apply simp
  apply(simp add: trm_assn.bn_defs)
  apply(erule_tac c="()" in Abs_lst_fcb2)
  apply(simp_all add: pure_fresh fresh_star_def)[3]
  apply(simp_all add: eqvt_at_def)
  done

(* assn-function prevents automatic discharge
termination by lexicographic_order
*)

nominal_function
  subst_trm :: "trm \<Rightarrow> name \<Rightarrow> trm \<Rightarrow> trm"  ("_ [_ ::= _]" [90, 90, 90] 90)
where
  "(Var x)[y ::= s] = (if x = y then s else (Var x))"
| "(App t1 t2)[y ::= s] = App (t1[y ::= s]) (t2[y ::= s])"
| "(set (bn as)) \<sharp>* (y, s) \<Longrightarrow>
      (Let as t)[y ::= s] = Let (apply_assn2 (\<lambda>t. t[y ::=s]) as) (t[y ::= s])"
  apply (simp only: eqvt_def subst_trm_graph_def)
  apply (rule, perm_simp)
  apply(rule)
  apply(rule TrueI)
  apply(case_tac x)
  apply(simp)
  apply (rule_tac y="a" and c="(b,c)" in trm_assn.strong_exhaust(1))
  apply (auto simp add: alpha_bn_refl)[3]
  apply(simp_all)[5]
  apply(simp)
  apply(erule conjE)+
  apply(erule alpha_bn_cases)
  apply(simp)
  apply(simp add: trm_assn.bn_defs)
  apply(erule_tac c="(ya,sa)" in Abs_lst1_fcb2)
  apply(simp add: Abs_fresh_iff fresh_star_def)
  apply(simp add: fresh_star_def)
  apply(simp_all add: eqvt_at_def perm_supp_eq fresh_star_Pair)[2]
  done

section {* direct definitions --- problems *}

lemma cheat: "P" sorry

definition
  "eqvt_at_bn f as \<equiv> \<forall>p. (p \<bullet> (f as)) = f (permute_bn p as)"

definition
  "alpha_bn_preserve f as \<equiv> \<forall>p. f as = f (permute_bn p as)"

lemma
  fixes as::"assn"
  assumes "eqvt_at f as"
  shows "eqvt_at_bn f as"
using assms
unfolding eqvt_at_bn_def
apply(rule_tac allI)
apply(drule k)
apply(erule conjE)
apply(subst (asm) eqvt_at_def)
apply(simp)

oops

nominal_function
<<<<<<< variant A
 (invariant "\<lambda>x y. case x of Inl x1 \<Rightarrow> True | Inr x2 \<Rightarrow> alpha_bn_preserve (height_assn2::assn \<Rightarrow> nat) x2")
>>>>>>> variant B
####### Ancestor
 (invariant "\<lambda>x y. case x of Inl x1 \<Rightarrow> True | Inr x2 \<Rightarrow> \<forall>p. (permute_bn p x2) = x2 \<longrightarrow> (p \<bullet> y) = y")
======= end
    height_trm2 :: "trm \<Rightarrow> nat"
and height_assn2 :: "assn \<Rightarrow> nat"
where
  "height_trm2 (Var x) = 1"
| "height_trm2 (App l r) = max (height_trm2 l) (height_trm2 r)"
| "set (bn as) \<sharp>* fv_bn as \<Longrightarrow> height_trm2 (Let as b) = max (height_assn2 as) (height_trm2 b)"
| "height_assn2 (Assn x t) = (height_trm2 t)"
  thm height_trm2_height_assn2_graph.intros[no_vars]
  thm height_trm2_height_assn2_graph_def
  apply (simp only: eqvt_def height_trm2_height_assn2_graph_def)
  apply (rule, perm_simp, rule)
  -- "invariant"
  apply(simp)
<<<<<<< variant A
  apply(simp)
  apply(simp)
  apply(simp)
  apply(simp add: alpha_bn_preserve_def)
  apply(simp add: height_assn2_def)
  apply(simp add: trm_assn.perm_bn_simps)
  apply(rule allI)
  thm height_trm2_height_assn2_graph.intros[no_vars]
  thm height_trm2_height_assn2_sumC_def
  apply(rule cheat)
  apply -
>>>>>>> variant B
####### Ancestor
  apply(simp)
  apply(simp)
  apply(simp)
  apply(rule cheat)
  apply -
======= end
  --"completeness"
  apply (case_tac x)
  apply(simp)
  apply (rule_tac y="a" and c="a" in trm_assn.strong_exhaust(1))
  apply (auto simp add: alpha_bn_refl)[3]
  apply (drule_tac x="assn" in meta_spec)
  apply (drule_tac x="trm" in meta_spec)
  apply(simp add: alpha_bn_refl)
  apply(rotate_tac 3)
  apply(drule meta_mp)
  apply(simp add: fresh_star_def trm_assn.fresh)
  apply(simp add: fresh_def)
  apply(subst supp_finite_atom_set)
  apply(simp)
  apply(simp)
  apply(simp)
  apply (case_tac b rule: trm_assn.exhaust(2))
  apply (auto)[1]
  apply(simp_all)[7]
  prefer 2
  apply(simp)
  prefer 2
  apply(simp)
  --"let case"
  apply (simp only: meta_eq_to_obj_eq[OF height_trm2_def, symmetric, unfolded fun_eq_iff])
  apply (simp only: meta_eq_to_obj_eq[OF height_assn2_def, symmetric, unfolded fun_eq_iff])
  apply (subgoal_tac "eqvt_at height_assn2 as")
  apply (subgoal_tac "eqvt_at height_assn2 asa")
  apply (subgoal_tac "eqvt_at height_trm2 b")
  apply (subgoal_tac "eqvt_at height_trm2 ba")
  apply (thin_tac "eqvt_at height_trm2_height_assn2_sumC (Inr as)")
  apply (thin_tac "eqvt_at height_trm2_height_assn2_sumC (Inr asa)")
  apply (thin_tac "eqvt_at height_trm2_height_assn2_sumC (Inl b)")
  apply (thin_tac "eqvt_at height_trm2_height_assn2_sumC (Inl ba)")
  defer
  apply (simp add: eqvt_at_def height_trm2_def)
  apply (simp add: eqvt_at_def height_trm2_def)
  apply (simp add: eqvt_at_def height_assn2_def)
  apply (simp add: eqvt_at_def height_assn2_def)
  apply (subgoal_tac "height_assn2 as = height_assn2 asa")
  apply (subgoal_tac "height_trm2 b = height_trm2 ba")
  apply simp
  apply(simp)
  apply(erule conjE)+
  apply(erule alpha_bn_cases)
  apply(simp)
  apply(simp add: trm_assn.bn_defs)
  apply(erule_tac c="()" in Abs_lst_fcb2)
  apply(simp_all add: fresh_star_def pure_fresh)[3]
  apply(simp add: eqvt_at_def)
  apply(simp add: eqvt_at_def)
  apply(drule Inl_inject)
  apply(simp (no_asm_use))
  apply(clarify)
  apply(erule alpha_bn_cases)
  apply(simp del: trm_assn.eq_iff)
  apply(simp only: trm_assn.bn_defs)
<<<<<<< variant A
  apply(erule_tac c="()" in Abs_lst1_fcb2')
  apply(simp_all add: fresh_star_def pure_fresh)[3]
  apply(simp add: eqvt_at_bn_def)
  apply(simp add: trm_assn.perm_bn_simps)
  apply(simp add: eqvt_at_bn_def)
  apply(simp add: trm_assn.perm_bn_simps)
  done

>>>>>>> variant B
  apply(erule_tac c="(trm_rawa)" in Abs_lst1_fcb2')
  apply(simp_all add: fresh_star_def pure_fresh)[2]
  apply(simp add: trm_assn.supp)
  apply(simp add: fresh_def)
  apply(subst (asm) supp_finite_atom_set)
  apply(simp add: finite_supp)
  apply(subst (asm) supp_finite_atom_set)
  apply(simp add: finite_supp)
  apply(simp)
  apply(simp add: eqvt_at_def perm_supp_eq)
  apply(simp add: eqvt_at_def perm_supp_eq)
  done
####### Ancestor
  apply(erule_tac c="()" in Abs_lst1_fcb2')
  apply(simp_all add: fresh_star_def pure_fresh)[3]

  oops
======= end

termination by lexicographic_order

lemma ww1:
  shows "finite (fv_trm t)"
  and "finite (fv_bn as)"
apply(induct t and as rule: trm_assn.inducts)
apply(simp_all add: trm_assn.fv_defs supp_at_base)
done

text {* works, but only because no recursion in as *}

nominal_function (invariant "\<lambda>x (y::atom set). finite y")
  frees_set :: "trm \<Rightarrow> atom set"
where
  "frees_set (Var x) = {atom x}"
| "frees_set (App t1 t2) = frees_set t1 \<union> frees_set t2"
| "frees_set (Let as t) = (frees_set t) - (set (bn as)) \<union> (fv_bn as)"
  apply(simp add: eqvt_def frees_set_graph_def)
  apply(rule, perm_simp, rule)
  apply(erule frees_set_graph.induct)
  apply(auto simp add: ww1)[3]
  apply(rule_tac y="x" in trm_assn.exhaust(1))
  apply(auto simp add: alpha_bn_refl)[3]
  apply(drule_tac x="assn" in meta_spec)
  apply(drule_tac x="trm" in meta_spec)
  apply(simp add: alpha_bn_refl)
  apply(simp_all)[5]
  apply(simp)
  apply(erule conjE)
  apply(erule alpha_bn_cases)
  apply(simp add: trm_assn.bn_defs)
  apply(simp add: trm_assn.fv_defs)
  (* apply(erule_tac c="(trm_rawa)" in Abs_lst1_fcb2) *)
  apply(subgoal_tac " frees_set_sumC t - {atom name} = frees_set_sumC ta - {atom namea}")
  apply(simp)
  apply(erule_tac c="()" in Abs_lst1_fcb2)
  apply(simp add: fresh_minus_atom_set)
  apply(simp add: fresh_star_def fresh_Unit)
  apply(simp add: Diff_eqvt eqvt_at_def, perm_simp, rule refl)
  apply(simp add: Diff_eqvt eqvt_at_def, perm_simp, rule refl)
  done

termination
  by lexicographic_order

lemma test:
  assumes a: "\<exists>y. f x = Inl y"
  shows "(p \<bullet> (Sum_Type.Projl (f x))) = Sum_Type.Projl ((p \<bullet> f) (p \<bullet> x))"
using a
apply clarify
apply(frule_tac p="p" in permute_boolI)
apply(simp (no_asm_use) only: eqvts)
apply(subst (asm) permute_fun_app_eq)
back
apply(simp)
done

nominal_function (default "sum_case (\<lambda>x. Inl undefined) (\<lambda>x. Inr undefined)")
  subst_trm2 :: "trm \<Rightarrow> name \<Rightarrow> trm \<Rightarrow> trm"  ("_ [_ ::trm2= _]" [90, 90, 90] 90) and
  subst_assn2 :: "assn \<Rightarrow> name \<Rightarrow> trm \<Rightarrow> assn"  ("_ [_ ::assn2= _]" [90, 90, 90] 90)
where
  "(Var x)[y ::trm2= s] = (if x = y then s else (Var x))"
| "(App t1 t2)[y ::trm2= s] = App (t1[y ::trm2= s]) (t2[y ::trm2= s])"
| "(set (bn as)) \<sharp>* (y, s, fv_bn as) \<Longrightarrow> (Let as t)[y ::trm2= s] = Let (ast[y ::assn2= s]) (t[y ::trm2= s])"
| "(Assn x t)[y ::assn2= s] = Assn x (t[y ::trm2= s])"
apply(subgoal_tac "\<And>p x r. subst_trm2_subst_assn2_graph x r \<Longrightarrow> subst_trm2_subst_assn2_graph (p \<bullet> x) (p \<bullet> r)")
apply(simp add: eqvt_def)
apply(rule allI)
apply(simp add: permute_fun_def permute_bool_def)
apply(rule ext)
apply(rule ext)
apply(rule iffI)
apply(drule_tac x="p" in meta_spec)
apply(drule_tac x="- p \<bullet> x" in meta_spec)
apply(drule_tac x="- p \<bullet> xa" in meta_spec)
apply(simp)
apply(drule_tac x="-p" in meta_spec)
apply(drule_tac x="x" in meta_spec)
apply(drule_tac x="xa" in meta_spec)
apply(simp)
--"Eqvt One way"
defer
  apply(rule TrueI)
  apply(case_tac x)
  apply(simp)
  apply(case_tac a)
  apply(simp)
  apply(rule_tac y="aa" and c="(b, c, aa)" in trm_assn.strong_exhaust(1))
  apply(blast)+
  apply(simp)
  apply(drule_tac x="assn" in meta_spec)
  apply(drule_tac x="b" in meta_spec)
  apply(drule_tac x="c" in meta_spec)
  apply(drule_tac x="trm" in meta_spec)
  apply(simp add: trm_assn.alpha_refl)
  apply(rotate_tac 5)
  apply(drule meta_mp)
  apply(simp add: fresh_star_Pair)
  apply(simp add: fresh_star_def trm_assn.fresh)
  apply(simp add: fresh_def)
  apply(subst supp_finite_atom_set)
  apply(simp)
  apply(simp)
  apply(simp)
  apply(case_tac b)
  apply(simp)
  apply(rule_tac y="a" in trm_assn.exhaust(2))
  apply(simp)
  apply(blast)
--"compatibility"
  apply(all_trivials)
  apply(simp)
  apply(simp)
  prefer 2
  apply(simp)
  apply(drule Inl_inject)
  apply(rule arg_cong)
  back
  apply (simp only: meta_eq_to_obj_eq[OF subst_trm2_def, symmetric, unfolded fun_eq_iff])
  apply (simp only: meta_eq_to_obj_eq[OF subst_assn2_def, symmetric, unfolded fun_eq_iff])
  apply (subgoal_tac "eqvt_at (\<lambda>ast. subst_assn2 ast ya sa) ast")
  apply (subgoal_tac "eqvt_at (\<lambda>asta. subst_assn2 asta ya sa) asta")
  apply (subgoal_tac "eqvt_at (\<lambda>t. subst_trm2 t ya sa) t")
  apply (subgoal_tac "eqvt_at (\<lambda>ta. subst_trm2 ta ya sa) ta")
  apply (thin_tac "eqvt_at subst_trm2_subst_assn2_sumC (Inr (ast, y, s))")
  apply (thin_tac "eqvt_at subst_trm2_subst_assn2_sumC (Inr (asta, ya, sa))")
  apply (thin_tac "eqvt_at subst_trm2_subst_assn2_sumC (Inl (t, y, s))")
  apply (thin_tac "eqvt_at subst_trm2_subst_assn2_sumC (Inl (ta, ya, sa))")
  apply(simp)
  (* HERE *)
  apply (subgoal_tac "subst_assn2 ast y s= subst_assn2 asta ya sa")
  apply (subgoal_tac "subst_trm2 t y s = subst_trm2 ta ya sa")
  apply(simp)
  apply(simp)
  apply(erule_tac conjE)+
  apply(erule alpha_bn_cases)
  apply(simp add: trm_assn.bn_defs)
  apply(rotate_tac 7)
  apply (erule_tac c="(ya,sa)" in Abs_lst1_fcb2)
  apply(erule fresh_eqvt_at)

  thm fresh_eqvt_at
  apply(simp add: Abs_fresh_iff)
  apply(simp add: fresh_star_def fresh_Pair)
  apply(simp add: eqvt_at_def atom_eqvt fresh_star_Pair perm_supp_eq)
  apply(simp add: eqvt_at_def atom_eqvt fresh_star_Pair perm_supp_eq)

  apply(simp_all add: fresh_star_def fresh_Pair_elim)[1]
  apply(blast)
  apply(simp_all)[5]
  apply(simp (no_asm_use))
  apply(simp)
  apply(erule conjE)+
  apply (erule_tac c="(ya,sa)" in Abs_lst1_fcb2)
  apply(simp add: Abs_fresh_iff)
  apply(simp add: fresh_star_def fresh_Pair)
  apply(simp add: eqvt_at_def atom_eqvt fresh_star_Pair perm_supp_eq)
  apply(simp add: eqvt_at_def atom_eqvt fresh_star_Pair perm_supp_eq)
done

end


theory Demo1
imports Complex_Main
begin

section{* An introductory example *}

lemma "\<not> surj(f :: 'a \<Rightarrow> 'a set)"
proof
  assume a: "surj f"
  from a have b: "\<forall>A. \<exists>a. A = f a" by(simp add: surj_def)
  from b have c: "\<exists>a. {x. x \<notin> f x} = f a" by blast
  from c show "False" by blast
qed

text{* A bit shorter: *}

lemma "\<not> surj(f :: 'a \<Rightarrow> 'a set)"
proof
  assume a: "surj f"
  from a have b: "\<exists>a. {x. x \<notin> f x} = f a" by(auto simp: surj_def)
  from b show "False" by blast
qed

subsection{* this, then, hence and thus *}

text{* Avoid labels, use this: *}

lemma "\<not> surj(f :: 'a \<Rightarrow> 'a set)"
proof
  assume "surj f"
  from this have "\<exists>a. {x. x \<notin> f x} = f a" by(auto simp: surj_def)
  from this show "False" by blast
qed

text{* then = from this *}

lemma "\<not> surj(f :: 'a \<Rightarrow> 'a set)"
proof
  assume "surj f"
  then have "\<exists>a. {x. x \<notin> f x} = f a" by(auto simp: surj_def)
  then show "False" by blast
qed

text{* hence = then have, thus = then show *}

lemma "\<not> surj(f :: 'a \<Rightarrow> 'a set)"
proof
  assume "surj f"
  hence "\<exists>a. {x. x \<notin> f x} = f a" by(auto simp: surj_def)
  thus "False" by blast
qed

subsection{* Structured statements: fixes, assumes, shows *}

lemma
  fixes f :: "'a \<Rightarrow> 'a set"
  assumes s: "surj f"
  shows "False"
proof -  --"no automatic proof step!"
  have "\<exists> a. {x. x \<notin> f x} = f a" using s
    by(auto simp: surj_def)
  thus "False" by blast
qed

section{* Proof patterns *}

subsection{* Propositional logic *}

lemma "P \<longleftrightarrow> Q"
proof
  assume "P"
  show "Q" sorry
next
  assume "Q"
  show "P" sorry
qed

lemma "P \<longrightarrow> Q"
proof
  assume "P"
  show "Q" sorry
qed

lemma "P \<and> Q"
proof
  show "P" sorry
next
  show "Q" sorry
qed

lemma "A = (B::'a set)"
proof
  show "A \<subseteq> B" sorry
next
  show "B \<subseteq> A" sorry
qed

lemma "A \<subseteq> B"
proof
  fix a
  assume "a \<in> A"
  show "a \<in> B" sorry
qed

text{* Contradiction *}

(*<*)
lemma P
proof (rule ccontr)
  assume "\<not>P"
  show "False" sorry
qed

text{* Case distinction *}

lemma "R"
proof -
  have "P \<or> Q" sorry
  then show "R"
  proof
    assume "P"
    show "R" sorry
  next
    assume "Q"
    show "R" sorry
  qed
qed

text{* obtain example *}

lemma "\<not> surj(f :: 'a \<Rightarrow> 'a set)"
proof
  assume "surj f"
  hence "\<exists>a. {x. x \<notin> f x} = f a" by(auto simp: surj_def)
  then obtain a where "{x. x \<notin> f x} = f a" by blast
  hence "a \<notin> f a \<longleftrightarrow> a \<in> f a" by blast
  thus "False" by blast
qed

text{* Interactive exercise: *}

lemma assumes "EX x. ALL y. P x y" shows "ALL y. EX x. P x y"
oops

subsection{* proof with complex method *}

lemma "k dvd (n+k) \<longleftrightarrow> k dvd (n::int)"
proof(auto simp add: dvd_def)
  fix a assume a: "n+k = k*a"
  show "EX b. n = k*b"
  proof
    show "n = k*(a - 1)" using a by(simp add: algebra_simps)
  qed
next
  fix a show "EX b. k*a + k = k*b"
  proof
    show "k*a + k = k*(a+1)" by(simp add: algebra_simps)
  qed
qed

section{* Streamlining proofs *}

subsection{* Pattern matching and ?-variables *}

text{* Show EX *}

lemma fixes x :: real assumes "x < y"
shows "EX z. x < z & z < y" (is "EX z. ?P z")
proof
  show "?P((x+y)/2)" using assms by simp
qed

text{* Multiple EX easier with forward proof: *}

lemma "EX x y :: int. x < z & z < y" (is "EX x y. ?P x y")
proof -
  have "?P (z - 1) (z + 1)" by arith
  thus ?thesis by blast
qed

subsection{* Quoting facts: *}

lemma assumes "x < (0::int)" shows "x*x > 0"
proof -
  from `x<0` show ?thesis by(metis mult_neg_neg)
qed

end