(*
  File:   Akra_Bazzi_Library.thy
  Author: Manuel Eberl <eberlm@in.tum.de>

  Lemma bucket for the Akra-Bazzi theorem.
*)

section \<open>Auxiliary lemmas\<close>
theory Akra_Bazzi_Library
imports
  Complex_Main
  "Landau_Symbols.Landau_More"
begin

(* TODO: Move? *)

lemma ln_mono: "0 < x \<Longrightarrow> 0 < y \<Longrightarrow> x \<le> y \<Longrightarrow> ln (x::real) \<le> ln y"
  by (subst ln_le_cancel_iff) simp_all

lemma ln_mono_strict: "0 < x \<Longrightarrow> 0 < y \<Longrightarrow> x < y \<Longrightarrow> ln (x::real) < ln y"
  by (subst ln_less_cancel_iff) simp_all

declare DERIV_powr[THEN DERIV_chain2, derivative_intros]

lemma sum_pos':
  assumes "finite I"
  assumes "\<exists>x\<in>I. f x > (0 :: _ :: linordered_ab_group_add)"
  assumes "\<And>x. x \<in> I \<Longrightarrow> f x \<ge> 0"
  shows   "sum f I > 0"
proof-
  from assms(2) guess x by (elim bexE) note x = this
  from x have "I = insert x I" by blast
  also from assms(1) have "sum f ... = f x + sum f (I - {x})" by (rule sum.insert_remove)
  also from x assms have "... > 0" by (intro add_pos_nonneg sum_nonneg) simp_all
  finally show ?thesis .
qed

lemma min_mult_left:
  assumes "(x::real) > 0"
  shows   "x * min y z = min (x*y) (x*z)"
  using assms by (auto simp add: min_def algebra_simps)

lemma max_mult_left:
  assumes "(x::real) > 0"
  shows   "x * max y z = max (x*y) (x*z)"
  using assms by (auto simp add: max_def algebra_simps)

lemma DERIV_nonneg_imp_mono:
  assumes "\<And>t. t\<in>{x..y} \<Longrightarrow> (f has_field_derivative f' t) (at t)"
  assumes "\<And>t. t\<in>{x..y} \<Longrightarrow> f' t \<ge> 0"
  assumes "(x::real) \<le> y"
  shows   "(f x :: real) \<le> f y"
proof (cases x y rule: linorder_cases)
  assume xy: "x < y"
  hence "\<exists>z. x < z \<and> z < y \<and> f y - f x = (y - x) * f' z"
    by (rule MVT2) (insert assms(1), simp)
  then guess z by (elim exE conjE) note z = this
  from z(1,2) assms(2) xy have "0 \<le> (y - x) * f' z" by (intro mult_nonneg_nonneg) simp_all
  also note z(3)[symmetric]
  finally show "f x \<le> f y" by simp
qed (insert assms(3), simp_all)

lemma eventually_conjE: "eventually (\<lambda>x. P x \<and> Q x) F \<Longrightarrow> (eventually P F \<Longrightarrow> eventually Q F \<Longrightarrow> R) \<Longrightarrow> R"
  apply (frule eventually_rev_mp[of _ _ P], simp)
  apply (drule eventually_rev_mp[of _ _ Q], simp)
  apply assumption
  done

lemma real_natfloor_nat: "x \<in> \<nat> \<Longrightarrow> real (nat \<lfloor>x\<rfloor>) = x" by (elim Nats_cases) simp

lemma eventually_natfloor:
  assumes "eventually P (at_top :: nat filter)"
  shows   "eventually (\<lambda>x. P (nat \<lfloor>x\<rfloor>)) (at_top :: real filter)"
proof-
  from assms obtain N where N: "\<And>n. n \<ge> N \<Longrightarrow> P n" using eventually_at_top_linorder by blast
  have "\<forall>n\<ge>real N. P (nat \<lfloor>n\<rfloor>)" by (intro allI impI N le_nat_floor) simp_all
  thus ?thesis using eventually_at_top_linorder by blast
qed

lemma tendsto_0_smallo_1: "f \<in> o(\<lambda>x. 1 :: real) \<Longrightarrow> (f \<longlongrightarrow> 0) at_top"
  by (drule smalloD_tendsto) simp

lemma filterlim_at_top_smallomega_1:
  assumes "f \<in> \<omega>[F](\<lambda>x. 1 :: real)" "eventually (\<lambda>x. f x > 0) F"
  shows   "filterlim f at_top F"
proof -
  from assms have "filterlim (\<lambda>x. norm (f x / 1)) at_top F"
    by (intro smallomegaD_filterlim_at_top_norm) (auto elim: eventually_mono)
  also have "?this \<longleftrightarrow> ?thesis"
    using assms by (intro filterlim_cong refl) (auto elim!: eventually_mono)
  finally show ?thesis .
qed

lemma smallo_imp_abs_less_real:
  assumes "f \<in> o[F](g)" "eventually (\<lambda>x. g x > (0::real)) F"
  shows   "eventually (\<lambda>x. \<bar>f x\<bar> < g x) F"
proof -
  have "1/2 > (0::real)" by simp
  from landau_o.smallD[OF assms(1) this] assms(2) show ?thesis
    by eventually_elim auto
qed

lemma smallo_imp_less_real:
  assumes "f \<in> o[F](g)" "eventually (\<lambda>x. g x > (0::real)) F"
  shows   "eventually (\<lambda>x. f x < g x) F"
  using smallo_imp_abs_less_real[OF assms] by eventually_elim simp

lemma smallo_imp_le_real:
  assumes "f \<in> o[F](g)" "eventually (\<lambda>x. g x \<ge> (0::real)) F"
  shows   "eventually (\<lambda>x. f x \<le> g x) F"
  using landau_o.smallD[OF assms(1) zero_less_one] assms(2) by eventually_elim simp

(* TODO MOVE *)

lemma one_plus_x_powr_approx_ex:
  assumes x: "abs (x::real) \<le> 1/2"
  obtains t where "abs t < 1/2" "(1 + x) powr p =
    1 + p * x + p * (p - 1) * (1 + t) powr (p - 2) / 2 * x ^ 2"
proof (cases "x = 0")
  assume x': "x \<noteq> 0"
  let ?f = "\<lambda>x. (1 + x) powr p"
  let ?f' = "\<lambda>x. p * (1 + x) powr (p - 1)"
  let ?f'' = "\<lambda>x. p * (p - 1) * (1 + x) powr (p - 2)"
  let ?fs = "(!) [?f, ?f', ?f'']"

  have A: "\<forall>m t. m < 2 \<and> t \<ge> -0.5 \<and> t \<le> 0.5 \<longrightarrow> (?fs m has_real_derivative ?fs (Suc m) t) (at t)"
  proof (clarify)
    fix m :: nat and t :: real assume m: "m < 2" and t: "t \<ge> -0.5" "t \<le> 0.5"
    thus "(?fs m has_real_derivative ?fs (Suc m) t) (at t)"
      using m by (cases m) (force intro: derivative_eq_intros algebra_simps)+
  qed
  have "\<exists>t. (if x < 0 then x < t \<and> t < 0 else 0 < t \<and> t < x) \<and>
              (1 + x) powr p = (\<Sum>m<2. ?fs m 0 / (fact m) * (x - 0)^m) +
              ?fs 2 t / (fact 2) * (x - 0)\<^sup>2"
    using assms x' by (intro Taylor[OF _ _ A]) simp_all
  then guess t by (elim exE conjE)
  note t = this
  with assms have "abs t < 1/2" by (auto split: if_split_asm)
  moreover from t(2) have "(1 + x) powr p = 1 + p * x + p * (p - 1) * (1 + t) powr (p - 2) / 2 * x ^ 2"
    by (simp add: numeral_2_eq_2 of_nat_Suc)
  ultimately show ?thesis by (rule that)
next
  assume "x = 0"
  with that[of 0] show ?thesis by simp
qed

