theory DecisionStump
imports
  Complex_Main
  "HOL-Data_Structures.Cmp"
begin

text "This document contains an attempt at providing an upper bound for the error of decision stumps.
      Since there is no non-trivial (better than 0.5) upper bound without assumptions,
      I tried to specify the conditions necessary for such a bound. I proof that the condition
      I came up with is sufficient for the bound provided but it turns out, it is not a necessary
      condition for a bound <0.5 and as such not optimal. However, such a bound would not be very
      powerful so this side-project was stopped."

locale Stump =
  fixes X :: "'a set"
    and y :: "'a \<Rightarrow> real"
    and D :: "'a \<Rightarrow> real"
    and comp :: "'a \<Rightarrow> 'a \<Rightarrow> nat \<Rightarrow> cmp_val"
    and d1 :: nat
  assumes
       nonemptyx: "X \<noteq> {}"
    and finitex: "finite X"
    and ytwoclass: "\<forall>x. y x \<in> {-1,1}"
    and Dsum: "sum D X = 1"
    and dgtz: "\<forall>x. D x \<ge> 0"
    and comprefl: "\<forall>x d. comp x x d = EQ"
    and compcomm: "\<forall>x y d. (comp x y d = EQ) = (comp y x d = EQ)"
begin

lemma
  assumes "\<forall>Xs\<subseteq>X. Xs \<noteq> {} \<longrightarrow> (\<exists>x1\<in>Xs.\<exists>d\<le>d1. \<forall>x2\<in>X. ((comp x1 x2 d = EQ) \<longrightarrow> (y x1 = y x2)))"
      and "\<forall>x. D x \<ge> 0"
      and "\<forall>x d. comp x x d = EQ"
      and "(\<forall>x3\<in>X. \<forall>d3\<le>d1. 1 / (2 ^ (card X)) > \<bar>\<Sum>x | x \<in> X \<and> comp x3 x d3 = EQ. D x * y x\<bar>)"
    shows part2: "n \<le> card X \<Longrightarrow> \<exists>S\<subseteq>X. card(S) = n \<and> sum D S \<le> 1/(2^(card (X-S))) - 1/(2^(card X))"
proof(induction n)
case 0
  then show ?case
    using zero_less_power by auto
next
  case c1:(Suc n)
  then show ?case
  proof(cases "n < card X")
    case c2: True
    from c1 obtain S where s1:"card S = n" "S\<subseteq>X" "sum D S \<le> 1/(2^(card (X-S))) - 1/(2^(card X))" by auto
    have s3: "X-S \<subseteq> X" by auto
    have "X-S \<noteq> {}" using c2 s1 by auto
    then obtain x1 d where s4: "x1\<in>(X-S)" "\<forall>x2\<in>(X-S). ((comp x1 x2 d = EQ) \<longrightarrow> (y x1 = y x2))" "d\<le>d1"
      using assms(1) s3 by (meson DiffE)

    have finites: "finite S"
      using finitex rev_finite_subset s1(2) by auto
    have s01: "X-S \<subseteq> X" by auto
    have s02: "x1 \<notin> S" using s4 by auto
   have "(\<Sum>x | x \<in> (X-S) \<and> comp x1 x d = EQ. D x * y x)
      = (\<Sum>x | x \<in> (X-S) \<and> comp x1 x d = EQ. D x) * y x1"
    using s4 by (smt CollectD sum.cong sum_distrib_right)
  then have s010:"\<bar>\<Sum>x | x \<in> (X-S) \<and> comp x1 x d = EQ. D x * y x\<bar>
      = (\<Sum>x | x \<in> (X-S) \<and> comp x1 x d = EQ. D x)"
    using assms(2) ytwoclass
    by (smt empty_iff insertE mult_cancel_left2 mult_minus_right sum_nonneg)

        have s03:"{x\<in>X-S. comp x1 x d = EQ}\<union>{x\<in>S. comp x1 x d = EQ} = {x\<in>X. comp x1 x d = EQ}" using s1(2) by auto
        have s04:"finite {x\<in>S. comp x1 x d = EQ}" using s1(2) finitex finite_subset by fastforce
        have s05:"finite {x\<in>X-S. comp x1 x d = EQ}" using finitex by auto
        have s06:"{x\<in>X-S. comp x1 x d = EQ}\<inter>{x\<in>S. comp x1 x d = EQ} = {}" by blast
  then have s011: "sum (\<lambda>x. D x * y x) {x\<in>X. comp x1 x d = EQ} =
        sum (\<lambda>x. D x * y x) {x\<in>X-S. comp x1 x d = EQ} +
        sum (\<lambda>x. D x * y x) {x\<in>S. comp x1 x d = EQ}"
    using Groups_Big.comm_monoid_add_class.sum.union_inter s03 s04 s05 s06
          Groups_Big.comm_monoid_add_class.sum.empty by smt
  have subs1:"{x\<in>S. comp x1 x d = EQ} \<subseteq> S" by auto
  have s111: "\<forall>x. \<bar> D x * y x\<bar> \<le> D x" using ytwoclass
     by (smt assms(2) empty_iff insert_iff mult_left_le mult_minus_right)
   have "(\<Sum>x | x \<in> (X-S) \<and> comp x1 x d = EQ. D x) \<le>
         \<bar>\<Sum>x | x \<in> (X) \<and> comp x1 x d = EQ. D x * y x\<bar> +
        \<bar>\<Sum>x | x \<in> S \<and> comp x1 x d = EQ. D x * y x\<bar>"
     using Groups.ordered_ab_group_add_abs_class.abs_triangle_ineq4 s010 s011 by auto
   also have "\<bar>\<Sum>x | x \<in> S \<and> comp x1 x d = EQ. D x * y x\<bar> \<le>
              (\<Sum>x | x \<in> S \<and> comp x1 x d = EQ.\<bar> D x * y x\<bar>)"  by blast
   also have "... \<le> (\<Sum>x | x \<in> S \<and> comp x1 x d = EQ. D x)" using s111
     by (simp add: sum_mono)
   also have "... \<le> sum D S"
     using subs1 by (meson assms(2) finitex infinite_super s1(2) sum_mono2)
   finally have "(\<Sum>x | x \<in> (X-S) \<and> comp x1 x d = EQ. D x) \<le>
         \<bar>\<Sum>x | x \<in> (X) \<and> comp x1 x d = EQ. D x * y x\<bar> + sum D S" by auto
   also have "\<bar>\<Sum>x | x \<in> (X) \<and> comp x1 x d = EQ. D x * y x\<bar> < 1/(2^card X)"
     using assms(4) s4(1,3) by blast
   finally have "(\<Sum>x | x \<in> (X-S) \<and> comp x1 x d = EQ. D x) < 1/(2 ^ (card (X-S)))"
     using s1(3) by auto
   moreover have "D x1 \<le> (\<Sum>x | x \<in> (X-S) \<and> comp x1 x d = EQ. D x)"
    using assms(2,3) s4
        proof -
          have f1: "\<forall>a r A. ((D a \<le> r \<or> sum D A \<noteq> r) \<or> a \<notin> A) \<or> infinite A"
            by (meson assms(2) sum_nonneg_leq_bound)
        have "finite {a \<in> X - S. comp x1 a d = EQ} \<and> x1 \<in> X - S \<and> comp x1 x1 d = EQ"
        using s4 assms(3) finitex by auto
          then show ?thesis
            using f1 by blast
        qed
  ultimately have s004: "D x1 < 1 / real (2 ^ (card (X-S)))"
    by auto
  have s6: "card (X - (S \<union> {x1})) = card (X - S) - 1"
    using s4(1) finitex by auto
  have s3: "card (X-S) \<ge> 1"
    by (metis One_nat_def Suc_leI s4(1) card_gt_0_iff empty_iff finite_Diff finitex)
  then have "(2::real) ^ (card (X - S) - 1) = 2 ^ card (X - S) / 2 ^ 1"
    by (simp add: power_diff)
  then have s5: "(2::real) ^ 1 / 2 ^ card (X - S) = 1 / 2 ^ (card (X - S) - 1)"
    by (smt diff_diff_cancel diff_le_self divide_divide_eq_left divide_self_if mult.commute power_diff s3 two_realpow_ge_one)
  have "sum D (S \<union> {x1}) \<le> sum D S + D x1"
    using s1(2) finite_subset finitex s02 by fastforce
  then have "sum D (S \<union> {x1}) < 1 / 2 ^ card (X - S) + 1 / 2 ^ card (X - S) - 1 / 2 ^ (card X)" using s004 s1(3) by auto
  then have "sum D (S\<union>{x1})< 1/(2^(card (X-(S\<union>{x1})))) - 1 / 2 ^ (card X)"
     using s5 s6 by auto
     then show ?thesis
       by (smt Un_insert_right card.insert finites insert_subset s01 s02 s1(1) s1(2) s4(1) set_mp sup_bot.right_neutral)
  next
    case False
    then show ?thesis using c1.prems by auto
  qed
