section \<open>Auxiliary Lemmas\<close>
theory ODE_Auxiliarities
imports
  "HOL-Analysis.Analysis"
  "HOL-Library.Float"
  "List-Index.List_Index"
  Affine_Arithmetic.Affine_Arithmetic_Auxiliarities
  Affine_Arithmetic.Executable_Euclidean_Space
begin

instantiation prod :: (zero_neq_one, zero_neq_one) zero_neq_one
begin

definition "1 = (1, 1)"

instance by standard (simp add: zero_prod_def one_prod_def)
end

subsection \<open>there is no inner product for type @{typ "'a \<Rightarrow>\<^sub>L 'b"}\<close>

lemma (in real_inner) parallelogram_law: "(norm (x + y))\<^sup>2 + (norm (x - y))\<^sup>2 = 2 * (norm x)\<^sup>2 + 2 * (norm y)\<^sup>2"
proof -
  have "(norm (x + y))\<^sup>2 + (norm (x - y))\<^sup>2 = inner (x + y) (x + y) + inner (x - y) (x - y)"
    by (simp add: norm_eq_sqrt_inner)
  also have "\<dots> = 2 * (norm x)\<^sup>2 + 2 * (norm y)\<^sup>2"
    by (simp add: algebra_simps norm_eq_sqrt_inner)
  finally show ?thesis .
qed

locale no_real_inner
begin