lemma powr_lower_bound: "\<lbrakk>(l::real) > 0; l \<le> x; x \<le> u\<rbrakk> \<Longrightarrow> min (l powr z) (u powr z) \<le> x powr z"
apply (cases "z \<ge> 0")
apply (rule order.trans[OF min.cobounded1 powr_mono2], simp_all) []
apply (rule order.trans[OF min.cobounded2 powr_mono2'], simp_all) []
done

lemma powr_upper_bound: "\<lbrakk>(l::real) > 0; l \<le> x; x \<le> u\<rbrakk> \<Longrightarrow> max (l powr z) (u powr z) \<ge> x powr z"
apply (cases "z \<ge> 0")
apply (rule order.trans[OF powr_mono2 max.cobounded2], simp_all) []
apply (rule order.trans[OF powr_mono2' max.cobounded1], simp_all) []
done

lemma one_plus_x_powr_Taylor2:
  obtains k where "\<And>x. abs (x::real) \<le> 1/2 \<Longrightarrow> abs ((1 + x) powr p - 1 - p*x) \<le> k*x^2"
proof-
  define k where "k = \<bar>p*(p - 1)\<bar> * max ((1/2) powr (p - 2)) ((3/2) powr (p - 2)) / 2"
  show ?thesis
  proof (rule that[of k])
    fix x :: real assume "abs x \<le> 1/2"
    from one_plus_x_powr_approx_ex[OF this, of p] guess t . note t = this
    from t have "abs ((1 + x) powr p - 1 - p*x) = \<bar>p*(p - 1)\<bar> * (1 + t) powr (p - 2)/2 * x\<^sup>2"
      by (simp add: abs_mult)
    also from t(1) have "(1 + t) powr (p - 2) \<le> max ((1/2) powr (p - 2)) ((3/2) powr (p - 2))"
      by (intro powr_upper_bound) simp_all
    finally show "abs ((1 + x) powr p - 1 - p*x) \<le> k*x^2"
      by (simp add: mult_left_mono mult_right_mono k_def)
  qed
qed

lemma one_plus_x_powr_Taylor2_bigo:
  assumes lim: "(f \<longlongrightarrow> 0) F"
  shows   "(\<lambda>x. (1 + f x) powr (p::real) - 1 - p * f x) \<in> O[F](\<lambda>x. f x ^ 2)"
proof -
  from one_plus_x_powr_Taylor2[of p] guess k .
  moreover from tendstoD[OF lim, of "1/2"]
    have "eventually (\<lambda>x. abs (f x) < 1/2) F" by (simp add: dist_real_def)
  ultimately have "eventually (\<lambda>x. norm ((1 + f x) powr p - 1 - p * f x) \<le> k * norm (f x ^ 2)) F"
    by (auto elim!: eventually_mono)
  thus ?thesis by (rule bigoI)
qed

lemma one_plus_x_powr_Taylor1_bigo:
  assumes lim: "(f \<longlongrightarrow> 0) F"
  shows   "(\<lambda>x. (1 + f x) powr (p::real) - 1) \<in> O[F](\<lambda>x. f x)"
proof -
  from assms have "(\<lambda>x. (1 + f x) powr p - 1 - p * f x) \<in> O[F](\<lambda>x. (f x)\<^sup>2)"
    by (rule one_plus_x_powr_Taylor2_bigo)
  also from assms have "f \<in> O[F](\<lambda>_. 1)" by (intro bigoI_tendsto) simp_all
  from landau_o.big.mult[of f F f, OF _ this] have "(\<lambda>x. (f x)^2) \<in> O[F](\<lambda>x. f x)"
    by (simp add: power2_eq_square)
  finally have A: "(\<lambda>x. (1 + f x) powr p - 1 - p * f x) \<in> O[F](f)" .
  have B: "(\<lambda>x. p * f x) \<in> O[F](f)" by simp
  from sum_in_bigo(1)[OF A B] show ?thesis by simp
qed

lemma x_times_x_minus_1_nonneg: "x \<le> 0 \<or> x \<ge> 1 \<Longrightarrow> (x::_::linordered_idom) * (x - 1) \<ge> 0"
proof (elim disjE)
  assume x: "x \<le> 0"
  also have "0 \<le> x^2" by simp
  finally show "x * (x - 1) \<ge> 0" by (simp add: power2_eq_square algebra_simps)
qed simp

lemma x_times_x_minus_1_nonpos: "x \<ge> 0 \<Longrightarrow> x \<le> 1 \<Longrightarrow> (x::_::linordered_idom) * (x - 1) \<le> 0"
  by (intro mult_nonneg_nonpos) simp_all

lemma powr_mono':
  assumes "(x::real) > 0" "x \<le> 1" "a \<le> b"
  shows   "x powr b \<le> x powr a"
proof-
  have "inverse x powr a \<le> inverse x powr b" using assms
    by (intro powr_mono) (simp_all add: field_simps)
  hence "inverse (x powr a) \<le> inverse (x powr b)" using assms by simp
  with assms show ?thesis by (simp add: field_simps)
qed

lemma powr_less_mono':
  assumes "(x::real) > 0" "x < 1" "a < b"
  shows   "x powr b < x powr a"
proof-
  have "inverse x powr a < inverse x powr b" using assms
    by (intro powr_less_mono) (simp_all add: field_simps)
  hence "inverse (x powr a) < inverse (x powr b)" using assms by simp
  with assms show ?thesis by (simp add: field_simps)
qed

lemma real_powr_at_bot:
  assumes "(a::real) > 1"
  shows   "((\<lambda>x. a powr x) \<longlongrightarrow> 0) at_bot"
proof-
  from assms have "filterlim (\<lambda>x. ln a * x) at_bot at_bot"
    by (intro filterlim_tendsto_pos_mult_at_bot[OF tendsto_const _ filterlim_ident]) auto
  hence "((\<lambda>x. exp (x * ln a)) \<longlongrightarrow> 0) at_bot"
    by (intro filterlim_compose[OF exp_at_bot]) (simp add: algebra_simps)
  thus ?thesis using assms unfolding powr_def by simp
qed

lemma real_powr_at_bot_neg:
  assumes "(a::real) > 0" "a < 1"
  shows   "filterlim (\<lambda>x. a powr x) at_top at_bot"
proof-
  from assms have "LIM x at_bot. ln (inverse a) * -x :> at_top"
    by (intro filterlim_tendsto_pos_mult_at_top[OF tendsto_const] filterlim_uminus_at_top_at_bot)
       (simp_all add: ln_inverse)
  with assms have "LIM x at_bot. x * ln a :> at_top"
    by (subst (asm) ln_inverse) (simp_all add: mult.commute)
  hence "LIM x at_bot. exp (x * ln a) :> at_top"
    by (intro filterlim_compose[OF exp_at_top]) simp
  thus ?thesis using assms unfolding powr_def by simp
qed

lemma real_powr_at_top_neg:
  assumes "(a::real) > 0" "a < 1"
  shows   "((\<lambda>x. a powr x) \<longlongrightarrow> 0) at_top"
proof-
  from assms have "LIM x at_top. ln (inverse a) * x :> at_top"
    by (intro filterlim_tendsto_pos_mult_at_top[OF tendsto_const])
       (simp_all add: filterlim_ident field_simps)
  with assms have "LIM x at_top. ln a * x :> at_bot"
    by (subst filterlim_uminus_at_bot) (simp add: ln_inverse)
  hence "((\<lambda>x. exp (x * ln a)) \<longlongrightarrow> 0) at_top"
    by (intro filterlim_compose[OF exp_at_bot]) (simp_all add: mult.commute)
  with assms show ?thesis unfolding powr_def by simp
qed

lemma eventually_nat_real:
  assumes "eventually P (at_top :: real filter)"
  shows   "eventually (\<lambda>x. P (real x)) (at_top :: nat filter)"
  using assms filterlim_real_sequentially
  unfolding filterlim_def le_filter_def eventually_filtermap by auto

end


theory "Abstract-Denotational-Props"
  imports "AbstractDenotational" Substitution
begin

context semantic_domain
begin

subsubsection {* The semantics ignores fresh variables *}

lemma ESem_considers_fv': "\<lbrakk> e \<rbrakk>\<^bsub>\<rho>\<^esub> = \<lbrakk> e \<rbrakk>\<^bsub>\<rho> f|` (fv e)\<^esub>"
proof (induct e arbitrary: \<rho> rule:exp_induct)
  case Var
  show ?case by simp
next
  have [simp]: "\<And> S x. S \<inter> insert x S = S" by auto
  case App
  show ?case
    by (simp, subst (1 2) App, simp)
next
  case (Lam x e)
  show ?case by simp
next
  case (Let as e)

  have "\<lbrakk>e\<rbrakk>\<^bsub>\<lbrace>as\<rbrace>\<rho>\<^esub> = \<lbrakk>e\<rbrakk>\<^bsub>(\<lbrace>as\<rbrace>\<rho>) f|` (fv as \<union> fv e)\<^esub>"
    apply (subst (1 2) Let(2))
    apply simp
    apply (metis inf_sup_absorb sup_commute)
    done
  also
  have "fv as \<subseteq> fv as \<union> fv e" by (rule inf_sup_ord(3))
  hence "(\<lbrace>as\<rbrace>\<rho>) f|` (fv as \<union> fv e) = \<lbrace>as\<rbrace>(\<rho> f|` (fv as \<union> fv e))"
     by (rule HSem_ignores_fresh_restr'[OF _ Let(1)])
  also
  have "\<lbrace>as\<rbrace>(\<rho> f|` (fv as \<union> fv e)) = \<lbrace>as\<rbrace>\<rho> f|` (fv as \<union> fv e - domA as)"
    by (rule HSem_restr_cong) (auto simp add: lookup_env_restr_eq)
  finally
  show ?case by simp
qed

sublocale has_ignore_fresh_ESem ESem
  by default (rule fv_supp_exp, rule ESem_considers_fv')

subsubsection {* Nicer equations for ESem, without freshness requirements *}

lemma ESem_Lam[simp]: "\<lbrakk> Lam [x]. e \<rbrakk>\<^bsub>\<rho>\<^esub> = tick \<cdot> (Fn \<cdot> (\<Lambda> v. \<lbrakk> e \<rbrakk>\<^bsub>\<rho>(x := v)\<^esub>))"
proof-
  have *: "\<And> v. ((\<rho> f|` (fv e - {x}))(x := v)) f|` fv e = (\<rho>(x := v)) f|` fv e"
    by (rule ext) (auto simp add: lookup_env_restr_eq)

  have "\<lbrakk> Lam [x]. e \<rbrakk>\<^bsub>\<rho>\<^esub> = \<lbrakk> Lam [x]. e \<rbrakk>\<^bsub>env_delete x \<rho>\<^esub>"
    by (rule ESem_fresh_cong) simp
  also have "\<dots> = tick \<cdot> (Fn \<cdot> (\<Lambda> v. \<lbrakk> e \<rbrakk>\<^bsub>(\<rho> f|` (fv e - {x}))(x := v)\<^esub>))"
    by simp
  also have "\<dots> = tick \<cdot> (Fn \<cdot> (\<Lambda> v. \<lbrakk> e \<rbrakk>\<^bsub>((\<rho> f|` (fv e - {x}))(x := v)) f|` fv e\<^esub>))"
    by (subst  ESem_considers_fv, rule)
  also have "\<dots> = tick \<cdot> (Fn \<cdot> (\<Lambda> v. \<lbrakk> e \<rbrakk>\<^bsub>\<rho>(x := v) f|` fv e\<^esub>))"
    unfolding *..
  also have "\<dots> = tick \<cdot> (Fn \<cdot> (\<Lambda> v. \<lbrakk> e \<rbrakk>\<^bsub>\<rho>(x := v)\<^esub>))"
    unfolding  ESem_considers_fv[symmetric]..
  finally show ?thesis.
qed
declare ESem.simps(1)[simp del]

lemma ESem_Let[simp]: "\<lbrakk>Let as body\<rbrakk>\<^bsub>\<rho>\<^esub> = tick \<cdot> (\<lbrakk>body\<rbrakk>\<^bsub>\<lbrace>as\<rbrace>\<rho>\<^esub>)"
proof-
  have "\<lbrakk> Let as body \<rbrakk>\<^bsub>\<rho>\<^esub> = tick \<cdot> (\<lbrakk>body\<rbrakk>\<^bsub>\<lbrace>as\<rbrace>(\<rho> f|` fv (Let as body))\<^esub>)"
    by simp
  also have "\<lbrace>as\<rbrace>(\<rho> f|` fv(Let as body)) = \<lbrace>as\<rbrace>(\<rho> f|` (fv as \<union> fv body))"
    by (rule HSem_restr_cong) (auto simp add: lookup_env_restr_eq)
  also have "\<dots> = (\<lbrace>as\<rbrace>\<rho>) f|` (fv as \<union> fv body)"
    by (rule HSem_ignores_fresh_restr'[symmetric, OF _ ESem_considers_fv]) simp
  also have "\<lbrakk>body\<rbrakk>\<^bsub>\<dots>\<^esub> = \<lbrakk>body\<rbrakk>\<^bsub>\<lbrace>as\<rbrace>\<rho>\<^esub>"
    by (rule ESem_fresh_cong) (auto simp add: lookup_env_restr_eq)
  finally show ?thesis.
qed
declare ESem.simps(4)[simp del]

subsubsection {* Denotation of Substitution *}

lemma ESem_subst_same: "\<rho> x = \<rho> y \<Longrightarrow>  \<lbrakk> e \<rbrakk>\<^bsub>\<rho>\<^esub> = \<lbrakk> e[x::= y] \<rbrakk>\<^bsub>\<rho>\<^esub>"
  and
  "\<rho> x = \<rho> y  \<Longrightarrow>  (\<^bold>\<lbrakk> as \<^bold>\<rbrakk>\<^bsub>\<rho>\<^esub>) = \<^bold>\<lbrakk> as[x::h=y] \<^bold>\<rbrakk>\<^bsub>\<rho>\<^esub>"
proof (nominal_induct e and as avoiding: x y arbitrary: \<rho> and \<rho> rule:exp_heap_strong_induct)
case Var thus ?case by auto
next
case App
  from App(1)[OF App(2)] App(2)
  show ?case by auto
next
case (Let as exp x y \<rho>)
  from `atom \` domA as \<sharp>* x` `atom \` domA as  \<sharp>* y`
  have "x \<notin> domA as" "y \<notin> domA as"
    by (metis fresh_star_at_base imageI)+
  hence [simp]:"domA (as[x::h=y]) = domA as"
    by (metis bn_subst)

  from `\<rho> x = \<rho> y`
  have "(\<lbrace>as\<rbrace>\<rho>) x = (\<lbrace>as\<rbrace>\<rho>) y"
    using `x \<notin> domA as` `y \<notin> domA as`
    by (simp add: lookup_HSem_other)
  hence "\<lbrakk>exp\<rbrakk>\<^bsub>\<lbrace>as\<rbrace>\<rho>\<^esub> = \<lbrakk>exp[x::=y]\<rbrakk>\<^bsub>\<lbrace>as\<rbrace>\<rho>\<^esub>"
    by (rule Let)
  moreover
  from `\<rho> x = \<rho> y`
  have "\<lbrace>as\<rbrace>\<rho> = \<lbrace>as[x::h=y]\<rbrace>\<rho>" and "(\<lbrace>as\<rbrace>\<rho>) x = (\<lbrace>as[x::h=y]\<rbrace>\<rho>) y"
    apply (induction rule: parallel_HSem_ind)
    apply (intro adm_lemmas cont2cont cont2cont_fun)
    apply simp
    apply simp
    apply simp
    apply (erule arg_cong[OF Let(3)])
    using `x \<notin> domA as` `y \<notin> domA as`
    apply simp
    done
  ultimately
  show ?case using Let(1,2,3) by (simp add: fresh_star_Pair)
next
case (Lam var exp x y \<rho>)
  from `\<rho> x = \<rho> y`
  have "\<And>v. (\<rho>(var := v)) x = (\<rho>(var := v)) y"
    using Lam(1,2) by (simp add: fresh_at_base)
  hence "\<And> v. \<lbrakk>exp\<rbrakk>\<^bsub>\<rho>(var := v)\<^esub> = \<lbrakk>exp[x::=y]\<rbrakk>\<^bsub>\<rho>(var := v)\<^esub>"
    by (rule Lam)
  thus ?case using Lam(1,2) by simp
next
case Nil thus ?case by auto
next
case Cons
  from Cons(1,2)[OF Cons(3)] Cons(3)
  show ?case by auto
qed

lemma ESem_subst:
  assumes "x \<noteq> y"
  shows "\<lbrakk> e \<rbrakk>\<^bsub>\<sigma>(x := \<sigma> y)\<^esub> = \<lbrakk> e[x::= y] \<rbrakk>\<^bsub>\<sigma>\<^esub>"
proof-
  have [simp]: "x \<notin> fv e[x::=y]" using assms by (auto simp add: fv_def supp_subst supp_at_base dest: set_mp[OF supp_subst])

  have "\<lbrakk> e \<rbrakk>\<^bsub>\<sigma>(x := \<sigma> y)\<^esub> = \<lbrakk> e[x::= y] \<rbrakk>\<^bsub>\<sigma>(x := \<sigma> y)\<^esub>"
    using assms(1)
    by (auto intro: ESem_subst_same simp add: Rep_cfun_inverse)
  also have "\<dots> = \<lbrakk> e[x::= y] \<rbrakk>\<^bsub>\<sigma>\<^esub>"
    by (rule ESem_fresh_cong) simp
  finally
  show ?thesis.
qed

end

end


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

datatype ('a, 'b) pair = pair2 "'a" "'b"

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

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

(*fun did not finish the proof*)
function twoThirds :: "int => int" where
  "twoThirds y =
   (if (y = 2) then 1 else
      (if (y = 1) then 1 else
         (if (y = 0) then 0 else 2 + (twoThirds (y - 3)))))"
  by pat_completeness auto

(*fun did not finish the proof*)
function third :: "int => int" where
  "third y =
   (if (y = 2) then 0 else
      (if (y = 1) then 0 else
         (if (y = 0) then 0 else 1 + (third (y - 3)))))"
  by pat_completeness auto

fun take :: "int => 'a list => 'a list" where
  "take y z =
   (if y <= 0 then nil2 else
      (case z of
         nil2 => nil2
         | cons2 z2 xs => cons2 z2 (take (y - 1) xs)))"

fun sort2 :: "int => int => int list" where
  "sort2 y z =
   (if y <= z then cons2 y (cons2 z (nil2)) else
      cons2 z (cons2 y (nil2)))"

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

fun length :: "'a list => int" where
  "length (nil2) = 0"
| "length (cons2 z l) = 1 + (length l)"

fun drop :: "int => 'a list => 'a list" where
  "drop y z =
   (if y <= 0 then z else
      (case z of
         nil2 => nil2
         | cons2 z2 xs1 => drop (y - 1) xs1))"

fun splitAt :: "int => 'a list =>
                (('a list), ('a list)) pair" where
  "splitAt y z = pair2 (take y z) (drop y z)"

function nstooge2sort2 :: "int list => int list"
  and nstoogesort2 :: "int list => int list"
  and nstooge2sort1 :: "int list => int list" where
  "nstooge2sort2 y =
   (case splitAt (twoThirds (length y)) y of
      pair2 ys2 zs1 => x (nstoogesort2 ys2) zs1)"
| "nstoogesort2 (nil2) = nil2"
| "nstoogesort2 (cons2 z (nil2)) = cons2 z (nil2)"
| "nstoogesort2 (cons2 z (cons2 y2 (nil2))) = sort2 z y2"
| "nstoogesort2 (cons2 z (cons2 y2 (cons2 x3 x4))) =
     nstooge2sort2
       (nstooge2sort1 (nstooge2sort2 (cons2 z (cons2 y2 (cons2 x3 x4)))))"
| "nstooge2sort1 y =
     (case splitAt (third (length y)) y of
        pair2 ys2 zs1 => x ys2 (nstoogesort2 zs1))"
  by pat_completeness auto

theorem property0 :
  "ordered (nstoogesort2 xs)"
  oops

end


section \<open>\isaheader{Specification of Annotated Lists}\<close>
theory AnnotatedListSpec
imports ICF_Spec_Base
begin

(*@intf AnnotatedList
  @abstype ('e \<times> 'a::monoid_add) list
  Lists with annotated elements. The annotations form a monoid, and there is
  a split operation to split the list according to its annotations. This is the
  abstract concept implemented by finger trees.
*)

subsection "Introduction"
text \<open>
  We define lists with annotated elements. The annotations form a monoid.

  We provide standard list operations and the split-operation, that
  splits the list according to its annotations.
\<close>
locale al =
  \<comment> \<open>Annotated lists are abstracted to lists of pairs of elements and annotations.\<close>
  fixes \<alpha> :: "'s \<Rightarrow> ('e \<times> 'a::monoid_add) list"
  fixes invar :: "'s \<Rightarrow> bool"

locale al_no_invar = al +
  assumes invar[simp, intro!]: "\<And>l. invar l"

subsection "Basic Annotated List Operations"

subsubsection "Empty Annotated List"
locale al_empty = al +
  constrains \<alpha> :: "'s \<Rightarrow> ('e \<times> 'a::monoid_add) list"
  fixes empty :: "unit \<Rightarrow> 's"
  assumes empty_correct:
    "invar (empty ())"
    "\<alpha> (empty ()) = Nil"

subsubsection "Emptiness Check"
locale al_isEmpty = al +
  constrains \<alpha> :: "'s \<Rightarrow> ('e \<times> 'a::monoid_add) list"
  fixes isEmpty :: "'s \<Rightarrow> bool"
  assumes isEmpty_correct:
    "invar s \<Longrightarrow> isEmpty s \<longleftrightarrow> \<alpha> s = Nil"

subsubsection "Counting Elements"
locale al_count = al +
  constrains \<alpha> :: "'s \<Rightarrow> ('e \<times> 'a::monoid_add) list"
  fixes count :: "'s \<Rightarrow> nat"
  assumes count_correct:
    "invar s \<Longrightarrow> count s = length(\<alpha> s)"

subsubsection "Appending an Element from the Left"
locale al_consl = al +
  constrains \<alpha> :: "'s \<Rightarrow> ('e \<times> 'a::monoid_add) list"
  fixes consl :: "'e \<Rightarrow> 'a \<Rightarrow> 's \<Rightarrow> 's"
  assumes consl_correct:
    "invar s \<Longrightarrow> invar (consl e a s)"
    "invar s \<Longrightarrow> (\<alpha> (consl e a s)) = (e,a) # (\<alpha> s)"

subsubsection "Appending an Element from the Right"
locale al_consr = al +
  constrains \<alpha> :: "'s \<Rightarrow> ('e \<times> 'a::monoid_add) list"
  fixes consr :: "'s \<Rightarrow> 'e \<Rightarrow> 'a \<Rightarrow> 's"
  assumes consr_correct:
    "invar s \<Longrightarrow> invar (consr s e a)"
    "invar s \<Longrightarrow> (\<alpha> (consr s e a)) = (\<alpha> s) @ [(e,a)]"

subsubsection "Take the First Element"
locale al_head = al +
  constrains \<alpha> :: "'s \<Rightarrow> ('e \<times> 'a::monoid_add) list"
  fixes head :: "'s \<Rightarrow> ('e \<times> 'a)"
  assumes head_correct:
    "\<lbrakk>invar s; \<alpha> s \<noteq> Nil\<rbrakk> \<Longrightarrow> head s = hd (\<alpha> s)"

subsubsection "Drop the First Element"
locale al_tail = al +
  constrains \<alpha> :: "'s \<Rightarrow> ('e \<times> 'a::monoid_add) list"
  fixes tail :: "'s \<Rightarrow> 's"
  assumes tail_correct:
    "\<lbrakk>invar s; \<alpha> s \<noteq> Nil\<rbrakk> \<Longrightarrow> \<alpha> (tail s) = tl (\<alpha> s)"
    "\<lbrakk>invar s; \<alpha> s \<noteq> Nil\<rbrakk> \<Longrightarrow> invar (tail s)"

subsubsection "Take the Last Element"
locale al_headR = al +
  constrains \<alpha> :: "'s \<Rightarrow> ('e \<times> 'a::monoid_add) list"
  fixes headR :: "'s \<Rightarrow> ('e \<times> 'a)"
  assumes headR_correct:
    "\<lbrakk>invar s; \<alpha> s \<noteq> Nil\<rbrakk> \<Longrightarrow> headR s = last (\<alpha> s)"

subsubsection "Drop the Last Element"
locale al_tailR = al +
  constrains \<alpha> :: "'s \<Rightarrow> ('e \<times> 'a::monoid_add) list"
  fixes tailR :: "'s \<Rightarrow> 's"
  assumes tailR_correct:
    "\<lbrakk>invar s; \<alpha> s \<noteq> Nil\<rbrakk> \<Longrightarrow> \<alpha> (tailR s) = butlast (\<alpha> s)"
    "\<lbrakk>invar s; \<alpha> s \<noteq> Nil\<rbrakk> \<Longrightarrow> invar (tailR s)"

subsubsection "Fold a Function over the Elements from the Left"
locale al_foldl = al +
  constrains \<alpha> :: "'s \<Rightarrow> ('e \<times> 'a::monoid_add) list"
  fixes foldl :: "('z \<Rightarrow> 'e \<times> 'a \<Rightarrow> 'z) \<Rightarrow> 'z \<Rightarrow> 's \<Rightarrow> 'z"
  assumes foldl_correct:
    "invar s \<Longrightarrow> foldl f \<sigma> s = List.foldl f \<sigma> (\<alpha> s)"

subsubsection "Fold a Function over the Elements from the Right"
locale al_foldr = al +
  constrains \<alpha> :: "'s \<Rightarrow> ('e \<times> 'a::monoid_add) list"
  fixes foldr :: "('e \<times> 'a \<Rightarrow> 'z \<Rightarrow> 'z) \<Rightarrow> 's \<Rightarrow> 'z \<Rightarrow> 'z"
  assumes foldr_correct:
    "invar s \<Longrightarrow> foldr f s \<sigma> = List.foldr f (\<alpha> s) \<sigma>"

locale poly_al_fold = al +
  constrains \<alpha> :: "'s \<Rightarrow> ('e \<times> 'a::monoid_add) list"
begin
  definition foldl where
    foldl_correct[code_unfold]: "foldl f \<sigma> s = List.foldl f \<sigma> (\<alpha> s)"
  definition foldr where
    foldr_correct[code_unfold]: "foldr f s \<sigma> = List.foldr f (\<alpha> s) \<sigma>"
end

subsubsection "Concatenation of Two Annotated Lists"
locale al_app = al +
  constrains \<alpha> :: "'s \<Rightarrow> ('e \<times> 'a::monoid_add) list"
  fixes app :: "'s \<Rightarrow> 's \<Rightarrow> 's"
  assumes app_correct:
    "\<lbrakk>invar s;invar s'\<rbrakk> \<Longrightarrow> \<alpha> (app s s') = (\<alpha> s) @ (\<alpha> s')"
    "\<lbrakk>invar s;invar s'\<rbrakk> \<Longrightarrow> invar (app s s')"

subsubsection "Readout the Summed up Annotations"
locale al_annot = al +
  constrains \<alpha> :: "'s \<Rightarrow> ('e \<times> 'a::monoid_add) list"
  fixes annot :: "'s \<Rightarrow> 'a"
  assumes annot_correct:
    "invar s \<Longrightarrow> (annot s) = (sum_list (map snd (\<alpha> s)))"

subsubsection "Split by Monotone Predicate"
locale al_splits = al +
  constrains \<alpha> :: "'s \<Rightarrow> ('e \<times> 'a::monoid_add) list"
  fixes splits :: "('a \<Rightarrow> bool) \<Rightarrow> 'a \<Rightarrow> 's \<Rightarrow>
                                ('s \<times> ('e \<times> 'a) \<times> 's)"
  assumes splits_correct:
    "\<lbrakk>invar s;
       \<forall>a b. p a \<longrightarrow> p (a + b);
       \<not> p i;
       p (i + sum_list (map snd (\<alpha> s)));
       (splits p i s) = (l, (e,a), r)\<rbrakk>
      \<Longrightarrow>
        (\<alpha> s) = (\<alpha> l) @ (e,a) # (\<alpha> r)  \<and>
        \<not> p (i + sum_list (map snd (\<alpha> l)))  \<and>
        p (i + sum_list (map snd (\<alpha> l)) + a)  \<and>
        invar l  \<and>
        invar r
    "
begin
  lemma splitsE:
    assumes
    invar: "invar s" and
    mono: "\<forall>a b. p a \<longrightarrow> p (a + b)" and
    init_ff: "\<not> p i" and
    sum_tt: "p (i + sum_list (map snd (\<alpha> s)))"
    obtains l e a r where
    "(splits p i s) = (l, (e,a), r)"
    "(\<alpha> s) = (\<alpha> l) @ (e,a) # (\<alpha> r)"
    "\<not> p (i + sum_list (map snd (\<alpha> l)))"
    "p (i + sum_list (map snd (\<alpha> l)) + a)"
    "invar l"
    "invar r"
    using assms
    apply (cases "splits p i s")
    apply (case_tac b)
    apply (drule_tac i = i and p = p
      and l = a and r = c and e = aa and a = ba in  splits_correct)
    apply (simp_all)
    done
end

subsection "Record Based Interface"
record ('e,'a,'s) alist_ops =
  alist_op_\<alpha> ::"'s \<Rightarrow> ('e \<times> 'a::monoid_add) list"
  alist_op_invar :: "'s \<Rightarrow> bool"
  alist_op_empty :: "unit \<Rightarrow> 's"
  alist_op_isEmpty :: "'s \<Rightarrow> bool"
  alist_op_count :: "'s \<Rightarrow> nat"
  alist_op_consl :: "'e \<Rightarrow> 'a \<Rightarrow> 's \<Rightarrow> 's"
  alist_op_consr :: "'s \<Rightarrow> 'e \<Rightarrow> 'a \<Rightarrow> 's"
  alist_op_head :: "'s \<Rightarrow> ('e \<times> 'a)"
  alist_op_tail :: "'s \<Rightarrow> 's"
  alist_op_headR :: "'s \<Rightarrow> ('e \<times> 'a)"
  alist_op_tailR :: "'s \<Rightarrow> 's"
  alist_op_app :: "'s \<Rightarrow> 's \<Rightarrow> 's"
  alist_op_annot :: "'s \<Rightarrow> 'a"
  alist_op_splits :: "('a \<Rightarrow> bool) \<Rightarrow> 'a \<Rightarrow> 's \<Rightarrow> ('s \<times> ('e \<times> 'a) \<times> 's)"

locale StdALDefs = poly_al_fold "alist_op_\<alpha> ops" "alist_op_invar ops"
  for ops :: "('e,'a::monoid_add,'s,'more) alist_ops_scheme"
begin
  abbreviation \<alpha> where "\<alpha> == alist_op_\<alpha> ops"
  abbreviation invar where "invar == alist_op_invar ops "
  abbreviation empty where "empty == alist_op_empty ops "
  abbreviation isEmpty where "isEmpty == alist_op_isEmpty ops "
  abbreviation count where "count == alist_op_count ops"
  abbreviation consl where "consl == alist_op_consl ops "
  abbreviation consr where "consr == alist_op_consr ops "
  abbreviation head where "head == alist_op_head ops "
  abbreviation tail where "tail == alist_op_tail ops "
  abbreviation headR where "headR == alist_op_headR ops "
  abbreviation tailR where "tailR == alist_op_tailR ops "
  abbreviation app where "app == alist_op_app ops "
  abbreviation annot where "annot == alist_op_annot ops "
  abbreviation splits where "splits == alist_op_splits ops "
end

locale StdAL = StdALDefs ops +
  al \<alpha> invar +
  al_empty \<alpha> invar empty +
  al_isEmpty \<alpha> invar isEmpty +
  al_count \<alpha> invar count +
  al_consl \<alpha> invar consl +
  al_consr \<alpha> invar consr +
  al_head \<alpha> invar head +
  al_tail \<alpha> invar tail +
  al_headR \<alpha> invar headR +
  al_tailR \<alpha> invar tailR +
  al_app \<alpha> invar app +
  al_annot \<alpha> invar annot +
  al_splits \<alpha> invar splits
  for ops
begin
  lemmas correct =
    empty_correct
    isEmpty_correct
    count_correct
    consl_correct
    consr_correct
    head_correct
    tail_correct
    headR_correct
    tailR_correct
    app_correct
    annot_correct
    foldl_correct
    foldr_correct
end

locale StdAL_no_invar = StdAL + al_no_invar \<alpha> invar

end


(*
   Author: Mike Stannett
   Date: 22 October 2012
   m.stannett@sheffield.ac.uk
   Updated 28 April 2016 to run under Isabelle2016.
*)
theory Axioms
imports SpaceTime SomeFunc
begin

record Body =
  Ph :: "bool"
  IOb :: "bool"

class WorldView = SpaceTime +
fixes
  (* Worldview relation *)
  W :: "Body \<Rightarrow> Body \<Rightarrow> 'a Point \<Rightarrow> bool" ("_ sees _ at _")
and
  (* Worldview transformation *)
  wvt :: "Body \<Rightarrow> Body \<Rightarrow> 'a Point \<Rightarrow> 'a Point"
assumes
  AxWVT: "\<lbrakk> IOb m; IOb k \<rbrakk> \<Longrightarrow> (W k b x \<longleftrightarrow> W m b (wvt m k x))"
and
  AxWVTSym: "\<lbrakk> IOb m; IOb k \<rbrakk> \<Longrightarrow> (y = wvt k m x  \<longleftrightarrow>  x = wvt m k y)"
begin
end

(* THE BASIC AXIOMS *)
(* ================ *)

class AxiomPreds = WorldView
begin
  fun sqrtTest :: "'a \<Rightarrow> 'a \<Rightarrow> bool" where
     "sqrtTest x r = ((r \<ge> 0) \<and> (r*r = x))"

  fun cTest :: "Body \<Rightarrow> 'a \<Rightarrow> bool" where
    "cTest m v = ( (v > 0) \<and> ( \<forall>x y . (
               (\<exists>p. (Ph p \<and> W m p x \<and> W m p y)) \<longleftrightarrow> (space2 x y = (v * v)*(time2 x y))
             )))"
end

(*
  AxEuclidean
  Quantities form a Euclidean field, ie positive quantities have
  square roots. We introduce a function, sqrt, that determines them.
*)
class AxEuclidean = AxiomPreds + Quantities +
assumes
  AxEuclidean: "(x \<ge> Groups.zero_class.zero) \<Longrightarrow> (\<exists>r. sqrtTest x r)"
begin

  abbreviation sqrt :: "'a \<Rightarrow> 'a" where
     "sqrt \<equiv> someFunc sqrtTest"

  lemma lemSqrt:
    assumes "x \<ge> 0"
      and   "r = sqrt x"
    shows   "r \<ge> 0  \<and>  r*r = x"
  proof -
    have rootExists: "(\<exists>r. sqrtTest x r)" by (metis AxEuclidean assms(1))
    hence "sqrtTest x (sqrt x)" by (metis lemSomeFunc)
    thus ?thesis using assms(2) by simp
  qed

end

(*
   AxLight
   There is an inertial observer, according to whom, any light
   signal moves with the same velocity in any direction
*)
class AxLight = WorldView +
assumes
  AxLight: "\<exists>m v.( IOb m \<and> (v > (0::'a)) \<and> ( \<forall>x y.(
              (\<exists>p.(Ph p \<and> W m p x \<and> W m p y)) \<longleftrightarrow> (space2 x y = (v * v)*time2 x y)
            )))"
begin
end

(*
  AxPh
  For any inertial observer, the speed of light is the same in every
  direction everywhere, and it is finite. Furthermore, it is possible
  to send out a light signal in any direction.
*)
class AxPh = WorldView + AxiomPreds +
assumes
  AxPh: "IOb m \<Longrightarrow> (\<exists>v. cTest m v)"
begin

  abbreviation c :: "Body \<Rightarrow> 'a" where
    "c \<equiv> someFunc cTest"

  fun lightcone :: "Body \<Rightarrow> 'a Point \<Rightarrow> 'a Cone" where
    "lightcone m v = mkCone v (c m)"

lemma lemCProps:
  assumes "IOb m"
     and  "v = c m"
  shows "(v > 0) \<and> (\<forall>x y.((\<exists>p. (Ph p \<and> W m p x \<and> W m p y))
                      \<longleftrightarrow> ( space2 x y = (c m * c m)*time2 x y )))"