qed

(*sperability assumption formulated*)
lemma
  assumes "\<forall>Xs\<subseteq>X. Xs \<noteq> {} \<longrightarrow> (\<exists>x1\<in>Xs.\<exists>d\<le>d1. \<forall>x2\<in>X. ((comp x1 x2 d = EQ) \<longrightarrow> (y x1 = y x2)))"
  and "sum D X = 1"
  and "\<forall>x. D x \<ge> 0"
  and "\<forall>x d. comp x x d = EQ"
  shows part1: "\<exists>x3\<in>X.\<exists>d3\<le>d1. abs (sum (\<lambda>x. D x * y x) {x\<in>X. comp x3 x d3 = EQ}) \<ge> 1/(2^ (card X))"
proof(rule ccontr)
  assume "\<not>?thesis"
  then have s1: "(\<forall>x3\<in>X. \<forall>d3\<le>d1. 1 / real (2 ^ (card X)) > \<bar>\<Sum>x | x \<in> X \<and> comp x3 x d3 = EQ. D x * y x\<bar>)"
    using linorder_not_le by auto
    have "\<exists>S\<subseteq>X. card S = card X \<and> sum D S \<le> 1/(2^(card (X-S))) - 1/(2^(card X))"
      using s1 assms(1,3,4) part2 by auto
    then obtain S where s2: "S\<subseteq>X" "card S = card X" "sum D S \<le> 1/(2^(card (X-S))) - 1/(2^(card X))"
      by auto
    then have "S = X" using finitex Finite_Set.card_subset_eq by auto
    then have "sum D X < 1" using s2(3)
      by (smt Diff_cancel card_empty divide_numeral_1 power_0 zero_less_divide_1_iff zero_less_power)
    then show False using assms(2) by auto
qed

(*apply to set is image*)

type_synonym 'b split  = "('b \<times> nat \<times> bool)"

definition "allsplits = X \<times> {0..d1} \<times> {False, True}"

fun comsplit :: "'a split \<Rightarrow> ('a split \<times> bool \<times> bool)" where
"comsplit s = (if snd (snd s) then (s, sum D {x\<in>X. y x = 1 \<and> comp x (fst s) (fst (snd s)) = LT}
                                > sum D {x\<in>X. y x = -1 \<and> comp x (fst s) (fst (snd s)) = LT},
                                 sum D {x\<in>X. y x = 1 \<and> comp x (fst s) (fst (snd s)) \<noteq> LT}
                                > sum D {x\<in>X. y x = -1 \<and> comp x (fst s) (fst (snd s)) \<noteq> LT})
                else (s, sum D {x\<in>X. y x = 1 \<and> comp x (fst s) (fst (snd s)) = GT}
                                > sum D {x\<in>X. y x = -1 \<and> comp x (fst s) (fst (snd s)) = GT},
                                 sum D {x\<in>X. y x = 1 \<and> comp x (fst s) (fst (snd s)) \<noteq> GT}
                                > sum D {x\<in>X. y x = -1 \<and> comp x (fst s) (fst (snd s)) \<noteq> GT}))"

fun err :: "'a split \<Rightarrow> real" where
"err (x3,d3,b) = (if b then min (sum D {x\<in>X. y x = 1 \<and> comp x3 x d3 = LT})
                                (sum D {x\<in>X. y x = -1 \<and> comp x3 x d3 = LT}) +
                                min (sum D {x\<in>X. y x = 1 \<and> comp x3 x d3 \<noteq> LT})
                                (sum D {x\<in>X. y x = -1 \<and> comp x3 x d3 \<noteq> LT})
                else min (sum D {x\<in>X. y x = 1 \<and> comp x3 x d3 = GT})
                                (sum D {x\<in>X. y x = -1 \<and> comp x3 x d3 = GT}) +
                                min (sum D {x\<in>X. y x = 1 \<and> comp x3 x d3 \<noteq> GT})
                                (sum D {x\<in>X. y x = -1 \<and> comp x3 x d3 \<noteq> GT}))"

lemma assumes "\<forall>Xs\<subseteq>X. Xs \<noteq> {} \<longrightarrow> (\<exists>x1\<in>Xs.\<exists>d\<le>d1. \<forall>x2\<in>X. ((comp x1 x2 d = EQ) \<longrightarrow> (y x1 = y x2)))"
      shows "Inf (image err allsplits) \<le> 1/2 - 1 / 2^(card X + 1)"