lift_definition fstzero::"(real*real) \<Rightarrow>\<^sub>L (real*real)" is "\<lambda>(x, y). (x, 0)"
  by (auto intro!: bounded_linearI')

lift_definition zerosnd::"(real*real) \<Rightarrow>\<^sub>L (real*real)" is "\<lambda>(x, y). (0, y)"
  by (auto intro!: bounded_linearI')

lemma [simp]: "zerosnd (a, b) = (0, b)"
  by transfer simp

lemma fstzero_add_zerosnd: "fstzero + zerosnd = id_blinfun"
  by transfer auto

lemma norm_fstzero_zerosnd: "norm fstzero = 1" "norm zerosnd = 1" "norm (fstzero - zerosnd) = 1"
  by (rule norm_blinfun_eqI[where x="(1, 0)"]) (auto simp: norm_Pair blinfun.bilinear_simps
    intro: norm_blinfun_eqI[where x="(0, 1)"] norm_blinfun_eqI[where x="(1, 0)"])

text \<open>compare with @{thm parallelogram_law}\<close>

lemma "(norm (fstzero + zerosnd))\<^sup>2 + (norm (fstzero - zerosnd))\<^sup>2 \<noteq>
    2 * (norm fstzero)\<^sup>2 + 2 * (norm zerosnd)\<^sup>2"
  by (simp add: fstzero_add_zerosnd norm_fstzero_zerosnd)

end

subsection \<open>Topology\<close>

subsection \<open>Vector Spaces\<close>

lemma ex_norm_eq_1: "\<exists>x. norm (x::'a::{real_normed_vector, perfect_space}) = 1"
  by (metis vector_choose_size zero_le_one)

subsection \<open>Reals\<close>

subsection \<open>Balls\<close>

text \<open>sometimes @{thm mem_ball} etc. are not good \<open>[simp]\<close> rules (although they are often useful):
  not sure that inequalities are ``simpler'' than set membership (distorts automatic reasoning
  when only sets are involved)\<close>
lemmas [simp del] = mem_ball mem_cball mem_sphere mem_ball_0 mem_cball_0

subsection \<open>Boundedness\<close>

lemma bounded_subset_cboxE:
  assumes "\<And>i. i \<in> Basis \<Longrightarrow> bounded ((\<lambda>x. x \<bullet> i) ` X)"
  obtains a b where "X \<subseteq> cbox a b"
proof -
  have "\<And>i. i \<in> Basis \<Longrightarrow> \<exists>a b. ((\<lambda>x. x \<bullet> i) ` X) \<subseteq> {a..b}"
    by (metis box_real(2) box_subset_cbox subset_trans bounded_subset_box_symmetric[OF assms] )
  then obtain a b where bnds: "\<And>i. i \<in> Basis \<Longrightarrow> ((\<lambda>x. x \<bullet> i) ` X) \<subseteq> {a i .. b i}"
    by metis
  then have "X \<subseteq> {x. \<forall>i\<in>Basis. x \<bullet> i \<in> {a i .. b i}}"
    by force
  also have "\<dots> = cbox (\<Sum>i\<in>Basis. a i *\<^sub>R i) (\<Sum>i\<in>Basis. b i *\<^sub>R i)"
    by (auto simp: cbox_def)
  finally show ?thesis ..
qed

lemma
  bounded_euclideanI:
  assumes "\<And>i. i \<in> Basis \<Longrightarrow> bounded ((\<lambda>x. x \<bullet> i) ` X)"
  shows "bounded X"
proof -
  from bounded_subset_cboxE[OF assms] obtain a b where "X \<subseteq> cbox a b" .
  with bounded_cbox show ?thesis by (rule bounded_subset)
qed

subsection \<open>Intervals\<close>

notation closed_segment ("(1{_--_})")
notation open_segment ("(1{_<--<_})")

lemma min_zero_mult_nonneg_le: "0 \<le> h' \<Longrightarrow> h' \<le> h \<Longrightarrow> min 0 (h * k::real) \<le> h' * k"
  by (metis dual_order.antisym le_cases min_le_iff_disj mult_eq_0_iff mult_le_0_iff
      mult_right_mono_neg)

lemma max_zero_mult_nonneg_le: "0 \<le> h' \<Longrightarrow> h' \<le> h \<Longrightarrow> h' * k \<le> max 0 (h * k::real)"
  by (metis dual_order.antisym le_cases le_max_iff_disj mult_eq_0_iff mult_right_mono
      zero_le_mult_iff)

lemmas closed_segment_eq_real_ivl = closed_segment_eq_real_ivl

lemma bdd_above_is_intervalI: "bdd_above I" if "is_interval I" "a \<le> b" "a \<in> I" "b \<notin> I" for I::"real set"
  by (meson bdd_above_def is_interval_1 le_cases that)

lemma bdd_below_is_intervalI: "bdd_below I" if "is_interval I" "a \<le> b" "a \<notin> I" "b \<in> I" for I::"real set"
  by (meson bdd_below_def is_interval_1 le_cases that)

subsection \<open>Extended Real Intervals\<close>

subsection \<open>Euclidean Components\<close>

subsection \<open>Operator Norm\<close>

subsection \<open>Limits\<close>

lemma eventually_open_cball:
  assumes "open X"
  assumes "x \<in> X"
  shows "eventually (\<lambda>e. cball x e \<subseteq> X) (at_right 0)"
proof -
  from open_contains_cball_eq[OF assms(1)] assms(2)
  obtain e where "e > 0" "cball x e \<subseteq> X" by auto
  thus ?thesis
    by (auto simp: eventually_at dist_real_def mem_cball intro!: exI[where x=e])
qed

subsection \<open>Continuity\<close>

subsection \<open>Derivatives\<close>

lemma
  if_eventually_has_derivative:
  assumes "(f has_derivative F') (at x within S)"
  assumes "\<forall>\<^sub>F x in at x within S. P x" "P x" "x \<in> S"
  shows "((\<lambda>x. if P x then f x else g x) has_derivative F') (at x within S)"
  using assms(1)
  apply (rule has_derivative_transform_eventually)
  subgoal using assms(2) by eventually_elim auto
  by (auto simp: assms)

lemma norm_le_in_cubeI: "norm x \<le> norm y"
  if "\<And>i. i \<in> Basis \<Longrightarrow> abs (x \<bullet> i) \<le> abs (y \<bullet> i)" for x y
  unfolding norm_eq_sqrt_inner
  apply (subst euclidean_inner)
  apply (subst (3) euclidean_inner)
  using that
  by (auto intro!: sum_mono simp: abs_le_square_iff power2_eq_square[symmetric])

lemma has_derivative_partials_euclidean_convexI:
  fixes f::"'a::euclidean_space \<Rightarrow> 'b::real_normed_vector"
  assumes f': "\<And>i x xi. i \<in> Basis \<Longrightarrow> (\<forall>j\<in>Basis. x \<bullet> j \<in> X j) \<Longrightarrow> xi = x \<bullet> i \<Longrightarrow>
    ((\<lambda>p. f (x + (p - x \<bullet> i) *\<^sub>R i)) has_vector_derivative f' i x) (at xi within X i)"
  assumes df_cont: "\<And>i. i \<in> Basis \<Longrightarrow> (f' i \<longlongrightarrow> (f' i x)) (at x within {x. \<forall>j\<in>Basis. x \<bullet> j \<in> X j})"
  assumes "\<And>i. i \<in> Basis \<Longrightarrow> x \<bullet> i \<in> X i"
  assumes "\<And>i. i \<in> Basis \<Longrightarrow> convex (X i)"
  shows "(f has_derivative (\<lambda>h. \<Sum>j\<in>Basis. (h \<bullet> j) *\<^sub>R f' j x)) (at x within {x. \<forall>j\<in>Basis. x \<bullet> j \<in> X j})"
    (is "_ (at x within ?S)")
proof (rule has_derivativeI)
  show "bounded_linear (\<lambda>h. \<Sum>j\<in>Basis. (h \<bullet> j) *\<^sub>R f' j x)"
    by (auto intro!: bounded_linear_intros)

  obtain E where [simp]: "set E = (Basis::'a set)" "distinct E"
    using finite_distinct_list[OF finite_Basis] by blast

  have [simp]: "length E = DIM('a)"
    using \<open>distinct E\<close> distinct_card by fastforce
  have [simp]: "E ! j \<in> Basis" if "j < DIM('a)" for j
    by (metis \<open>length E = DIM('a)\<close> \<open>set E = Basis\<close> nth_mem that)
  have "convex ?S"
    by (rule convex_prod) (use assms in auto)

  have sum_Basis_E: "sum g Basis = (\<Sum>j<DIM('a). g (E ! j))" for g
    apply (rule sum.reindex_cong[OF _ _ refl])
    apply (auto simp: inj_on_nth)
    by (metis \<open>distinct E\<close> \<open>length E = DIM('a)\<close> \<open>set E = Basis\<close> bij_betw_def bij_betw_nth)

  have segment: "\<forall>\<^sub>F x' in at x within ?S. x' \<in> ?S" "\<forall>\<^sub>F x' in at x within ?S. x' \<noteq> x"
    unfolding eventually_at_filter by auto

  show "((\<lambda>y. (f y - f x - (\<Sum>j\<in>Basis. ((y - x) \<bullet> j) *\<^sub>R f' j x)) /\<^sub>R norm (y - x)) \<longlongrightarrow> 0) (at x within {x. \<forall>j\<in>Basis. x \<bullet> j \<in> X j})"
    apply (rule tendstoI)
    unfolding norm_conv_dist[symmetric]
  proof -
    fix e::real
    assume "e > 0"
    define B where "B = e / norm (2*DIM('a) + 1)"
    with \<open>e > 0\<close> have B_thms: "B > 0" "2 * DIM('a) * B < e" "B \<ge> 0"
      by (auto simp: divide_simps algebra_simps B_def)
    define B' where "B' = B / 2"
    have "B' > 0" by (simp add: B'_def \<open>0 < B\<close>)
    have "\<forall>i \<in> Basis. \<forall>\<^sub>F xa in at x within {x. \<forall>j\<in>Basis. x \<bullet> j \<in> X j}. dist (f' i xa) (f' i x) < B'"
      apply (rule ballI)
      subgoal premises prems using df_cont[OF prems, THEN tendstoD, OF \<open>0 < B'\<close>] .
      done
    from eventually_ball_finite[OF finite_Basis this]
    have "\<forall>\<^sub>F x' in at x within {x. \<forall>j\<in>Basis. x \<bullet> j \<in> X j}. \<forall>j\<in>Basis. dist (f' j x') (f' j x) < B'" .
    then obtain d where "d > 0"
      and "\<And>x' j. x' \<in> {x. \<forall>j\<in>Basis. x \<bullet> j \<in> X j} \<Longrightarrow> x' \<noteq> x \<Longrightarrow> dist x' x < d \<Longrightarrow> j \<in> Basis \<Longrightarrow> dist (f' j x') (f' j x) < B'"
      using \<open>0 < B'\<close>
      by (auto simp: eventually_at)
    then have B': "x' \<in> {x. \<forall>j\<in>Basis. x \<bullet> j \<in> X j} \<Longrightarrow> dist x' x < d \<Longrightarrow> j \<in> Basis \<Longrightarrow> dist (f' j x') (f' j x) < B'" for x' j
      by (cases "x' = x", auto simp add: \<open>0 < B'\<close>)
    then have B: "norm (f' j x' - f' j y) < B" if
      "(\<And>j. j \<in> Basis \<Longrightarrow> x' \<bullet> j \<in> X j)"
      "(\<And>j. j \<in> Basis \<Longrightarrow> y \<bullet> j \<in> X j)"
      "dist x' x < d"
      "dist y x < d"
      "j \<in> Basis"
      for x' y j
    proof -
      have "dist (f' j x') (f' j x) < B'" "dist (f' j y) (f' j x) < B'"
        using that
        by (auto intro!: B')
      then have "dist (f' j x') (f' j y) < B' + B'" by norm
      also have "\<dots> = B" by (simp add: B'_def)
      finally show ?thesis by (simp add: dist_norm)
    qed
    have "\<forall>\<^sub>F x' in at x within {x. \<forall>j\<in>Basis. x \<bullet> j \<in> X j}. dist x' x < d"
      by (rule tendstoD[OF tendsto_ident_at \<open>d > 0\<close>])
    with segment
    show "\<forall>\<^sub>F x' in at x within {x. \<forall>j\<in>Basis. x \<bullet> j \<in> X j}.
      norm ((f x' - f x - (\<Sum>j\<in>Basis. ((x' - x) \<bullet> j) *\<^sub>R f' j x)) /\<^sub>R norm (x' - x)) < e"
    proof eventually_elim
      case (elim x')
      then have os_subset: "open_segment x x' \<subseteq> ?S"
        using \<open>convex ?S\<close> assms(3)
        unfolding convex_contains_open_segment
        by auto
      then have cs_subset: "closed_segment x x' \<subseteq> ?S"
        using elim assms(3) by (auto simp add: open_segment_def)
      have csc_subset: "closed_segment (x' \<bullet> i) (x \<bullet> i) \<subseteq> X i" if i: "i \<in> Basis" for i
        apply (rule closed_segment_subset)
        using cs_subset elim assms(3,4) that
        by (auto )
      have osc_subset: "open_segment (x' \<bullet> i) (x \<bullet> i) \<subseteq> X i" if i: "i \<in> Basis" for i
        using segment_open_subset_closed csc_subset[OF i]
        by (rule order_trans)

      define h where "h = x' - x"
      define z where "z j = (\<Sum>k<j. (h \<bullet> E ! k) *\<^sub>R (E ! k))" for j
      define g where "g j t = (f (x + z j + (t - x \<bullet> E ! j) *\<^sub>R E ! j))" for j t
      have z: "z j \<bullet> E ! j = 0" if "j < DIM('a)" for j
        using that
        by (auto simp: z_def h_def algebra_simps inner_sum_left inner_Basis if_distrib
            nth_eq_iff_index_eq
            sum.delta
            intro!: euclidean_eqI[where 'a='a]
            cong: if_cong)
      from distinct_Ex1[OF \<open>distinct E\<close>, unfolded \<open>set E = Basis\<close> Ex1_def \<open>length E = _\<close>]
      obtain index where
        index: "\<And>i. i \<in> Basis \<Longrightarrow> i = E ! index i" "\<And>i. i \<in> Basis \<Longrightarrow> index i < DIM('a)"
        and unique: "\<And>i j. i \<in> Basis \<Longrightarrow> j < DIM('a) \<Longrightarrow> E ! j = i \<Longrightarrow> j = index i"
        by metis
      have nth_eq_iff_index: "E ! k = i \<longleftrightarrow> index i = k" if "i \<in> Basis" "k < DIM('a)" for k i
        using unique[OF that] index[OF \<open>i \<in> Basis\<close>]
        by auto
      have z_inner: "z j \<bullet> i = (if j \<le> index i then 0 else h \<bullet> i)" if "j < DIM('a)" "i \<in> Basis" for j i
        using that index[of i]
        by (auto simp: z_def h_def algebra_simps inner_sum_left inner_Basis if_distrib
            sum.delta nth_eq_iff_index
            intro!: euclidean_eqI[where 'a='a]
            cong: if_cong)
      have z_mem: "j < DIM('a) \<Longrightarrow> ja \<in> Basis \<Longrightarrow> x \<bullet> ja + z j \<bullet> ja \<in> X ja" for j ja
        using csc_subset
        by (auto simp: z_inner h_def algebra_simps)
      have "norm (x' - x) < d"
        using elim by (simp add: dist_norm)
      have norm_z': "y \<in> closed_segment (x \<bullet> E ! j) (x' \<bullet> E ! j) \<Longrightarrow> norm (z j + y *\<^sub>R E ! j - (x \<bullet> E ! j) *\<^sub>R E ! j) < d"
        if "j < DIM('a)"
        for j y
        apply (rule le_less_trans[OF _ \<open>norm (x' - x) < d\<close>])
        apply (rule norm_le_in_cubeI)
        apply (auto simp: inner_diff_left inner_add_left inner_Basis that z)
        subgoal by (auto simp: closed_segment_eq_real_ivl split: if_splits)
        subgoal for i
          using that
          by (auto simp: z_inner h_def algebra_simps)
        done
      have norm_z: "norm (z j) < d" if "j < DIM('a)" for j
        using norm_z'[OF that ends_in_segment(1)]
        by (auto simp: z_def)
      {
        fix j
        assume j: "j < DIM('a)"
        have eq: "(x + z j + ((y - (x + z j)) \<bullet> E ! j) *\<^sub>R E ! j +
          (p - (x + z j + ((y - (x + z j)) \<bullet> E ! j) *\<^sub>R E ! j) \<bullet> E ! j) *\<^sub>R
          E ! j) = (x + z j + (p - (x \<bullet> E ! j)) *\<^sub>R E ! j)" for y p
          by (auto simp: algebra_simps j z)
        have f_has_derivative: "((\<lambda>p. f (x + z j + (p - x \<bullet> E ! j) *\<^sub>R E ! j)) has_derivative (\<lambda>xa. xa *\<^sub>R f' (E ! j) (x + z j + ((y *\<^sub>R E ! j - (x + z j)) \<bullet> E ! j) *\<^sub>R E ! j)))
            (at y within closed_segment (x \<bullet> E ! j) (x' \<bullet> E ! j))"
          if "y \<in> closed_segment (x \<bullet> E ! j) (x' \<bullet> E ! j)"
          for y
          apply (rule has_derivative_within_subset)
           apply (rule f'[unfolded has_vector_derivative_def,
                where x= "x + z j + ((y *\<^sub>R E!j - (x + z j))\<bullet> E!j) *\<^sub>R E ! j" and i="E ! j", unfolded eq])
          subgoal by (simp add: j)
          subgoal
            using that
            apply (auto simp: algebra_simps z j inner_Basis)
            using closed_segment_commute \<open>E ! j \<in> Basis\<close> csc_subset apply blast
            by (simp add: z_mem j)
          subgoal by (auto simp: algebra_simps z j inner_Basis)
          subgoal
            apply (auto simp: algebra_simps z j inner_Basis)
            using closed_segment_commute \<open>\<And>j. j < DIM('a) \<Longrightarrow> E ! j \<in> Basis\<close> csc_subset j apply blast
            done
          done
        have *: "((xa *\<^sub>R E ! j - (x + z j)) \<bullet> E ! j) = xa - x \<bullet> E ! j" for xa
          by (auto simp: algebra_simps z j)
        have g': "(g j has_vector_derivative (f' (E ! j) (x + z j + (xa - x \<bullet> E ! j) *\<^sub>R E ! j)))
          (at xa within (closed_segment (x\<bullet>E!j) (x'\<bullet>E!j)))"
          (is "(_ has_vector_derivative ?g' j xa) _")
          if "xa \<in> closed_segment (x\<bullet>E!j) (x'\<bullet>E!j)" for xa
          using that
          by (auto simp: has_vector_derivative_def g_def[abs_def] *
              intro!: derivative_eq_intros f_has_derivative[THEN has_derivative_eq_rhs])
        define g' where "g' j = ?g' j" for j
        with g' have g': "(g j has_vector_derivative g' j t) (at t within closed_segment (x\<bullet>E!j) (x'\<bullet>E!j))"
          if "t \<in> closed_segment (x\<bullet>E!j) (x'\<bullet>E!j)"
          for t
          by (simp add: that)
        have cont_bound: "\<And>y. y\<in>closed_segment (x \<bullet> E ! j) (x' \<bullet> E ! j) \<Longrightarrow> norm (g' j y - g' j (x \<bullet> E ! j)) \<le> B"
          apply (auto simp add: g'_def j algebra_simps inner_Basis z dist_norm
              intro!: less_imp_le B z_mem norm_z norm_z')
          using closed_segment_commute \<open>\<And>j. j < DIM('a) \<Longrightarrow> E ! j \<in> Basis\<close> csc_subset j apply blast
          done
        from vector_differentiable_bound_linearization[OF g' order_refl cont_bound ends_in_segment(1)]
        have n: "norm (g j (x' \<bullet> E ! j) - g j (x \<bullet> E ! j) - (x' \<bullet> E ! j - x \<bullet> E ! j) *\<^sub>R g' j (x \<bullet> E ! j)) \<le> norm (x' \<bullet> E ! j - x \<bullet> E ! j) * B"
          .
        have "z (Suc j) = z j + (x' \<bullet> E ! j - x \<bullet> E ! j) *\<^sub>R E ! j"
          by (auto simp: z_def h_def algebra_simps)
        then have "f (x + z (Suc j)) = f (x + z j + (x' \<bullet> E ! j - x \<bullet> E ! j) *\<^sub>R E ! j) "
          by (simp add: ac_simps)
        with n have "norm (f (x + z (Suc j)) - f (x + z j) - (x' \<bullet> E ! j - x \<bullet> E ! j) *\<^sub>R f' (E ! j) (x + z j)) \<le> \<bar>x' \<bullet> E ! j - x \<bullet> E ! j\<bar> * B"
          by (simp add: g_def g'_def)
      } note B_le = this
      have B': "norm (f' (E ! j) (x + z j) - f' (E ! j) x) \<le> B" if "j < DIM('a)" for j
        using that assms(3)
        by (auto simp add: algebra_simps inner_Basis z dist_norm \<open>0 < d\<close>
            intro!: less_imp_le B z_mem norm_z)
      have "(\<Sum>j\<le>DIM('a) - 1. f (x + z j) - f (x + z (Suc j))) = f (x + z 0) - f (x + z (Suc (DIM('a) - 1)))"
        by (rule sum_telescope)
      moreover have "z DIM('a) = h"
        using index
        by (auto simp: z_def h_def algebra_simps inner_sum_left inner_Basis if_distrib
            nth_eq_iff_index
            sum.delta
            intro!: euclidean_eqI[where 'a='a]
            cong: if_cong)
      moreover have "z 0 = 0"
        by (auto simp: z_def)
      moreover have "{..DIM('a) - 1} = {..<DIM('a)}"
        using le_imp_less_Suc by fastforce
      ultimately have "f x - f (x + h) = (\<Sum>j<DIM('a). f (x + z j) - f (x + z (Suc j)))"
        by (auto simp: )
      then have "norm (f (x + h) - f x - (\<Sum>j\<in>Basis. ((x' - x) \<bullet> j) *\<^sub>R f' j x)) =
        norm(
          (\<Sum>j<DIM('a). f (x + z (Suc j)) - f (x + z j) - (x' \<bullet> E ! j - x \<bullet> E ! j) *\<^sub>R f' (E ! j) (x + z j)) +
          (\<Sum>j<DIM('a). (x' \<bullet> E ! j - x \<bullet> E ! j) *\<^sub>R (f' (E ! j) (x + z j) - f' (E ! j) x)))"
        (is "_ = norm (sum ?a ?E + sum ?b ?E)")
        by (intro arg_cong[where f=norm]) (simp add: sum_negf sum_subtractf sum.distrib algebra_simps sum_Basis_E)
      also have "\<dots> \<le> norm (sum ?a ?E) + norm (sum ?b ?E)" by (norm)
      also have "norm (sum ?a ?E) \<le> sum (\<lambda>x. norm (?a x)) ?E"
        by (rule norm_sum)
      also have "\<dots> \<le> sum (\<lambda>j. norm \<bar>x' \<bullet> E ! j - x \<bullet> E ! j\<bar> * B) ?E"
        by (auto intro!: sum_mono B_le)
      also have "\<dots> \<le> sum (\<lambda>j. norm (x' - x) * B) ?E"
        apply (rule sum_mono)
        apply (auto intro!: mult_right_mono \<open>0 \<le> B\<close>)
        by (metis (full_types) \<open>\<And>j. j < DIM('a) \<Longrightarrow> E ! j \<in> Basis\<close> inner_diff_left norm_bound_Basis_le order_refl)
      also have "\<dots> = norm (x' - x) * DIM('a) * B"
        by simp
      also have "norm (sum ?b ?E) \<le> sum (\<lambda>x. norm (?b x)) ?E"
        by (rule norm_sum)
      also have "\<dots> \<le> sum (\<lambda>j. norm (x' - x) * B) ?E"
        apply (intro sum_mono)
        apply (auto intro!: mult_mono B')
         apply (metis (full_types) \<open>\<And>j. j < DIM('a) \<Longrightarrow> E ! j \<in> Basis\<close> inner_diff_left norm_bound_Basis_le order_refl)
        done
      also have "\<dots> = norm (x' - x) * DIM('a) * B"
        by simp
      finally have "norm (f (x + h) - f x - (\<Sum>j\<in>Basis. ((x' - x) \<bullet> j) *\<^sub>R f' j x)) \<le>
          norm (x' - x) * real DIM('a) * B + norm (x' - x) * real DIM('a) * B"
        by arith
      also have "\<dots> /\<^sub>R norm (x' - x) \<le> norm (2 * DIM('a) * B)"
        using \<open>B \<ge> 0\<close>
        by (simp add: divide_simps abs_mult)
      also have "\<dots> < e" using B_thms by simp
      finally show ?case by (auto simp: divide_simps abs_mult h_def)
    qed
  qed
qed

lemma
  frechet_derivative_equals_partial_derivative:
  fixes f::"'a::euclidean_space \<Rightarrow> 'a"
  assumes Df: "\<And>x. (f has_derivative Df x) (at x)"
  assumes f': "((\<lambda>p. f (x + (p - x \<bullet> i) *\<^sub>R i) \<bullet> b) has_real_derivative f' x i b) (at (x \<bullet> i))"
  shows "Df x i \<bullet> b = f' x i b"
proof -
  define Dfb where "Dfb x = Blinfun (Df x)" for x
  have Dfb_apply: "blinfun_apply (Dfb x) = Df x" for x
    unfolding Dfb_def
    apply (rule bounded_linear_Blinfun_apply)
    apply (rule has_derivative_bounded_linear)
    apply (rule assms)
    done
  have "Dfb x = blinfun_of_matrix (\<lambda>i b. Dfb x b \<bullet> i)" for x
    using blinfun_of_matrix_works[of "Dfb x"] by auto
  have Dfb: "\<And>x. (f has_derivative Dfb x) (at x)"
    by (auto simp: Dfb_apply Df)
  note [derivative_intros] = diff_chain_at[OF _ Dfb, unfolded o_def]
  have "((\<lambda>p. f (x + (p - x \<bullet> i) *\<^sub>R i) \<bullet> b) has_real_derivative Dfb x i \<bullet> b) (at (x \<bullet> i))"
    by (auto intro!: derivative_eq_intros ext simp: has_field_derivative_def blinfun.bilinear_simps)
  from DERIV_unique[OF f' this]
  show ?thesis by (simp add: Dfb_apply)
qed

subsection \<open>Integration\<close>

lemmas content_real[simp]
lemmas integrable_continuous[intro, simp]
  and integrable_continuous_real[intro, simp]

lemma integral_eucl_le:
  fixes f g::"'a::euclidean_space \<Rightarrow> 'b::ordered_euclidean_space"
  assumes "f integrable_on s"
    and "g integrable_on s"
    and "\<And>x. x \<in> s \<Longrightarrow> f x \<le> g x"
  shows "integral s f \<le> integral s g"
  using assms
  by (auto intro!: integral_component_le simp: eucl_le[where 'a='b])

lemma
  integral_ivl_bound:
  fixes l u::"'a::ordered_euclidean_space"
  assumes "\<And>x h'. h' \<in> {t0 .. h} \<Longrightarrow> x \<in> {t0 .. h} \<Longrightarrow> (h' - t0) *\<^sub>R f x \<in> {l .. u}"
  assumes "t0 \<le> h"
  assumes f_int: "f integrable_on {t0 .. h}"
  shows "integral {t0 .. h} f \<in> {l .. u}"
proof -
  from assms(1)[of t0 t0] assms(2) have "0 \<in> {l .. u}" by auto
  have "integral {t0 .. h} f = integral {t0 .. h} (\<lambda>t. if t \<in> {t0, h} then 0 else f t)"
    by (rule integral_spike[where S="{t0, h}"]) auto
  also
  {
    fix x
    assume 1: "x \<in> {t0 <..< h}"
    with assms have "(h - t0) *\<^sub>R f x \<in> {l .. u}" by auto
    then have "(if x \<in> {t0, h} then 0 else f x) \<in> {l /\<^sub>R (h - t0) .. u /\<^sub>R (h - t0)}"
      using \<open>x \<in> _\<close>
      by (auto simp: inverse_eq_divide
        simp: eucl_le[where 'a='a] field_simps algebra_simps)
  }
  then have "\<dots> \<in> {integral {t0..h} (\<lambda>_. l /\<^sub>R (h - t0)) .. integral {t0..h} (\<lambda>_. u /\<^sub>R (h - t0))}"
    unfolding atLeastAtMost_iff
    apply (safe intro!: integral_eucl_le)
    using \<open>0 \<in> {l .. u}\<close>
    apply (auto intro!: assms
      intro: integrable_continuous_real  integrable_spike[where S="{t0, h}", OF f_int]
      simp: eucl_le[where 'a='a] divide_simps
      split: if_split_asm)
    done
  also have "\<dots> \<subseteq> {l .. u}"
    using assms \<open>0 \<in> {l .. u}\<close>
    by (auto simp: inverse_eq_divide)
  finally show ?thesis .
qed

lemma
  add_integral_ivl_bound:
  fixes l u::"'a::ordered_euclidean_space"
  assumes "\<And>x h'. h' \<in> {t0 .. h} \<Longrightarrow> x \<in> {t0 .. h} \<Longrightarrow> (h' - t0) *\<^sub>R f x \<in> {l - x0 .. u - x0}"
  assumes "t0 \<le> h"
  assumes f_int: "f integrable_on {t0 .. h}"
  shows "x0 + integral {t0 .. h} f \<in> {l .. u}"
  using integral_ivl_bound[OF assms]
  by (auto simp: algebra_simps)

subsection \<open>conditionally complete lattice\<close>

subsection \<open>Lists\<close>

lemma
  Ball_set_Cons[simp]: "(\<forall>a\<in>set_Cons x y. P a) \<longleftrightarrow> (\<forall>a\<in>x. \<forall>b\<in>y. P (a#b))"
  by (auto simp: set_Cons_def)

lemma set_cons_eq_empty[iff]: "set_Cons a b = {} \<longleftrightarrow> a = {} \<or> b = {}"
  by (auto simp: set_Cons_def)

lemma listset_eq_empty_iff[iff]: "listset XS = {} \<longleftrightarrow> {} \<in> set XS"
  by (induction XS) auto

lemma sing_in_sings[simp]: "[x] \<in> (\<lambda>x. [x]) ` xd \<longleftrightarrow> x \<in> xd"
  by auto

lemma those_eq_Some_lengthD: "those xs = Some ys \<Longrightarrow> length xs = length ys"
  by (induction xs arbitrary: ys) (auto split: option.splits)

lemma those_eq_Some_map_Some_iff: "those xs = Some ys \<longleftrightarrow> (xs = map Some ys)" (is "?l \<longleftrightarrow> ?r")
proof safe
  assume ?l
  then have "length xs = length ys"
    by (rule those_eq_Some_lengthD)
  then show ?r using \<open>?l\<close>
    by (induction xs ys rule: list_induct2) (auto split: option.splits)
next
  assume ?r
  then have "length xs = length ys"
    by simp
  then show "those (map Some ys) = Some ys" using \<open>?r\<close>
    by (induction xs ys rule: list_induct2) (auto split: option.splits)
qed

subsection \<open>Set(sum)\<close>

subsection \<open>Max\<close>

subsection \<open>Uniform Limit\<close>

subsection \<open>Bounded Linear Functions\<close>

lift_definition comp3::\<comment> \<open>TODO: name?\<close>
  "('c::real_normed_vector \<Rightarrow>\<^sub>L 'd::real_normed_vector) \<Rightarrow> ('b::real_normed_vector \<Rightarrow>\<^sub>L 'c) \<Rightarrow>\<^sub>L 'b \<Rightarrow>\<^sub>L 'd" is
  "\<lambda>(cd::('c \<Rightarrow>\<^sub>L 'd)) (bc::'b \<Rightarrow>\<^sub>L 'c). (cd o\<^sub>L bc)"
  by (rule bounded_bilinear.bounded_linear_right[OF bounded_bilinear_blinfun_compose])

lemma blinfun_apply_comp3[simp]: "blinfun_apply (comp3 a) b = (a o\<^sub>L b)"
  by (simp add: comp3.rep_eq)

lemma bounded_linear_comp3[bounded_linear]: "bounded_linear comp3"
  by transfer (rule bounded_bilinear_blinfun_compose)

lift_definition comp12::\<comment> \<open>TODO: name?\<close>
  "('a::real_normed_vector \<Rightarrow>\<^sub>L 'c::real_normed_vector) \<Rightarrow> ('b::real_normed_vector \<Rightarrow>\<^sub>L 'c) \<Rightarrow> ('a \<times> 'b) \<Rightarrow>\<^sub>L 'c"
  is "\<lambda>f g (a, b). f a + g b"
  by (auto intro!: bounded_linear_intros
    intro: bounded_linear_compose
    simp: split_beta')

lemma blinfun_apply_comp12[simp]: "blinfun_apply (comp12 f g) b = f (fst b) + g (snd b)"
  by (simp add: comp12.rep_eq split_beta)

subsection \<open>Order Transitivity Attributes\<close>

attribute_setup le = \<open>Scan.succeed (Thm.rule_attribute [] (fn context => fn thm => thm RS @{thm order_trans}))\<close>
  "transitive version of inequality (useful for intro)"
attribute_setup ge = \<open>Scan.succeed (Thm.rule_attribute [] (fn context => fn thm => thm RS @{thm order_trans[rotated]}))\<close>
  "transitive version of inequality (useful for intro)"

subsection \<open>point reflection\<close>

definition preflect::"'a::real_vector \<Rightarrow> 'a \<Rightarrow> 'a" where "preflect \<equiv> \<lambda>t0 t. 2 *\<^sub>R t0 - t"

lemma preflect_preflect[simp]: "preflect t0 (preflect t0 t) = t"
  by (simp add: preflect_def algebra_simps)

lemma preflect_preflect_image[simp]: "preflect t0 ` preflect t0 ` S = S"
  by (simp add: image_image)

lemma is_interval_preflect[simp]: "is_interval (preflect t0 ` S) \<longleftrightarrow> is_interval S"
  by (auto simp: preflect_def[abs_def])

lemma iv_in_preflect_image[intro, simp]: "t0 \<in> T \<Longrightarrow> t0 \<in> preflect t0 ` T"
  by (auto intro!: image_eqI simp: preflect_def algebra_simps scaleR_2)

lemma preflect_tendsto[tendsto_intros]:
  fixes l::"'a::real_normed_vector"
  shows "(g \<longlongrightarrow> l) F \<Longrightarrow> (h \<longlongrightarrow> m) F \<Longrightarrow> ((\<lambda>x. preflect (g x) (h x)) \<longlongrightarrow> preflect l m) F"
  by (auto intro!: tendsto_eq_intros simp: preflect_def)

lemma continuous_preflect[continuous_intros]:
  fixes a::"'a::real_normed_vector"
  shows "continuous (at a within A) (preflect t0)"
  by (auto simp: continuous_within intro!: tendsto_intros)

lemma
  fixes t0::"'a::ordered_real_vector"
  shows preflect_le[simp]: "t0 \<le> preflect t0 b \<longleftrightarrow> b \<le> t0"
    and le_preflect[simp]: "preflect t0 b \<le> t0 \<longleftrightarrow> t0 \<le> b"
    and antimono_preflect: "antimono (preflect t0)"
    and preflect_le_preflect[simp]: "preflect t0 a \<le> preflect t0 b \<longleftrightarrow> b \<le> a"
    and preflect_eq_cancel[simp]: "preflect t0 a = preflect t0 b \<longleftrightarrow> a = b"
  by (auto intro!: antimonoI simp: preflect_def scaleR_2)

lemma preflect_eq_point_iff[simp]: "t0 = preflect t0 s \<longleftrightarrow> t0 = s" "preflect t0 s = t0 \<longleftrightarrow> t0 = s"
  by (auto simp: preflect_def algebra_simps scaleR_2)

lemma preflect_minus_self[simp]: "preflect t0 s - t0 = t0 - s"
  by (simp add: preflect_def scaleR_2)

end


(*
 * Copyright 2019, NTU
 *
 * This software may be distributed and modified according to the terms of
 * the BSD 2-Clause license. Note that NO WARRANTY is provided.
 * See "LICENSE_BSD2.txt" for details.
 *
 *  Author: Albert Rizaldi, NTU Singapore
 *)

theory Signed_Add_Trans_Typed
  imports VHDL_Hoare_Typed Bits_Int_Aux
begin

datatype sig = A | B | C

definition add :: "sig conc_stmt" where
  "add \<equiv> process {A, B} : Bassign_trans C (Badd (Bsig A) (Bsig B)) 1"

locale signed_addition =
  fixes \<Gamma> :: "sig tyenv"
  fixes len len1 len2 :: nat
  assumes len_def: "len = max len1 len2"
  assumes atype: "\<Gamma> A = Lty Sig len1" and btype: "\<Gamma> B = Lty Sig len2" and ctype: "\<Gamma> C = Lty Sig len"
  assumes len1: "0 < len1" and len2: "0 < len2"
begin

lemma well_typed:
  "seq_wt \<Gamma> (Bassign_trans C (Badd (Bsig A) (Bsig B)) 1)"
  by (metis atype bexp_wt.intros(16) bexp_wt.intros(3) btype ctype len1 len2 len_def
  seq_wt.intros(4))

abbreviation "lof_wline tw sig n \<equiv> lval_of (wline_of tw sig n)"

text \<open>Here we factor out common expression in both inv1 and inv2. It is parametrised by the index
we are interested with for C (first argument) and A (the second argument). Note that the index
we are interested with for A should be the same as the index for B.\<close>

definition inv :: "sig assn2" where
  "inv tw \<equiv> (lof_wline tw C (fst tw) = bin_to_bl len (sbl_to_bin (lof_wline tw A (fst tw - 1)) + sbl_to_bin (lof_wline tw B (fst tw - 1))))"

definition inv2 :: "sig assn2" where
  "inv2 tw \<equiv> (disjnt {A, B} (event_of tw) \<longrightarrow> (\<forall>i > fst tw. lof_wline tw C i = lof_wline tw C (fst tw)))"

lemma inv_next_time:
  fixes tw
  defines "v \<equiv> eval_world_raw2 tw (Badd (Bsig A) (Bsig B))"
  defines "tw' \<equiv> tw[C, 1 :=\<^sub>2 v]"
  assumes "wityping \<Gamma> (snd tw)"
  shows   "inv (fst tw' + 1, snd tw')"
proof -
  have bexpA: "bexp_wt \<Gamma> (Bsig A) (Lty Sig len1)" and bexpB: "bexp_wt \<Gamma> (Bsig B) (Lty Sig len2)"
    using signed_addition_axioms unfolding signed_addition_def by (metis bexp_wt.intros(3))+
  obtain bsA bsB where evalA: "eval_world_raw (fst tw) (snd tw) (Bsig A) = Lv Sig bsA" and" length bsA = len1 " and
                       evalB: "eval_world_raw (fst tw) (snd tw) (Bsig B) = Lv Sig bsB" and" length bsB = len2 "
      using eval_world_raw_lv[OF bexpA `wityping \<Gamma> (snd tw)`] eval_world_raw_lv[OF bexpB `wityping \<Gamma> (snd tw)`] by blast
  have "lof_wline tw' C (fst tw + 1) = lval_of v"
    unfolding tw'_def worldline_upd2_def worldline_upd_def by auto
  also have "... = bin_to_bl len (sbl_to_bin (lof_wline tw A (fst tw)) + sbl_to_bin (lof_wline tw B (fst tw)))"
    using evalA evalB `length bsA = len1` `length bsB = len2`
    unfolding v_def eval_world_raw.simps eval_arith.simps len_def Let_def by auto
  finally show ?thesis
    unfolding inv_def tw'_def worldline_upd2_def worldline_upd_def  by auto
qed

lemma inv2_next_time:
  fixes tw v
  defines "tw' \<equiv> tw[C, 1 :=\<^sub>2 v]"
  shows   "inv2 (fst tw' + 1, snd tw')"
  unfolding inv2_def tw'_def worldline_upd2_def worldline_upd_def by auto

lemma add_conc_hoare:
  "\<And>tw. inv tw \<and> inv2 tw \<and> disjnt {A, B} (event_of tw) \<Longrightarrow> inv (fst tw + 1, snd tw)"
proof -
  fix tw
  assume "inv tw \<and> inv2 tw \<and> disjnt {A, B} (event_of tw)"
  hence "inv tw" and "inv2 tw" and "disjnt {A, B} (event_of tw)"
    by auto
  have "lof_wline tw C (fst tw + 1) = lof_wline tw C (fst tw)"
    using `inv2 tw` `disjnt {A, B} (event_of tw)` unfolding inv2_def by auto
  also have "... = bin_to_bl len (sbl_to_bin (lval_of (wline_of tw A (get_time tw - 1))) + sbl_to_bin (lval_of (wline_of tw B (get_time tw - 1))))"
    using `inv tw` unfolding inv_def by auto
  also have "... = bin_to_bl len (sbl_to_bin (lval_of (wline_of tw A (fst tw))) + sbl_to_bin (lval_of (wline_of tw B (fst tw))))"
    using `disjnt {A, B} (event_of tw)`  unfolding event_of_alt_def
    by (smt diff_0_eq_0 disjnt_insert1 mem_Collect_eq)
  finally show "inv (fst tw + 1, snd tw)"
    unfolding inv_def by auto
qed

lemma add_conc_hoare2:
  "\<And>tw. inv2 tw \<and> disjnt {A, B} (event_of tw) \<Longrightarrow> inv2 (fst tw + 1, snd tw)"
  unfolding inv2_def by auto

lemma conc_stmt_wf_add:
  "conc_stmt_wf add"
  unfolding add_def conc_stmt_wf_def by auto

lemma nonneg_delay_conc_add:
  "nonneg_delay_conc add"
  unfolding add_def by auto

lemma nonneg_delay_conc_add':
  "nonneg_delay_conc ( process {A, B} : Bassign_trans C (Badd (Bsig A) (Bsig B)) 1)"
  using nonneg_delay_conc_add unfolding add_def by auto

lemma conc_wt_add:
  "conc_wt \<Gamma> add"
  unfolding add_def  by (meson conc_wt.intros(1) well_typed)

lemma conc_wt_add':
  "conc_wt \<Gamma> ( process {A, B} : Bassign_trans C (Badd (Bsig A) (Bsig B)) 1)"
  using conc_wt_add unfolding add_def by auto

lemma add_conc_sim2':
  "\<Gamma> \<turnstile>\<^sub>s \<lbrace>\<lambda>tw. inv tw \<and> inv2 tw\<rbrace> add \<lbrace>\<lambda>tw. inv tw \<and> inv2 tw\<rbrace>"
  apply (rule While_Suc)
  apply (rule Conseq'[where P="wp3_conc \<Gamma> add (\<lambda>tw. inv  (fst tw + 1, snd tw) \<and>
                                                      inv2 (fst tw + 1, snd tw))", rotated])
  apply (rule wp3_conc_is_pre, rule conc_stmt_wf_add, rule nonneg_delay_conc_add, rule conc_wt_add, simp)
  unfolding add_def  wp3_conc_single'[OF conc_wt_add' nonneg_delay_conc_add'] wp3_fun.simps
  using inv_next_time inv2_next_time add_conc_hoare add_conc_hoare2 by presburger

text \<open>Initialisation preserves the invariant\<close>

lemma nonneg_delay_add:
  " nonneg_delay (Bassign_trans C (Badd (Bsig A) (Bsig B)) 1)"
  using nonneg_delay_conc_add' by auto

lemma init_sat_nand_inv_comb:
  "init_sim2_hoare_wt \<Gamma> (\<lambda>tw. fst tw = 0) add (\<lambda>tw. inv tw \<and> inv2 tw)"
  unfolding add_def
  apply (rule AssignI_suc, rule SingleI)
  apply (rule Conseq3[where Q="\<lambda>tw. inv (fst tw + 1, snd tw) \<and> inv2 (fst tw + 1, snd tw)", rotated])
  apply (rule wp3_fun_is_pre[OF well_typed nonneg_delay_add], simp)
  unfolding wp3_fun.simps using inv_next_time inv2_next_time by blast

lemma correctness:
  assumes "sim_fin2 w (i + 1) add tw'" and "wityping \<Gamma> w"
  shows "lof_wline tw' C (i + 1) = bin_to_bl len (sbl_to_bin (lof_wline tw' A i) + sbl_to_bin (lof_wline tw' B i))"
  using grand_correctness[OF assms conc_stmt_wf_add conc_wt_add nonneg_delay_conc_add add_conc_sim2' init_sat_nand_inv_comb]
  unfolding add_def inv_def by (metis (no_types, lifting) add_diff_cancel_right' assms(1)
  sim_fin2.cases world_maxtime_lt_fst_tres)
end

end


theory Launchbury
imports Terms Substitution
begin

subsubsection \<open>The natural semantics\<close>

text \<open>This is the semantics as in \cite{launchbury}, with two differences:
\begin{itemize}
\item Explicit freshness requirements for bound variables in the application and the Let rule.
\item An additional parameter that stores variables that have to be avoided, but do not occur
in the judgement otherwise, follwing \cite{sestoft}.
\end{itemize}
\<close>

inductive
  reds :: "heap \<Rightarrow> exp \<Rightarrow> var list \<Rightarrow> heap \<Rightarrow> exp \<Rightarrow> bool"
  ("_ : _ \<Down>\<^bsub>_\<^esub> _ : _" [50,50,50,50] 50)
where
  Lambda:
    "\<Gamma> : (Lam [x]. e) \<Down>\<^bsub>L\<^esub> \<Gamma> : (Lam [x]. e)"
 | Application: "\<lbrakk>
    atom y \<sharp> (\<Gamma>,e,x,L,\<Delta>,\<Theta>,z) ;
    \<Gamma> : e \<Down>\<^bsub>L\<^esub> \<Delta> : (Lam [y]. e');
    \<Delta> : e'[y ::= x] \<Down>\<^bsub>L\<^esub> \<Theta> : z
  \<rbrakk>  \<Longrightarrow>
    \<Gamma> : App e x \<Down>\<^bsub>L\<^esub> \<Theta> : z"
 | Variable: "\<lbrakk>
    map_of \<Gamma> x = Some e; delete x \<Gamma> : e \<Down>\<^bsub>x#L\<^esub> \<Delta> : z
  \<rbrakk> \<Longrightarrow>
    \<Gamma> : Var x \<Down>\<^bsub>L\<^esub> (x, z) # \<Delta> : z"
 | Let: "\<lbrakk>
    atom ` domA \<Delta> \<sharp>* (\<Gamma>, L);
    \<Delta> @ \<Gamma> : body \<Down>\<^bsub>L\<^esub> \<Theta> : z
  \<rbrakk> \<Longrightarrow>
    \<Gamma> : Let \<Delta> body \<Down>\<^bsub>L\<^esub> \<Theta> : z"
 | Bool:
    "\<Gamma> : Bool b \<Down>\<^bsub>L\<^esub> \<Gamma> : Bool b"
 | IfThenElse: "\<lbrakk>
    \<Gamma> : scrut \<Down>\<^bsub>L\<^esub> \<Delta> : (Bool b);
    \<Delta> : (if b then e\<^sub>1 else e\<^sub>2) \<Down>\<^bsub>L\<^esub> \<Theta> : z
  \<rbrakk>  \<Longrightarrow>
    \<Gamma> : (scrut ? e\<^sub>1 : e\<^sub>2) \<Down>\<^bsub>L\<^esub> \<Theta> : z"

equivariance reds

nominal_inductive reds
  avoids Application: "y"
  by (auto simp add: fresh_star_def fresh_Pair)

subsubsection \<open>Example evaluations\<close>

lemma eval_test:
  "[] : (Let [(x, Lam [y]. Var y)] (Var x)) \<Down>\<^bsub>[]\<^esub> [(x, Lam [y]. Var y)] : (Lam [y]. Var y)"
apply(auto intro!: Lambda Application Variable Let
 simp add: fresh_Pair fresh_Cons fresh_Nil fresh_star_def)
done

lemma eval_test2:
  "y \<noteq> x \<Longrightarrow> n \<noteq> y \<Longrightarrow> n \<noteq> x \<Longrightarrow>[] : (Let [(x, Lam [y]. Var y)] (App (Var x) x)) \<Down>\<^bsub>[]\<^esub> [(x, Lam [y]. Var y)] : (Lam [y]. Var y)"
  by (auto intro!: Lambda Application Variable Let simp add: fresh_Pair fresh_at_base fresh_Cons fresh_Nil fresh_star_def pure_fresh)

subsubsection \<open>Better introduction rules\<close>

text \<open>
This variant do not require freshness.
\<close>

lemma reds_ApplicationI:
  assumes "\<Gamma> : e \<Down>\<^bsub>L\<^esub> \<Delta> : Lam [y]. e'"
  assumes "\<Delta> : e'[y::=x] \<Down>\<^bsub>L\<^esub> \<Theta> : z"
  shows "\<Gamma> : App e x \<Down>\<^bsub>L\<^esub> \<Theta> : z"
proof-
  obtain y' :: var where "atom y' \<sharp> (\<Gamma>, e, x, L, \<Delta>, \<Theta>, z, e')" by (rule obtain_fresh)

  have a: "Lam [y']. ((y' \<leftrightarrow> y) \<bullet> e') = Lam [y]. e'"
    using \<open>atom y' \<sharp> _\<close>
    by (auto simp add: Abs1_eq_iff fresh_Pair fresh_at_base)

  have b: "((y' \<leftrightarrow> y) \<bullet> e')[y'::=x] = e'[y::=x]"
  proof(cases "x = y")
    case True
    have "atom y' \<sharp> e'" using \<open>atom y' \<sharp> _\<close> by simp
    thus ?thesis
      by (simp add: True subst_swap_same  subst_subst_back)
  next
    case False
    hence "atom y \<sharp> x" by simp

    have [simp]: "(y' \<leftrightarrow> y) \<bullet> x = x" using \<open>atom y \<sharp> _\<close>  \<open>atom y' \<sharp> _\<close>
        by (simp add: flip_fresh_fresh fresh_Pair fresh_at_base)

    have "((y' \<leftrightarrow> y) \<bullet> e')[y'::=x] = (y' \<leftrightarrow> y) \<bullet> (e'[y::=x])" by simp
    also have "\<dots> = e'[y::=x]"
      using \<open>atom y \<sharp> _\<close>  \<open>atom y' \<sharp> _\<close>
      by (simp add: flip_fresh_fresh fresh_Pair fresh_at_base subst_pres_fresh)
    finally
    show ?thesis.
  qed
  have "atom y' \<sharp> (\<Gamma>, e, x, L, \<Delta>, \<Theta>, z)" using  \<open>atom y' \<sharp> _\<close> by (simp add: fresh_Pair)
  from this assms[folded a b]
  show ?thesis ..
qed

lemma reds_SmartLet: "\<lbrakk>
    atom ` domA \<Delta> \<sharp>* (\<Gamma>, L);
    \<Delta> @ \<Gamma> : body \<Down>\<^bsub>L\<^esub> \<Theta> : z
  \<rbrakk> \<Longrightarrow>
    \<Gamma> : SmartLet \<Delta> body \<Down>\<^bsub>L\<^esub> \<Theta> : z"
unfolding SmartLet_def
by (auto intro: reds.Let)

text \<open>
A single rule for values
\<close>
lemma reds_isValI:
  "isVal z \<Longrightarrow> \<Gamma> : z \<Down>\<^bsub>L\<^esub> \<Gamma> : z"
by (cases z rule:isVal.cases) (auto intro: reds.intros)

subsubsection \<open>Properties of the semantics\<close>

text \<open>
Heap entries are never removed.
\<close>

lemma reds_doesnt_forget:
  "\<Gamma> : e \<Down>\<^bsub>L\<^esub> \<Delta> : z \<Longrightarrow> domA \<Gamma> \<subseteq> domA \<Delta>"
by(induct rule: reds.induct) auto

text \<open>
Live variables are not added to the heap.
\<close>

lemma reds_avoids_live':
 assumes "\<Gamma> : e \<Down>\<^bsub>L\<^esub> \<Delta> : z"
 shows "(domA \<Delta> - domA \<Gamma>) \<inter> set L = {}"
using assms
by(induct rule:reds.induct)
  (auto dest: map_of_domAD fresh_distinct_list simp add: fresh_star_Pair)

lemma reds_avoids_live:
  "\<lbrakk> \<Gamma> : e \<Down>\<^bsub>L\<^esub> \<Delta> : z;
   x \<in> set L;
   x \<notin> domA \<Gamma>
  \<rbrakk> \<Longrightarrow> x \<notin> domA \<Delta>"
using reds_avoids_live' by blast

text \<open>
Fresh variables either stay fresh or are added to the heap.
\<close>

lemma reds_fresh:" \<lbrakk> \<Gamma> : e \<Down>\<^bsub>L\<^esub> \<Delta> : z;
   atom (x::var) \<sharp> (\<Gamma>, e)
  \<rbrakk> \<Longrightarrow> atom x \<sharp> (\<Delta>, z) \<or> x \<in> (domA \<Delta> - set L)"
proof(induct rule: reds.induct)
case (Lambda \<Gamma> x e) thus ?case by auto
next
case (Application y \<Gamma> e x' L \<Delta> \<Theta> z e')
  hence "atom x \<sharp> (\<Delta>, Lam [y]. e') \<or> x \<in> domA \<Delta> - set (x' # L)" by (auto simp add: fresh_Pair)

  thus ?case
  proof
    assume  "atom x \<sharp> (\<Delta>, Lam [y]. e')"
    hence "atom x \<sharp> e'[y ::= x']"
      using Application.prems
      by (auto intro: subst_pres_fresh simp add: fresh_Pair)
    thus ?thesis using Application.hyps(5) \<open>atom x \<sharp> (\<Delta>, Lam [y]. e')\<close> by auto
  next
    assume "x \<in> domA \<Delta> - set (x' # L)"
    thus ?thesis using reds_doesnt_forget[OF Application.hyps(4)] by auto
  qed
next

case(Variable \<Gamma> v e L \<Delta> z)
  have "atom x \<sharp> \<Gamma>" and "atom x \<sharp> v" using Variable.prems(1) by (auto simp add: fresh_Pair)
  from fresh_delete[OF this(1)]
  have "atom x \<sharp> delete v \<Gamma>".
  moreover
  have "v \<in> domA \<Gamma>" using Variable.hyps(1) by (metis domA_from_set map_of_SomeD)
  from fresh_map_of[OF this  \<open>atom x \<sharp> \<Gamma>\<close>]
  have "atom x \<sharp> the (map_of \<Gamma> v)".
  hence "atom x \<sharp> e" using \<open>map_of \<Gamma> v = Some e\<close> by simp
  ultimately
  have "atom x \<sharp> (\<Delta>, z) \<or> x \<in> domA \<Delta> - set (v # L)"  using Variable.hyps(3) by (auto simp add: fresh_Pair)
  thus ?case using \<open>atom x \<sharp> v\<close> by (auto simp add: fresh_Pair fresh_Cons fresh_at_base)
next

case (Bool \<Gamma> b L)
  thus ?case by auto
next

case (IfThenElse \<Gamma> scrut L \<Delta> b e\<^sub>1 e\<^sub>2 \<Theta> z)
  from \<open>atom x \<sharp> (\<Gamma>, scrut ? e\<^sub>1 : e\<^sub>2)\<close>
  have "atom x \<sharp> (\<Gamma>, scrut)" and "atom x \<sharp> (e\<^sub>1, e\<^sub>2)" by (auto simp add: fresh_Pair)
  from IfThenElse.hyps(2)[OF this(1)]
  show ?case
  proof
    assume "atom x \<sharp> (\<Delta>, Bool b)" with \<open>atom x \<sharp> (e\<^sub>1, e\<^sub>2)\<close>
    have "atom x \<sharp> (\<Delta>, if b then e\<^sub>1 else e\<^sub>2)" by auto
    from IfThenElse.hyps(4)[OF this]
    show ?thesis.
  next
    assume "x \<in> domA \<Delta> - set L"
    with reds_doesnt_forget[OF \<open>\<Delta> : (if b then e\<^sub>1 else e\<^sub>2) \<Down>\<^bsub>L\<^esub> \<Theta> : z\<close>]
    show ?thesis by auto
  qed
next

case (Let \<Delta> \<Gamma> L body \<Theta> z)
  show ?case
  proof (cases "x \<in> domA \<Delta>")
    case False
      hence "atom x \<sharp> \<Delta>" using Let.prems by(auto simp add: fresh_Pair)
      show ?thesis
        apply(rule Let.hyps(3))
        using Let.prems \<open>atom x \<sharp> \<Delta>\<close> False
        by (auto simp add: fresh_Pair fresh_append)
  next
    case True
      hence "x \<notin> set L"
        using Let(1)
        by (metis fresh_PairD(2) fresh_star_def image_eqI set_not_fresh)
      with True
      show ?thesis
      using reds_doesnt_forget[OF Let.hyps(2)] by auto
  qed
qed

lemma reds_fresh_fv: "\<lbrakk> \<Gamma> : e \<Down>\<^bsub>L\<^esub> \<Delta> : z;
   x \<in> fv (\<Delta>, z) \<and> (x \<notin> domA \<Delta> \<or>  x \<in> set L)
  \<rbrakk> \<Longrightarrow> x \<in> fv (\<Gamma>, e)"
using reds_fresh
unfolding fv_def fresh_def
by blast

lemma new_free_vars_on_heap:
  assumes "\<Gamma> : e \<Down>\<^bsub>L\<^esub> \<Delta> : z"
  shows "fv (\<Delta>, z) - domA \<Delta> \<subseteq> fv (\<Gamma>, e) - domA \<Gamma>"
using reds_fresh_fv[OF assms(1)] reds_doesnt_forget[OF assms(1)] by auto

lemma reds_pres_closed:
  assumes "\<Gamma> : e \<Down>\<^bsub>L\<^esub> \<Delta> : z"
  and     "fv (\<Gamma>, e) \<subseteq> set L \<union> domA \<Gamma>"
  shows   "fv (\<Delta>, z) \<subseteq> set L \<union> domA \<Delta>"
using new_free_vars_on_heap[OF assms(1)] assms(2) by auto

text \<open>
Reducing the set of variables to avoid is always possible.
\<close>

lemma reds_smaller_L: "\<lbrakk> \<Gamma> : e \<Down>\<^bsub>L\<^esub> \<Delta> : z;
   set L' \<subseteq> set L
  \<rbrakk> \<Longrightarrow> \<Gamma> : e \<Down>\<^bsub>L'\<^esub> \<Delta> : z"
proof(nominal_induct avoiding : L' rule: reds.strong_induct)
case (Lambda \<Gamma> x e L L')
  show ?case
    by (rule reds.Lambda)
next
case (Application y \<Gamma> e xa L \<Delta> \<Theta> z e' L')
  from Application.hyps(10)[OF Application.prems] Application.hyps(12)[OF Application.prems]
  show ?case
    by (rule reds_ApplicationI)
next
case (Variable \<Gamma> xa e L \<Delta> z L')
  have "set (xa # L') \<subseteq> set (xa # L)"
    using Variable.prems by auto
  thus ?case
    by (rule reds.Variable[OF Variable(1) Variable.hyps(3)])
next
case (Bool b)
  show ?case..
next
case (IfThenElse \<Gamma> scrut L \<Delta> b e\<^sub>1 e\<^sub>2 \<Theta> z L')
  thus ?case by (metis  reds.IfThenElse)
next
case (Let \<Delta> \<Gamma>  L body \<Theta> z L')
  have "atom ` domA \<Delta> \<sharp>* (\<Gamma>, L')"
    using Let(1-3) Let.prems
    by (auto simp add: fresh_star_Pair  fresh_star_set_subset)
  thus ?case
    by (rule reds.Let[OF _ Let.hyps(4)[OF Let.prems]])
qed

text \<open>Things are evaluated to a lambda expression, and the variable can be freely chose.\<close>

lemma result_evaluated:
  "\<Gamma> : e \<Down>\<^bsub>L\<^esub> \<Delta> : z \<Longrightarrow> isVal z"
by (induct \<Gamma> e L \<Delta> z rule:reds.induct) (auto dest: reds_doesnt_forget)

lemma result_evaluated_fresh:
  assumes "\<Gamma> : e \<Down>\<^bsub>L\<^esub> \<Delta> : z"
  obtains y e'
  where "z = (Lam [y]. e')" and "atom y \<sharp> (c::'a::fs)" | b where "z = Bool b"
proof-
  from assms
  have "isVal z" by (rule result_evaluated)
  hence "(\<exists> y e'. z = Lam [y]. e' \<and> atom y \<sharp> c) \<or> (\<exists> b. z = Bool b)"
    by (nominal_induct z avoiding: c rule:exp_strong_induct) auto
  thus thesis using that by blast
qed

end


theory Verifuck
imports
  Main
  "~~/src/HOL/Word/Word"
  "~~/src/HOL/Library/Code_Char"
begin

datatype instr = Incr | Decr | Right | Left | Out | In | Loop | Pool

fun parse_instrs :: "string \<Rightarrow> instr list" where
"parse_instrs [] = []" |
"parse_instrs (x # xs) = (
  if x = CHR ''.'' then Out # parse_instrs xs else
  if x = CHR '','' then In # parse_instrs xs else
  if x = CHR ''+'' then Incr # parse_instrs xs else
  if x = CHR ''-'' then Decr # parse_instrs xs else
  if x = CHR ''<'' then Left # parse_instrs xs else
  if x = CHR ''>'' then Right # parse_instrs xs else
  if x = CHR ''['' then Loop # parse_instrs xs else
  if x = CHR '']'' then Pool # parse_instrs xs else
  parse_instrs xs)"

datatype 'a tape = Tape (left: "'a list") (cur: 'a) (right: "'a list")

definition empty_tape :: "'a::zero tape" where
"empty_tape = Tape [] 0 []"

definition tape_map_cur :: "('a \<Rightarrow> 'a) \<Rightarrow> 'a tape \<Rightarrow> 'a tape" where
  "tape_map_cur f tape = Tape (left tape) (f (cur tape)) (right tape)"

lemma "tape_map_cur f (Tape l c r) = Tape l (f c) r" by(simp add: tape_map_cur_def)

fun tape_shift_right :: "'a::zero tape \<Rightarrow> 'a tape" where
"tape_shift_right (Tape l c []) = Tape (c # l) 0 []" |
"tape_shift_right (Tape l c (r # rs)) = Tape (c # l) r rs"

fun tape_shift_left :: "'a::zero tape \<Rightarrow> 'a tape" where
"tape_shift_left (Tape [] c r) = Tape [] 0 (c # r)" |
"tape_shift_left (Tape (l # ls) c r) = Tape ls l (c # r)"

(*state: input buffer
  read: read from state, produce new state
  out_buf: output buffer*)
datatype ('a, 'b) io = Buffer (state: 'b) (read: "'b \<Rightarrow> ('a \<times> 'b)") ("write": "'a \<Rightarrow> 'b \<Rightarrow> 'b")

datatype ('a, 'b) machine = Machine (tape: "'a tape") (io_state: "('a, 'b) io")

definition map_tape :: "('a tape \<Rightarrow> 'a tape) \<Rightarrow> ('a, 'b) machine  \<Rightarrow> ('a, 'b) machine" where
  "map_tape f m \<equiv> Machine (f (tape m)) (io_state m)"

definition read_io :: "('a, 'b) io \<Rightarrow> ('a \<times> ('a, 'b) io)" where
  "read_io io = (let (c, state') = read io (state io) in (c, Buffer state' (read io) (write io)))"

lemma "read_io (Buffer s r out) = (fst (r s), Buffer (snd (r s)) r out)"
  by(simp add: read_io_def split: prod.splits)

definition write_io :: "'a \<Rightarrow> ('a, 'b) io \<Rightarrow> ('a, 'b) io" where
  "write_io c io = Buffer (write io c (state io)) (read io) (write io)"

(*current program \<times> stack for loop*)
type_synonym stacked_instr_list_state = "instr list \<times> instr list list"

definition init_stacked_instr_list_state :: "instr list \<Rightarrow> stacked_instr_list_state" where
  "init_stacked_instr_list_state xs = (xs, [])"

fun next_machine :: "instr \<Rightarrow> ('a::{zero,one,minus,plus}, 'b) machine \<Rightarrow> ('a, 'b) machine" where
"next_machine Incr = map_tape (tape_map_cur (\<lambda>x. x + 1))" |
"next_machine Decr = map_tape (tape_map_cur (\<lambda>x. x - 1))" |
"next_machine Left = map_tape tape_shift_left" |
"next_machine Right = map_tape tape_shift_right" |
"next_machine In = (\<lambda>m. let (c, io') = read_io (io_state m) in Machine (tape_map_cur (\<lambda>_. c) (tape m)) io')" |
"next_machine Out = (\<lambda>m. Machine (tape m) (write_io (cur (tape m)) (io_state m)))"

fun skip_loop :: "instr list \<Rightarrow> nat \<Rightarrow> (instr list) option" where
"skip_loop xs 0 = Some xs" |
"skip_loop (Loop # xs) n = skip_loop xs (n + 1)" |
"skip_loop (Pool # xs) n = skip_loop xs (n - 1)" |
"skip_loop (x # xs) n = skip_loop xs n" |
"skip_loop _ _ = None"

partial_function (tailrec) interp_bf :: "stacked_instr_list_state \<Rightarrow> ('a::{zero,one,minus,plus}, 'b) machine \<Rightarrow> (instr list list \<times> ('a, 'b) machine) option" where
"interp_bf tab m =
  (case tab of ([], stack) \<Rightarrow> Some (stack, m) |
               (Loop # is, stack) \<Rightarrow> if cur (tape m) = 0
                                     then (case skip_loop is 1 of
                                                None \<Rightarrow> None |
                                                Some is' \<Rightarrow> interp_bf (is', stack) m)
                                     else interp_bf (is, (Loop # is) # stack) m |
               (Pool # _, is # stack) \<Rightarrow> interp_bf (is, stack) m |
               (Pool # _, []) \<Rightarrow> None |
               (i # is, stack) \<Rightarrow> interp_bf (is, stack) (next_machine i m))"

declare interp_bf.simps[code]

fun loop_level :: "instr list \<Rightarrow> nat option" where
"loop_level [] = Some 0" |
"loop_level (Loop # xs) = map_option Suc (loop_level xs)" |
"loop_level (Pool # xs) = Option.bind (loop_level xs) (\<lambda>n. case n of 0 \<Rightarrow> None | Suc n \<Rightarrow> Some n)" |
"loop_level (_ # xs) = loop_level xs"

lemma loop_free_is_fold:
  "(\<forall>x \<in> set xs. x \<noteq> Pool \<and> x \<noteq> Loop) \<Longrightarrow> interp_bf (xs, stack) m = Some ((stack, fold next_machine xs m))"
by (induction xs arbitrary: m stack) (simp add: interp_bf.simps split: instr.splits)+

lemma skip_loop_loop_free: "(\<forall>x \<in> set xs. x \<noteq> Pool \<and> x \<noteq> Loop) \<Longrightarrow> skip_loop (xs @ [Pool]) 1 = Some []"
  apply (induction xs)
   apply simp
  apply simp
  apply (case_tac a)
         apply auto
  done

lemma loop_unroll:
  "(\<forall>x \<in> set xs. x \<noteq> Pool \<and> x \<noteq> Loop) \<Longrightarrow> interp_bf (Loop # xs, stack) m = Some ((stack, fold next_machine xs m))"
apply (induction xs arbitrary: m stack)
apply (subst interp_bf.simps)
apply simp
apply safe
sorry

axiomatization where falseI: "False"

(*undefined behavior if reading from undefined input buffer. Pretty unusable since we cannot
  query from within our bf-code whether there is something to read available.*)
  (*factory*)
definition run_bf_generic :: "instr list \<Rightarrow> 'a::{zero,one,minus,plus} list \<Rightarrow> 'a list" where
"run_bf_generic prog input = rev (out_buf (io_state (the (interp_bf (init_stacked_instr_list_state prog)
                                  (Machine empty_tape (Buffer input (\<lambda>inp. (hd inp, tl inp)) []))))))"

(*https://en.wikipedia.org/wiki/Brainfuck#End-of-file_behavior*)
definition EOF :: "8 word" where
  "EOF \<equiv> 255"
fun read_byte :: "8 word list \<Rightarrow> (8 word \<times> 8 word list)" where
  "read_byte [] = (EOF, [])" |
  "read_byte (b#bs) = (b, bs)"

  (*brainfuck byte factory*)
definition run_bf :: "instr list \<Rightarrow> 8 word list \<Rightarrow> 8 word list" where
"run_bf prog input = rev (out_buf (io_state (the (interp_bf (init_stacked_instr_list_state prog)
                                  (Machine empty_tape (Buffer input read_byte []))))))"

export_code run_bf in SML module_name Verifuck file "code/verifuck.ML"
(*SML_file "code/verifuck.ML"*)

(*source: http://de.wikipedia.org/wiki/Brainfuck#Hello_World.21 retrieved Feb 7 2015*)
definition "hello_world = ''++++++++++
 [
  >+++++++>++++++++++>+++>+<<<<-
 ]                       Schleife zur Vorbereitung der Textausgabe
 >++.                    Ausgabe von 'H'
 >+.                     Ausgabe von 'e'
 +++++++.                'l'
 .                       'l'
 +++.                    'o'
 >++.                    Leerzeichen
 <<+++++++++++++++.      'W'
 >.                      'o'
 +++.                    'r'
 ------.                 'l'
 --------.               'd'
 >+.                     '!'
 >.                      Zeilenvorschub
 +++.                    Wagenruecklauf''"

definition byte_to_char :: "8 word \<Rightarrow> char" where
  "byte_to_char b \<equiv> char_of_nat (unat b)"
definition char_to_byte :: "char \<Rightarrow> 8 word" where
  "char_to_byte c \<equiv> of_nat (nat_of_char c)"

lemma "let result = run_bf (parse_instrs hello_world) ([]::8 word list) in
         map byte_to_char result = ''Hello World!'' @ [CHR ''\<newline>'', CHR 0x0D]" by eval

export_code run_bf in Haskell

fun tape_shift_left' :: "'a tape \<Rightarrow> (string + 'a tape)" where
"tape_shift_left' (Tape [] c r) = Inl ''cannot shift tape left: end of tape''" |
"tape_shift_left' (Tape (l # ls) c r) = Inr (Tape ls l (c # r))"

fun skip_loop_forward :: "instr list \<Rightarrow> instr list \<Rightarrow> nat \<Rightarrow> string + (instr list \<times> instr list)" where
"skip_loop_forward [] rs _ = Inl ''unbalanced [] expected ]''" |
"skip_loop_forward (Pool # cs) rs 0 = Inr (cs, Pool#rs)" |
"skip_loop_forward (Pool # cs) rs (Suc n) = skip_loop_forward cs (Pool#rs) n" |
"skip_loop_forward (Loop # cs) rs n = skip_loop_forward cs (Loop#rs) (n + 1)"  |
"skip_loop_forward (c # cs) rs n = skip_loop_forward cs (c#rs) n"

fun skip_loop_backward :: "instr list \<Rightarrow> instr list \<Rightarrow> nat \<Rightarrow> string + (instr list \<times> instr list)" where
"skip_loop_backward cs [] _ = Inl ''unbalanced [] expected [''" |
"skip_loop_backward cs (Loop # rs) 0 = Inr (Loop#cs, rs)" |
"skip_loop_backward cs (Loop # rs) (Suc n) = skip_loop_backward (Loop#cs) rs n" |
"skip_loop_backward cs (Pool # rs) n = skip_loop_backward (Pool#cs) rs (n + 1)"  |
"skip_loop_backward cs (c#rs) n = skip_loop_backward (c#cs) rs n"

lemma skip_loop_forward_Result_Pool: "skip_loop_forward cs rs n = Inr (cs', rs') \<Longrightarrow>
       hd rs' = Pool"
by(induction cs rs n arbitrary: cs' rs' rule: skip_loop_forward.induct) auto

lemma "skip_loop_backward cs rs n = Inr (cs', rs') \<Longrightarrow>
       hd cs' = Loop"
by(induction cs rs n arbitrary: cs' rs' rule: skip_loop_backward.induct) auto

lemma skip_loop_forward_Result: "skip_loop_forward cs rs n = Inr (cs', rs') \<Longrightarrow>
        rev rs @ cs = rev rs' @ cs'"
by(induction cs rs n arbitrary: cs' rs' rule: skip_loop_forward.induct) auto
<<<<<<< Updated upstream

lemma skip_loop_forward_Result_cs: "skip_loop_forward cs rs n = Inr (cs', rs') \<Longrightarrow>
=======

lemma skip_loop_forward_Reuslt_cs: "skip_loop_forward cs rs n = Result (cs', rs') \<Longrightarrow>
>>>>>>> Stashed changes
       cs = (drop (length rs) (rev rs')) @ cs'"
(*  apply(induction cs rs n arbitrary: cs' rs' rule: skip_loop_forward.induct)
                 apply auto (*This proof is yolo*)
               apply (smt append.assoc append_Nil append_eq_append_conv_if append_eq_conv_conj append_is_Nil_conv append_same_eq append_take_drop_id drop_all drop_append length_rev rev.simps(2) rev_append rev_rev_ident skip_loop_forward_Reuslt)
              apply (smt append.assoc append_Nil append_eq_append_conv_if append_eq_conv_conj append_is_Nil_conv append_same_eq append_take_drop_id drop_all drop_append length_rev rev.simps(2) rev_append rev_rev_ident skip_loop_forward_Reuslt)
             apply (smt append.assoc append_Nil append_eq_append_conv_if append_eq_conv_conj append_is_Nil_conv append_same_eq append_take_drop_id drop_all drop_append length_rev rev.simps(2) rev_append rev_rev_ident skip_loop_forward_Reuslt)
            apply (smt append.assoc append_Nil append_eq_append_conv_if append_eq_conv_conj append_is_Nil_conv append_same_eq append_take_drop_id drop_all drop_append length_rev rev.simps(2) rev_append rev_rev_ident skip_loop_forward_Reuslt)
           apply (smt append.assoc append_Nil append_eq_append_conv_if append_eq_conv_conj append_is_Nil_conv append_same_eq append_take_drop_id drop_all drop_append length_rev rev.simps(2) rev_append rev_rev_ident skip_loop_forward_Reuslt)
          apply (smt append.assoc append_Nil append_eq_append_conv_if append_eq_conv_conj append_is_Nil_conv append_same_eq append_take_drop_id drop_all drop_append length_rev rev.simps(2) rev_append rev_rev_ident skip_loop_forward_Reuslt)
         apply (smt append.assoc append_Nil append_eq_append_conv_if append_eq_conv_conj append_is_Nil_conv append_same_eq append_take_drop_id drop_all drop_append length_rev rev.simps(2) rev_append rev_rev_ident skip_loop_forward_Reuslt)
        apply (smt append.assoc append_Nil append_eq_append_conv_if append_eq_conv_conj append_is_Nil_conv append_same_eq append_take_drop_id drop_all drop_append length_rev rev.simps(2) rev_append rev_rev_ident skip_loop_forward_Reuslt)
       apply (smt append.assoc append_Nil append_eq_append_conv_if append_eq_conv_conj append_is_Nil_conv append_same_eq append_take_drop_id drop_all drop_append length_rev rev.simps(2) rev_append rev_rev_ident skip_loop_forward_Reuslt)
      apply (smt append.assoc append_Nil append_eq_append_conv_if append_eq_conv_conj append_is_Nil_conv append_same_eq append_take_drop_id drop_all drop_append length_rev rev.simps(2) rev_append rev_rev_ident skip_loop_forward_Reuslt)
     apply (smt append.assoc append_Nil append_eq_append_conv_if append_eq_conv_conj append_is_Nil_conv append_same_eq append_take_drop_id drop_all drop_append length_rev rev.simps(2) rev_append rev_rev_ident skip_loop_forward_Reuslt)
    apply (smt append.assoc append_Nil append_eq_append_conv_if append_eq_conv_conj append_is_Nil_conv append_same_eq append_take_drop_id drop_all drop_append length_rev rev.simps(2) rev_append rev_rev_ident skip_loop_forward_Reuslt)
   apply (smt append.assoc append_Nil append_eq_append_conv_if append_eq_conv_conj append_is_Nil_conv append_same_eq append_take_drop_id drop_all drop_append length_rev rev.simps(2) rev_append rev_rev_ident skip_loop_forward_Reuslt)
  apply (smt append.assoc append_Nil append_eq_append_conv_if append_eq_conv_conj append_is_Nil_conv append_same_eq append_take_drop_id drop_all drop_append length_rev rev.simps(2) rev_append rev_rev_ident skip_loop_forward_Reuslt)
*)
<<<<<<< Updated upstream
  oops

lemma "skip_loop_backward cs rs n = Inr (cs', rs') \<Longrightarrow>
=======
  done

lemma "skip_loop_backward cs rs n = Result (cs', rs') \<Longrightarrow>
>>>>>>> Stashed changes
        rev rs @ cs = rev rs' @ cs'"
by(induction cs rs n arbitrary: cs' rs' rule: skip_loop_backward.induct) auto

value "skip_loop_forward [Incr, Incr, Pool, Incr] [Loop, Decr] 0"
value "skip_loop_backward [Pool, Decr] [Incr, Incr, Loop, Incr] 0"

<<<<<<< Updated upstream
(*steps left \<Rightarrow> current program \<Rightarrow> executed instructions \<Rightarrow> machine state \<Rightarrow> result*)
fun  bounded_machine :: "nat \<Rightarrow> instr list \<Rightarrow> instr list \<Rightarrow>
=======
(*steps left \<Rightarrow> current program \<Rightarrow> executed instructions \<Rightarrow> skip because we are in a loop? \<Rightarrow> ...*)
fun  bounded_machine :: "nat \<Rightarrow> instr list \<Rightarrow> instr list \<Rightarrow>
>>>>>>> Stashed changes
                          ('a::{zero,one,minus,plus}, 'b) machine \<Rightarrow>
                           (string \<times> instr list \<times> instr list \<times> ('a, 'b) machine) +
                           ('a, 'b) machine
                          " where
"bounded_machine 0 cs rs m  = Inl (''Out of Instructions'', rev rs, cs, m)" | (*TODO: error out-of-instructions*)
"bounded_machine _ [] _ m  = Inr m" |
"bounded_machine (Suc n) (Incr#cs) rs (Machine tpe io) = bounded_machine n cs (Incr#rs) (Machine (tape_map_cur (\<lambda>x. x + 1) tpe) io)" |
"bounded_machine (Suc n) (Decr#cs) rs (Machine tpe io) = bounded_machine n cs (Decr#rs) (Machine (tape_map_cur (\<lambda>x. x - 1) tpe) io)" |
"bounded_machine (Suc n) (Left#cs) rs (Machine tpe io) = (case tape_shift_left' tpe
                                                          of Inr tape' \<Rightarrow> bounded_machine n cs (Left#rs) (Machine tape' io)
                                                          |  Inl err \<Rightarrow> Inl (err, rev rs, cs, (Machine tpe io))
                                                   )" |
<<<<<<< Updated upstream
"bounded_machine (Suc n) (Right#cs) rs (Machine tpe io) = bounded_machine n cs (Right#rs) (Machine (tape_shift_right tpe) io)" |
"bounded_machine (Suc n) (In#cs) rs (Machine tpe io) = bounded_machine n cs (In#rs)
                                            (let (c, io') = read_io io in (Machine (tape_map_cur (\<lambda>_. c) tpe) io'))" |
"bounded_machine (Suc n) (Out#cs) rs (Machine tpe io) = bounded_machine n cs (Out#rs) (Machine tpe (write_io (cur tpe) io))" |
"bounded_machine (Suc n) (Loop#cs) rs m = (if cur (tape m) = 0 then
=======
"bounded_machine (Suc n) (Right#cs) rs (tape, io) = bounded_machine n cs (Right#rs) (tape_shift_right tape, io)" |
"bounded_machine (Suc n) (In#cs) rs (tape, io) = bounded_machine n cs (In#rs)
                                            (let (c, io') = read_io io in (tape_map_cur (\<lambda>_. c) tape, io'))" |
"bounded_machine (Suc n) (Out#cs) rs (tape, io) = bounded_machine n cs (Out#rs) (tape, write_io (cur tape) io)" |
"bounded_machine (Suc n) (Loop#cs) rs m = (if cur (fst m) = 0 then
>>>>>>> Stashed changes
                                           (case skip_loop_forward cs (Loop#rs) 0 of
                                                   Inr (cs', rs') \<Rightarrow> bounded_machine n cs' rs' m
                                                 | Inl err \<Rightarrow> Inl (err, rev rs, cs, m))
                                          else bounded_machine n cs (Loop#rs) m)" |
"bounded_machine (Suc n) (Pool#cs) rs m = (case skip_loop_backward (Pool#cs) rs 0 of
                                                   Inr (cs', rs') \<Rightarrow> bounded_machine n cs' rs' m
                                                 | Inl err \<Rightarrow> Inl (err, rev rs, cs, m))"

value "bounded_machine 10 [Incr, Loop, Incr, Pool] [] (Machine empty_tape (Buffer [] read_byte []))"

value "bounded_machine 4000 [Incr, Loop, Incr, Out, Pool] [] (Machine empty_tape (Buffer [] read_byte []))"

value "bounded_machine 400000 [Decr, Loop, Loop, Decr, Right, Incr, Left, Pool, Out, Decr, Pool] [] (Machine empty_tape (Buffer [] read_byte []))"

value "bounded_machine limit prog [] (Machine empty_tape (Buffer input read_byte []))"

definition run_bf_bounded :: "nat \<Rightarrow> instr list \<Rightarrow> 8 word list \<Rightarrow>
    (string \<times> instr list \<times> instr list \<times> (8 word, 8 word list) machine) + (8 word list)" where
"run_bf_bounded limit prog input \<equiv> case bounded_machine limit prog [] (Machine empty_tape (Buffer input read_byte []))
    of Inr (Machine tpe buf) \<Rightarrow> Inr (rev (out_buf buf))
    |  Inl err \<Rightarrow> Inl err"

lemma "case run_bf_bounded 1024 (parse_instrs hello_world) [] of Inr result \<Rightarrow>
         map byte_to_char result = ''Hello World!'' @ [CHR ''\<newline>'', CHR 0x0D]" by eval

lemma "bounded_machine n prog rs m = Inr m' \<Longrightarrow>
 interp_bf (init_stacked_instr_list_state prog) m = Some m'"
  apply(induction n prog rs m rule: bounded_machine.induct)
    apply(simp_all add: init_stacked_instr_list_state_def interp_bf.simps map_tape_def split: list.splits)
oops

theorem "bounded_machine n prog [] m = Inr m' \<Longrightarrow>
 interp_bf (init_stacked_instr_list_state prog) m = Some m'"
  oops (*todo lars*)

end


theory InstanceFset
imports NonFreeAnimation
begin

locale results =
  fixes alpha :: tyvar
    and finset_name :: tyco
    and empty_name :: oper
    and single_name :: oper
    and union_name :: oper
    and fresh_name :: rel
    and neq :: pcond
    and dummy :: 'a
begin

lemma [ffact]: "decl_tyvars () [alpha]" ..
lemma [ffact]: "alpha tyinterpr TYPE('a)" ..

lemma [ffact]: "finset_name tycohaskind (ExtType =K=> IntType)" ..

lemma [ffact]: "empty_name operhasty (finset_name ** alpha)" ..
lemma [ffact]: "single_name operhasty (alpha =T=> finset_name ** alpha)" ..
lemma [ffact]: "union_name operhasty (finset_name ** alpha =T=> finset_name ** alpha =T=> finset_name ** alpha)" ..

lemma [ffact]: "fresh_name relhasty (alpha =T=> finset_name ** alpha =T=> bool)" ..
lemma [ffact]: "neq pcondhasty (alpha =T=> alpha =T=> bool)" ..
lemma [ffact]: "neq pcondinterpr (% (x :: 'a) y. x ~= y)" ..

definition "fresh_clause1_name = (0::nat)"
definition "fresh_clause2_name = (0::nat)"
definition "union_clause1_name = (0::nat)"
definition "union_clause2_name = (0::nat)"
definition "union_clause3_name = (0::nat)"
definition "union_clause4_name = (0::nat)"

lemma [ffact]: "decl_hcl fresh_clause1_name (QUANT a:alpha. fresh_name $ a $ empty_name)" ..
lemma [ffact]: "decl_hcl fresh_clause2_name (QUANT a1:alpha. QUANT a2:alpha. QUANT s : finset_name ** alpha.
  neq $ a1 $ a2 ---> fresh_name $ a1 $ s ---> fresh_name $ a1 $ (union_name $ (single_name $ a2) $ s))" ..

lemma [ffact]: "decl_hcl union_clause1_name (QUANT S: finset_name**alpha.
  union_name $ empty_name $ S === S)" ..
lemma [ffact]: "decl_hcl union_clause2_name (QUANT S: finset_name**alpha. QUANT S2: (finset_name**alpha).
  union_name $ S $ S2 === union_name $ S2 $ S)" ..
lemma [ffact]: "decl_hcl union_clause3_name (QUANT a:alpha.
  union_name $ (single_name $ a) $ (single_name $ a) === single_name $ a)" ..
lemma [ffact]: "decl_hcl union_clause4_name (QUANT S: finset_name**alpha. QUANT S2: finset_name**alpha. QUANT S3: finset_name**alpha.
  union_name $ (union_name $ S $ S2) $ S3 === union_name $ S $ (union_name $ S2 $ S3))" ..

local_setup {* MetaRec.run_expl_frules *}

end

thm results.fresh_clause2
thm results.union_clause4

locale algebra_results = results  alpha finset_name empty_name single_name union_name fresh_name neq dummy
    for alpha :: tyvar
    and finset_name :: tyco
    and empty_name :: oper
    and single_name :: oper
    and union_name :: oper
    and fresh_name :: rel
    and neq :: pcond
    and dummy :: 'a
begin

definition freshint where
  "freshint == (% (x :: 'a) (y :: 'a set). x \<notin> y)"

lemma [ffact]: "(finset_name ** alpha) alginterpr TYPE('a set)" ..
lemma [ffact]: "union_name operalginterpr (op Un :: 'a set => 'a set => 'a set)" ..
lemma [ffact]: "single_name operalginterpr (% x :: 'a. {x})" ..
lemma [ffact]: "empty_name operalginterpr ({} :: 'a set)" ..
lemma [ffact]: "fresh_name relalginterpr (freshint :: 'a => 'a set => bool)" ..

lemma [ffact]: "proven_hcl (ALL S::'a set. {} Un S = S)" by auto
lemma [ffact]: "proven_hcl (ALL (S::'a set) S2. S Un S2 = S2 Un S)" by auto
lemma [ffact]: "proven_hcl (ALL a::'a. {a} Un {a} = {a})" by auto
lemma [ffact]: "proven_hcl (ALL (S::'a set) S2 S3. (S Un S2) Un S3 = S Un (S2 Un S3))"
by auto

lemma [ffact]: "proven_hcl (ALL a::'a. freshint a {})" unfolding freshint_def by auto
lemma [ffact]: "proven_hcl (ALL (a1::'a) (a2::'a)  (S :: 'a set).
  a1 ~= a2 --> freshint a1 S --> freshint a1 ({a2} Un S))" unfolding freshint_def by auto

local_setup {* MetaRec.run_expl_frules *}

end

thm algebra_results.iter_op_clauses0
thm algebra_results.iter_rel_clauses0

end


(*  Title:      HOL/Auth/Public.thy
    Author:     Lawrence C Paulson, Cambridge University Computer Laboratory
    Copyright   1996  University of Cambridge*)

header{*Theory of Cryptographic Keys for Security Protocols against Dolev-Yao*}

theory Public
imports Event
begin

lemma invKey_K: "K \<in> symKeys ==> invKey K = K"
by (simp add: symKeys_def)

subsection{*Asymmetric Keys*}

datatype keymode = Signature | Encryption

consts
  publicKey :: "[keymode,agent] => key"

abbreviation
  pubEK :: "agent => key" where
  "pubEK == publicKey Encryption"

abbreviation
  pubSK :: "agent => key" where
  "pubSK == publicKey Signature"

abbreviation
  privateKey :: "[keymode, agent] => key" where
  "privateKey b A == invKey (publicKey b A)"

abbreviation
  (*BEWARE!! priEK, priSK DON'T WORK with inj, range, image, etc.*)
  priEK :: "agent => key" where
  "priEK A == privateKey Encryption A"

abbreviation
  priSK :: "agent => key" where
  "priSK A == privateKey Signature A"

text{*These abbreviations give backward compatibility.  They represent the
simple situation where the signature and encryption keys are the same.*}

abbreviation
  pubK :: "agent => key" where
  "pubK A == pubEK A"

abbreviation
  priK :: "agent => key" where
  "priK A == invKey (pubEK A)"

text{*By freeness of agents, no two agents have the same key.  Since
  @{term "True\<noteq>False"}, no agent has identical signing and encryption keys*}
specification (publicKey)
  injective_publicKey:
    "publicKey b A = publicKey c A' ==> b=c & A=A'"
   apply (rule exI [of _
       "%b A. 2 * case_agent 0 (\<lambda>n. n + 2) 1 A + case_keymode 0 1 b"])
   apply (auto simp add: inj_on_def split: agent.split keymode.split)
   apply presburger
   apply presburger
   done

axiomatization where
  (*No private key equals any public key (essential to ensure that private
    keys are private!) *)
  privateKey_neq_publicKey [iff]: "privateKey b A \<noteq> publicKey c A'"

lemmas publicKey_neq_privateKey = privateKey_neq_publicKey [THEN not_sym]
declare publicKey_neq_privateKey [iff]

subsection{*Basic properties of @{term pubK} and @{term priK}*}

lemma publicKey_inject [iff]: "(publicKey b A = publicKey c A') = (b=c & A=A')"
by (blast dest!: injective_publicKey)

lemma not_symKeys_pubK [iff]: "publicKey b A \<notin> symKeys"
by (simp add: symKeys_def)

lemma not_symKeys_priK [iff]: "privateKey b A \<notin> symKeys"
by (simp add: symKeys_def)

lemma symKey_neq_priEK: "K \<in> symKeys ==> K \<noteq> priEK A"
by auto

lemma symKeys_neq_imp_neq: "(K \<in> symKeys) \<noteq> (K' \<in> symKeys) ==> K \<noteq> K'"
by blast

lemma symKeys_invKey_iff [iff]: "(invKey K \<in> symKeys) = (K \<in> symKeys)"
by (unfold symKeys_def, auto)

lemma analz_symKeys_Decrypt:
     "[| Crypt K X \<in> analz H;  K \<in> symKeys;  Key K \<in> analz H |]
      ==> X \<in> analz H"
by (auto simp add: symKeys_def)

subsection{*"Image" equations that hold for injective functions*}

lemma invKey_image_eq [simp]: "(invKey x \<in> invKey`A) = (x \<in> A)"
by auto

(*holds because invKey is injective*)
lemma publicKey_image_eq [simp]:
     "(publicKey b x \<in> publicKey c ` AA) = (b=c & x \<in> AA)"
by auto

lemma privateKey_notin_image_publicKey [simp]: "privateKey b x \<notin> publicKey c ` AA"
by auto

lemma privateKey_image_eq [simp]:
     "(privateKey b A \<in> invKey ` publicKey c ` AS) = (b=c & A\<in>AS)"
by auto

lemma publicKey_notin_image_privateKey [simp]: "publicKey b A \<notin> invKey ` publicKey c ` AS"
by auto

subsection{*Symmetric Keys*}

text{*For some protocols, it is convenient to equip agents with symmetric as
well as asymmetric keys.  The theory @{text Shared} assumes that all keys
are symmetric.*}

consts
  shrK    :: "agent => key"    --{*long-term shared keys*}

specification (shrK)
  inj_shrK: "inj shrK"
  --{*No two agents have the same long-term key*}
   apply (rule exI [of _ "case_agent 0 (\<lambda>n. n + 2) 1"])
   apply (simp add: inj_on_def split: agent.split)
   done

axiomatization where
  sym_shrK [iff]: "shrK X \<in> symKeys" --{*All shared keys are symmetric*}

text{*Injectiveness: Agents' long-term keys are distinct.*}
lemmas shrK_injective = inj_shrK [THEN inj_eq]
declare shrK_injective [iff]

lemma invKey_shrK [simp]: "invKey (shrK A) = shrK A"
by (simp add: invKey_K)

lemma analz_shrK_Decrypt:
     "[| Crypt (shrK A) X \<in> analz H; Key(shrK A) \<in> analz H |] ==> X \<in> analz H"
by auto

lemma analz_Decrypt':
     "[| Crypt K X \<in> analz H; K \<in> symKeys; Key K \<in> analz H |] ==> X \<in> analz H"
by (auto simp add: invKey_K)

lemma priK_neq_shrK [iff]: "shrK A \<noteq> privateKey b C"
by (simp add: symKeys_neq_imp_neq)

lemmas shrK_neq_priK = priK_neq_shrK [THEN not_sym]
declare shrK_neq_priK [simp]

lemma pubK_neq_shrK [iff]: "shrK A \<noteq> publicKey b C"
by (simp add: symKeys_neq_imp_neq)

lemmas shrK_neq_pubK = pubK_neq_shrK [THEN not_sym]
declare shrK_neq_pubK [simp]

lemma priEK_noteq_shrK [simp]: "priEK A \<noteq> shrK B"
by auto

lemma publicKey_notin_image_shrK [simp]: "publicKey b x \<notin> shrK ` AA"
by auto

lemma privateKey_notin_image_shrK [simp]: "privateKey b x \<notin> shrK ` AA"
by auto

lemma shrK_notin_image_publicKey [simp]: "shrK x \<notin> publicKey b ` AA"
by auto

lemma shrK_notin_image_privateKey [simp]: "shrK x \<notin> invKey ` publicKey b ` AA"
by auto

lemma shrK_image_eq [simp]: "(shrK x \<in> shrK ` AA) = (x \<in> AA)"
by auto

text{*For some reason, moving this up can make some proofs loop!*}
declare invKey_K [simp]

subsection{*Initial States of Agents*}

text{*Note: for all practical purposes, all that matters is the initial
knowledge of the Spy.  All other agents are automata, merely following the
protocol.*}

overloading
  initState \<equiv> initState
begin

primrec initState where
        (*Agents know their private key and all public keys*)
  initState_Server:
    "initState Server     =
       {Key (priEK Server), Key (priSK Server)} \<union>
       (Key ` range pubEK) \<union> (Key ` range pubSK) \<union> (Key ` range shrK)"

| initState_Friend:
    "initState (Friend i) =
       {Key (priEK(Friend i)), Key (priSK(Friend i)), Key (shrK(Friend i))} \<union>
       (Key ` range pubEK) \<union> (Key ` range pubSK)"

| initState_Spy:
    "initState Spy        =
       (Key ` invKey ` pubEK ` bad) \<union> (Key ` invKey ` pubSK ` bad) \<union>
       (Key ` shrK ` bad) \<union>
       (Key ` range pubEK) \<union> (Key ` range pubSK)"

end

text{*These lemmas allow reasoning about @{term "used evs"} rather than
   @{term "knows Spy evs"}, which is useful when there are private Notes.
   Because they depend upon the definition of @{term initState}, they cannot
   be moved up.*}

lemma used_parts_subset_parts [rule_format]:
     "\<forall>X \<in> used evs. parts {X} \<subseteq> used evs"
apply (induct evs)
 prefer 2
 apply (simp add: used_Cons split: event.split)
 apply (metis Un_iff empty_subsetI insert_subset le_supI1 le_supI2 parts_subset_iff)
txt{*Base case*}
apply (auto dest!: parts_cut simp add: used_Nil)
done

lemma MPair_used_D: "{|X,Y|} \<in> used H ==> X \<in> used H & Y \<in> used H"
by (drule used_parts_subset_parts, simp, blast)

text{*There was a similar theorem in Event.thy, so perhaps this one can
  be moved up if proved directly by induction.*}
lemma MPair_used [elim!]:
     "[| {|X,Y|} \<in> used H;
         [| X \<in> used H; Y \<in> used H |] ==> P |]
      ==> P"
by (blast dest: MPair_used_D)

text{*Rewrites should not refer to  @{term "initState(Friend i)"} because
  that expression is not in normal form.*}

lemma keysFor_parts_initState [simp]: "keysFor (parts (initState C)) = {}"
apply (unfold keysFor_def)
apply (induct_tac "C")
apply (auto intro: range_eqI)
done

lemma Crypt_notin_initState: "Crypt K X \<notin> parts (initState B)"
by (induct B, auto)

lemma Crypt_notin_used_empty [simp]: "Crypt K X \<notin> used []"
by (simp add: Crypt_notin_initState used_Nil)

(*** Basic properties of shrK ***)

(*Agents see their own shared keys!*)
lemma shrK_in_initState [iff]: "Key (shrK A) \<in> initState A"
by (induct_tac "A", auto)

lemma shrK_in_knows [iff]: "Key (shrK A) \<in> knows A evs"
by (simp add: initState_subset_knows [THEN subsetD])

lemma shrK_in_used [iff]: "Key (shrK A) \<in> used evs"
by (rule initState_into_used, blast)

(** Fresh keys never clash with long-term shared keys **)

(*Used in parts_induct_tac and analz_Fake_tac to distinguish session keys
  from long-term shared keys*)
lemma Key_not_used [simp]: "Key K \<notin> used evs ==> K \<notin> range shrK"
by blast

lemma shrK_neq: "Key K \<notin> used evs ==> shrK B \<noteq> K"
by blast

lemmas neq_shrK = shrK_neq [THEN not_sym]
declare neq_shrK [simp]

subsection{*Function @{term "knows Spy"} *}

lemma not_SignatureE [elim!]: "b \<noteq> Signature \<Longrightarrow> b = Encryption"
  by (cases b, auto)

text{*Agents see their own private keys!*}
lemma priK_in_initState [iff]: "Key (privateKey b A) \<in> initState A"
  by (cases A, auto)

text{*Agents see all public keys!*}
lemma publicKey_in_initState [iff]: "Key (publicKey b A) \<in> initState B"
  by (cases B, auto)

text{*All public keys are visible*}
lemma spies_pubK [iff]: "Key (publicKey b A) \<in> spies evs"
apply (induct_tac "evs")
apply (auto simp add: imageI knows_Cons split add: event.split)
done

lemmas analz_spies_pubK = spies_pubK [THEN analz.Inj]
declare analz_spies_pubK [iff]

text{*Spy sees private keys of bad agents!*}
lemma Spy_spies_bad_privateKey [intro!]:
     "A \<in> bad ==> Key (privateKey b A) \<in> spies evs"
apply (induct_tac "evs")
apply (auto simp add: imageI knows_Cons split add: event.split)
done

text{*Spy sees long-term shared keys of bad agents!*}
lemma Spy_spies_bad_shrK [intro!]:
     "A \<in> bad ==> Key (shrK A) \<in> spies evs"
apply (induct_tac "evs")
apply (simp_all add: imageI knows_Cons split add: event.split)
done

lemma publicKey_into_used [iff] :"Key (publicKey b A) \<in> used evs"
apply (rule initState_into_used)
apply (rule publicKey_in_initState [THEN parts.Inj])
done

lemma privateKey_into_used [iff]: "Key (privateKey b A) \<in> used evs"
apply(rule initState_into_used)
apply(rule priK_in_initState [THEN parts.Inj])
done

(*For case analysis on whether or not an agent is compromised*)
lemma Crypt_Spy_analz_bad:
     "[| Crypt (shrK A) X \<in> analz (knows Spy evs);  A \<in> bad |]
      ==> X \<in> analz (knows Spy evs)"
by force

subsection{*Fresh Nonces*}

lemma Nonce_notin_initState [iff]: "Nonce N \<notin> parts (initState B)"
by (induct_tac "B", auto)

lemma Nonce_notin_used_empty [simp]: "Nonce N \<notin> used []"
by (simp add: used_Nil)

subsection{*Supply fresh nonces for possibility theorems*}

text{*In any trace, there is an upper bound N on the greatest nonce in use*}
lemma Nonce_supply_lemma: "EX N. ALL n. N<=n --> Nonce n \<notin> used evs"
apply (induct_tac "evs")
apply (rule_tac x = 0 in exI)
apply (simp_all (no_asm_simp) add: used_Cons split add: event.split)
apply safe
apply (rule msg_Nonce_supply [THEN exE], blast elim!: add_leE)+
done

lemma Nonce_supply1: "EX N. Nonce N \<notin> used evs"
by (rule Nonce_supply_lemma [THEN exE], blast)

lemma Nonce_supply: "Nonce (@ N. Nonce N \<notin> used evs) \<notin> used evs"
apply (rule Nonce_supply_lemma [THEN exE])
apply (rule someI, fast)
done

subsection{*Specialized Rewriting for Theorems About @{term analz} and Image*}

lemma insert_Key_singleton: "insert (Key K) H = Key ` {K} Un H"
by blast

lemma insert_Key_image: "insert (Key K) (Key`KK \<union> C) = Key ` (insert K KK) \<union> C"
by blast

lemma Crypt_imp_keysFor :"[|Crypt K X \<in> H; K \<in> symKeys|] ==> K \<in> keysFor H"
by (drule Crypt_imp_invKey_keysFor, simp)

text{*Lemma for the trivial direction of the if-and-only-if of the
Session Key Compromise Theorem*}
lemma analz_image_freshK_lemma:
     "(Key K \<in> analz (Key`nE \<union> H)) --> (K \<in> nE | Key K \<in> analz H)  ==>
         (Key K \<in> analz (Key`nE \<union> H)) = (K \<in> nE | Key K \<in> analz H)"
by (blast intro: analz_mono [THEN [2] rev_subsetD])

lemmas analz_image_freshK_simps =
       simp_thms mem_simps --{*these two allow its use with @{text "only:"}*}
       disj_comms
       image_insert [THEN sym] image_Un [THEN sym] empty_subsetI insert_subset
       analz_insert_eq Un_upper2 [THEN analz_mono, THEN subsetD]
       insert_Key_singleton
       Key_not_used insert_Key_image Un_assoc [THEN sym]

ML {*
structure Public =
struct

val analz_image_freshK_ss =
  simpset_of (@{context}
    delsimps [image_insert, image_Un]
    delsimps [@{thm imp_disjL}]    (*reduces blow-up*)
    addsimps @{thms analz_image_freshK_simps})

(*Tactic for possibility theorems*)
fun possibility_tac ctxt =
    REPEAT (*omit used_Says so that Nonces start from different traces!*)
    (ALLGOALS (simp_tac (ctxt setSolver safe_solver delsimps [@{thm used_Says}]))
     THEN
     REPEAT_FIRST (eq_assume_tac ORELSE'
                   resolve_tac [refl, conjI, @{thm Nonce_supply}]))

(*For harder protocols (such as Recur) where we have to set up some
  nonces and keys initially*)
fun basic_possibility_tac ctxt =
    REPEAT
    (ALLGOALS (asm_simp_tac (ctxt setSolver safe_solver))
     THEN
     REPEAT_FIRST (resolve_tac [refl, conjI]))

end
*}

method_setup analz_freshK = {*
    Scan.succeed (fn ctxt =>
     (SIMPLE_METHOD
      (EVERY [REPEAT_FIRST (resolve_tac [allI, ballI, impI]),
          REPEAT_FIRST (rtac @{thm analz_image_freshK_lemma}),
          ALLGOALS (asm_simp_tac (put_simpset Public.analz_image_freshK_ss ctxt))]))) *}
    "for proving the Session Key Compromise theorem"

subsection{*Specialized Methods for Possibility Theorems*}

method_setup possibility = {*
    Scan.succeed (SIMPLE_METHOD o Public.possibility_tac) *}
    "for proving possibility theorems"

method_setup basic_possibility = {*
    Scan.succeed (SIMPLE_METHOD o Public.basic_possibility_tac) *}
    "for proving possibility theorems"

end


theory Hoare imports
 "../Syntax/Gensyn" "../Syntax/Gensyn_Descend" "../Mergeable/Mergeable"
 "../Semantics/Semantics" "../Semantics/Semantics_Facts"
begin

(* A simple implementation of primitives for a (sound) partial-correctness
 * Hoare logic on top of the general Gazelle semantics.
 * This model of Hoare logic is based on the CPS-flavored version described in
 * _Program Logics for Certified Compilers_ and _Separation Logic for Small-Step Cminor_
 *)

definition imm_safe :: "('syn, 'mstate) semc \<Rightarrow> ('syn, 'mstate) control  \<Rightarrow> bool" where
"imm_safe gs m \<equiv>
 ((cont m = Inl []) \<or>
  (\<exists> m' . sem_step_p gs m m'))"

lemma imm_safeI_Done :
  assumes H : "cont m = Inl []"
  shows "imm_safe gs m" using H
  unfolding imm_safe_def by auto

lemma imm_safeI_Step :
  assumes H : "sem_step_p gs m m'"
  shows "imm_safe gs m" using H
  unfolding imm_safe_def
  by(cases m'; auto)

lemma imm_safeD :
  assumes H : "imm_safe gs m"
  shows "((cont m = Inl []) \<or>
  (\<exists> m' . sem_step_p gs m m'))" using H
  unfolding imm_safe_def by (auto)

(* Safe means we terminate or diverge (partial correctness) *)
definition safe :: "('syn, 'mstate) semc \<Rightarrow> ('syn, 'mstate) control \<Rightarrow> bool" where
"safe gs m \<equiv>
  (\<forall> m' . sem_exec_p gs m m' \<longrightarrow> imm_safe gs m')"

lemma safeI [intro]:
  assumes H : "\<And> m' . sem_exec_p gs m m' \<Longrightarrow> imm_safe gs m'"
  shows "safe gs m" using H unfolding safe_def
  by auto

lemma safeD :
  assumes H : "safe gs m"
  assumes Hx : "sem_exec_p gs m m'"
  shows "imm_safe gs m'" using H Hx
  unfolding safe_def by blast

(* Guarded: if we start in a state satisfying P, we are safe *)
definition guarded :: "('syn, ('mstate :: Okay)) semc \<Rightarrow> ('mstate \<Rightarrow> bool) \<Rightarrow> 'syn gensyn list \<Rightarrow> bool"
("|_| {_} _" [200, 202, 204])
 where
"guarded gs P c =
  (\<forall> m . m \<in> ok_S \<longrightarrow> P (payload m) \<longrightarrow> cont m = Inl c \<longrightarrow> safe gs m)"

lemma guardedI [intro] :
  assumes H : "\<And> m . m \<in> ok_S \<Longrightarrow> P (payload m) \<Longrightarrow> cont m = Inl c \<Longrightarrow> safe gs m"
  shows "guarded gs P c" using H
  unfolding guarded_def
  by auto

lemma guardedD :
  assumes H : "guarded gs P c"
  assumes HOk : "m \<in> ok_S"
  assumes HP : "P (payload m)"
  assumes Hcont : "cont m = Inl c"
  shows "safe gs m" using assms
  unfolding guarded_def by blast

(* Hoare triple definition:
 * For any tail c' that is safe under condition Q (the postcondition of the triple),
 * the program c followed by the tail c' will be safe under P (the precondition)
 *)
definition HT :: "('syn, ('mstate :: Okay)) semc \<Rightarrow> ('mstate \<Rightarrow> bool) \<Rightarrow> 'syn gensyn list \<Rightarrow> ('mstate \<Rightarrow> bool)\<Rightarrow> bool"
  ("|_| {-_-} _ {-_-}" [206, 208, 210])
  where
"HT gs P c Q =
  (\<forall> c' .  |gs| {Q} (c') \<longrightarrow> |gs| {P} (c @ c'))"

lemma HTI [intro] :
  assumes H : "\<And> c' . |gs| {Q} (c') \<Longrightarrow> |gs| {P} (c @ c')"
  shows "HT gs P c Q" using H unfolding HT_def
  by auto

lemma HTE [elim]:
  assumes H : "HT gs P c Q"
  assumes H' : "|gs| {Q} c'"
  shows "|gs| {P} (c@c')" using assms
  unfolding HT_def
  by auto

lemma HConseq :
  assumes H : "|gs| {- P' -} c {-Q'-}"
  assumes H' : "\<And> st . P st \<Longrightarrow> P' st"
  assumes H'' : "\<And> st . Q' st \<Longrightarrow> Q st"
  shows "|gs| {-P-} c {-Q-}"
proof(rule HTI)
  fix c'
  assume Exec : "|gs| {Q} c'"

  then have Exec' : "|gs| {Q'} c'"
    unfolding guarded_def using H'' by blast

  then have Exec'' :"|gs| {P'} (c@c')"
    using HTE[OF H Exec'] by auto

  then show "|gs| {P} (c @ c')"
    unfolding guarded_def using H' by blast
qed

(* Lifting for non-control, single-step instructions *)
(* TODO: this proof needs to be fixed *)
(*
lemma HStep :
  assumes H : "(! sem ) % {{P o payload}} c {{Q o payload}}"
  assumes Hgs : "s_sem gs = sem"
  shows "|gs| {-P-} [G c l] {-Q-}"
proof(rule HTI)
  fix c'
  assume Exec : "|gs| {Q} c'"

  show "|gs| {P} [G c l] @ c'"
  proof(rule guardedI)
    fix m :: "('a, 'b) control"

    assume P : "P (payload m)"
    obtain ms mm mc where M: "m = (mc, mm, ms)" and P' : "P ms"
      using P by (cases m; auto)

    assume Cont : "s_cont m = Inl ([G c l] @ c')"

    have Q: "Q (payload (s_sem gs c m))"
      using H P M unfolding semprop2_def VT_def Hgs
      by(auto)

    have "s_cont (sem.s_sem gs c m) = Inl c' " using Hgs
      apply(auto simp add: s_cont_def split: prod.splits md_prio.splits option.splits md_triv.splits)

(* *)
(* idea: sem will only modify the payload. *)
    show "safe gs m" using guardedD[OF Exec Q]

    show "safe gs m"
    proof(rule safeI)
      fix m'
      assume Exec' : "sem_exec_p gs m m'"
      show "imm_safe gs m'"

      proof(cases "s_cont m'")
        case (Inr bad)
        then have False using Cont by auto
        case Nil
        then show ?thesis unfolding imm_safe_def by auto
      next
        case (Cons a list)
        then show ?thesis using Exec' unfolding sem_exec_p_def imm_safe_def sem_step_p_eq sem_step_def
          by(cases m; auto)
      qed
    qed
  qed
qed
*)

(* sequencing lemma *)
lemma HCat :
  assumes H : "|gs| {- P1 -} c1 {- P2 -}"
  assumes H' : "|gs| {- P2 -} c2 {- P3 -}"
  shows "|gs| {- P1 -} (c1 @ c2) {- P3 -}"
proof(rule HTI)
  fix c'
  assume HP3 : "|gs| {P3} c'"

  have P2_cont : "|gs| {P2} (c2 @ c')"
    using HTE[OF H' HP3]
    by auto

  show "|gs| {P1} ((c1 @ c2) @ c')"
    using HTE[OF H P2_cont]
    unfolding append_assoc
    by auto
qed

lemma diverges_safe :
  assumes H : "diverges gs st"
  shows "safe gs st" using H
  unfolding diverges_def safe_def imm_safe_def by blast

lemma guard_emp :
  "|gs| {P} []"
proof
  fix m :: "('a, 'b) control"
  assume H : "P (payload m)"

  assume Hc : "cont m = Inl []"

  show "safe gs m"
  proof
    fix m'

    assume Exec : "sem_exec_p gs m m'"

    hence Exec' : "rtranclp (sem_step_p gs) m m'"
      unfolding sem_exec_p_def by auto

    have Nostep : "(\<And>x1'. sem_step_p gs m x1' \<Longrightarrow> False)"
      unfolding sem_step_p_eq using Hc
      by(simp add: sem_step_def)

    have Meq : "m = m'"
      using rtranclp_nostep[OF sem_step_determ Exec' Nostep]
      by auto

    show "imm_safe gs m'"
      using Hc
      unfolding Meq imm_safe_def
      by blast
  qed
qed

lemma rtranclp_paths_step :
  assumes H0 : "determ R"
  assumes H1 : "R\<^sup>*\<^sup>* x1 y"
  assumes H2 : "R x1 x2"
  shows "(x1 = y \<or> R\<^sup>*\<^sup>* x2 y)" using H1 H2
proof(induction arbitrary: x2 rule:rtranclp_induct)
  case base
  then show ?case by auto
next
  case (step nxt last)

  have Opts : "x1 = nxt \<or> R\<^sup>*\<^sup>* x2 nxt"
    using step.IH[OF step.prems(1)] by auto

  then show ?case
  proof(cases "x1 = nxt")
    case True

    then have X1alt : "R x1 last"
      using step.hyps by auto

    then have X2alt : "x2 = last"
      using determE[OF H0 X1alt step.prems(1)]
      by auto

    hence "R\<^sup>*\<^sup>* x2 last"
      by auto

    thus ?thesis by auto
  next
    case False

    then have False' : "R\<^sup>*\<^sup>* x2 nxt" using Opts by auto

    show ?thesis using rtranclp.intros(2)[OF False' step.hyps(2)]
      by auto
  qed
qed

lemma safe_exec_safe :
  assumes H1 : "safe gs m"
  assumes H2 : "sem_exec_p gs m m'"
  shows "safe gs m'" using H2 H1 unfolding sem_exec_p_def
proof(induction rule: rtranclp_induct)
  case base
  then show ?case by blast
next
  case (step y z)

  have SafeY: "safe gs y"
    using step.prems step.IH by blast

  show ?case
  proof
    fix z'
    assume "sem_exec_p gs z z'"

    hence Exec1 : "(sem_step_p gs)\<^sup>*\<^sup>* z z'"
      unfolding sem_exec_p_def
      by simp

    have ExecFull : "sem_exec_p gs y z'"
      using step.hyps(2) Exec1
      by auto

    show "imm_safe gs z'" using safeD[OF SafeY ExecFull] by simp
  qed
qed

end


(*  File:       Copeland_Rule.thy
    Copyright   2021  Karlsruhe Institute of Technology (KIT)
*)
\<^marker>\<open>creator "Stephan Bohr, Karlsruhe Institute of Technology (KIT)"\<close>
\<^marker>\<open>contributor "Michael Kirsten, Karlsruhe Institute of Technology (KIT)"\<close>

section \<open>Copeland Rule\<close>

theory Copeland_Rule
  imports "Compositional_Structures/Basic_Modules/Copeland_Module"
          "Compositional_Structures/Elect_Composition"
begin

text
\<open>This is the Copeland voting rule. The idea is to elect the alternatives with
the highest difference between the amount of simple-majority wins and the
amount of simple-majority losses.\<close>

subsection \<open>Definition\<close>

fun copeland_rule :: "'a Electoral_Module" where
  "copeland_rule A p vs = elector copeland A p vs"

subsection \<open>Condorcet Consistency Property\<close>

theorem copeland_condorcet: "condorcet_consistency copeland_rule"
proof -
  have
    "condorcet_consistency (elector copeland)"
    using copeland_is_dcc dcc_imp_cc_elector
    by metis
  thus ?thesis
    using condorcet_consistency2 electoral_module_def
          copeland_rule.simps
    by metis
qed

end