proof -
  have vExists: "(\<exists>v. cTest m v)" by (metis AxPh assms(1))
  hence "cTest m (c m)" by (metis lemSomeFunc)
  thus ?thesis using assms(2) by simp
qed

lemma lemCCone:
  assumes "IOb m"
    and   "onCone y (lightcone m x)"
  shows   "\<exists>p. (Ph p \<and> W m p x \<and> W m p y)"
proof -
  have "(\<exists>p.(Ph p \<and> W m p x \<and> W m p y))
                      \<longleftrightarrow> ( space2 x y = (c m * c m)*time2 x y )"
    by (smt assms(1) lemCProps)
  hence ph_exists: "(space2 x y = (c m * c m)*time2 x y) \<longrightarrow> (\<exists>p.(Ph p \<and> W m p x \<and> W m p y))"
    by metis
  define lcmx where "lcmx = lightcone m x"
  have lcmx_vertex: "vertex lcmx = x" by (simp add: lcmx_def)
  have lcmx_slope: "slope lcmx = c m" by (simp add: lcmx_def)
  have "onCone y lcmx \<longrightarrow> (space2 x y = (c m * c m)*time2 x y)"
    by (metis lcmx_vertex lcmx_slope onCone.simps)
  hence "space2 x y = (c m * c m)*time2 x y" by (metis lcmx_def assms(2))
  thus ?thesis by (metis ph_exists)