proof(rule ccontr)
  assume a1: "\<not>?thesis"
  have "\<exists>x3\<in>X.\<exists>d3\<le>d1. abs (sum (\<lambda>x. D x * y x) {x\<in>X. comp x3 x d3 = EQ}) \<ge> 1/(2^ (card X))"
    using part1 dgtz Dsum comprefl assms by auto
  then obtain x3 d3 where s1: "x3\<in>X" "d3\<le>d1" "abs (sum (\<lambda>x. D x * y x) {x\<in>X. comp x3 x d3 = EQ}) \<ge> 1/(2^ (card X))"
    by auto
  have s2: "(x3, d3, False) \<in> allsplits" using allsplits_def s1(1,2) by auto
  have s3: "bdd_below (image err allsplits)" using allsplits_def finitex by auto
  from a1 have "1/2 - 1 / 2^(card X + 1) < (INF i:allsplits. err i)" by auto
  from s2 s3 this have s20: "err (x3, d3, False) > 1/2 - 1 / 2^(card X + 1)"
    using Conditionally_Complete_Lattices.conditionally_complete_lattice_class.less_cINF_D
        [of err allsplits "1/2 - 1 / 2^(card X + 1)" "(x3, d3, False)"] by auto
  have s4: "err (x3, d3, False) = min (sum D {x\<in>X. y x = 1 \<and> comp x3 x d3 = GT})
                                (sum D {x\<in>X. y x = -1 \<and> comp x3 x d3 = GT}) +
                                min (sum D {x\<in>X. y x = 1 \<and> comp x3 x d3 \<noteq> GT})
                                (sum D {x\<in>X. y x = -1 \<and> comp x3 x d3 \<noteq> GT})" by auto
  let ?s = "sgn (sum (\<lambda>x. D x * y x) {x\<in>X. comp x3 x d3 = EQ})"
  have s5: "?s \<in> {-1,1}" using s1(3) zero_less_power
    by (smt insertCI sgn_neg sgn_pos zero_less_divide_1_iff)
  from this s4 have "(sum D {x\<in>X. y x = -1*?s \<and> comp x3 x d3 \<noteq> GT}) +
        (sum D {x\<in>X. y x = ?s \<and> comp x3 x d3 = GT}) \<ge> err (x3, d3, False)"
    by (smt Collect_cong empty_iff insert_iff)
  from this s1(3) have s12: "abs (sum (\<lambda>x. D x * y x) {x\<in>X. comp x3 x d3 = EQ}) +
             (sum D {x\<in>X. y x = -1*?s \<and> comp x3 x d3 \<noteq> GT}) +
             (sum D {x\<in>X. y x = ?s \<and> comp x3 x d3 = GT})
              \<ge> err (x3, d3, False) + 1/(2^ (card X))" by auto
  have s13: "abs (sum (\<lambda>x. D x * y x) {x\<in>X. comp x3 x d3 = EQ})
      = ?s * (sum (\<lambda>x. D x * y x) {x\<in>X. comp x3 x d3 = EQ})"
    by (simp add: linordered_idom_class.abs_sgn)
  have "{x\<in>X. comp x3 x d3 = EQ} = {x\<in>{x\<in>X. comp x3 x d3 = EQ}. y x = ?s} \<union> {x\<in>{x\<in>X. comp x3 x d3 = EQ}. y x \<noteq> ?s}"
    by auto
  then have "{x\<in>X. comp x3 x d3 = EQ} = {x\<in>X. y x = ?s \<and> comp x3 x d3 = EQ} \<union> {x\<in>X. y x \<noteq> ?s \<and> comp x3 x d3 = EQ}"
    by auto
  moreover have "{x\<in>X. y x = ?s \<and> comp x3 x d3 = EQ} \<inter> {x\<in>X. y x \<noteq> ?s \<and> comp x3 x d3 = EQ} = {}"
    by auto
  moreover have "finite {x\<in>X. y x = ?s \<and> comp x3 x d3 = EQ}" using finitex by auto
  moreover have "finite {x\<in>X. y x \<noteq> ?s \<and> comp x3 x d3 = EQ}" using finitex by auto
  ultimately have s6: "(sum (\<lambda>x. D x * y x) {x\<in>X. comp x3 x d3 = EQ}) = ((sum (\<lambda>x. D x * y x) {x\<in>X. y x = ?s \<and> comp x3 x d3 = EQ}) +
                        (sum (\<lambda>x. D x * y x) {x\<in>X. y x \<noteq> ?s \<and> comp x3 x d3 = EQ}))"
    using sum.union_disjoint by (metis (no_types, lifting))
  have s9: "(sum (\<lambda>x. D x * y x) {x\<in>X. y x = ?s \<and> comp x3 x d3 = EQ}) = (sum (\<lambda>x. D x * ?s) {x\<in>X. y x = ?s \<and> comp x3 x d3 = EQ})"
    by auto
  then have s7: "(sum (\<lambda>x. D x * ?s) {x\<in>X. y x = ?s \<and> comp x3 x d3 = EQ}) = ?s * (sum D {x\<in>X. y x = ?s \<and> comp x3 x d3 = EQ})"
    by (smt mult.commute sum.cong sum_distrib_left)
  have s11: "{x\<in>X. y x \<noteq> ?s \<and> comp x3 x d3 = EQ} = {x\<in>X. y x = -1*?s \<and> comp x3 x d3 = EQ}"
    using s5 ytwoclass by auto
  then have s8: "(sum (\<lambda>x. D x * y x) {x\<in>X. y x \<noteq> ?s \<and> comp x3 x d3 = EQ}) = (sum (\<lambda>x. D x * -1*?s) {x\<in>X. y x = -1*?s \<and> comp x3 x d3 = EQ})"
    by auto
  have s10: "(sum (\<lambda>x. D x * -1*?s) {x\<in>X. y x = -1*?s \<and> comp x3 x d3 = EQ}) = -1*?s*(sum D {x\<in>X. y x = -1*?s \<and> comp x3 x d3 = EQ})"
    by (smt mult.commute mult_minus_left sum.cong sum_distrib_left)
   have "?s * (sum (\<lambda>x. D x * y x) {x\<in>X. comp x3 x d3 = EQ}) =  (sum D {x\<in>X. y x = ?s \<and> comp x3 x d3 = EQ}) -
                        (sum D {x\<in>X. y x = -1*?s \<and> comp x3 x d3 = EQ})"
     by (smt mult_cancel_right1 mult_minus_left s1(3) s10 s11 s6 s7 s8 s9 sgn_neg sgn_pos zero_less_divide_1_iff zero_less_power)
   from this s12 s13 have s14: "(sum D {x\<in>X. y x = ?s \<and> comp x3 x d3 = EQ}) -
                           (sum D {x\<in>X. y x = -1*?s \<and> comp x3 x d3 = EQ}) +
                           (sum D {x\<in>X. y x = -1*?s \<and> comp x3 x d3 \<noteq> GT}) +
                           (sum D {x\<in>X. y x = ?s \<and> comp x3 x d3 = GT})
                            \<ge> err (x3, d3, False) + 1/(2^ (card X))"
     by linarith
   have "{x\<in>X. y x = -1*?s \<and> comp x3 x d3 = LT} \<inter> {x\<in>X. y x = -1*?s \<and> comp x3 x d3 = EQ} = {}"
     by auto
   moreover have "{x\<in>X. y x = -1*?s \<and> comp x3 x d3 \<noteq> GT} =
          {x\<in>X. y x = -1*?s \<and> comp x3 x d3 = LT} \<union> {x\<in>X. y x = -1*?s \<and> comp x3 x d3 = EQ}"
   using Un_def[of "{x\<in>X. y x = -1*?s \<and> comp x3 x d3 = LT}" "{x\<in>X. y x = -1*?s \<and> comp x3 x d3 = EQ}"]
     by (smt Collect_cong cmp_val.distinct(3) cmp_val.distinct(5) cmp_val.exhaust mem_Collect_eq)
   moreover have "finite {x\<in>X. y x = -1*?s \<and> comp x3 x d3 = LT}" using finitex by auto
   moreover have "finite {x\<in>X. y x = -1*?s \<and> comp x3 x d3 = EQ}" using finitex by auto
   ultimately have s15: "(sum D {x\<in>X. y x = -1*?s \<and> comp x3 x d3 \<noteq> GT})
       - (sum D {x\<in>X. y x = -1*?s \<and> comp x3 x d3 = EQ})
       = (sum D {x\<in>X. y x = -1*?s \<and> comp x3 x d3 = LT})"
    using sum.union_disjoint by smt

   have "{x\<in>X. y x = ?s \<and> comp x3 x d3 = GT} \<inter> {x\<in>X. y x = ?s \<and> comp x3 x d3 = EQ} = {}"
     by auto
   moreover have "{x\<in>X. y x = ?s \<and> comp x3 x d3 \<noteq> LT} =
          {x\<in>X. y x = ?s \<and> comp x3 x d3 = GT} \<union> {x\<in>X. y x = ?s \<and> comp x3 x d3 = EQ}"
     using Un_def[of "{x\<in>X. y x = ?s \<and> comp x3 x d3 = GT}" "{x\<in>X. y x = ?s \<and> comp x3 x d3 = EQ}"]
     by (smt Collect_cong cmp_val.distinct(4) cmp_val.distinct(2) cmp_val.exhaust mem_Collect_eq)
   moreover have "finite {x\<in>X. y x = ?s \<and> comp x3 x d3 = GT}" using finitex by auto
   moreover have "finite {x\<in>X. y x = ?s \<and> comp x3 x d3 = EQ}" using finitex by auto
   ultimately have "(sum D {x\<in>X. y x = ?s \<and> comp x3 x d3 \<noteq> LT})
       = (sum D {x\<in>X. y x = ?s \<and> comp x3 x d3 = EQ})
       + (sum D {x\<in>X. y x = ?s \<and> comp x3 x d3 = GT})"
    using sum.union_disjoint by smt

  from this s14 s15 have s21: " (sum D {x\<in>X. y x = -1*?s \<and> comp x3 x d3 = LT}) +
                           (sum D {x\<in>X. y x = ?s \<and> comp x3 x d3 \<noteq> LT})
                            \<ge> err (x3, d3, False) + 1/(2^ (card X))"
    by linarith
  from s20 have "err (x3, d3, False) + (1::real)/(2^ (card X))
                            > 1/2 + 1/(2^ (card X + 1))"
    by simp
  from s21 this have s22: "(sum D {x\<in>X. y x = -1*?s \<and> comp x3 x d3 = LT}) +
                      (sum D {x\<in>X. y x = ?s \<and> comp x3 x d3 \<noteq> LT})
                        > 1/2 + 1/(2^ (card X + 1))"
    by linarith
  have "{x\<in>X. y x = -1*?s \<and> comp x3 x d3 = LT} \<union> {x\<in>X. y x = ?s \<and> comp x3 x d3 = LT}
        = {x\<in>X. comp x3 x d3 = LT}" using s5 ytwoclass by auto
  moreover have "{x\<in>X. y x = -1*?s \<and> comp x3 x d3 = LT} \<inter> {x\<in>X. y x = ?s \<and> comp x3 x d3 = LT}
        = {}" using s5 by auto
  moreover have "finite {x\<in>X. y x = -1*?s \<and> comp x3 x d3 = LT}" using finitex by auto
  moreover have "finite {x\<in>X. y x = ?s \<and> comp x3 x d3 = LT}" using finitex by auto
  ultimately have "(sum D {x\<in>X. y x = ?s \<and> comp x3 x d3 = LT}) +
                   (sum D {x\<in>X. y x = -1*?s \<and> comp x3 x d3 = LT}) =
                   (sum D {x\<in>X. comp x3 x d3 = LT})"
    using sum.union_disjoint by smt
  moreover have "{x\<in>X. y x = -1*?s \<and> comp x3 x d3 \<noteq> LT} \<union> {x\<in>X. y x = ?s \<and> comp x3 x d3 \<noteq> LT}
        = {x\<in>X. comp x3 x d3 \<noteq> LT}" using s5 ytwoclass by auto
  moreover have "{x\<in>X. y x = -1*?s \<and> comp x3 x d3 \<noteq> LT} \<inter> {x\<in>X. y x = ?s \<and> comp x3 x d3 \<noteq> LT}
        = {}" using s5 by auto
  moreover have "finite {x\<in>X. y x = -1*?s \<and> comp x3 x d3 \<noteq> LT}" using finitex by auto
  moreover have "finite {x\<in>X. y x = ?s \<and> comp x3 x d3 \<noteq> LT}" using finitex by auto
  ultimately have "(sum D {x\<in>X. y x = ?s \<and> comp x3 x d3 = LT}) +
                   (sum D {x\<in>X. y x = -1*?s \<and> comp x3 x d3 = LT}) +
                   (sum D {x\<in>X. y x = ?s \<and> comp x3 x d3 \<noteq> LT}) +
                   (sum D {x\<in>X. y x = -1*?s \<and> comp x3 x d3 \<noteq> LT}) =
                   (sum D {x\<in>X. comp x3 x d3 = LT}) +
                   (sum D {x\<in>X. comp x3 x d3 \<noteq> LT})"
    using sum.union_disjoint by smt
  moreover have "{x\<in>X. comp x3 x d3 = LT} \<union> {x\<in>X. comp x3 x d3 \<noteq> LT} = X" by auto
  moreover have "{x\<in>X. comp x3 x d3 = LT} \<inter> {x\<in>X. comp x3 x d3 \<noteq> LT} = {}" by auto
  moreover have "finite {x\<in>X. comp x3 x d3 = LT}" using finitex by auto
  moreover have "finite {x\<in>X. comp x3 x d3 \<noteq> LT}" using finitex by auto
  ultimately have "(sum D {x\<in>X. y x = ?s \<and> comp x3 x d3 = LT}) +
                   (sum D {x\<in>X. y x = -1*?s \<and> comp x3 x d3 = LT}) +
                   (sum D {x\<in>X. y x = ?s \<and> comp x3 x d3 \<noteq> LT}) +
                   (sum D {x\<in>X. y x = -1*?s \<and> comp x3 x d3 \<noteq> LT}) =
                   sum D X"
    using sum.union_disjoint by smt
  from this s22 have "(sum D {x\<in>X. y x = -1*?s \<and> comp x3 x d3 \<noteq> LT})+
                      (sum D {x\<in>X. y x = ?s \<and> comp x3 x d3 = LT})
                         < 1/2 - 1/(2^ (card X + 1))"
    using Dsum by linarith
  moreover have "err (x3,d3,True) \<le> (sum D {x\<in>X. y x = -1*?s \<and> comp x3 x d3 \<noteq> LT})+
                      (sum D {x\<in>X. y x = ?s \<and> comp x3 x d3 = LT})" using s5 by auto
  ultimately have s24: "err (x3,d3,True) < 1/2 - 1/(2^(card X +1))" by linarith
  have s23: "(x3, d3, True) \<in> allsplits" using allsplits_def s1(1,2) by auto
  from a1 have "1/2 - 1 / 2^(card X + 1) < (INF i:allsplits. err i)" by auto
  from s23 s3 this have s20: "err (x3, d3, True) > 1/2 - 1 / 2^(card X + 1)"
    using Conditionally_Complete_Lattices.conditionally_complete_lattice_class.less_cINF_D
        [of err allsplits "1/2 - 1 / 2^(card X + 1)" "(x3, d3, True)"] by auto
  from this s24 show False by auto