qed

lemma lemCPos:
  assumes "IOb m"
  shows   "c m > 0"
  by (metis assms(1) lemCProps)

lemma lemCPhoton:
  assumes "IOb m"
  shows "\<forall>x y. (\<exists>p. (Ph p \<and> W m p x \<and> W m p y)) \<longleftrightarrow> (space2 x y = (c m * c m)*(time2 x y))"
  by (metis assms(1) lemCProps)

end

(*
  AxEv
  Inertial observers see the same events (meetings of bodies).
  This also enables us to discuss the worldview transformation.
*)
class AxEv = WorldView +
assumes
  AxEv: "\<lbrakk> IOb m; IOb k\<rbrakk> \<Longrightarrow>  (\<exists>y. (\<forall>b. (W m b x  \<longleftrightarrow> W k b y)))"
begin
end

(*
  Inertial observers can move with any speed slower than that of light
*)
class AxThExp = WorldView + AxPh +
assumes
    AxThExp: "IOb m \<Longrightarrow> (\<forall>x y .(
       (\<exists>k.(IOb k \<and> W m k x \<and> W m k y)) \<longleftrightarrow> (space2 x y < (c m * c m) * time2 x y)
       ))"

begin
end

(*
  Every inertial observer is stationary according to himself
*)
class AxSelf = WorldView +
assumes
  AxSelf: "IOb m  \<Longrightarrow>  (W m m x) \<longrightarrow> (onAxisT x)"
begin
end

(*
  All inertial observers agree that the speed of light is 1
*)
class AxC = WorldView + AxPh +
assumes
  AxC: "IOb m \<Longrightarrow> c m = 1"
begin
end

(*
  Inertial observers agree as to the spatial distance between two
  events if these two events are simultaneous for both of them.
*)
class AxSym = WorldView +
assumes
  AxSym: "\<lbrakk> IOb m; IOb k \<rbrakk> \<Longrightarrow>
            (W m e x \<and> W m f y \<and> W k e x'\<and> W k f y' \<and>
            tval x = tval y \<and> tval x' = tval y' )
          \<longrightarrow> (space2 x y = space2 x' y')"
begin
end

(*
  AxLines
  All observers agree about lines
*)
class AxLines = WorldView +
assumes
  AxLines: "\<lbrakk> IOb m; IOb k; collinear x p q \<rbrakk> \<Longrightarrow>
     collinear (wvt k m x) (wvt k m p) (wvt k m q)"
begin
end

(*
  AxPlanes
  All observers agree about planes
*)
class AxPlanes = WorldView +
assumes
  AxPlanes: "\<lbrakk> IOb m; IOb k \<rbrakk> \<Longrightarrow>
     (coplanar e x y z  \<longrightarrow> coplanar (wvt k m e) (wvt k m x) (wvt k m y) (wvt k m z))"
begin
end

(*
  AxCones
  All observers agree about lightcones
*)
class AxCones = WorldView + AxPh +
assumes
  AxCones: "\<lbrakk> IOb m; IOb k \<rbrakk> \<Longrightarrow>
     ( onCone x (lightCone m v) \<longrightarrow> onCone (wvt k m x) (lightcone k (wvt k m v)))"
begin
end

(*
  All inertial observers see time travelling in the same direction. That
  is, if m thinks that k reached y after he reached x, then
  k should also think that he reached y after he reached x.
*)
class AxTime = WorldView +
assumes
  AxTime: "\<lbrakk> IOb m; IOb k \<rbrakk>
              \<Longrightarrow>( x \<lesssim> y \<longrightarrow> wvt k m x \<lesssim> wvt k m y )"
begin
end

end


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

datatype Nat = Z | S "Nat"

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

fun add3acc :: "Nat => Nat => Nat => Nat" where
  "add3acc (Z) (Z) z = z"
| "add3acc (Z) (S x3) z = add3acc Z x3 (S z)"
| "add3acc (S x2) y z = add3acc x2 (S y) z"

fun mul3acc :: "Nat => Nat => Nat => Nat" where
  "mul3acc (Z) y z = Z"
| "mul3acc (S x2) (Z) z = Z"
| "mul3acc (S x2) (S x3) (Z) = Z"
| "mul3acc (S x2) (S x3) (S x4) =
     (let fail :: Nat =
       plus
         (S Z)
         (add3acc
            (mul3acc x2 x3 x4)
            (add3acc
               (mul3acc (S Z) x3 x4) (mul3acc x2 (S Z) x4) (mul3acc x2 x3 (S Z)))
            (add3acc (S x2) (S x3) (S x4)))
     in (if (x2 = Z) then
           (if (x3 = Z) then (if (x4 = Z) then S Z else fail) else fail)
           else
           fail))"

theorem property0 :
  "((mul3acc x y z) = (mul3acc y x z))"
  oops

end


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

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

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

fun filter :: "('a => bool) => 'a list => 'a list" where
  "filter p (nil2) = nil2"
| "filter p (cons2 z xs) =
     (if p z then cons2 z (filter p xs) else filter p xs)"

(*fun did not finish the proof*)
function qsort :: "int list => int list" where
  "qsort (nil2) = nil2"
| "qsort (cons2 z xs) =
     x (qsort (filter (% (z2 :: int) => z2 <= z) xs))
       (x (cons2 z (nil2)) (qsort (filter (% (x2 :: int) => x2 > z) xs)))"
  by pat_completeness auto

fun count :: "'a => 'a list => int" where
  "count y (nil2) = 0"
| "count y (cons2 z2 ys) =
     (if (y = z2) then 1 + (count y ys) else count y ys)"

theorem property0 :
  "((count y (qsort xs)) = (count y xs))"
  oops

end


theory isar_sketching_tests
imports Main
begin

(*
lemma "thm"
proof
  have l1 using ... by sorry
  ...
  have ln using ... by sorry
  shows "thm" using l1 ... ln by auto
*)

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

lemma test2: "\<not> surj(f :: 'a \<Rightarrow> 'a set)"
proof
  assume surj: "surj f"
  have diagonal_argument: "\<exists>a. {x. x \<notin> f x} = f a" using surj by sorry
  show "False" using diagonal_argument by blast
qed

end


(*  Title:      HOL/UNITY/Guar.thy
    Author:     Lawrence C Paulson, Cambridge University Computer Laboratory
    Author:     Sidi Ehmety

From Chandy and Sanders, "Reasoning About Program Composition",
Technical Report 2000-003, University of Florida, 2000.

Compatibility, weakest guarantees, etc.  and Weakest existential
property, from Charpentier and Chandy "Theorems about Composition",
Fifth International Conference on Mathematics of Program, 2000.
*)

section{*Guarantees Specifications*}

theory Guar
imports Comp
begin

instance program :: (type) order
  by default (auto simp add: program_less_le dest: component_antisym intro: component_trans)