qed


theory PredicateTransformers
  imports "../Algebra/BBI"
begin

no_notation plus (infixl "+" 65)

text{*
  Predicate transformers are functions from predicates to predicates, abstractly, from
  commutative quantale unital to commutative quantale unital
*}

instantiation "fun" :: (quantale_Sup, quantale_Sup) quantale_Sup
begin

definition "F * G \<equiv> \<lambda>h. \<Squnion> {F f * G g | f g. h = f * g}"

lemma qmult_apply [simp, code]:
  "(F * G) h \<equiv>  \<Squnion> {F f * G g | f g. h = f * g}"
  by (simp add: times_fun_def)

lemma sup_distrib_left_fun: "(f * (g + h)) x = (f * g + f * h) x"
  by (subst qmult_apply, subst sup_apply, subst Sup.qdistl) simp

lemma sup_distrib_right_fun: "((f + g) * h) x = (f * h + g * h) x"
  by (subst qmult_apply, subst sup_apply, subst Sup.qdistr) simp

lemma qSup_distl_fun: "(f * \<Squnion>G) x = (\<Squnion>(op * f ` G)) x"
  apply (auto simp add: qSUP_distl intro!: antisym Sup_least SUP_mono)
  apply (metis (lifting, mono_tags) Sup_upper mem_Collect_eq)
  by (auto intro!: SUP_least Sup_mono) (metis SUP_upper)