text{*Existential and Universal properties.  I formalize the two-program
      case, proving equivalence with Chandy and Sanders's n-ary definitions*}

definition ex_prop :: "'a program set => bool" where
   "ex_prop X == \<forall>F G. F ok G -->F \<in> X | G \<in> X --> (F\<squnion>G) \<in> X"

definition strict_ex_prop  :: "'a program set => bool" where
   "strict_ex_prop X == \<forall>F G.  F ok G --> (F \<in> X | G \<in> X) = (F\<squnion>G \<in> X)"

definition uv_prop  :: "'a program set => bool" where
   "uv_prop X == SKIP \<in> X & (\<forall>F G. F ok G --> F \<in> X & G \<in> X --> (F\<squnion>G) \<in> X)"

definition strict_uv_prop  :: "'a program set => bool" where
   "strict_uv_prop X ==
      SKIP \<in> X & (\<forall>F G. F ok G --> (F \<in> X & G \<in> X) = (F\<squnion>G \<in> X))"

text{*Guarantees properties*}

definition guar :: "['a program set, 'a program set] => 'a program set" (infixl "guarantees" 55) where
          (*higher than membership, lower than Co*)
   "X guarantees Y == {F. \<forall>G. F ok G --> F\<squnion>G \<in> X --> F\<squnion>G \<in> Y}"

  (* Weakest guarantees *)
definition wg :: "['a program, 'a program set] => 'a program set" where
  "wg F Y == Union({X. F \<in> X guarantees Y})"

   (* Weakest existential property stronger than X *)
definition wx :: "('a program) set => ('a program)set" where
   "wx X == Union({Y. Y \<subseteq> X & ex_prop Y})"

  (*Ill-defined programs can arise through "Join"*)
definition welldef :: "'a program set" where
  "welldef == {F. Init F \<noteq> {}}"

definition refines :: "['a program, 'a program, 'a program set] => bool"
                        ("(3_ refines _ wrt _)" [10,10,10] 10) where
  "G refines F wrt X ==
     \<forall>H. (F ok H & G ok H & F\<squnion>H \<in> welldef \<inter> X) -->
         (G\<squnion>H \<in> welldef \<inter> X)"

definition iso_refines :: "['a program, 'a program, 'a program set] => bool"
                              ("(3_ iso'_refines _ wrt _)" [10,10,10] 10) where
  "G iso_refines F wrt X ==
   F \<in> welldef \<inter> X --> G \<in> welldef \<inter> X"

lemma OK_insert_iff:
     "(OK (insert i I) F) =
      (if i \<in> I then OK I F else OK I F & (F i ok JOIN I F))"
by (auto intro: ok_sym simp add: OK_iff_ok)

subsection{*Existential Properties*}

lemma ex1:
  assumes "ex_prop X" and "finite GG"
  shows "GG \<inter> X \<noteq> {} \<Longrightarrow> OK GG (%G. G) \<Longrightarrow> (\<Squnion>G \<in> GG. G) \<in> X"
  apply (atomize (full))
  using assms(2) apply induct
   using assms(1) apply (unfold ex_prop_def)
   apply (auto simp add: OK_insert_iff Int_insert_left)
  done

lemma ex2:
     "\<forall>GG. finite GG & GG \<inter> X \<noteq> {} --> OK GG (%G. G) -->(\<Squnion>G \<in> GG. G):X
      ==> ex_prop X"
apply (unfold ex_prop_def, clarify)
apply (drule_tac x = "{F,G}" in spec)
apply (auto dest: ok_sym simp add: OK_iff_ok)
done

(*Chandy & Sanders take this as a definition*)
lemma ex_prop_finite:
     "ex_prop X =
      (\<forall>GG. finite GG & GG \<inter> X \<noteq> {} & OK GG (%G. G)--> (\<Squnion>G \<in> GG. G) \<in> X)"
by (blast intro: ex1 ex2)

(*Their "equivalent definition" given at the end of section 3*)
lemma ex_prop_equiv:
     "ex_prop X = (\<forall>G. G \<in> X = (\<forall>H. (G component_of H) --> H \<in> X))"
apply auto
apply (unfold ex_prop_def component_of_def, safe, blast, blast)
apply (subst Join_commute)
apply (drule ok_sym, blast)
done

subsection{*Universal Properties*}

lemma uv1:
  assumes "uv_prop X"
    and "finite GG"
    and "GG \<subseteq> X"
    and "OK GG (%G. G)"
  shows "(\<Squnion>G \<in> GG. G) \<in> X"
  using assms(2-)
  apply induct
   using assms(1)
   apply (unfold uv_prop_def)
   apply (auto simp add: Int_insert_left OK_insert_iff)
  done

lemma uv2:
     "\<forall>GG. finite GG & GG \<subseteq> X & OK GG (%G. G) --> (\<Squnion>G \<in> GG. G) \<in> X
      ==> uv_prop X"
apply (unfold uv_prop_def)
apply (rule conjI)
 apply (drule_tac x = "{}" in spec)
 prefer 2
 apply clarify
 apply (drule_tac x = "{F,G}" in spec)
apply (auto dest: ok_sym simp add: OK_iff_ok)
done

(*Chandy & Sanders take this as a definition*)
lemma uv_prop_finite:
     "uv_prop X =
      (\<forall>GG. finite GG & GG \<subseteq> X & OK GG (%G. G) --> (\<Squnion>G \<in> GG. G): X)"
by (blast intro: uv1 uv2)

subsection{*Guarantees*}

lemma guaranteesI:
     "(!!G. [| F ok G; F\<squnion>G \<in> X |] ==> F\<squnion>G \<in> Y) ==> F \<in> X guarantees Y"
by (simp add: guar_def component_def)

lemma guaranteesD:
     "[| F \<in> X guarantees Y;  F ok G;  F\<squnion>G \<in> X |] ==> F\<squnion>G \<in> Y"
by (unfold guar_def component_def, blast)

(*This version of guaranteesD matches more easily in the conclusion
  The major premise can no longer be  F \<subseteq> H since we need to reason about G*)
lemma component_guaranteesD:
     "[| F \<in> X guarantees Y;  F\<squnion>G = H;  H \<in> X;  F ok G |] ==> H \<in> Y"
by (unfold guar_def, blast)

lemma guarantees_weaken:
     "[| F \<in> X guarantees X'; Y \<subseteq> X; X' \<subseteq> Y' |] ==> F \<in> Y guarantees Y'"
by (unfold guar_def, blast)

lemma subset_imp_guarantees_UNIV: "X \<subseteq> Y ==> X guarantees Y = UNIV"
by (unfold guar_def, blast)

(*Equivalent to subset_imp_guarantees_UNIV but more intuitive*)
lemma subset_imp_guarantees: "X \<subseteq> Y ==> F \<in> X guarantees Y"
by (unfold guar_def, blast)

(*Remark at end of section 4.1 *)

lemma ex_prop_imp: "ex_prop Y ==> (Y = UNIV guarantees Y)"
apply (simp (no_asm_use) add: guar_def ex_prop_equiv)
apply safe
 apply (drule_tac x = x in spec)
 apply (drule_tac [2] x = x in spec)
 apply (drule_tac [2] sym)
apply (auto simp add: component_of_def)
done

lemma guarantees_imp: "(Y = UNIV guarantees Y) ==> ex_prop(Y)"
by (auto simp add: guar_def ex_prop_equiv component_of_def dest: sym)

lemma ex_prop_equiv2: "(ex_prop Y) = (Y = UNIV guarantees Y)"
apply (rule iffI)
apply (rule ex_prop_imp)
apply (auto simp add: guarantees_imp)
done

subsection{*Distributive Laws.  Re-Orient to Perform Miniscoping*}

lemma guarantees_UN_left:
     "(\<Union>i \<in> I. X i) guarantees Y = (\<Inter>i \<in> I. X i guarantees Y)"
by (unfold guar_def, blast)

lemma guarantees_Un_left:
     "(X \<union> Y) guarantees Z = (X guarantees Z) \<inter> (Y guarantees Z)"
by (unfold guar_def, blast)

lemma guarantees_INT_right:
     "X guarantees (\<Inter>i \<in> I. Y i) = (\<Inter>i \<in> I. X guarantees Y i)"
by (unfold guar_def, blast)

lemma guarantees_Int_right:
     "Z guarantees (X \<inter> Y) = (Z guarantees X) \<inter> (Z guarantees Y)"
by (unfold guar_def, blast)

lemma guarantees_Int_right_I:
     "[| F \<in> Z guarantees X;  F \<in> Z guarantees Y |]
     ==> F \<in> Z guarantees (X \<inter> Y)"
by (simp add: guarantees_Int_right)

lemma guarantees_INT_right_iff:
     "(F \<in> X guarantees (INTER I Y)) = (\<forall>i\<in>I. F \<in> X guarantees (Y i))"
by (simp add: guarantees_INT_right)

lemma shunting: "(X guarantees Y) = (UNIV guarantees (-X \<union> Y))"
by (unfold guar_def, blast)

lemma contrapositive: "(X guarantees Y) = -Y guarantees -X"
by (unfold guar_def, blast)

(** The following two can be expressed using intersection and subset, which
    is more faithful to the text but looks cryptic.
**)

lemma combining1:
    "[| F \<in> V guarantees X;  F \<in> (X \<inter> Y) guarantees Z |]
     ==> F \<in> (V \<inter> Y) guarantees Z"
by (unfold guar_def, blast)

lemma combining2:
    "[| F \<in> V guarantees (X \<union> Y);  F \<in> Y guarantees Z |]
     ==> F \<in> V guarantees (X \<union> Z)"
by (unfold guar_def, blast)

(** The following two follow Chandy-Sanders, but the use of object-quantifiers
    does not suit Isabelle... **)

(*Premise should be (!!i. i \<in> I ==> F \<in> X guarantees Y i) *)
lemma all_guarantees:
     "\<forall>i\<in>I. F \<in> X guarantees (Y i) ==> F \<in> X guarantees (\<Inter>i \<in> I. Y i)"
by (unfold guar_def, blast)

(*Premises should be [| F \<in> X guarantees Y i; i \<in> I |] *)
lemma ex_guarantees:
     "\<exists>i\<in>I. F \<in> X guarantees (Y i) ==> F \<in> X guarantees (\<Union>i \<in> I. Y i)"
by (unfold guar_def, blast)

subsection{*Guarantees: Additional Laws (by lcp)*}

lemma guarantees_Join_Int:
    "[| F \<in> U guarantees V;  G \<in> X guarantees Y; F ok G |]
     ==> F\<squnion>G \<in> (U \<inter> X) guarantees (V \<inter> Y)"
apply (simp add: guar_def, safe)
 apply (simp add: Join_assoc)
apply (subgoal_tac "F\<squnion>G\<squnion>Ga = G\<squnion>(F\<squnion>Ga) ")
 apply (simp add: ok_commute)
apply (simp add: Join_ac)
done

lemma guarantees_Join_Un:
    "[| F \<in> U guarantees V;  G \<in> X guarantees Y; F ok G |]
     ==> F\<squnion>G \<in> (U \<union> X) guarantees (V \<union> Y)"
apply (simp add: guar_def, safe)
 apply (simp add: Join_assoc)
apply (subgoal_tac "F\<squnion>G\<squnion>Ga = G\<squnion>(F\<squnion>Ga) ")
 apply (simp add: ok_commute)
apply (simp add: Join_ac)
done

lemma guarantees_JN_INT:
     "[| \<forall>i\<in>I. F i \<in> X i guarantees Y i;  OK I F |]
      ==> (JOIN I F) \<in> (INTER I X) guarantees (INTER I Y)"
apply (unfold guar_def, auto)
apply (drule bspec, assumption)
apply (rename_tac "i")
apply (drule_tac x = "JOIN (I-{i}) F\<squnion>G" in spec)
apply (auto intro: OK_imp_ok
            simp add: Join_assoc [symmetric] JN_Join_diff JN_absorb)
done

lemma guarantees_JN_UN:
    "[| \<forall>i\<in>I. F i \<in> X i guarantees Y i;  OK I F |]
     ==> (JOIN I F) \<in> (UNION I X) guarantees (UNION I Y)"
apply (unfold guar_def, auto)
apply (drule bspec, assumption)
apply (rename_tac "i")
apply (drule_tac x = "JOIN (I-{i}) F\<squnion>G" in spec)
apply (auto intro: OK_imp_ok
            simp add: Join_assoc [symmetric] JN_Join_diff JN_absorb)
done

subsection{*Guarantees Laws for Breaking Down the Program (by lcp)*}

lemma guarantees_Join_I1:
     "[| F \<in> X guarantees Y;  F ok G |] ==> F\<squnion>G \<in> X guarantees Y"
by (simp add: guar_def Join_assoc)

lemma guarantees_Join_I2:
     "[| G \<in> X guarantees Y;  F ok G |] ==> F\<squnion>G \<in> X guarantees Y"
apply (simp add: Join_commute [of _ G] ok_commute [of _ G])
apply (blast intro: guarantees_Join_I1)
done

lemma guarantees_JN_I:
     "[| i \<in> I;  F i \<in> X guarantees Y;  OK I F |]
      ==> (\<Squnion>i \<in> I. (F i)) \<in> X guarantees Y"
apply (unfold guar_def, clarify)
apply (drule_tac x = "JOIN (I-{i}) F\<squnion>G" in spec)
apply (auto intro: OK_imp_ok simp add: JN_Join_diff Join_assoc [symmetric])
done

(*** well-definedness ***)

lemma Join_welldef_D1: "F\<squnion>G \<in> welldef ==> F \<in> welldef"
by (unfold welldef_def, auto)

lemma Join_welldef_D2: "F\<squnion>G \<in> welldef ==> G \<in> welldef"
by (unfold welldef_def, auto)

(*** refinement ***)

lemma refines_refl: "F refines F wrt X"
by (unfold refines_def, blast)

(*We'd like transitivity, but how do we get it?*)
lemma refines_trans:
     "[| H refines G wrt X;  G refines F wrt X |] ==> H refines F wrt X"
apply (simp add: refines_def)
oops

lemma strict_ex_refine_lemma:
     "strict_ex_prop X
      ==> (\<forall>H. F ok H & G ok H & F\<squnion>H \<in> X --> G\<squnion>H \<in> X)
              = (F \<in> X --> G \<in> X)"
by (unfold strict_ex_prop_def, auto)

lemma strict_ex_refine_lemma_v:
     "strict_ex_prop X
      ==> (\<forall>H. F ok H & G ok H & F\<squnion>H \<in> welldef & F\<squnion>H \<in> X --> G\<squnion>H \<in> X) =
          (F \<in> welldef \<inter> X --> G \<in> X)"
apply (unfold strict_ex_prop_def, safe)
apply (erule_tac x = SKIP and P = "%H. ?PP H --> ?RR H" in allE)
apply (auto dest: Join_welldef_D1 Join_welldef_D2)
done

lemma ex_refinement_thm:
     "[| strict_ex_prop X;
         \<forall>H. F ok H & G ok H & F\<squnion>H \<in> welldef \<inter> X --> G\<squnion>H \<in> welldef |]
      ==> (G refines F wrt X) = (G iso_refines F wrt X)"
apply (rule_tac x = SKIP in allE, assumption)
apply (simp add: refines_def iso_refines_def strict_ex_refine_lemma_v)
done

lemma strict_uv_refine_lemma:
     "strict_uv_prop X ==>
      (\<forall>H. F ok H & G ok H & F\<squnion>H \<in> X --> G\<squnion>H \<in> X) = (F \<in> X --> G \<in> X)"
by (unfold strict_uv_prop_def, blast)

lemma strict_uv_refine_lemma_v:
     "strict_uv_prop X
      ==> (\<forall>H. F ok H & G ok H & F\<squnion>H \<in> welldef & F\<squnion>H \<in> X --> G\<squnion>H \<in> X) =
          (F \<in> welldef \<inter> X --> G \<in> X)"
apply (unfold strict_uv_prop_def, safe)
apply (erule_tac x = SKIP and P = "%H. ?PP H --> ?RR H" in allE)
apply (auto dest: Join_welldef_D1 Join_welldef_D2)
done

lemma uv_refinement_thm:
     "[| strict_uv_prop X;
         \<forall>H. F ok H & G ok H & F\<squnion>H \<in> welldef \<inter> X -->
             G\<squnion>H \<in> welldef |]
      ==> (G refines F wrt X) = (G iso_refines F wrt X)"
apply (rule_tac x = SKIP in allE, assumption)
apply (simp add: refines_def iso_refines_def strict_uv_refine_lemma_v)
done

(* Added by Sidi Ehmety from Chandy & Sander, section 6 *)
lemma guarantees_equiv:
    "(F \<in> X guarantees Y) = (\<forall>H. H \<in> X \<longrightarrow> (F component_of H \<longrightarrow> H \<in> Y))"
by (unfold guar_def component_of_def, auto)

lemma wg_weakest: "!!X. F\<in> (X guarantees Y) ==> X \<subseteq> (wg F Y)"
by (unfold wg_def, auto)

lemma wg_guarantees: "F\<in> ((wg F Y) guarantees Y)"
by (unfold wg_def guar_def, blast)

lemma wg_equiv: "(H \<in> wg F X) = (F component_of H --> H \<in> X)"
by (simp add: guarantees_equiv wg_def, blast)

lemma component_of_wg: "F component_of H ==> (H \<in> wg F X) = (H \<in> X)"
by (simp add: wg_equiv)

lemma wg_finite:
    "\<forall>FF. finite FF & FF \<inter> X \<noteq> {} --> OK FF (%F. F)
          --> (\<forall>F\<in>FF. ((\<Squnion>F \<in> FF. F): wg F X) = ((\<Squnion>F \<in> FF. F):X))"
apply clarify
apply (subgoal_tac "F component_of (\<Squnion>F \<in> FF. F) ")
apply (drule_tac X = X in component_of_wg, simp)
apply (simp add: component_of_def)
apply (rule_tac x = "\<Squnion>F \<in> (FF-{F}) . F" in exI)
apply (auto intro: JN_Join_diff dest: ok_sym simp add: OK_iff_ok)
done

lemma wg_ex_prop: "ex_prop X ==> (F \<in> X) = (\<forall>H. H \<in> wg F X)"
apply (simp (no_asm_use) add: ex_prop_equiv wg_equiv)
apply blast
done

(** From Charpentier and Chandy "Theorems About Composition" **)
(* Proposition 2 *)
lemma wx_subset: "(wx X)<=X"
by (unfold wx_def, auto)

lemma wx_ex_prop: "ex_prop (wx X)"
apply (simp add: wx_def ex_prop_equiv cong: bex_cong, safe, blast)
apply force
done

lemma wx_weakest: "\<forall>Z. Z<= X --> ex_prop Z --> Z \<subseteq> wx X"
by (auto simp add: wx_def)

(* Proposition 6 *)
lemma wx'_ex_prop: "ex_prop({F. \<forall>G. F ok G --> F\<squnion>G \<in> X})"
apply (unfold ex_prop_def, safe)
 apply (drule_tac x = "G\<squnion>Ga" in spec)
 apply (force simp add: Join_assoc)
apply (drule_tac x = "F\<squnion>Ga" in spec)
apply (simp add: ok_commute  Join_ac)
done

text{* Equivalence with the other definition of wx *}

lemma wx_equiv: "wx X = {F. \<forall>G. F ok G --> (F\<squnion>G) \<in> X}"
apply (unfold wx_def, safe)
 apply (simp add: ex_prop_def, blast)
apply (simp (no_asm))
apply (rule_tac x = "{F. \<forall>G. F ok G --> F\<squnion>G \<in> X}" in exI, safe)
apply (rule_tac [2] wx'_ex_prop)
apply (drule_tac x = SKIP in spec)+
apply auto
done

text{* Propositions 7 to 11 are about this second definition of wx.
   They are the same as the ones proved for the first definition of wx,
 by equivalence *}

(* Proposition 12 *)
(* Main result of the paper *)
lemma guarantees_wx_eq: "(X guarantees Y) = wx(-X \<union> Y)"
by (simp add: guar_def wx_equiv)

(* Rules given in section 7 of Chandy and Sander's
    Reasoning About Program composition paper *)
lemma stable_guarantees_Always:
     "Init F \<subseteq> A ==> F \<in> (stable A) guarantees (Always A)"
apply (rule guaranteesI)
apply (simp add: Join_commute)
apply (rule stable_Join_Always1)
 apply (simp_all add: invariant_def)
done

lemma constrains_guarantees_leadsTo:
     "F \<in> transient A ==> F \<in> (A co A \<union> B) guarantees (A leadsTo (B-A))"
apply (rule guaranteesI)
apply (rule leadsTo_Basis')
 apply (drule constrains_weaken_R)
  prefer 2 apply assumption
 apply blast
apply (blast intro: Join_transient_I1)
done

end


(*  File:       Minimax_Module.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>Minimax Module\<close>

theory Minimax_Module
  imports "Component_Types/Elimination_Module"
begin

text \<open>
  This is the Minimax module used by the Minimax voting rule. The Minimax rule
  elects the alternatives with the highest Minimax score. The module implemented
  herein only rejects the alternatives not elected by the voting rule, and defers
  the alternatives that would be elected by the full voting rule.
\<close>

subsection \<open>Definition\<close>

fun minimax_score :: "'a Evaluation_Function" where
  "minimax_score x A p =
    Min {prefer_count p x y | y . y \<in> A - {x}}"

fun minimax :: "'a Electoral_Module" where
  "minimax A p = max_eliminator minimax_score A p"

subsection \<open>Lemma\<close>

lemma non_cond_winner_minimax_score:
  assumes
    prof: "profile A p" and
    winner: "condorcet_winner A p w" and
    l_in_A: "l \<in> A" and
    l_neq_w: "l \<noteq> w"
  shows "minimax_score l A p \<le> prefer_count p l w"
proof (simp)
  let
    ?set = "{prefer_count p l y | y . y \<in> A - {l}}" and
      ?lscore = "minimax_score l A p"
  have "finite A"
    using prof winner
    by simp
  hence "finite (A - {l})"
    using finite_Diff
    by simp
  hence finite: "finite ?set"
    by simp
  have "w \<in> A"
    using winner
    by simp
  hence 0: "w \<in> A - {l}"
    using l_neq_w
    by force
  hence not_empty: "?set \<noteq> {}"
    by blast
  have "?lscore = Min ?set"
    by simp
  hence 1: "?lscore \<in> ?set \<and> (\<forall> p \<in> ?set. ?lscore \<le> p)"
    using local.finite not_empty Min_le Min_eq_iff
    by (metis (no_types, lifting))
  thus "Min {card {i. i < length p \<and> (y, l) \<in> p!i} | y. y \<in> A \<and> y \<noteq> l} \<le>
          card {i. i < length p \<and> (w, l) \<in> p!i}"
    using 0
    by auto
qed

subsection \<open>Property\<close>

theorem minimax_score_cond_rating: "condorcet_rating minimax_score"
proof (unfold condorcet_rating_def minimax_score.simps prefer_count.simps, safe, rule ccontr)
  fix
    A :: "'a set" and
    p :: "'a Profile" and
    w :: "'a" and
    l :: "'a"
  assume
    winner: "condorcet_winner A p w" and
    l_in_A: "l \<in> A" and
    l_neq_w:"l \<noteq> w" and
    min_leq:
      "\<not> Min {card {i. i < length p \<and> (let r = (p!i) in (y \<preceq>\<^sub>r l))} |
        y. y \<in> A - {l}} <
      Min {card {i. i < length p \<and> (let r = (p!i) in (y \<preceq>\<^sub>r w))} |
          y. y \<in> A - {w}}"
  hence 000:
    "Min {prefer_count p l y | y. y \<in> A - {l}} \<ge>
        Min {prefer_count p w y | y. y \<in> A - {w}}"
    by auto
  have prof: "profile A p"
    using condorcet_winner.simps winner
    by metis
  from prof winner l_in_A l_neq_w
  have 100:
    "prefer_count p l w  \<ge> Min {prefer_count p l y | y . y \<in> A - {l}}"
    using non_cond_winner_minimax_score minimax_score.simps
    by metis
  from l_in_A
  have l_in_A_without_w: "l \<in> A - {w}"
    by (simp add: l_neq_w)
  hence 2: "{prefer_count p w y | y . y \<in> A - {w}} \<noteq> {}"
    by blast
  have "finite (A - {w})"
    using prof condorcet_winner.simps winner finite_Diff
    by metis
  hence 3: "finite {prefer_count p w y | y . y \<in> A - {w}}"
    by simp
  from 2 3
  have 4:
    "\<exists> n \<in> A - {w} . prefer_count p w n =
      Min {prefer_count p w y | y . y \<in> A - {w}}"
    using Min_in
    by fastforce
  then obtain n where 200:
    "prefer_count p w n =
        Min {prefer_count p w y | y . y \<in> A - {w}}" and
    6: "n \<in> A - {w}"
    by metis
  hence n_in_A: "n \<in> A"
    using DiffE
    by metis
  from 6
  have n_neq_w: "n \<noteq> w"
    by simp
  from winner
  have w_in_A: "w \<in> A"
    by simp
  from 6 prof winner
  have 300: "prefer_count p w n > prefer_count p n w"
    by simp
  from 100 000 200
  have 400: "prefer_count p l w \<ge> prefer_count p w n"
    by linarith
  with prof n_in_A w_in_A l_in_A n_neq_w
       l_neq_w pref_count_sym
  have 700: "prefer_count p n w \<ge> prefer_count p w l"
    by metis
  have "prefer_count p l w > prefer_count p w l"
    using "300" "400" "700"
    by linarith
  hence "wins l p w"
    by simp
  thus False
    using l_in_A_without_w wins_antisym winner
    unfolding condorcet_winner.simps
    by metis
qed

theorem minimax_is_dcc: "defer_condorcet_consistency minimax"
proof (unfold defer_condorcet_consistency_def electoral_module_def, safe)
  fix
    A :: "'a set" and
    p :: "'a Profile"
  assume
    finA: "finite A" and
    profA: "profile A p"
  have "well_formed A (max_eliminator minimax_score A p)"
    using finA max_elim_sound par_comp_result_sound profA
    by metis
  thus "well_formed A (minimax A p)"
    by simp
next
  fix
    A :: "'a set" and
    p :: "'a Profile" and
    w :: "'a"
  assume
    cwin_w: "condorcet_winner A p w" and
    finA: "finite A"
  have max_mmaxscore_dcc:
    "defer_condorcet_consistency (max_eliminator minimax_score)"
    using cr_eval_imp_dcc_max_elim
    by (simp add: minimax_score_cond_rating)
  hence
    "max_eliminator minimax_score A p =
      ({},
       A - defer (max_eliminator minimax_score) A p,
       {a \<in> A. condorcet_winner A p a})"
    using cwin_w finA
    unfolding defer_condorcet_consistency_def
    by (metis (no_types))
  thus
    "minimax A p =
      ({},
       A - defer minimax A p,
       {d \<in> A. condorcet_winner A p d})"
    by simp
qed

end


header {* Concrete setting *}

theory Concrete
imports Syntactic_Criteria After_Execution
begin

lemma (in PL_Indis) WbisT_If_cross:
  assumes "c1 \<approx>wT c2" "c1 \<approx>wT c1" "c2 \<approx>wT c2"
  shows "(If tst c1 c2) \<approx>wT (If tst c1 c2)"
proof -
  def \<phi> \<equiv> "\<lambda>c d. \<exists>c1' c2'. c = If tst c1' c2' \<and> d = If tst c1' c2' \<and> c1' \<approx>wT c2' \<and> c1' \<approx>wT c1' \<and> c2' \<approx>wT c2'"
  with assms have "\<phi> (If tst c1 c2) (If tst c1 c2)" by auto
  then show ?thesis
  proof (induct rule: WbisT_coinduct[where \<phi>=\<phi>])
    case (cont c s d t c' s')
    note cont(2,3)
    moreover from cont obtain c1 c2
      where \<phi>: "c = If tst c1 c2" "d = If tst c1 c2" "c1 \<approx>wT c2" "c1 \<approx>wT c1" "c2 \<approx>wT c2"
      by (auto simp: \<phi>_def)
    moreover then have "c2 \<approx>wT c1"
      using WbisT_sym unfolding sym_def by blast
    ultimately have "(d, t) \<rightarrow>*c (if tval tst t then c1 else c2, t) \<and> s' \<approx> t \<and>
      (\<phi> c' (if tval tst t then c1 else c2) \<or> c' \<approx>wT (if tval tst t then c1 else c2))"
      by (auto simp: \<phi>_def)
    then show ?case by auto
  qed (auto simp: \<phi>_def)
qed

text{*

We instatiate the following notions, kept generic so far:

\begin{itemize}
  \item On the language syntax:
  \begin{itemize}
    \item atoms, tests and states just like at the possibilistic case;
    \item choices, to either if-choices (based on tests) or binary fixed-probability choices;
    \item the schedulers, to the uniform one
  \end{itemize}
  \item On the security semantics, the lattice of levels and the indis relation, again, just like at the possibilistic case.
\end{itemize}
*}

datatype level = Lo | Hi

lemma [dest]: "\<And> l A. \<lbrakk>l \<in> A; Lo \<notin> A\<rbrakk> \<Longrightarrow> l = Hi" and
      [dest]: "\<And> l A. \<lbrakk>l \<in> A; Hi \<notin> A\<rbrakk> \<Longrightarrow> l = Lo"
by (metis level.exhaust)+

declare level.split[split]

instantiation level :: complete_lattice
begin
  definition top_level: "top \<equiv> Hi"
  definition bot_level: "bot \<equiv> Lo"
  definition inf_level: "inf l1 l2 \<equiv> if Lo \<in> {l1,l2} then Lo else Hi"
  definition sup_level: "sup l1 l2 \<equiv> if Hi \<in> {l1,l2} then Hi else Lo"
  definition less_eq_level: "less_eq l1 l2 \<equiv> (l1 = Lo \<or> l2 = Hi)"
  definition less_level: "less l1 l2 \<equiv> l1 = Lo \<and> l2 = Hi"
  definition Inf_level: "Inf L \<equiv> if Lo \<in> L then Lo else Hi"
  definition Sup_level: "Sup L \<equiv> if Hi \<in> L then Hi else Lo"
instance
  proof qed (auto simp: top_level bot_level inf_level sup_level
                        less_eq_level less_level Inf_level Sup_level)
end

lemma sup_eq_Lo[simp]: "sup a b = Lo \<longleftrightarrow> a = Lo \<and> b = Lo"
  by (auto simp: sup_level)

datatype var = h | h' | l | l'
datatype exp = Ct nat | Var var | Plus exp exp | Minus exp exp
datatype test = Tr | Eq exp exp | Gt exp exp | Non test
datatype atom = Assign var exp
type_synonym state = "var \<Rightarrow> nat"

syntax
 "_assign" :: "'a \<Rightarrow> 'a \<Rightarrow> 'a"  ("_ ::= _" [1000, 61] 61)

translations
  "x ::= expr" == "CONST Atm (CONST Assign x expr)"

primrec sec where
  "sec h  = Hi"
| "sec h' = Hi"
| "sec l  = Lo"
| "sec l' = Lo"

fun eval where
 "eval (Ct n) s = n"
|"eval (Var x) s = s x"
|"eval (Plus e1 e2) s = eval e1 s + eval e2 s"
|"eval (Minus e1 e2) s = eval e1 s - eval e2 s"

fun tval where
 "tval Tr s = True"
|"tval (Eq e1 e2) s = (eval e1 s = eval e2 s)"
|"tval (Gt e1 e2) s = (eval e1 s > eval e2 s)"
|"tval (Non e) s = (\<not> tval e s)"

fun aval where
"aval (Assign x e) s = (s (x := eval e s))"

definition indis :: "(state * state) set"where
"indis \<equiv> {(s,t). ALL x. sec x = Lo \<longrightarrow> s x = t x}"

interpretation Example_PL!: PL_Indis tval aval indis
proof
  show "equiv UNIV indis"
    unfolding refl_on_def sym_def trans_def equiv_def indis_def by auto
qed

fun exprSec where
 "exprSec (Ct n) = bot"
|"exprSec (Var x) = sec x"
|"exprSec (Plus e1 e2) = sup (exprSec e1) (exprSec e2)"
|"exprSec (Minus e1 e2) = sup (exprSec e1) (exprSec e2)"

fun tstSec where
 "tstSec Tr = bot"
|"tstSec (Eq e1 e2) = sup (exprSec e1) (exprSec e2)"
|"tstSec (Gt e1 e2) = sup (exprSec e1) (exprSec e2)"
|"tstSec (Non e) = tstSec e"

lemma exprSec_Lo_eval_eq: "exprSec expr = Lo \<Longrightarrow> (s, t) \<in> indis \<Longrightarrow> eval expr s = eval expr t"
  by (induct expr) (auto simp: indis_def)

lemma compatAtmSyntactic[simp]: "exprSec expr = Lo \<or> sec v = Hi \<Longrightarrow> Example_PL.compatAtm (Assign v expr)"
  unfolding Example_PL.compatAtm_def
  by (induct expr)
     (auto simp: indis_def intro!: arg_cong2[where f="op +"] arg_cong2[where f="op -"] exprSec_Lo_eval_eq)

lemma presAtmSyntactic[simp]: "sec v = Hi \<Longrightarrow> Example_PL.presAtm (Assign v expr)"
  unfolding Example_PL.presAtm_def by (simp add: indis_def)

lemma compatTstSyntactic[simp]: "tstSec tst = Lo \<Longrightarrow> Example_PL.compatTst tst"
  unfolding Example_PL.compatTst_def
  by (induct tst)
     (simp_all, safe del: iffI
              intro!: arg_cong2[where f="op ="] arg_cong2[where f="op < :: nat \<Rightarrow> nat \<Rightarrow> bool"] exprSec_Lo_eval_eq)

lemma "Example_PL.SC_discr (h ::= Ct 0)"
  by (simp add: Example_PL.SC_discr.simps)

abbreviation "siso c \<equiv> Example_PL.siso c"
abbreviation "siso0 c \<equiv> Example_PL.siso0 c"
abbreviation "discr c \<equiv> Example_PL.discr c"
abbreviation "discr0 c \<equiv> Example_PL.discr0 c"
abbreviation Sbis_abbrev (infix "\<approx>s" 55) where "c1 \<approx>s c2 \<equiv> (c1,c2) \<in> Example_PL.Sbis"
abbreviation ZObis_abbrev (infix "\<approx>01" 55) where "c1 \<approx>01 c2 \<equiv> (c1,c2) \<in> Example_PL.ZObis"
abbreviation ZObisT_abbrev (infix "\<approx>01T" 55) where "c1 \<approx>01T c2 \<equiv> (c1,c2) \<in> Example_PL.ZObisT"
abbreviation Wbis_abbrev (infix "\<approx>w" 55) where "c1 \<approx>w c2 \<equiv> (c1,c2) \<in> Example_PL.Wbis"
abbreviation WbisT_abbrev (infix "\<approx>wT" 55) where "c1 \<approx>wT c2 \<equiv> (c1,c2) \<in> Example_PL.WbisT"
abbreviation BisT_abbrev (infix "\<approx>T" 55) where "c1 \<approx>T c2 \<equiv> (c1,c2) \<in> Example_PL.BisT"

subsection {* Programs from EXAMPLE 1 *}

definition [simp]: "c0 = (h ::= Ct 0)"

definition [simp]: "c1 = (if Eq (Var l) (Ct 0) then h ::= Ct 1 else l ::= Ct 2)"

definition [simp]: "c2 = (if Eq (Var h) (Ct 0) then h ::= Ct 1 else h ::= Ct 2)"

definition [simp]: "c3 = (if Eq (Var h) (Ct 0) then h ::= Ct 1 ;; h ::= Ct 2
                                         else h ::= Ct 3)"

definition [simp]: "c4 = l ::= Ct 4 ;; c3"

definition [simp]: "c5 = c3 ;; l ::= Ct 4"

definition [simp]: "c6 = l ::= Var h"

definition [simp]: "c7 = l ::= Var h ;; l ::= Ct 0"

definition [simp]: "c8 = h' ::= Var h ;;
  while Gt (Var h) (Ct 0) do (h ::= Minus (Var h) (Ct 1) ;; h' ::= Plus (Var h') (Ct 1)) ;;
  l ::= Ct 4"