lemma qSup_distr_fun: "(\<Squnion>G * f) x = (\<Squnion>((\<lambda>g. g * f) ` G)) x"
  apply (auto simp add: qSUP_distr intro!: antisym Sup_least SUP_mono)
  apply (metis (lifting, mono_tags) Sup_upper mem_Collect_eq)
  by (auto intro!: SUP_least Sup_mono) (metis SUP_upper)

lemma Sup_distl_assoc: "(f :: 'a \<Rightarrow> 'b) y * \<Squnion>{g y' * h z' |y' z' :: 'a. z = y' * z'} = \<Squnion>{f y * (g y' * h z') |y' z'. z = y' * z'}"
  by (auto simp only: Sup.Join_distl intro!: Sup.Join_eqI2)

lemma qSup_distr_assoc: "\<Squnion>{((f :: 'a \<Rightarrow> 'b) y * g y') | y y' :: 'a. z = (y * y')} * h z' = \<Squnion>{(f y * g y') * h z' | y y'. z = (y * y')}"
  by (auto simp only: qSup_distr intro: Sup.Join_eqI2)

lemma qmult_assoc_fun: "(f * (g * h)) x = ((f * g) * h) x"
proof -
  have "(f * (g * h)) x = \<Squnion> {\<Squnion> {(f y * g y') * h z' | y' z'. z = y' * z'} | y z. x = y * z}"
    by (simp add: Sup_distl_assoc mult.assoc)
  also have "... = \<Squnion> {(f y * g y') * h z' | y' z' y z. z = y' * z' \<and> x = y * z}"
    apply (rule antisym, rule Sup_least, safe, rule Sup_mono, auto, rule Sup_least, auto)
    apply (subgoal_tac "\<exists>ya z. y * (y' * z') = ya * z \<and> f y * g y' * h z' \<le> \<Squnion>{f ya * g y' * h z' |y' z'. z = y' * z'}")
    apply (smt Sup_upper2 mem_Collect_eq)
    by (smt Sup_le_iff dual_order.refl mem_Collect_eq)
  also have "... = \<Squnion> {(f y * g y') * h z' | z' y y'. x = y * (y' * z')}"
    by (auto intro: Sup.Join_eqI2)
  also have "... = \<Squnion> {(f y * g y') * h z' | z' y y'. x = (y * y') * z'}"
    by (metis mult.assoc)
  also have "... = \<Squnion> {(f y * g y') * h z' | z' y y' z. z = (y * y') \<and> x = z * z'}"
    by (auto intro: Sup.Join_eqI2)
  also have "... = \<Squnion>{ \<Squnion>{(f y * g y') * h z' | y y'. z = (y * y')} | z z'. x = z * z'}"
    apply (rule antisym, rule Sup_least, auto)
    apply (subgoal_tac "\<exists>z z'a. y * y' * z' = z * z'a \<and> f y * g y' * h z' \<le> \<Squnion>{f y * g y' * h z'a |y y'. z = y * y'}")
    apply (smt Sup_upper2 mem_Collect_eq)
    apply (smt Sup_le_iff dual_order.refl mem_Collect_eq)
    by (rule Sup_least, safe, rule Sup_mono, auto)
  finally show ?thesis
    by (simp add: qSup_distr_assoc)
qed

instance
  apply default
  apply (rule ext, rule qmult_assoc_fun[symmetric])
  apply (rule ext, rule qSup_distr_fun)
  by (metis (lifting, mono_tags) qSup_distl_fun eq_iff le_funI)+