definition [simp]: "c9 = c7 | l' ::= Var l"

definition [simp]: "c10 = c5 | l ::= Ct 5"

definition [simp]: "c11 = c8 | l ::= Ct 5"

declare bot_level[iff]

theorem c0: "siso c0" "discr c0"
  by auto

theorem c1: "siso c1" "c1 \<approx>s c1"
  by auto

theorem c2: "discr c2"
  by auto

theorem Sbis_c2: "c2 \<approx>s c2"
  oops

theorem c3: "discr c3"
  by auto

theorem c4: "c4 \<approx>01 c4"
  by auto

theorem c5: "c5 \<approx>w c5"
  by auto

text{* Example 4 from the paper *}

theorem "c3 \<approx>wT c3" by auto

theorem "c5 \<approx>wT c5" by auto

corollary "discr (while Eq (Var h) (Ct 0)  do h ::= Ct 0)"
  by auto

text{* Example 5 from the paper *}

definition [simp]: "c12 \<equiv> h ::= Ct 4 ;;
  while Gt (Var h) (Ct 0)
    do (h ::= Minus (Var h) (Ct 1) ;; h' ::= Plus (Var h') (Ct 1)) ;;
  l ::= Ct 1"

corollary "(c12 | l ::= Ct 2) \<approx>T (c12 | l ::= Ct 2)"
  by auto

definition [simp]: "c13 =
  (if Eq (Var h) (Ct 0) then h ::= Ct 1 ;; l ::= Ct 2 else l ::= Ct 2) ;; l' ::= Ct 4"

lemma c13_inner:
  "(h ::= Ct 1 ;; l ::= Ct 2) \<approx>wT (l ::= Ct 2)"
proof -
  def \<phi> \<equiv> "\<lambda>(c :: (test, atom) com) (d :: (test, atom) com).
    c = h ::= Ct 1 ;; l ::= Ct 2 \<and> d = l ::= Ct 2 \<or>
    d = h ::= Ct 1 ;; l ::= Ct 2 \<and> c = l ::= Ct 2"
  then have "\<phi> (h ::= Ct 1 ;; l ::= Ct 2) (l ::= Ct 2)"
    by auto
  then show ?thesis
  proof (induct rule: Example_PL.WbisT_coinduct[where \<phi>=\<phi>])
    case sym then show ?case by (auto simp add: \<phi>_def)
  next
    case (cont c s d t c' s') then show ?case
      by (auto simp add: \<phi>_def intro!: exI[of _ "l ::= Ct 2"] exI[of _ t])
         (auto simp: indis_def)
  next
    have exec:
        "\<And>t. Example_PL.MtransT (h ::= Ct 1 ;; l ::= Ct 2, t) (aval (Assign l (Ct 2)) (aval (Assign h (Ct 1)) t))"
        by (simp del: aval.simps)
           (blast intro: Example_PL.transC_MtransT Example_PL.transC_MtransC.SeqT Example_PL.transT.Atm Example_PL.transT_MtransT)
    case (termi c s d t s') with exec show ?case
      by (auto simp add: \<phi>_def intro!: exI[of _ "t (h := 1, l := 2)"])
         (auto simp: indis_def)
  qed
qed

theorem "c13 \<approx>wT c13"
   using c13_inner
   by (auto intro!: Example_PL.Seq_WbisT Example_PL.WbisT_If_cross)

end