end

text {* Unit is also lifted *}

instantiation "fun" :: (quantale_Sup_unital, quantale_Sup_unital) quantale_Sup_unital
begin

definition
  "1 \<equiv> \<lambda>x. if x = 1 then 1 else \<bottom>"

lemma qunitl_fun[simp]: "(1 * f) x = f x"
  by (auto simp: one_fun_def intro!: Sup_eqI)

lemma qunitr_fun[simp]: "(f * 1) x = f x"
  by (auto simp: one_fun_def intro!: Sup_eqI)

instance
  by default  (auto intro: qunitr_fun qunitl_fun)

end

text {* Commutativity is also lifted *}

instance "fun" :: (comm_quantale_Sup, comm_quantale_Sup) comm_quantale_Sup
proof (default, simp_all add: mult.assoc, rule ext)
  fix f g :: "'a :: comm_quantale_Sup \<Rightarrow> 'b :: comm_quantale_Sup"
  fix x :: "'a :: comm_quantale_Sup"
  have "(f * g) x = \<Squnion> {f y * g z | y z. x = y * z}" by simp
  also have "... = \<Squnion> {g z * f y | z y. x = z * y}"
    by (auto intro!: Sup.Join_eqI2 mult.commute)
  finally show "(f * g) x = (g * f) x" by simp
qed

instance "fun" :: (comm_quantale_Sup_unital, comm_quantale_Sup_unital) comm_quantale_Sup_unital
  by default auto

text {* Distributivity is also lifted *}

instance "fun" :: (distrib_quantale_Sup, distrib_quantale_Sup) distrib_quantale_Sup ..

instance "fun" :: (distrib_comm_quantale_Sup_unital, distrib_comm_quantale_Sup_unital) distrib_comm_quantale_Sup_unital ..

text {* BBI *}

instance "fun" :: (bbi, bbi) bbi ..

end


subsection \<open>Zones and DBMs\<close>
theory Zones
  imports DBM
begin

type_synonym ('c, 't) zone = "('c, 't) cval set"

type_synonym ('c, 't) cval = "'c \<Rightarrow> 't"

definition cval_add :: "('c,'t) cval \<Rightarrow> 't::plus \<Rightarrow> ('c,'t) cval" (infixr "\<oplus>" 64)
where
  "u \<oplus> d = (\<lambda> x. u x + d)"

definition zone_delay :: "('c, ('t::time)) zone \<Rightarrow> ('c, 't) zone"
("_\<^sup>\<up>" [71] 71)
where
  "Z\<^sup>\<up> = {u \<oplus> d|u d. u \<in> Z \<and> d \<ge> (0::'t)}"

fun clock_set :: "'c list \<Rightarrow> 't::time \<Rightarrow> ('c,'t) cval \<Rightarrow> ('c,'t) cval"
where
  "clock_set [] _ u = u" |
  "clock_set (c#cs) t u = (clock_set cs t u)(c:=t)"

abbreviation clock_set_abbrv :: "'c list \<Rightarrow> 't::time \<Rightarrow> ('c,'t) cval \<Rightarrow> ('c,'t) cval"
("[_\<rightarrow>_]_" [65,65,65] 65)
where
  "[r \<rightarrow> t]u \<equiv> clock_set r t u"

definition zone_set :: "('c, 't::time) zone \<Rightarrow> 'c list \<Rightarrow> ('c, 't) zone"
("_\<^bsub>_ \<rightarrow> 0\<^esub>" [71] 71)
where
  "zone_set Z r = {[r \<rightarrow> (0::'t)]u | u . u \<in> Z}"

lemma clock_set_set[simp]:
  "([r\<rightarrow>d]u) c = d" if "c \<in> set r"
  using that by (induction r) auto

lemma clock_set_id[simp]:
  "([r\<rightarrow>d]u) c = u c" if "c \<notin> set r"
  using that by (induction r) auto

definition DBM_zone_repr :: "('t::time) DBM \<Rightarrow> ('c \<Rightarrow> nat) \<Rightarrow> nat \<Rightarrow> ('c, 't :: time) zone"
("[_]\<^bsub>_,_\<^esub>" [72,72,72] 72)
where
  "[M]\<^bsub>v,n\<^esub> = {u . DBM_val_bounded v u M n}"

lemma dbm_entry_val_mono_1:
  "dbm_entry_val u (Some c) (Some c') b \<Longrightarrow> b \<preceq> b' \<Longrightarrow> dbm_entry_val u (Some c) (Some c') b'"
proof (induction b, goal_cases)
  case 1 thus ?case using le_dbm_le le_dbm_lt by - (cases b'; fastforce)
next
  case 2 thus ?case using lt_dbm_le lt_dbm_lt by (cases b'; fastforce)
next
  case 3 thus ?case unfolding dbm_le_def by auto
qed

lemma dbm_entry_val_mono_3:
  "dbm_entry_val u (Some c) None b \<Longrightarrow> b \<preceq> b' \<Longrightarrow> dbm_entry_val u (Some c) None b'"
proof (induction b, goal_cases)
  case 1 thus ?case using le_dbm_le le_dbm_lt by - (cases b'; fastforce)
next
  case 2 thus ?case using lt_dbm_le lt_dbm_lt by (cases b'; fastforce)
next
  case 3 thus ?case unfolding dbm_le_def by auto
qed

lemmas dbm_entry_val_mono = dbm_entry_val_mono_1 dbm_entry_val_mono_2 dbm_entry_val_mono_3

lemma DBM_le_subset:
  "\<forall> i j. i \<le> n \<longrightarrow> j \<le> n \<longrightarrow> M i j \<preceq> M' i j \<Longrightarrow> u \<in> [M]\<^bsub>v,n\<^esub> \<Longrightarrow> u \<in> [M']\<^bsub>v,n\<^esub>"
proof -
  assume A: "\<forall>i j. i \<le> n \<longrightarrow> j \<le> n \<longrightarrow> M i j \<preceq> M' i j" "u \<in> [M]\<^bsub>v,n\<^esub>"
  hence "DBM_val_bounded v u M n" by (simp add: DBM_zone_repr_def)
  with A(1) have "DBM_val_bounded v u M' n" unfolding DBM_val_bounded_def
  proof (auto, goal_cases)
    case 1 from this(1,2) show ?case unfolding less_eq[symmetric] by fastforce
  next
    case (2 c)
    hence "dbm_entry_val u None (Some c) (M 0 (v c))" "M 0 (v c) \<preceq> M' 0 (v c)" by auto
    thus ?case using dbm_entry_val_mono_2 by fast
  next
    case (3 c)
    hence "dbm_entry_val u (Some c) None (M (v c) 0)" "M (v c) 0 \<preceq> M' (v c) 0" by auto
    thus ?case using dbm_entry_val_mono_3 by fast
  next
    case (4 c1 c2)
    hence "dbm_entry_val u (Some c1) (Some c2) (M (v c1) (v c2))" "M (v c1) (v c2) \<preceq> M' (v c1) (v c2)"
    by auto
    thus ?case using dbm_entry_val_mono_1 by fast
  qed
  thus "u \<in> [M']\<^bsub>v,n\<^esub>" by (simp add: DBM_zone_repr_def)
qed

end


theory ConcreteSemantics7_1_2_BigStep
  imports Main "~~/src/HOL/IMP/Com"
begin

section "6 Introduction"

text \<open>
When building upon any of those theories,
for example when solving an exercise, the imports section needs to include
"~~/src/HOL/IMP/T" where T is the name of the required theory
\<close>

section "7 IMP: A Simple Imperative Language"

(* two styles of defining the semantics of a programming language:
- big-step and
- small-step operational semantics.
*)

(* As a smaller concrete example, we will apply our semantics to the concept of program equivalence. *)

subsection "7.1 IMP Commands"

text \<open>
Before we jump into any formalization or define the abstract syntax of commands,
we need to determine which constructs the language IMP should contain
\<close>

(* For an imperative language,
we will want the basics such as assignments
*)

 value "''x''  ::= Plus(V ''y'')(N 1);; ''y''  ::= N 2"
 (* value "x := y + 1; y := 2" *)

text \<open>
even the more concrete Isabelle notation above is occasionally somewhat cumbersome to use.
one could write separate parsing/printing ML code that integrates with Isabelle and implements the concrete syntax of the language.
\<close>

text \<open>
Therefore definitions and theorems about the core language only need to worry about one type of loop,
while still supporting the full richness of a larger language.
This significantly reduces proof size and effort for the theorems that we discuss in this book.
\<close>

subsection "7.2 Big-Step Semantics"

text \<open>
use a big-step operational semantics to give meaning to commands.

In an operational semantics setting,
the aim is to capture the meaning of a program as a relation that describes how a program executes

easier to define and understand,
\<close>

subsubsection "7.2.1 Definition"

text \<open>
In big-step operational semantics, the relation to be defined is between program,initial state, and final state.
  Intermediate states during the execution of the program are not visible in the relation.
\<close>

(* Predicates in the big-step rules are called "judgements" *)

text \<open>
The idea is
  to have at least one rule per syntactic construct and
  to add further rules when case distinctions become necessary.
\<close>

inductive
  big_step :: "com \<times> state \<Rightarrow> state \<Rightarrow> bool" (infix "\<Rightarrow>" 55)
where
Skip: "(SKIP,s) \<Rightarrow> s" |
Assign: "(x ::= a,s) \<Rightarrow> s(x := aval a s)" |
Seq: "\<lbrakk> (c\<^sub>1,s\<^sub>1) \<Rightarrow> s\<^sub>2;  (c\<^sub>2,s\<^sub>2) \<Rightarrow> s\<^sub>3 \<rbrakk> \<Longrightarrow> (c\<^sub>1;;c\<^sub>2, s\<^sub>1) \<Rightarrow> s\<^sub>3" |
IfTrue: "\<lbrakk> bval b s;  (c\<^sub>1,s) \<Rightarrow> t \<rbrakk> \<Longrightarrow> (IF b THEN c\<^sub>1 ELSE c\<^sub>2, s) \<Rightarrow> t" |
IfFalse: "\<lbrakk> \<not>bval b s;  (c\<^sub>2,s) \<Rightarrow> t \<rbrakk> \<Longrightarrow> (IF b THEN c\<^sub>1 ELSE c\<^sub>2, s) \<Rightarrow> t" |
WhileFalse: "\<not>bval b s \<Longrightarrow> (WHILE b DO c,s) \<Rightarrow> s" |
WhileTrue:
"\<lbrakk> bval b s\<^sub>1;  (c,s\<^sub>1) \<Rightarrow> s\<^sub>2;  (WHILE b DO c, s\<^sub>2) \<Rightarrow> s\<^sub>3 \<rbrakk>
\<Longrightarrow> (WHILE b DO c, s\<^sub>1) \<Rightarrow> s\<^sub>3"

subsubsection "7.2.2 Deriving IMP Executions"

text \<open>
state the lemma with a schematic variable and
let Isabelle compute its value as the proof progresses.
\<close>

schematic_goal ex: "(''x'' ::= N 5;; ''y'' ::= V ''x'', s) \<Rightarrow> ?t"
apply(rule Seq)
apply(rule Assign)
apply simp
apply(rule Assign)
done
(*
I got theorem
  ex: (''x'' ::= N 5;; ''y'' ::= V ''x'', ?s) \<Rightarrow> ?s
      (''x'' := 5, ''y'' := aval (V ''x'') (?s(''x'' := 5)))

In text, the author wrote that
we get the expected
(''x'' ::= N 5;; ''y'' ::= V ''x'', s)  \<Rightarrow> s(''x'' := 5, ''y'' := 5)

There seems be merely different.
*)

text\<open>We want to execute the big-step rules:\<close>

code_pred big_step .

text \<open>The introduction rules are good for automatically
construction small program executions. The recursive cases
may require backtracking, so we declare the set as unsafe
intro rules.\<close>
declare big_step.intros [intro]

text\<open>The standard induction rule
@{thm [display] big_step.induct [no_vars]}\<close>

thm big_step.induct

values "{t. (SKIP, \<lambda>_.0) \<Rightarrow> t}"

text \<open> Functions cannot always easily be printed, but lists can be, \<close>

values "{map t [''x'', ''y''] | t. (''x'' ::= N 2, \<lambda>_.0) \<Rightarrow> t}"

text \<open>
This section showed us
  how to construct program derivations and
  how to execute small IMP programs according to the big-step semantics.

In the next section,
we instead
  deconstruct executions that we know have happened and
  analyse all possible ways we could have gotten there
\<close>

subsubsection "7.2.3 Rule Inversion"

text \<open>
These inverted rules can be proved automatically by Isabelle from the original rules.
Moreover, proof methods like auto and blast can be instructed to use
both the introduction and the inverted rules automatically during proof search.
\<close>

inductive_cases SkipE[elim!]: "(SKIP,s) \<Rightarrow> t"
thm SkipE
inductive_cases AssignE[elim!]: "(x ::= a,s) \<Rightarrow> t"
thm AssignE
inductive_cases SeqE[elim!]: "(c1;;c2,s1) \<Rightarrow> s3"
thm SeqE
inductive_cases IfE[elim!]: "(IF b THEN c1 ELSE c2,s) \<Rightarrow> t"
thm IfE

inductive_cases WhileE[elim]: "(WHILE b DO c,s) \<Rightarrow> t"
thm WhileE

lemma "(IF b THEN SKIP ELSE SKIP, s) \<Rightarrow> t \<Longrightarrow> t = s"
by blast

lemma assumes "(IF b THEN SKIP ELSE SKIP, s) \<Rightarrow> t"
shows "t = s"
proof-
  from assms show ?thesis
  proof cases  \<comment> \<open>inverting assms\<close>
    case IfTrue thm IfTrue
    thus ?thesis by blast
  next
    case IfFalse thus ?thesis by blast
  qed
qed

(* Using rule inversion to prove simplification rules: *)
lemma assign_simp:
  "(x ::= a,s) \<Rightarrow> s' \<longleftrightarrow> (s' = s(x := aval a s))"
  by auto

lemma "(c1;;c2;;c3, s) \<Rightarrow> s' \<longleftrightarrow> (c1;;(c2;;c3), s) \<Rightarrow> s'"
proof
  assume "(c1;;c2;;c3, s) \<Rightarrow> s'"
  then obtain s1 s2 where
    c1: "(c1, s) \<Rightarrow> s1" and
    "(c2, s1) \<Rightarrow> s2" and
    "(c3, s2) \<Rightarrow> s'"  by blast
    (* This method is not able to be used without the above SeqE. *)
  then have "(c2;;c3, s1) \<Rightarrow> s'" using Seq by auto
  then show " (c1;;(c2;;c3), s) \<Rightarrow> s'" using Seq c1 by auto
next
  assume "(c1;;(c2;;c3), s) \<Rightarrow> s'"
  then show "(c1;;c2;;c3, s) \<Rightarrow> s'"  by (meson Seq SeqE)
qed

text \<open>
Big Stepの証明は基本的に上記の証明と代わりないが、オリジナルの証明の方がわかりやすい。
あと、私の証明では、`by (meson Seq SeqE)`を最後に使っているが、オリジナルではそうではない。
オリジナルのTheoryに入れられているいずれかのlemmaが効いているのであろうが、それはなにか。
\<close>

subsubsection "7.2.4 Equivalence of Commands"

(* semantic equivalence *)
abbreviation
  equiv_c :: "com \<Rightarrow> com \<Rightarrow> bool" (infix "\<sim>" 50) where
  "c \<sim> c' \<equiv> (\<forall>s t. (c,s) \<Rightarrow> t  =  (c',s) \<Rightarrow> t)"

text \<open>
Big_Stepの証明とだいぶ違い、blastで済んでいるが、なぜだ。
\<close>
lemma "(WHILE b DO c) \<sim> (IF b THEN c;; WHILE b DO c ELSE SKIP)" (is "?w \<sim> ?iw")
proof -
(* have "(?iw, s) \<Rightarrow> t" if assm: "(?w, s) \<Rightarrow> t" for s t sorry
have "(?w, s) \<Rightarrow> t" if assm: "(?iw, s) \<Rightarrow> t" for s t sorry *)
 have "(?iw, s) \<Rightarrow> t" if assm: "(?w, s) \<Rightarrow> t" for s t
proof -
  from assm show ?thesis
  proof cases
    case WhileFalse
    thus ?thesis
      (* using IfFalse Skip  *)
      by blast
      (* ここで `using IfFalse Skip` が必要にったり明示されたりするのを避けるなら、
      declare big_step.intros [intro]
      が必要 *)
  next
    case WhileTrue
    thus ?thesis by blast
  qed
qed
moreover have "(?w, s) \<Rightarrow> t" if assm: "(?iw, s) \<Rightarrow> t" for s t
proof -
  from assm show ?thesis
    proof cases
      case IfFalse
      thus ?thesis by blast
    next
      case IfTrue
      thus ?thesis by blast
    qed
qed
ultimately show ?thesis by blast
qed
(* picking this:
    (WHILE b DO c, ?s) \<Rightarrow> ?t \<Longrightarrow> (IF b THEN c;; WHILE b DO c ELSE SKIP, ?s) \<Rightarrow> ?t
    (IF b THEN c;; WHILE b DO c ELSE SKIP, ?s) \<Rightarrow> ?t \<Longrightarrow> (WHILE b DO c, ?s) \<Rightarrow> ?t
Illegal application of proof command in "chain" mode
多分Whileに関するEliminationRuleを入れていないからかな?
=> `proof -`としていなかったことが原因。
*)

lemma "(c) \<sim> (IF b THEN c ELSE c)" (is "?w \<sim> ?iw")
by blast
(* proof -
 have "(?iw, s) \<Rightarrow> t" if assm: "(?w, s) \<Rightarrow> t" for s t
  proof cases
    case (bval b s)
    then show ?thesis sorry
  next
    case \<not> (bval b s)
    then show ?thesis sorry
  qed
 moreover have "(?w, s) \<Rightarrow> t" if assm: "(?iw, s) \<Rightarrow> t" for s t sorry
 ultimately show ?thesis by blast
qed *)

text\<open>
This induction schema is almost perfect for our purposes, but
our trick for reusing the tuple syntax means that the induction
schema has two parameters instead of the \<open>c\<close>, \<open>s\<close>,
and \<open>s'\<close> that we are likely to encounter. Splitting
the tuple parameter fixes this:
\<close>
lemmas big_step_induct = big_step.induct[split_format(complete)]
thm big_step_induct

lemma sim_while_cong_aux:
  "(WHILE b DO c,s) \<Rightarrow> t  \<Longrightarrow> c \<sim> c' \<Longrightarrow>  (WHILE b DO c',s) \<Rightarrow> t"
apply(induction "WHILE b DO c" s t arbitrary: b c rule: big_step_induct)
apply (simp add: WhileFalse)
apply (simp add: WhileTrue)
done

lemma sim_while_cong: "c \<sim> c' \<Longrightarrow> WHILE b DO c \<sim> WHILE b DO c'"
using sim_while_cong_aux by auto

text \<open>Command equivalence is an equivalence relation, i.e.\ it is
reflexive, symmetric, and transitive. Because we used an abbreviation
above, Isabelle derives this automatically.\<close>

lemma sim_refl:  "c \<sim> c" by simp
lemma sim_sym:   "(c \<sim> c') = (c' \<sim> c)" by auto
lemma sim_trans: "c \<sim> c' \<Longrightarrow> c' \<sim> c'' \<Longrightarrow> c \<sim> c''" by auto

subsubsection "7.2.5 Execution in IMP is Deterministic"

(* determinism. *)
theorem big_step_determ: "\<lbrakk> (c,s) \<Rightarrow> t; (c,s) \<Rightarrow> u \<rbrakk> \<Longrightarrow> u = t"
apply(induction arbitrary: u rule:big_step_induct)
apply(blast+)
done
(* テキストのFig. 7.4. と同じように各ケースを明記してもよいが、全部blastで解決されるため、`blast+`を使う` *)

end