theory FOR_Semantics
  imports FOR_Certificate
    Lift_Root_Step
    "FOL-Fitting.FOL_Fitting"
begin

section \<open>Semantics of Relations\<close>

definition is_to_trs :: "('f, 'v) trs list \<Rightarrow> ftrs list \<Rightarrow> ('f, 'v) trs" where
  "is_to_trs Rs is = \<Union>(set (map (case_ftrs ((!) Rs) ((`) prod.swap \<circ> (!) Rs)) is))"

primrec eval_gtt_rel :: "('f \<times> nat) set \<Rightarrow> ('f, 'v) trs list \<Rightarrow> ftrs gtt_rel \<Rightarrow> 'f gterm rel" where
  "eval_gtt_rel \<F> Rs (ARoot is) = Restr (grrstep (is_to_trs Rs is)) (\<T>\<^sub>G \<F>)"
| "eval_gtt_rel \<F> Rs (GInv g) = prod.swap ` (eval_gtt_rel \<F> Rs g)"
| "eval_gtt_rel \<F> Rs (AUnion g1 g2) = (eval_gtt_rel \<F> Rs g1) \<union> (eval_gtt_rel \<F> Rs g2)"
| "eval_gtt_rel \<F> Rs (ATrancl g) = (eval_gtt_rel \<F> Rs g)\<^sup>+"
| "eval_gtt_rel \<F> Rs (AComp g1 g2) = (eval_gtt_rel \<F> Rs g1) O (eval_gtt_rel \<F> Rs g2)"
| "eval_gtt_rel \<F> Rs (GTrancl g) = gtrancl_rel \<F> (eval_gtt_rel \<F> Rs g)"
| "eval_gtt_rel \<F> Rs (GComp g1 g2) =  gcomp_rel \<F> (eval_gtt_rel \<F> Rs g1) (eval_gtt_rel \<F> Rs g2)"

primrec eval_rr1_rel :: "('f \<times> nat) set \<Rightarrow> ('f, 'v) trs list \<Rightarrow> ftrs rr1_rel \<Rightarrow> 'f gterm set"
  and eval_rr2_rel :: "('f \<times> nat) set \<Rightarrow> ('f, 'v) trs list \<Rightarrow> ftrs rr2_rel \<Rightarrow> 'f gterm rel" where
  "eval_rr1_rel \<F> Rs R1Terms = (\<T>\<^sub>G \<F>)"
| "eval_rr1_rel \<F> Rs (R1Union R S) = (eval_rr1_rel \<F> Rs R) \<union> (eval_rr1_rel \<F> Rs S)"
| "eval_rr1_rel \<F> Rs (R1Inter R S) = (eval_rr1_rel \<F> Rs R) \<inter> (eval_rr1_rel \<F> Rs S)"
| "eval_rr1_rel \<F> Rs (R1Diff R S) = (eval_rr1_rel \<F> Rs R) - (eval_rr1_rel \<F> Rs S)"
| "eval_rr1_rel \<F> Rs (R1Proj n R) = (case n of 0 \<Rightarrow> fst ` (eval_rr2_rel \<F> Rs R)
                                             | _ \<Rightarrow> snd ` (eval_rr2_rel \<F> Rs R))"
| "eval_rr1_rel \<F> Rs (R1NF is) = NF (Restr (grstep (is_to_trs Rs is)) (\<T>\<^sub>G \<F>)) \<inter> (\<T>\<^sub>G \<F>)"
| "eval_rr1_rel \<F> Rs (R1Inf R) = {s. infinite (eval_rr2_rel \<F> Rs R `` {s})}"
| "eval_rr2_rel \<F> Rs (R2GTT_Rel A W X) = lift_root_step \<F> W X (eval_gtt_rel \<F> Rs A)"
| "eval_rr2_rel \<F> Rs (R2Inv R) = prod.swap ` (eval_rr2_rel \<F> Rs R)"
| "eval_rr2_rel \<F> Rs (R2Union R S) = (eval_rr2_rel \<F> Rs R) \<union> (eval_rr2_rel \<F> Rs S)"
| "eval_rr2_rel \<F> Rs (R2Inter R S) = (eval_rr2_rel \<F> Rs R) \<inter> (eval_rr2_rel \<F> Rs S)"
| "eval_rr2_rel \<F> Rs (R2Diff R S) = (eval_rr2_rel \<F> Rs R) - (eval_rr2_rel \<F> Rs S)"
| "eval_rr2_rel \<F> Rs (R2Comp R S) = (eval_rr2_rel \<F> Rs R) O (eval_rr2_rel \<F> Rs S)"
| "eval_rr2_rel \<F> Rs (R2Diag R) = Id_on (eval_rr1_rel \<F> Rs R)"
| "eval_rr2_rel \<F> Rs (R2Prod R S) = (eval_rr1_rel \<F> Rs R) \<times> (eval_rr1_rel \<F> Rs S)"

subsection \<open>Semantics of Formulas\<close>

fun eval_formula ::  "('f \<times> nat) set \<Rightarrow> ('f, 'v) trs list \<Rightarrow> (nat \<Rightarrow> 'f gterm) \<Rightarrow>
  ftrs formula \<Rightarrow> bool" where
  "eval_formula \<F> Rs \<alpha> (FRR1 r1 x) \<longleftrightarrow> \<alpha> x \<in> eval_rr1_rel \<F> Rs r1"
| "eval_formula \<F> Rs \<alpha> (FRR2 r2 x y) \<longleftrightarrow> (\<alpha> x, \<alpha> y) \<in> eval_rr2_rel \<F> Rs r2"
| "eval_formula \<F> Rs \<alpha> (FAnd fs) \<longleftrightarrow> (\<forall>f \<in> set fs. eval_formula \<F> Rs \<alpha> f)"
| "eval_formula \<F> Rs \<alpha> (FOr fs) \<longleftrightarrow> (\<exists>f \<in> set fs. eval_formula \<F> Rs \<alpha> f)"
| "eval_formula \<F> Rs \<alpha> (FNot f) \<longleftrightarrow> \<not> eval_formula \<F> Rs \<alpha> f"
| "eval_formula \<F> Rs \<alpha> (FExists f) \<longleftrightarrow> (\<exists>z \<in> \<T>\<^sub>G \<F>. eval_formula \<F> Rs (\<alpha>\<langle>0 : z\<rangle>) f)"
| "eval_formula \<F> Rs \<alpha> (FForall f) \<longleftrightarrow> (\<forall>z \<in> \<T>\<^sub>G \<F>. eval_formula \<F> Rs (\<alpha>\<langle>0 : z\<rangle>) f)"

fun formula_arity :: "'trs formula \<Rightarrow> nat" where
  "formula_arity (FRR1 r1 x) = Suc x"
| "formula_arity (FRR2 r2 x y) = max (Suc x) (Suc y)"
| "formula_arity (FAnd fs) = max_list (map formula_arity fs)"
| "formula_arity (FOr fs) = max_list (map formula_arity fs)"
| "formula_arity (FNot f) = formula_arity f"
| "formula_arity (FExists f) = formula_arity f - 1"
| "formula_arity (FForall f) = formula_arity f - 1"

lemma R1NF_reps:
  assumes "funas_trs R \<subseteq> \<F>" "\<forall> t. (term_of_gterm s, term_of_gterm t) \<in> rstep R \<longrightarrow> \<not>funas_gterm t \<subseteq> \<F>"
    and "funas_gterm s \<subseteq> \<F>" "(l, r) \<in> R" "term_of_gterm s = C\<langle>l \<cdot> (\<sigma>  :: 'b \<Rightarrow> ('a, 'b) Term.term)\<rangle>"
  shows False
proof -
  obtain c where w: "funas_term (c :: ('a, 'b) Term.term) \<subseteq> \<F>" "ground c"
    using assms(3) funas_term_of_gterm_conv ground_term_of_gterm by blast
  define \<tau> where "\<tau> x = (if x \<in> vars_term l then \<sigma> x else c)" for x
  from assms(4-) have terms: "term_of_gterm s = C\<langle>l \<cdot> \<tau>\<rangle>" "(C\<langle>l \<cdot> \<tau>\<rangle>, C\<langle>r \<cdot> \<tau>\<rangle>) \<in> rstep R"
    using \<tau>_def by auto (metis term_subst_eq)
  from this(1) have [simp]: "funas_gterm s = funas_term C\<langle>l \<cdot> \<tau>\<rangle>" by (metis funas_term_of_gterm_conv)
  from w assms(1, 3, 4) have [simp]: "funas_term C\<langle>r \<cdot> \<tau>\<rangle> \<subseteq> \<F>" using \<tau>_def
    by (auto simp: funas_trs_def funas_term_subst)
  moreover have "ground C\<langle>r \<cdot> \<tau>\<rangle>" using terms(1) w \<tau>_def
    by (auto intro!: ground_substI) (metis term_of_gterm_ctxt_subst_apply_ground)
  ultimately show ?thesis using assms(2) terms(2)
    by (metis funas_term_of_gterm_conv ground_term_to_gtermD terms(1))
qed

text \<open>The central property we are interested in is satisfiability\<close>

definition formula_satisfiable where
  "formula_satisfiable \<F> Rs f \<longleftrightarrow> (\<exists>\<alpha>. range \<alpha> \<subseteq> \<T>\<^sub>G \<F> \<and> eval_formula \<F> Rs \<alpha> f)"

subsection \<open>Validation\<close>

subsection \<open>Defining properties of @{const gcomp_rel} and @{const gtrancl_rel}\<close>

lemma gcomp_rel_sig:
  assumes "R \<subseteq> \<T>\<^sub>G \<F> \<times> \<T>\<^sub>G \<F>" and "S \<subseteq> \<T>\<^sub>G \<F> \<times> \<T>\<^sub>G \<F>"
  shows "gcomp_rel \<F> R S \<subseteq> \<T>\<^sub>G \<F> \<times> \<T>\<^sub>G \<F>"
  using assms subsetD[OF signature_pres_funas_cl(2)[OF assms(1)]]
  by (auto simp: gcomp_rel_def lift_root_step.simps gmctxt_cl_gmctxtex_onp_conv) (metis refl_onD2 relf_on_gmctxtcl_funas)

lemma gtrancl_rel_sig:
  assumes "R \<subseteq> \<T>\<^sub>G \<F> \<times> \<T>\<^sub>G \<F>"
  shows "gtrancl_rel \<F> R \<subseteq> \<T>\<^sub>G \<F> \<times> \<T>\<^sub>G \<F>"
  using gtrancl_rel_sound[OF assms] by simp

lemma gtrancl_rel:
  assumes "R \<subseteq> \<T>\<^sub>G \<F> \<times> \<T>\<^sub>G \<F>"
  shows "lift_root_step \<F> PAny EStrictParallel (gtrancl_rel \<F> R) = (lift_root_step \<F> PAny ESingle R)\<^sup>+"
  unfolding lift_root_step.simps using gmctxtcl_funas_strict_gtrancl_rel[OF assms] .

lemma gtrancl_rel':
  assumes "R \<subseteq> \<T>\<^sub>G \<F> \<times> \<T>\<^sub>G \<F>"
  shows "lift_root_step \<F> PAny EParallel (gtrancl_rel \<F> R) = Restr ((lift_root_step \<F> PAny ESingle R)\<^sup>*) (\<T>\<^sub>G \<F>)"
  using assms gtrancl_rel[OF assms]
  by (auto simp: lift_root_step_Parallel_conv
      simp flip: reflcl_trancl dest: Restr_simps(5)[OF lift_root_step_sig, THEN subsetD])

text \<open>GTT relation semantics respects the signature\<close>

lemma eval_gtt_rel_sig:
  "eval_gtt_rel \<F> Rs g \<subseteq> \<T>\<^sub>G \<F> \<times> \<T>\<^sub>G \<F>"
proof -
  show ?thesis by (induct g) (auto 0 3 simp: gtrancl_rel_sig gcomp_rel_sig dest: tranclD tranclD2)
qed

text \<open>RR1 and RR2 relation semantics respect the signature\<close>

lemma eval_rr12_rel_sig:
  "eval_rr1_rel \<F> Rs r1 \<subseteq> \<T>\<^sub>G \<F>"
  "eval_rr2_rel \<F> Rs r2 \<subseteq> \<T>\<^sub>G \<F> \<times> \<T>\<^sub>G \<F>"
proof (induct r1 and r2)
  case (R1Inf r2) then show ?case by (auto dest!: infinite_imp_nonempty)
next
  case (R1Proj i r2) then show ?case by (fastforce split: nat.splits)
next
  case (R2GTT_Rel g W X) then show ?case by (simp add: lift_root_step_sig eval_gtt_rel_sig)
qed auto

subsection \<open>Correctness of derived constructions\<close>

lemma R1Fin:
  "eval_rr1_rel \<F> Rs (R1Fin r) = {t \<in> \<T>\<^sub>G \<F>. finite {s. (t, s) \<in> eval_rr2_rel \<F> Rs r}}"
  by (auto simp: R1Fin_def Image_def)

lemma R2Eq:
  "eval_rr2_rel \<F> Rs R2Eq = Id_on (\<T>\<^sub>G \<F>)"
  by (auto simp: \<T>\<^sub>G_funas_gterm_conv R2Eq_def)

lemma R2Reflc:
  "eval_rr2_rel \<F> Rs (R2Reflc r) = eval_rr2_rel \<F> Rs r \<union> Id_on (\<T>\<^sub>G \<F>)"
  "eval_rr2_rel \<F> Rs (R2Reflc r) = Restr ((eval_rr2_rel \<F> Rs r)\<^sup>=) (\<T>\<^sub>G \<F>)"
  using eval_rr12_rel_sig(2)[of \<F> Rs "R2Reflc r"]
  by (auto simp: R2Reflc_def R2Eq)

lemma R2Step:
  "eval_rr2_rel \<F> Rs (R2Step ts) = Restr (grstep (is_to_trs Rs ts)) (\<T>\<^sub>G \<F>)"
  by (auto simp: lift_root_step.simps R2Step_def grstep_lift_root_step grrstep_subst_cl_conv grstepD_grstep_conv grstepD_def)

lemma R2StepEq:
  "eval_rr2_rel \<F> Rs (R2StepEq ts) = Restr ((grstep (is_to_trs Rs ts))\<^sup>=) (\<T>\<^sub>G \<F>)"
  by (auto simp: R2StepEq_def R2Step R2Reflc(2))

lemma R2Steps:
  fixes \<F> Rs ts defines "R \<equiv> Restr (grstep (is_to_trs Rs ts)) (\<T>\<^sub>G \<F>)"
  shows "eval_rr2_rel \<F> Rs (R2Steps ts) = R\<^sup>+"
  by (simp add: R2Steps_def GSteps_def R_def gtrancl_rel grstep_lift_root_step)
     (metis FOR_Semantics.gtrancl_rel Sigma_cong grstep_lift_root_step inf.cobounded2 lift_root_Any_EStrict_eq)

lemma R2StepsEq:
  fixes \<F> Rs ts defines "R \<equiv> Restr (grstep (is_to_trs Rs ts)) (\<T>\<^sub>G \<F>)"
  shows "eval_rr2_rel \<F> Rs (R2StepsEq ts) = Restr (R\<^sup>*) (\<T>\<^sub>G \<F>)"
  using R2Steps[of \<F> Rs ts]
  by (simp add: R2StepsEq_def R2Steps_def lift_root_step_Parallel_conv Int_Un_distrib2 R_def Restr_simps flip: reflcl_trancl)

lemma R2StepsNF:
  fixes \<F> Rs ts defines "R \<equiv> Restr (grstep (is_to_trs Rs ts)) (\<T>\<^sub>G \<F>)"
  shows "eval_rr2_rel \<F> Rs (R2StepsNF ts) = Restr (R\<^sup>* \<inter> UNIV \<times> NF R) (\<T>\<^sub>G \<F>)"
  using R2StepsEq[of \<F> Rs ts]
  by (auto simp: R2StepsNF_def R2StepsEq_def R_def)

lemma R2ParStep:
  "eval_rr2_rel \<F> Rs (R2ParStep ts) = Restr (gpar_rstep (is_to_trs Rs ts)) (\<T>\<^sub>G \<F>)"
  by (simp add: R2ParStep_def gar_rstep_lift_root_step)

lemma R2RootStep:
  "eval_rr2_rel \<F> Rs (R2RootStep ts) = Restr (grrstep (is_to_trs Rs ts)) (\<T>\<^sub>G \<F>)"
  by (simp add: R2RootStep_def lift_root_step.simps)

lemma R2RootStepEq:
  "eval_rr2_rel \<F> Rs (R2RootStepEq ts) = Restr ((grrstep (is_to_trs Rs ts))\<^sup>=) (\<T>\<^sub>G \<F>)"
  by (auto simp: R2RootStepEq_def R2RootStep R2Reflc(2))

lemma R2RootSteps:
  fixes \<F> Rs ts defines "R \<equiv> Restr (grrstep (is_to_trs Rs ts)) (\<T>\<^sub>G \<F>)"
  shows "eval_rr2_rel \<F> Rs (R2RootSteps ts) = R\<^sup>+"
  by (simp add: R2RootSteps_def R_def lift_root_step.simps)

lemma R2RootStepsEq:
  fixes \<F> Rs ts defines "R \<equiv> Restr (grrstep (is_to_trs Rs ts)) (\<T>\<^sub>G \<F>)"
  shows "eval_rr2_rel \<F> Rs (R2RootStepsEq ts) = Restr (R\<^sup>*) (\<T>\<^sub>G \<F>)"
  by (auto simp: R2RootStepsEq_def R2Reflc_def R2RootSteps R_def R2Eq_def Int_Un_distrib2 Restr_simps simp flip: reflcl_trancl)

lemma R2NonRootStep:
  "eval_rr2_rel \<F> Rs (R2NonRootStep ts) = Restr (gnrrstep (is_to_trs Rs ts)) (\<T>\<^sub>G \<F>)"
  by (simp add: R2NonRootStep_def grrstep_lift_root_gnrrstep)

lemma R2NonRootStepEq:
  "eval_rr2_rel \<F> Rs (R2NonRootStepEq ts) = Restr ((gnrrstep (is_to_trs Rs ts))\<^sup>=) (\<T>\<^sub>G \<F>)"
  by (auto simp: R2NonRootStepEq_def R2Reflc_def R2Eq_def R2NonRootStep Int_Un_distrib2)

lemma R2NonRootSteps:
  fixes \<F> Rs ts defines "R \<equiv> Restr (gnrrstep (is_to_trs Rs ts)) (\<T>\<^sub>G \<F>)"
  shows "eval_rr2_rel \<F> Rs (R2NonRootSteps ts) = R\<^sup>+"
  apply (simp add: lift_root_step.simps gnrrstepD_gnrrstep_conv gnrrstepD_def
    grrstep_subst_cl_conv R2NonRootSteps_def R_def GSteps_def lift_root_step_Parallel_conv)
  apply (intro gmctxtex_funas_nroot_strict_gtrancl_rel)
  by simp

lemma R2NonRootStepsEq:
  fixes \<F> Rs ts defines "R \<equiv> Restr (gnrrstep (is_to_trs Rs ts)) (\<T>\<^sub>G \<F>)"
  shows "eval_rr2_rel \<F> Rs (R2NonRootStepsEq ts) = Restr (R\<^sup>*) (\<T>\<^sub>G \<F>)"
  using R2NonRootSteps[of \<F> Rs ts]
  by (simp add: R2NonRootSteps_def R2NonRootStepsEq_def lift_root_step_Parallel_conv
    R_def Int_Un_distrib2 Restr_simps flip: reflcl_trancl)

lemma converse_to_prod_swap:
  "R\<inverse> = prod.swap ` R"
  by auto

lemma R2Meet:
  fixes \<F> Rs ts defines "R \<equiv> Restr (grstep (is_to_trs Rs ts)) (\<T>\<^sub>G \<F>)"
  shows "eval_rr2_rel \<F> Rs (R2Meet ts) = Restr ((R\<inverse>)\<^sup>* O R\<^sup>*) (\<T>\<^sub>G \<F>)"
  apply (simp add: R2Meet_def R_def GSteps_def converse_to_prod_swap gcomp_rel[folded lift_root_step.simps] gtrancl_rel' swap_lift_root_step grstep_lift_root_step)
  apply (simp add: Restr_simps converse_Int converse_Un converse_Times Int_Un_distrib2 flip: reflcl_trancl trancl_converse converse_to_prod_swap)
  done

lemma R2Join:
  fixes \<F> Rs ts defines "R \<equiv> Restr (grstep (is_to_trs Rs ts)) (\<T>\<^sub>G \<F>)"
  shows "eval_rr2_rel \<F> Rs (R2Join ts) = Restr (R\<^sup>* O (R\<inverse>)\<^sup>*) (\<T>\<^sub>G \<F>)"
  apply (simp add: R2Join_def R_def GSteps_def converse_to_prod_swap  gcomp_rel[folded lift_root_step.simps] gtrancl_rel' swap_lift_root_step grstep_lift_root_step)
  apply (simp add: Restr_simps converse_to_prod_swap[symmetric] converse_Int converse_Un converse_Times Int_Un_distrib2 flip: reflcl_trancl trancl_converse)
  done

end


theory prop_16
imports Main
        "$HIPSTER_HOME/IsaHipster"
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 even :: "Nat => bool" where
  "even (Z) = True"
  | "even (S (Z)) = False"
  | "even (S (S z)) = even z"

  (*hipster plus even *)
lemma lemma_a [thy_expl]: "plus x2 Z = x2"
by (hipster_induct_schemes plus.simps)

lemma lemma_aa [thy_expl]: "plus (plus x2 y2) z2 = plus x2 (plus y2 z2)"
by (hipster_induct_schemes plus.simps)

lemma lemma_ab [thy_expl]: "plus x2 (S y2) = S (plus x2 y2)"
by (hipster_induct_schemes plus.simps)

lemma lemma_ac [thy_expl]: "plus x1 (plus y1 x1) = plus y1 (plus x1 x1)"
by (hipster_induct_schemes plus.simps)

lemma lemma_ad [thy_expl]: "plus x2 (plus y2 y2) = plus y2 (plus y2 x2)"
by (hipster_induct_schemes plus.simps)

lemma lemma_ae [thy_expl]: "plus x2 (S y2) = S (plus y2 x2)"
by (hipster_induct_schemes plus.simps)

lemma lemma_af [thy_expl]: "plus (S x2) y2 = S (plus y2 x2)"
by (hipster_induct_schemes plus.simps)

lemma lemma_ag [thy_expl]: "plus (plus x2 y2) (plus x2 z2) = plus (plus x2 z2) (plus x2 y2)"
by (hipster_induct_schemes plus.simps)

lemma lemma_ah [thy_expl]: "plus (plus x2 y2) (plus z2 x2) = plus (plus z2 x2) (plus x2 y2)"
by (hipster_induct_schemes plus.simps)

lemma lemma_ai [thy_expl]: "plus x2 (plus y2 z2) = plus y2 (plus z2 x2)"
by (hipster_induct_schemes plus.simps)

hipster even plus
lemma lemma_aj [thy_expl]: "even (plus x1 x1) = True"
by (hipster_induct_schemes even.simps plus.simps)

  theorem x0 :
    "even (plus x x)"
    by (tactic \<open>Subgoal.FOCUS_PARAMS (K (Tactic_Data.hard_tac @{context})) @{context} 1\<close>)
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_weird_nat_mul3acc_spec
  imports "../../Test_Base"
begin

datatype Nat = Z | S "Nat"

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

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

fun 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) = (times (times x y) z))"
  oops

end


theory NSA_Test
imports "~~/src/HOL/NSA/StarDef" "../src/Applicative"
begin

lemma star_interchange: "f \<star> star_of x = star_of (\<lambda>f. f x) \<star> f"
proof -
  have "\<forall>f x. f \<star> x = star_of (\<lambda>x f. f x) \<star> x \<star> f" by transfer simp
  hence "\<forall>f x. f \<star> star_of x = star_of (\<lambda>x f. f x) \<star> star_of x \<star> f" by blast
  hence "\<forall>f x. f \<star> star_of x = star_of (\<lambda>f. f x) \<star> f" by (simp only: Ifun_star_of)
  thus ?thesis by auto
qed

applicative star (C, K, W)
for
  pure: star_of
  ap: Ifun
apply (transfer, simp)
apply (transfer, simp)
apply (rule Ifun_star_of)
apply (rule star_interchange)
apply (transfer, simp)+
done

end


theory e imports Main       (* Aqvist's System E: C. Benzmüller & X. Parent, 2019 *)
begin

nitpick_params[user_axioms=true, show_all, expect=genuine, format = 3]

(*nitpick_params [sat_solver = MiniSat_JNI]*)
typedecl i (*Possible worlds.*)
type_synonym \<sigma> = "(i\<Rightarrow>bool)"
type_synonym \<alpha> = "i\<Rightarrow>\<sigma>" (*Type of betterness relation between worlds.*)
type_synonym \<tau> = "\<sigma>\<Rightarrow>\<sigma>"

consts aw::i (*Actual world.*)
abbreviation etrue  :: "\<sigma>" ("\<^bold>\<top>") where "\<^bold>\<top> \<equiv> \<lambda>w. True"
abbreviation efalse :: "\<sigma>" ("\<^bold>\<bottom>")  where "\<^bold>\<bottom> \<equiv> \<lambda>w. False"
abbreviation enot :: "\<sigma>\<Rightarrow>\<sigma>" ("\<^bold>\<not>_"[52]53)  where "\<^bold>\<not>\<phi> \<equiv> \<lambda>w. \<not>\<phi>(w)"
abbreviation eand :: "\<sigma>\<Rightarrow>\<sigma>\<Rightarrow>\<sigma>" (infixr"\<^bold>\<and>"51) where "\<phi>\<^bold>\<and>\<psi> \<equiv> \<lambda>w. \<phi>(w)\<and>\<psi>(w)"
abbreviation eor  :: "\<sigma>\<Rightarrow>\<sigma>\<Rightarrow>\<sigma>" (infixr"\<^bold>\<or>"50) where "\<phi>\<^bold>\<or>\<psi> \<equiv> \<lambda>w. \<phi>(w)\<or>\<psi>(w)"
abbreviation eimp :: "\<sigma>\<Rightarrow>\<sigma>\<Rightarrow>\<sigma>" (infixr"\<^bold>\<rightarrow>"49) where "\<phi>\<^bold>\<rightarrow>\<psi> \<equiv> \<lambda>w. \<phi>(w)\<longrightarrow>\<psi>(w)"
abbreviation eequ :: "\<sigma>\<Rightarrow>\<sigma>\<Rightarrow>\<sigma>" (infixr"\<^bold>\<leftrightarrow>"48) where "\<phi>\<^bold>\<leftrightarrow>\<psi> \<equiv> \<lambda>w. \<phi>(w)\<longleftrightarrow>\<psi>(w)"

(*Possibilist--constant domain--quantification.*)
abbreviation eforall ("\<^bold>\<forall>") where "\<^bold>\<forall>\<Phi> \<equiv> \<lambda>w.\<forall>x. (\<Phi> x w)"
abbreviation eforallB (binder"\<^bold>\<forall>"[8]9) where "\<^bold>\<forall>x. \<phi>(x) \<equiv> \<^bold>\<forall>\<phi>"
abbreviation eexists ("\<^bold>\<exists>") where "\<^bold>\<exists>\<Phi> \<equiv> \<lambda>w.\<exists>x. (\<Phi> x w)"
abbreviation eexistsB (binder"\<^bold>\<exists>"[8]9) where "\<^bold>\<exists>x. \<phi>(x) \<equiv> \<^bold>\<exists>\<phi>"

abbreviation ebox :: "\<sigma>\<Rightarrow>\<sigma>" ("\<box>") where "\<box> \<equiv> \<lambda>\<phi> w.  \<forall>v. \<phi>(v)"
definition ddediomond  :: "\<sigma>\<Rightarrow>\<sigma>" ("\<diamond>") where "\<diamond>\<phi> \<equiv> \<lambda>w. \<exists>v. \<phi>(v)"

consts r :: "\<alpha>" (infixr "r" 70) (*Betterness relation, cf. def. of \<circle><_|_>.*)

axiomatization where
  totalness: "(\<forall>x y. (x r y) \<or> (y r x))" and
  ferrer: "(\<forall>x y z u. (x r y) \<and> (z r u) \<longrightarrow> (x r u) \<or> (z r y))" and
  quasitr: "(\<forall>x y z u. (x r y) \<and> (y r z) \<longrightarrow> (x r u) \<or> (u r z))"

abbreviation emax  :: "\<sigma>\<Rightarrow>\<sigma>" ("max<_>")
  where "max<\<phi>> \<equiv> (\<lambda>v. ( (\<phi>)(v) \<and> (\<forall>x. ((\<phi>)(x) \<longrightarrow> (x r v \<longrightarrow>  v r x)) )) )"
abbreviation esubset :: "\<sigma>\<Rightarrow>\<sigma>\<Rightarrow>bool" (infix "\<^bold>\<subseteq>" 53)
  where "\<phi> \<^bold>\<subseteq> \<psi> \<equiv> \<forall>x. \<phi> x \<longrightarrow> \<psi> x"
abbreviation econd  :: "\<sigma>\<Rightarrow>\<sigma>\<Rightarrow>\<sigma>" ("\<circle><_|_>")
  where "\<circle><\<psi>|\<phi>> \<equiv>  \<lambda>w. max<\<phi>> \<^bold>\<subseteq> \<psi>"
abbreviation euncobl :: "\<sigma>\<Rightarrow>\<sigma>" ("\<^bold>\<circle><_>")
  where "\<^bold>\<circle><\<phi>> \<equiv> \<circle><\<phi>|\<^bold>\<top>>"
abbreviation ddeperm :: "\<sigma>\<Rightarrow>\<sigma>\<Rightarrow>\<sigma>" ("P<_|_>")
  where "P<\<psi>|\<phi>> \<equiv>\<^bold>\<not>\<circle><\<^bold>\<not>\<psi>|\<phi>>"

abbreviation evalid :: "\<sigma>\<Rightarrow>bool" ("\<lfloor>_\<rfloor>"[8]109)  (*Global validity.*)
  where "\<lfloor>p\<rfloor> \<equiv> \<forall>w. p w"
abbreviation ecjactual :: "\<sigma>\<Rightarrow>bool" ("\<lfloor>_\<rfloor>\<^sub>l"[7]105) (*Local validity — in world aw.*)
  where "\<lfloor>p\<rfloor>\<^sub>l \<equiv> p(aw)"

lemma True nitpick [satisfy,user_axioms,expect=genuine] oops (*Consistency conf.*)

(*axioms of E holding irrespective of the properties of r*)
lemma Abs:"\<lfloor>\<circle><\<psi>|\<phi>> \<^bold>\<rightarrow> \<box>\<circle><\<psi>|\<phi>>\<rfloor>"  sledgehammer oops
lemma Nec:"\<lfloor>\<box>\<psi> \<^bold>\<rightarrow> \<circle><\<psi>|\<phi>>\<rfloor>"  sledgehammer oops
lemma Ext:"\<lfloor>\<box>(\<phi>\<^sub>1\<^bold>\<leftrightarrow>\<phi>\<^sub>2) \<^bold>\<rightarrow> (\<circle><\<psi>|\<phi>\<^sub>1> \<^bold>\<leftrightarrow> \<circle><\<psi>|\<phi>\<^sub>2>)\<rfloor>"  sledgehammer oops
lemma Id:"\<lfloor>\<circle><\<phi>|\<phi>>\<rfloor>"  sledgehammer oops
lemma Sh:"\<lfloor>\<circle><\<psi>|\<phi>\<^sub>1\<^bold>\<and>\<phi>\<^sub>2> \<^bold>\<rightarrow> \<circle><(\<phi>\<^sub>2\<^bold>\<rightarrow>\<psi>)|\<phi>\<^sub>1>\<rfloor>"  sledgehammer oops
lemma MP:"(\<lfloor>\<phi>\<rfloor>\<and>\<lfloor>\<phi>\<^bold>\<rightarrow>\<psi>\<rfloor>)\<Longrightarrow>\<lfloor>\<psi>\<rfloor>"  sledgehammer oops
lemma N:"\<lfloor>\<phi>\<rfloor>\<Longrightarrow>\<lfloor>\<box>\<phi>\<rfloor>"  sledgehammer oops
lemma COK:"\<lfloor>\<circle><(\<psi>\<^sub>1\<^bold>\<rightarrow>\<psi>\<^sub>2)|\<phi>> \<^bold>\<rightarrow> (\<circle><\<psi>\<^sub>1|\<phi>> \<^bold>\<rightarrow> \<circle><\<psi>\<^sub>2|\<phi>>)\<rfloor>" sledgehammer oops (*countermodel*)

(*disjunctive rationlity*)

lemma "\<lfloor>\<circle><\<psi>|\<phi>\<^bold>\<or>\<psi>>\<^bold>\<rightarrow>(\<circle><\<psi>|\<phi>>\<^bold>\<or>\<circle><\<psi>|\<chi>>)\<rfloor>" nitpick oops

lemma "\<lfloor>( \<circle><\<psi>|\<phi>> \<^bold>\<and> \<circle><\<chi>|\<phi>>) \<^bold>\<rightarrow> \<circle><\<psi>|\<phi>\<^bold>\<and>\<chi>>\<rfloor>" nitpick oops

lemma  "\<lfloor>\<diamond>\<phi> \<^bold>\<rightarrow> (\<circle><\<psi>|\<phi>> \<^bold>\<rightarrow> P<\<psi>|\<phi>>)\<rfloor>"  nitpick  oops

(*Rational Monotony.*)
lemma "\<lfloor>((\<circle><\<psi>|\<phi>>) \<^bold>\<and> \<^bold>\<not>(\<circle><\<^bold>\<not>\<xi>|\<phi>>)) \<^bold>\<rightarrow> \<circle><\<psi>|\<phi>\<^bold>\<and>\<xi>>\<rfloor>"  nitpick [user_axioms,expect=genuine]oops

(*Rational Monotony.*)
lemma "\<lfloor>((\<circle><\<psi>|\<phi>>) \<^bold>\<and> \<^bold>\<not>(\<circle><\<^bold>\<not>\<psi>|\<phi>\<and>\<xi>>)) \<^bold>\<rightarrow> \<circle><\<psi>|\<phi>\<^bold>\<and>\<xi>>\<rfloor>"  nitpick [user_axioms,expect=genuine]

end


theory CTCS3
  imports HHLProver.ContinuousInv
    HHLProver.BigStepParallel
    HHLProver.Complementlemma
begin

locale CTCS3 =
  fixes Stop_point :: real    \<comment> \<open>64000\<close>
  fixes V_limit :: real       \<comment> \<open>100\<close>
  fixes Next_V_limit :: real  \<comment> \<open>40\<close>
  fixes Period :: real        \<comment> \<open>0.125\<close>
  fixes A_minus :: real       \<comment> \<open>1\<close>
  fixes A_plus :: real        \<comment> \<open>1\<close>
  assumes Period[simp]: "Period > 0"
  assumes Stop_point[simp]: "Stop_point > 0"
  assumes V_limit: "V_limit > 0"
  assumes Next_V_limit: "Next_V_limit > 0"
  assumes A_minus: "A_minus > 0"
  assumes A_plus: "A_plus > 0"
begin

definition "Pull_curve_max_d = V_limit * V_limit / (2 * A_minus)"
definition "Pull_curve_coeff = sqrt (2 * A_minus)"

lemma Pull_curve_coeff_ge_zero [simp]:
  "Pull_curve_coeff > 0"
  unfolding Pull_curve_coeff_def using A_minus by auto

lemma Pull_curve_max_d_ge_zero [simp]:
  "Pull_curve_max_d > 0"
  unfolding Pull_curve_max_d_def using V_limit A_minus by auto

text \<open>Variables\<close>

definition A :: char where "A = CHR ''a''"
definition V :: char where "V = CHR ''b''"
definition S :: char where "S = CHR ''c''"
definition T :: char where "T = CHR ''k''"
definition Command_a :: char where "Command_a = CHR ''n''"
definition Level :: char where "Level = CHR ''l''"
definition Next_seg_v :: char where "Next_seg_v = CHR ''s''"

text \<open>Processes\<close>
lemma train_vars_distinct [simp]: "A \<noteq> V" "A \<noteq> S" "A \<noteq> T"
                                  "V \<noteq> A" "V \<noteq> S" "V \<noteq> T"
                                  "S \<noteq> A" "S \<noteq> V" "S \<noteq> T"
                                  "T \<noteq> A" "T \<noteq> V" "T \<noteq> S"
  unfolding A_def V_def S_def T_def by auto

definition Train :: proc where
  "Train =
    Rep (
      T ::= (\<lambda>_. 0);
      Cont (ODE ((\<lambda>_ _. 0)(S := (\<lambda>s. s V),
                           V := (\<lambda>s. s A), T := (\<lambda>_. 1))))
                ((\<lambda>s. s T < Period \<and> s V > 0));
      Wait (\<lambda>s. Period - s T);
      Cm (''Train2Control''[!](\<lambda>s. s V));
      Cm (''Train2Control''[!](\<lambda>s. s S));
      Cm (''Control2Train''[?]A)
    )"

text \<open>Running time of ODE\<close>
definition T_t :: "real \<Rightarrow> real \<Rightarrow> real" where
  "T_t v0 a = (if v0 \<le> 0 then 0
               else (if v0 + a * Period > 0 then Period
               else v0/(-a)))"

lemma T_t_prop1:
  "\<not>v0 \<le> 0 \<Longrightarrow> 0 < T_t v0 a"
  unfolding T_t_def using Period
  apply auto
  subgoal premises pre
  proof -
    have "a<0" using pre Period
      by (smt mult_nonneg_nonneg)
    then show ?thesis using pre
      by (simp add: divide_pos_neg)
  qed
  done

lemma T_t_prop2:
  "\<not>v0 \<le> 0 \<Longrightarrow> T_t v0 a \<le> Period"
  unfolding T_t_def
  apply auto
  by (metis Period add_nonneg_pos add_pos_nonneg leI linear linorder_neqE_linordered_idom
        mult.commute mult_pos_pos mult_zero_left neg_less_minus_divide_eq real_0_less_add_iff)

lemma T_t_prop3:
  "\<not>v0 \<le> 0 \<Longrightarrow> \<not> T_t v0 a < Period \<Longrightarrow> T_t v0 a = Period"
  using T_t_prop2
  by (simp add: dual_order.antisym)

lemma linear_ge:
  assumes "(tmax::real)\<ge>0"
    and "(a::real) \<ge> (c::real)"
    and "a + (b::real)*tmax\<ge>c"
    and "(t::real) \<ge> 0"
    and "t \<le> tmax"
  shows "a+b*t \<ge> c"
proof (cases "b\<ge>0")
  case True
  then have "b*t \<ge>0"
    using assms by auto
  then have "a+b*t \<ge>a"
    by auto
  then show ?thesis using assms by auto
next
  case False
  then have "b*t \<ge> b*tmax"
    using assms by auto
  then have "a+b*t \<ge> a+b*tmax"
    by auto
  then show ?thesis using assms by auto
qed

lemma linear_g:
  assumes "(tmax::real)\<ge>0"
    and "(a::real) > (c::real)"
    and "a + (b::real)*tmax>c"
    and "(t::real) \<ge> 0"
    and "t \<le> tmax"
  shows "a+b*t > c"
proof (cases "b\<ge>0")
  case True
  then have "b*t \<ge>0"
    using assms by auto
  then have "a+b*t \<ge>a"
    by auto
  then show ?thesis using assms by auto
next
  case False
  then have "b*t \<ge> b*tmax"
    using assms by auto
  then have "a+b*t \<ge> a+b*tmax"
    by auto
  then show ?thesis using assms by auto
qed

definition T_tassn :: "real \<Rightarrow> real \<Rightarrow> real \<Rightarrow> tassn" where
  "T_tassn v0 s0 a =
    (if v0 \<le> 0 then
       emp\<^sub>t @\<^sub>t Wait\<^sub>t (Period) (\<lambda>t. State ((\<lambda>_. 0)(V := v0, S := s0,
                                            A := a, T := 0))) ({}, {})
     else
       Wait\<^sub>t (T_t v0 a) (\<lambda>t. State ((\<lambda>_. 0)(V := v0+a*t, S := s0+v0*t+1/2*a*t*t,
                                            A := a, T := t))) ({}, {})
    @\<^sub>t Wait\<^sub>t (Period - T_t v0 a) (\<lambda>t. State ((\<lambda>_. 0)(V := v0+a*(T_t v0 a), S := s0+v0*(T_t v0 a)+1/2*a*(T_t v0 a)*(T_t v0 a),
                                            A := a, T := (T_t v0 a)))) ({}, {}))"

fun Train_inv :: "real \<times> real \<times> real \<times> real\<Rightarrow> real list \<Rightarrow> tassn" where
  "Train_inv (v0, s0, a0, t0) [] = emp\<^sub>t"
| "Train_inv (v0, s0, a0, t0) (a # as) =
    T_tassn v0 s0 a0 @\<^sub>t
    (Out\<^sub>t (State ((\<lambda>_. 0)(V := v0+a0*(T_t v0 a0), S := s0+v0*(T_t v0 a0)+1/2*a0*(T_t v0 a0)*(T_t v0 a0), A := a0, T := (T_t v0 a0)))) ''Train2Control'' (v0+a0*(T_t v0 a0))) @\<^sub>t
    (Out\<^sub>t (State ((\<lambda>_. 0)(V := v0+a0*(T_t v0 a0), S := s0+v0*(T_t v0 a0)+1/2*a0*(T_t v0 a0)*(T_t v0 a0), A := a0, T := (T_t v0 a0)))) ''Train2Control'' (s0+v0*(T_t v0 a0)+1/2*a0*(T_t v0 a0)*(T_t v0 a0))) @\<^sub>t
    (In\<^sub>t (State ((\<lambda>_. 0)(V := v0+a0*(T_t v0 a0), S := s0+v0*(T_t v0 a0)+1/2*a0*(T_t v0 a0)*(T_t v0 a0), A := a0, T := (T_t v0 a0)))) ''Control2Train'' a) @\<^sub>t
    Train_inv (v0+a0*(T_t v0 a0), s0+v0*(T_t v0 a0)+1/2*a0*(T_t v0 a0)*(T_t v0 a0), a, T_t v0 a0) (as)"

fun Train_end_state :: "real \<times> real \<times> real \<times> real \<Rightarrow> real list \<Rightarrow> state" where
  "Train_end_state (v0, s0, a0, t0) [] = ((\<lambda>_. 0)(V := v0, S := s0, A := a0, T := t0))"
| "Train_end_state (v0, s0, a0, t0) (a # rest) =
   Train_end_state (v0 + a0 * T_t v0 a0, s0 + v0 * (T_t v0 a0) +
                          1/2 * a0 * (T_t v0 a0) * (T_t v0 a0), a, T_t v0 a0) rest"

lemma Train_end_state_rw:
  "(Train_end_state (v0, s0, a0, t0) xs)(T := 0) =
   (\<lambda>_. 0)(V := Train_end_state (v0, s0, a0, t0) xs V,
           S := Train_end_state (v0, s0, a0, t0) xs S,
           A := Train_end_state (v0, s0, a0, t0) xs A, T := 0)"
  apply (induct xs arbitrary: v0 s0 a0 t0) by auto

definition Train_ode_state :: "state \<Rightarrow> state" where
  "Train_ode_state s = (\<lambda>_. 0)(V := s V + s A * (T_t  (s V)  (s A)),
           S := s S + s V * (T_t  (s V)  (s A)) + s A * (T_t  (s V)  (s A)) * (T_t  (s V)  (s A)) / 2,
           A := s A, T := (T_t  (s V)  (s A)))"

lemma Train_end_state_snoc:
  "Train_end_state (v0, s0, a0, t0) (xs @ [a]) =
   (Train_ode_state (Train_end_state (v0, s0, a0, t0) (xs))) (A := a)"
  apply (induct xs arbitrary: v0 s0 a0 t0) unfolding Train_ode_state_def by auto

lemma Train_inv_snoc:
  "Train_inv (v0, s0, a0, t0) (xs @ [a]) =
   Train_inv (v0, s0, a0, t0) xs @\<^sub>t
   T_tassn (Train_end_state (v0, s0, a0, t0) xs V) (Train_end_state (v0, s0, a0, t0) xs S) (Train_end_state (v0, s0, a0, t0) xs A) @\<^sub>t
   Out\<^sub>t (State (Train_ode_state(Train_end_state (v0, s0, a0, t0) xs))) ''Train2Control'' (Train_end_state (v0, s0, a0, t0) xs V + (Train_end_state (v0, s0, a0, t0) xs A) * T_t (Train_end_state (v0, s0, a0, t0) xs V) (Train_end_state (v0, s0, a0, t0) xs A)) @\<^sub>t
   Out\<^sub>t (State (Train_ode_state(Train_end_state (v0, s0, a0, t0) xs))) ''Train2Control'' (Train_end_state (v0, s0, a0, t0) xs S  +
            Train_end_state (v0, s0, a0, t0) xs V * T_t (Train_end_state (v0, s0, a0, t0) xs V) (Train_end_state (v0, s0, a0, t0) xs A) +
            (Train_end_state (v0, s0, a0, t0) xs A) * T_t (Train_end_state (v0, s0, a0, t0) xs V) (Train_end_state (v0, s0, a0, t0) xs A) * T_t (Train_end_state (v0, s0, a0, t0) xs V) (Train_end_state (v0, s0, a0, t0) xs A) / 2) @\<^sub>t
   In\<^sub>t (State (Train_ode_state(Train_end_state (v0, s0, a0, t0) xs))) ''Control2Train'' a
   "
proof (induct xs arbitrary: v0 s0 a0 t0)
  case Nil
  have "((\<lambda>_. 0)(V := v0 + a0 * T_t v0 a0, S := s0 + v0 * T_t v0 a0 + a0 * T_t v0 a0 * T_t v0 a0 / 2, A := a0, T := T_t v0 a0)) =
        (\<lambda>a. if a = T then T_t v0 a0
             else ((\<lambda>_. 0)
                   (V := v0 + a0 * T_t v0 a0, S := s0 + v0 * T_t v0 a0 + a0 * T_t v0 a0 * T_t v0 a0 / 2, A := a0))
                   a)"
    apply (rule ext) by auto
  then show ?case
    unfolding Train_ode_state_def
    by auto
next
  case (Cons a xs)
  show ?case
    by (auto simp add: Cons join_assoc)
qed

lemma trainode:
  "\<Turnstile>
    {\<lambda>s tr. s = (\<lambda>_. 0)(V := v0, S := s0, A := a, T := 0) \<and> P tr}
      Cont (ODE ((\<lambda>_ _. 0)(S := (\<lambda>s. s V), V := (\<lambda>s. s A), T := (\<lambda>_. 1))))
                (\<lambda>s. s T < Period \<and> s V > 0);
      Wait (\<lambda>s. Period - s T)
    {\<lambda>s tr. s = (\<lambda>_. 0)(V := v0 + a * (T_t v0 a),
                        S := s0 + v0 * (T_t v0 a) + 1/2 * a * (T_t v0 a) * (T_t v0 a),
                        A := a, T := (T_t v0 a)) \<and>
            (P @\<^sub>t (T_tassn v0 s0 a)) tr}"
  proof (cases "v0 \<le> 0")
  case True
  then show ?thesis unfolding T_tassn_def T_t_def apply auto
    apply (rule Valid_seq)
    apply (rule Valid_ode_exit_st)
     apply auto
    apply(rule Valid_strengthen_post)
     prefer 2
     apply(rule Valid_wait_sp)
    apply(auto simp add:entails_def pure_assn_def conj_assn_def)
    done
next
case False
  then show ?thesis unfolding T_tassn_def apply auto
    apply(rule Valid_seq[where Q = "\<lambda> s tr .  s = (\<lambda>_. 0)
           (V := v0 + a * T_t v0 a, S := s0 + v0 * T_t v0 a + a * T_t v0 a * T_t v0 a / 2, A := a, T := T_t v0 a) \<and> (P @\<^sub>t
            Wait\<^sub>t (T_t v0 a) (\<lambda>t. State ((\<lambda>_. 0)(V := v0 + a * t, S := s0 + v0 * t + a * t * t / 2, A := a, T := t))) ({}, {})) tr"])
    subgoal
apply (rule Valid_ode_unique_solution_st)
    subgoal using T_t_prop1 by auto
    subgoal
      unfolding ODEsol_def has_vderiv_on_def
      apply auto
    subgoal
      using T_t_prop1
      by (meson not_le_imp_less order.asym)
    apply (rule exI[where x=1]) apply auto
    subgoal for x
    apply (rule has_vector_derivative_projI)
     apply (auto simp add: state2vec_def)
     unfolding power2_eq_square
     subgoal
       apply (rule has_vector_derivative_eq_rhs)
        apply (fast intro!: derivative_intros) by simp
     subgoal
      apply (rule has_vector_derivative_eq_rhs)
        apply (fast intro!: derivative_intros) by simp
     subgoal premises pre for i
   proof-
     have eq: "i \<noteq> S \<Longrightarrow>
           i \<noteq> V \<Longrightarrow>
           i \<noteq> T \<Longrightarrow>
           (\<lambda>t. if i = A then a
                 else ((\<lambda>_. 0)(V := v0 + a * t, S := s0 + v0 * t + a * (t * t) / 2))
                       i) = (\<lambda>t. if i = A then a else 0)"
       by auto
     have 1: ?thesis if "i = A"
       using eq that by auto
     have 2: ?thesis if "i \<noteq> A"
       using eq that pre by auto
     show ?thesis using 1 2 by linarith
       qed
       done
     done
   subgoal unfolding T_t_def apply auto
     subgoal for t
       using linear_g Period
       by (smt mult_nonneg_nonneg mult_strict_left_mono_neg)
     subgoal for t
       by (smt T_t_def T_t_prop2 minus_divide_right)
     subgoal for t
       by (metis add_strict_increasing mult.commute neg_less_minus_divide_eq not_less real_0_less_add_iff split_mult_pos_le)
     done
  subgoal unfolding T_t_def by auto
  subgoal by simp
  subgoal
   proof-
    have bl:"bounded_linear (\<lambda>(v::vec) . \<chi> x. if x = T then 0 else if x = V then (v$A) else if x = S then (v$V) else 0)"
      apply (rule bounded_linearI')
      using vec_lambda_unique by fastforce+
    show ?thesis
      unfolding state2vec_def vec2state_def fun_upd_def
      apply (rule c1_implies_local_lipschitz[where f'="(\<lambda>(t,v). Blinfun(\<lambda>(v::vec) . \<chi> x. if x = T then 0 else if x = V then (v$A) else if x = S then (v$V) else 0))"])
         apply (auto simp add: bounded_linear_Blinfun_apply[OF bl])
      subgoal premises pre for t x
        unfolding has_derivative_def apply (auto simp add: bl)
        apply (rule vec_tendstoI)
        by (auto simp add: state2vec_def)
        done
    qed
    done
  apply(rule Valid_strengthen_post)
   prefer 2
   apply(rule Valid_wait_sp)
  by (auto simp add:entails_def pure_assn_def conj_assn_def join_assoc)
qed

lemma Valid_seq':
  "\<Turnstile> {P} c1;c2 {Q} \<Longrightarrow> \<Turnstile> {Q} c3 {R} \<Longrightarrow> \<Turnstile> {P} c1; c2; c3 {R}"
 unfolding Valid_def
  apply (auto elim!: seqE)
  using seqB by fastforce

lemma Train_prop:
  "\<Turnstile>
    {\<lambda>s tr. s = (\<lambda>_. 0)(V := v0, S := s0, A := a0, T := t0) \<and> emp\<^sub>t tr}
      Train
    {\<lambda>s tr. \<exists>xs. s = Train_end_state (v0, s0, a0, t0) xs \<and>
                 Train_inv (v0, s0, a0, t0) xs tr}"
  unfolding Train_def
  apply (rule Valid_weaken_pre)
   prefer 2 apply (rule Valid_rep)
  apply (rule Valid_ex_pre)
  subgoal for xs
    apply (rule Valid_seq)
    apply (rule Valid_assign_sp_st)
    apply (rule Valid_seq')
     apply (subst Train_end_state_rw)
     apply (rule trainode)
    apply (rule Valid_seq)
apply (rule Valid_send_sp_st)
    apply (rule Valid_seq)
    apply (rule Valid_send_sp_st)
    apply (rule Valid_strengthen_post)
    prefer 2
    apply (rule Valid_receive_sp_st)
    apply (auto simp add :entails_def)
    subgoal for tr a
      apply (rule exI[where x="xs@[a]"])
      apply (auto simp add: Train_end_state_snoc Train_inv_snoc join_assoc Train_ode_state_def)
      done
    done
  apply(auto simp add:entails_def)
  subgoal for tr
    apply (rule exI[where x="[]"])
    apply auto
    done
  done

text \<open>Limit on velocity as a function of position and
  maximum velocity in the next segment.

\<close>
definition fs_gen :: "real \<Rightarrow> real \<Rightarrow> real" where
   "fs_gen s next_v =
      (let D = Stop_point - s in
        if D \<ge> Pull_curve_max_d then
          V_limit
        else if D \<ge> 0 then
          sqrt (next_v * next_v + 2 * A_minus * D)
        else 0)"

definition com_a_gen :: "real \<Rightarrow> real \<Rightarrow> real \<Rightarrow> real" where
  "com_a_gen s v next_v =
      (let s1' = s + v * Period + A_plus * Period\<^sup>2 / 2 in
       let target_v1 = fs_gen s1' next_v in
         if v + A_plus * Period \<le> target_v1 then
           A_plus
         else let s2' = s + v * Period in
              let target_v2 = fs_gen s2' next_v in
                if v \<le> target_v2 then 0
                else -A_minus)"

lemma control_vars_distinct [simp]: "Command_a \<noteq> V" "Command_a \<noteq> S" "Command_a \<noteq> Level" "Command_a \<noteq> Next_seg_v"
                                  "V \<noteq> Command_a" "V \<noteq> S" "V \<noteq> Level" "V \<noteq> Next_seg_v"
                                  "S \<noteq> Command_a" "S \<noteq> V" "S \<noteq> Level" "S \<noteq> Next_seg_v"
                                  "Level \<noteq> Command_a" "Level \<noteq> V" "Level \<noteq> S" "Level \<noteq> Next_seg_v"
                                  "Next_seg_v \<noteq> Command_a" "Next_seg_v \<noteq> V" "Next_seg_v \<noteq> S" "Next_seg_v \<noteq> Level"

  unfolding Command_a_def V_def S_def Level_def Next_seg_v_def by auto

definition Control :: proc where
  "Control =

    Rep(
Level ::= (\<lambda>_. 2.5);Next_seg_v ::= (\<lambda>_. 0);
      Cm (''Train2Control''[?]V);
      Cm (''Train2Control''[?]S);
      (IF (\<lambda>s. s Level = 2.5 \<and> s S > Stop_point) THEN
          Level ::= (\<lambda>_. 3)
       ELSE Skip FI);
      (IF (\<lambda>s. s Level = 3 \<and> s S < Stop_point / 2) THEN
          Next_seg_v ::= (\<lambda>_. Next_V_limit)
       ELSE Skip FI);
      Command_a ::= (\<lambda>s. com_a_gen (s S) (s V) (s Next_seg_v));
      Cm (''Control2Train''[!](\<lambda>s. s Command_a)))"

definition fs :: "real \<Rightarrow> real" where
   "fs s =
      (let D = Stop_point - s in
        if D \<ge> Pull_curve_max_d then
          V_limit
        else if D \<ge> 0 then
          Pull_curve_coeff * sqrt(D)
        else 0)"

definition com_a :: "real \<Rightarrow> real \<Rightarrow> real" where
  "com_a s v =
      (let s1' = s + v * Period + A_plus * Period\<^sup>2 / 2 in
       let target_v1 = fs s1' in
         if v + A_plus * Period \<le> target_v1 then
           A_plus
         else let s2' = s + v * Period in
              let target_v2 = fs s2' in
                if v \<le> target_v2 then 0
                else -A_minus)"

lemma fs_gen_zero:
  "fs_gen s 0 = fs s"
  unfolding fs_gen_def fs_def Let_def Pull_curve_coeff_def
  by (auto simp add: real_sqrt_mult)

lemma com_a_zero:
  "com_a_gen s v 0 = com_a s v"
  unfolding com_a_gen_def com_a_def
  using fs_gen_zero by auto

fun Control_blocks :: "real \<times> real \<times> real \<times> real \<Rightarrow> (real \<times> real) list \<Rightarrow> tassn" where
  "Control_blocks (v0, s0, a0, l0) [] = emp\<^sub>t"
| "Control_blocks (v0, s0, a0, l0) ((v, s) # rest) =
    In\<^sub>t (State ((\<lambda>_. 0)(V := v0, S := s0, Command_a := a0, Level := 2.5, Next_seg_v := 0))) ''Train2Control'' v @\<^sub>t
    In\<^sub>t (State ((\<lambda>_. 0)(V := v, S := s0, Command_a := a0, Level := 2.5, Next_seg_v := 0))) ''Train2Control'' s @\<^sub>t
    Out\<^sub>t (State ((\<lambda>_. 0)(V := v, S := s, Command_a := com_a s v, Level := if s > Stop_point then 3 else 2.5, Next_seg_v := 0))) ''Control2Train'' (com_a s v) @\<^sub>t
    Control_blocks (v, s, com_a s v, if s > Stop_point then 3 else 2.5) rest"

fun Control_end_state :: "real \<times> real \<times> real \<times> real  \<Rightarrow> (real \<times> real) list \<Rightarrow> state" where
  "Control_end_state (v0, s0, a0, l0) [] = ((\<lambda>_. 0)(V := v0, S := s0, Command_a := a0, Level := l0, Next_seg_v := 0))"
| "Control_end_state (v0, s0, a0, l0) ((v, s) # rest) = Control_end_state (v, s, com_a s v, if s > Stop_point then 3 else 2.5) rest"

lemma Control_end_state_snoc:
  "Control_end_state (v0, s0, a0, l0) (xs @ [(v, s)]) =
   (Control_end_state (v0, s0, a0, l0) xs)(V := v, S := s, Command_a := com_a s v,Level := if s > Stop_point then 3 else 2.5, Next_seg_v := 0)"
  apply (induct xs arbitrary: v0 s0 a0 l0) by auto

lemma Control_blocks_snoc:
  "Control_blocks (v0, s0, a0, l0) (xs @ [(v, s)]) =
   Control_blocks (v0, s0, a0, l0) xs @\<^sub>t
   In\<^sub>t (State ((Control_end_state (v0, s0, a0, l0) xs)(Level := 2.5, Next_seg_v := 0))) ''Train2Control'' v @\<^sub>t
   In\<^sub>t (State ((Control_end_state (v0, s0, a0, l0) xs)(V := v, Level := 2.5, Next_seg_v := 0))) ''Train2Control'' s @\<^sub>t
   Out\<^sub>t (State ((Control_end_state (v0, s0, a0, l0) xs)(V := v, S := s, Command_a := com_a s v,Level := if s > Stop_point then 3 else 2.5, Next_seg_v := 0))) ''Control2Train'' (com_a s v)"
  apply (induct xs arbitrary: v0 s0 a0 l0)
   apply (auto simp add: join_assoc Control_end_state_snoc)
   apply (simp add: fun_upd_twist)
apply (simp add: fun_upd_twist)
  done

lemma Control_prop:
  "\<Turnstile>
    {\<lambda>s tr. s = ((\<lambda>_. 0)(V := v0, S := s0, Command_a := a0,
                       Level := l0, Next_seg_v := 0 )) \<and> emp\<^sub>t tr}
      Control
    {\<lambda>s tr. \<exists>xs. s = Control_end_state (v0, s0, a0, l0) xs
                         \<and> Control_blocks (v0, s0, a0, l0) xs tr}"
  unfolding Control_def
  apply (rule Valid_weaken_pre)
   prefer 2 apply (rule Valid_rep)
  apply (rule Valid_ex_pre)
  subgoal for xs
    apply (rule Valid_seq)
     apply (rule Valid_assign_sp_st)
      apply (rule Valid_seq)
       apply (rule Valid_assign_sp_st)
        apply (rule Valid_seq)
    apply (rule Valid_receive_sp_st)
    apply (rule Valid_ex_pre)
        subgoal for v
      apply (rule Valid_seq)
      apply (rule Valid_receive_sp_st)
      apply (rule Valid_ex_pre)
       subgoal for s
         apply(rule Valid_seq)
          apply(rule Valid_cond_sp2)
           apply (rule Valid_assign_sp_st)
          apply(rule Valid_skip)
         apply(rule Valid_seq)
          apply(rule Valid_if_split)
           apply(rule Valid_cond_sp2)
            apply (rule Valid_assign_sp_st)
           apply(rule Valid_skip)
          apply(rule Valid_cond_sp2)
            apply (rule Valid_assign_sp_st)
          apply(rule Valid_skip)
         apply(rule Valid_seq)
          apply(rule Valid_if_split)
           apply(rule Valid_if_split)
            apply (rule Valid_assign_sp_st)
           apply (rule Valid_assign_sp_st)
          apply(rule Valid_if_split)
           apply (rule Valid_assign_sp_st)
          apply (rule Valid_assign_sp_st)
         apply(rule Valid_strengthen_post)
          prefer 2
          apply(rule Valid_if_split)
           apply(rule Valid_if_split)
            apply(rule Valid_send_sp)
           apply(rule Valid_send_sp)
          apply(rule Valid_if_split)
            apply(rule Valid_send_sp)
          apply(rule Valid_send_sp)
         apply(auto simp add:entails_def)
         subgoal
           using Stop_point by linarith
         subgoal for sa tr
           apply (rule exI[where x="xs@[(v,s)]"])
           apply(auto simp add: pure_assn_def conj_assn_def join_assoc Control_end_state_snoc Control_blocks_snoc fun_upd_twist com_a_zero)
           done
         subgoal for sa tr
           apply (rule exI[where x="xs@[(v,s)]"])
           apply(auto simp add: pure_assn_def conj_assn_def join_assoc Control_end_state_snoc Control_blocks_snoc fun_upd_twist com_a_zero)
           done
         subgoal for sa tr
           apply (rule exI[where x="xs@[(v,s)]"])
           apply(auto simp add: pure_assn_def conj_assn_def join_assoc Control_end_state_snoc Control_blocks_snoc fun_upd_twist com_a_zero)
           done
         done
       done
     done
   apply(auto simp add: entails_def)
   apply (rule exI[where x="[]"]) by auto

text \<open>Once through the loop. Input and output are s and v\<close>
fun loop_once :: "real \<times> real \<Rightarrow> real \<times> real" where
  "loop_once (s, v) = (if v \<le> 0 then (s, v) else
    (let a = com_a s v in
     let v' = v + a * Period in
     let s' = s + v * Period + a * Period\<^sup>2 / 2 in
      if v'> 0 then (s', v') else (s - v^2/(2*a), 0)))"
declare loop_once.simps[simp del]

lemma loop_once_prop1:
  assumes "v>0"
  shows " loop_once(s,v) =
    (s + v * T_t v (com_a s v) + com_a s v * T_t v (com_a s v) * T_t v (com_a s v) / 2,
     v + com_a s v * T_t v (com_a s v))"
  using assms unfolding T_t_def
  apply auto
  unfolding Let_def loop_once.simps apply auto
   apply (simp add: power2_eq_square)
  by (simp add: power2_eq_square)

lemma fs_at_least_zero:
  "fs s \<ge> 0"
  unfolding fs_def Let_def apply auto
  using V_limit apply auto
  using  Pull_curve_coeff_ge_zero
  by (simp add: dual_order.strict_implies_order)

lemma fs_at_most_limit:
  "fs s \<le> V_limit"
  unfolding fs_def Let_def
  apply auto
  subgoal premises pre
  proof-
    have "Stop_point - s < V_limit * V_limit / (2 * A_minus)"
        using pre unfolding Pull_curve_max_d_def Pull_curve_coeff_def by auto
      then have 31: "(Stop_point - s) * (2 * A_minus) < V_limit * V_limit"
        using A_minus
        by (metis lattice_ab_group_add_class.zero_less_double_add_iff_zero_less_single_add mult_2 pos_less_divide_eq)
      have 32: "sqrt (2 * A_minus) * sqrt (Stop_point - s) = sqrt ((Stop_point - s) * (2 * A_minus))"
        using A_minus pre by (simp add: real_sqrt_mult)
      have 33: "V_limit = sqrt (V_limit * V_limit)"
        using V_limit by auto
      show ?thesis
        unfolding Pull_curve_max_d_def Pull_curve_coeff_def 32
        apply (subst 33) using 31
        using real_sqrt_less_iff
        using less_eq_real_def by blast
    qed
    subgoal using V_limit by auto
    done

lemma fs_prop1:
  assumes "v \<le> fs(s)"
    and "v \<ge> 0"
    and "s \<le> Stop_point"
  shows "v^2 \<le> 2 * A_minus * (Stop_point - s)"
proof-
  have 1: "v^2 \<le> 2 * A_minus * (Stop_point - s)" if "Stop_point - s \<ge> Pull_curve_max_d"
  proof-
    have 11: "v\<le>V_limit"
      using assms(1) that unfolding fs_def Let_def by auto
    then have 12: "v^2\<le>V_limit^2"
      using assms(2) V_limit by simp
    have 13:" V_limit^2 \<le>2 * A_minus * (Stop_point - s)"
      using that A_minus unfolding Pull_curve_max_d_def
      by (auto simp add: power2_eq_square field_simps)
    then show ?thesis using 12 by auto
  qed
  have 2:"v^2 \<le> 2 * A_minus * (Stop_point - s)" if "Stop_point - s < Pull_curve_max_d"
  proof-
    have 21:"v \<le> Pull_curve_coeff * sqrt(Stop_point - s)"
      using assms that unfolding fs_def by auto
    then show ?thesis using assms A_minus unfolding Pull_curve_coeff_def
      by (metis power2_eq_square real_sqrt_le_iff real_sqrt_mult real_sqrt_pow2)
  qed
  show ?thesis using 1 2 assms
    by linarith
qed

fun loop_invariant :: "real \<times> real \<Rightarrow> bool" where
  "loop_invariant (s, v) \<longleftrightarrow> v \<le> fs s \<and> v \<ge> 0 \<and> s \<le> Stop_point"

lemma loop_once_invariant:
  assumes "v \<le> fs s \<and> v \<ge> 0 \<and> s \<le> Stop_point"
    and "(s', v') = loop_once (s, v)"
  shows "v' \<le> fs s' \<and> v' \<ge> 0 \<and> s' \<le> Stop_point"
proof -
  have case0:"v' \<le> fs s' \<and> v' \<ge> 0 \<and> s' \<le> Stop_point" if cond0:"v \<le> 0"
    using assms that loop_once.simps by auto
  have case1:"v' \<le> fs s' \<and> v' \<ge> 0 \<and> s' \<le> Stop_point" if cond1:"v + A_plus * Period \<le> fs (s + v * Period + A_plus * Period\<^sup>2 / 2)" "v>0"
  proof-
    have 1:"com_a s v = A_plus"
      using that unfolding com_a_def by auto
    have 2:"v + A_plus * Period > 0" using assms A_plus Period
      by (simp add: add_strict_increasing2)
    have 3:"(s', v') = (s + v * Period + A_plus * Period\<^sup>2 / 2,v + A_plus * Period )"
      using assms 1  2 that loop_once.simps by auto
    have 4:"v' \<le> fs s'"
      using that 3
      unfolding fs_def Let_def by auto
    have 5:"v' \<ge> 0"
      using 3 that 2 by auto
    have 6:"s' \<le> Stop_point"
      using 3 2 that apply(simp add: fs_def Let_def) apply auto
      by (smt Pull_curve_max_d_ge_zero)
    show ?thesis using 4 5 6 by auto
  qed
  have case2:"v' \<le> fs s' \<and> v' \<ge> 0 \<and> s' \<le> Stop_point" if cond2:
    "\<not> v + A_plus * Period \<le> fs (s + v * Period + A_plus * Period\<^sup>2 / 2)"
    "v \<le> fs (s + v * Period)" "v>0"
  proof-
    have 1: "com_a s v = 0" using that unfolding com_a_def by auto
    have 2: "(s',v') = (s + v * Period, v)" using assms 1 loop_once.simps by auto
    have 3:"v' \<le> fs s'"
      using 2 that
      unfolding fs_def Let_def apply auto
      subgoal premises pre
      proof-
        have "v\<le>0" using pre
          using Pull_curve_max_d_ge_zero by auto
        then show ?thesis using pre by auto
      qed
      done
    have 4:"v' \<ge> 0"
      using 2 assms by auto
    have 5:"s' \<le> Stop_point"
    proof-
      have "v = 0" if "s' > Stop_point"
        using 2 3 unfolding fs_def Let_def
        using Pull_curve_max_d_ge_zero assms(1) that by auto
      then have"s=s'" if "s' > Stop_point" using 2 that by auto
      then show ?thesis using assms
        using leI by blast
    qed
    then show ?thesis using 3 4 5 by auto
  qed
  have case3:"v' \<le> fs s' \<and> v' \<ge> 0 \<and> s' \<le> Stop_point" if cond3:
    "\<not> v + A_plus * Period \<le> fs (s + v * Period + A_plus * Period\<^sup>2 / 2)"
    "\<not> v \<le> fs (s + v * Period)" "v>0"
  proof-
    have 1: "com_a s v = -A_minus" using that unfolding com_a_def by auto
    have case31: "v' \<le> fs s' \<and> v' \<ge> 0 \<and> s' \<le> Stop_point" if cond31:"v -A_minus * Period >0"
    proof-
      have 2:"(s',v') = (s + v * Period - A_minus * Period\<^sup>2 / 2, v - A_minus  * Period)"
        using assms 1 cond31 cond3 loop_once.simps by auto
      have 3:"s' \<le> Stop_point"
        using 2 apply auto
        subgoal premises pre
        proof-
          have "v^2 \<le> 2 * A_minus * (Stop_point - s)"
              using fs_prop1 assms by auto
          then have "v^2 - 2 * A_minus * v * Period + A_minus^2 * Period^2 \<le>
                      2 * A_minus * (Stop_point - s) - 2 * A_minus * v * Period + A_minus^2 * Period^2"
            by auto
          then have "v^2 - 2 * A_minus * v * Period + A_minus^2 * Period^2 \<le>
                      2 * A_minus * (Stop_point - s - v * Period + 1/2 * A_minus * Period^2)"
            by (auto simp add: algebra_simps power2_eq_square)
          then have "(v - A_minus * Period)^2 \<le> 2 * A_minus * (Stop_point - (s + v * Period - 1/2 * A_minus * Period^2))"
            by (auto simp add: algebra_simps power2_eq_square)
          then have " 2 * A_minus * (Stop_point - (s + v * Period - 1/2 * A_minus * Period^2)) > 0"
            by (smt that zero_less_power)
          then show ?thesis using A_minus
            by (smt mult_cancel_right1 mult_le_0_iff times_divide_eq_left)
        qed
        done
       have 4:"v' \<le> fs s'"
        using 2
        unfolding fs_def Let_def apply auto
        subgoal using assms(1) fs_at_most_limit A_minus Period
          by (smt mult_diff_mult real_mult_less_iff1)
        subgoal premises pre
        proof-
          have "v^2 \<le> 2 * A_minus * (Stop_point - s)"
            using fs_prop1 assms by auto
          then have "v^2 - 2 * A_minus * v * Period + A_minus^2 * Period^2 \<le>
                      2 * A_minus * (Stop_point - s) - 2 * A_minus * v * Period + A_minus^2 * Period^2"
            by auto
          then have "v^2 - 2 * A_minus * v * Period + A_minus^2 * Period^2 \<le>
                      2 * A_minus * (Stop_point - s - v * Period + 1/2 * A_minus * Period^2)"
            by (auto simp add: algebra_simps power2_eq_square)
          then have "(v - A_minus * Period)^2 \<le> 2 * A_minus * (Stop_point - (s + v * Period - 1/2 * A_minus * Period^2))"
            by (auto simp add: algebra_simps power2_eq_square)
          then have a:"sqrt((v - A_minus * Period)^2) \<le> sqrt(2 * A_minus * (Stop_point - (s + v * Period - 1/2 * A_minus * Period^2)))"
            using real_sqrt_le_iff by blast
          have b:"(v - A_minus * Period) = sqrt((v - A_minus * Period)^2)"
            using cond31 by auto
          have c:"sqrt(2 * A_minus * (Stop_point - (s + v * Period - 1/2 * A_minus * Period^2))) = sqrt(2 * A_minus) * sqrt((Stop_point - (s + v * Period - 1/2 * A_minus * Period^2)))"
            by (simp add: real_sqrt_mult)
          show ?thesis using a b c unfolding Pull_curve_coeff_def by auto
        qed
        subgoal using assms fs_at_most_limit A_minus Period
          using Pull_curve_max_d_ge_zero by linarith
        subgoal using 3 by auto
        done
      have 5:"v'\<ge>0"
        using 2 cond31 by auto
      show ?thesis using 3 4 5 by auto
    qed
    have case32: "v' \<le> fs s' \<and> v' \<ge> 0 \<and> s' \<le> Stop_point" if cond32:"v -A_minus * Period \<le> 0"
    proof-
      have 2:"(s',v') = (s + v^2/(2*A_minus), 0)"
        using 1 assms cond32 loop_once.simps by auto
      have 3:"s' \<le> Stop_point"
      proof-
        have "v\<^sup>2 \<le> 2 * A_minus * (Stop_point - s)"
          using 2 assms fs_prop1 by auto
        then have "v\<^sup>2 /(2* A_minus) \<le> Stop_point - s"
          using A_minus
          by (smt divide_divide_eq_left divide_less_cancel real_divide_square_eq)
        then have "s + v\<^sup>2 /(2* A_minus) \<le> Stop_point"
          by auto
        then show ?thesis
          using 2 by auto
      qed
      have 4: "v'\<le>fs s'"
        using 2 3 fs_at_least_zero by auto
      have 5: "v'\<ge> 0"
        using 2 by auto
      show ?thesis using 3 4 5 by auto
    qed
    show ?thesis
      using case31 case32 by linarith
  qed
  show ?thesis
    using case0 case1 case2 case3
    by linarith
qed

lemma loop_once_invariant':
  assumes "loop_invariant (s,v)"
    and "(s', v') = loop_once (s, v)"
  shows "loop_invariant (s',v')"
  using loop_once_invariant assms
  using loop_invariant.simps by blast

definition system :: pproc where
  "system = Parallel (Single Train)
                     {''Train2Control'', ''Control2Train''}
                     (Single Control)"

definition P_tassn :: "real \<Rightarrow> real \<Rightarrow> tassn " where
  "P_tassn v0 s0 =
   (\<up>(loop_invariant (s0, v0)) \<and>\<^sub>t
    (if v0 \<le> 0 then
       emp\<^sub>t @\<^sub>t Wait\<^sub>t (Period) (\<lambda>t. ParState (State ((\<lambda>_. 0)(V := v0, S := s0, A := com_a s0 v0, T := 0))) (State ((\<lambda>_. 0)(V := v0, S := s0, Command_a := com_a s0 v0, Level := 2.5, Next_seg_v := 0)) )) ({}, {''Train2Control''})
     else
       Wait\<^sub>t (T_t v0 (com_a s0 v0))
    (\<lambda>t. ParState
      (State ((\<lambda>_. 0)(V := v0 + com_a s0 v0 * t,
                      S := s0 + v0 * t + 1/2 * com_a s0 v0 * t * t,
                      A := com_a s0 v0, T := t)))
      (State ((\<lambda>_. 0)(V := v0, S := s0, Command_a := com_a s0 v0, Level := 2.5, Next_seg_v := 0))))
                      ({}, {''Train2Control''})
    @\<^sub>t Wait\<^sub>t (Period - T_t v0 (com_a s0 v0))
    (\<lambda>t. ParState
      (State ((\<lambda>_. 0)(V := v0 + com_a s0 v0 * (T_t v0 (com_a s0 v0)),
                      S := s0 + v0 * (T_t v0 (com_a s0 v0)) + 1/2 * com_a s0 v0 * (T_t v0 (com_a s0 v0)) * (T_t v0 (com_a s0 v0)),
                      A := com_a s0 v0, T := T_t v0 (com_a s0 v0))))
      (State ((\<lambda>_. 0)(V := v0, S := s0, Command_a := com_a s0 v0, Level := 2.5, Next_seg_v := 0)) )) ({}, {''Train2Control''})
))"

fun tot_block :: "real \<times> real \<Rightarrow> nat \<Rightarrow> tassn" where
  "tot_block (s0, v0) 0 = emp\<^sub>t"
| "tot_block (s0, v0) (Suc n) =
   P_tassn v0 s0 @\<^sub>t
   IO\<^sub>t ''Train2Control'' (snd (loop_once (s0, v0))) @\<^sub>t
   IO\<^sub>t ''Train2Control'' (fst (loop_once (s0, v0))) @\<^sub>t
   IO\<^sub>t ''Control2Train'' (com_a (fst (loop_once (s0, v0))) (snd (loop_once (s0, v0)))) @\<^sub>t
   tot_block (loop_once (s0, v0) ) n"

fun tot_seq :: "real \<times> real \<Rightarrow> nat \<Rightarrow> (real \<times> real) list" where
  "tot_seq (v, s) 0 = []"
| "tot_seq (v, s) (Suc n) = (v, s) # tot_seq (loop_once (v, s)) n"

lemma combine:
  "loop_invariant (s0, v0) \<Longrightarrow>
   combine_assn {''Train2Control'', ''Control2Train''}
     (Train_inv (v0, s0, com_a s0 v0, t0) as) (Control_blocks (v0, s0, com_a s0 v0, 2.5) vs)
      \<Longrightarrow>\<^sub>t  tot_block (s0,v0) (length as)"
proof (induct as arbitrary: vs v0 s0 t0)
  case Nil
  then show ?case
  proof(cases vs)
    case Nil
    then show ?thesis by auto
  next
    case (Cons vsp rest)
    then show ?thesis
      apply auto
        subgoal
        proof (cases vsp)
          case (Pair v s)
          then show ?thesis
            apply auto
            subgoal
            apply (rule entails_tassn_trans)
             apply (subst combine_assn_emp_in)
               apply auto
              by (rule false_assn_entails)
            apply (rule entails_tassn_trans)
             apply (subst combine_assn_emp_in)
               apply auto
            by (rule false_assn_entails)
        qed
        done
    qed
next
  case (Cons a as)
  note Cons1 = Cons
  then show ?case
  proof (cases vs)
    case Nil
    then show ?thesis apply auto
      subgoal
        apply (rule entails_tassn_trans)
        unfolding T_tassn_def
        apply auto
         apply (rule combine_assn_wait_emp)
          apply auto
        apply(subst join_assoc)
        apply (rule combine_assn_wait_emp)
        using T_t_prop1 by auto
      done
    next
      case (Cons vsp rest)
    then show ?thesis
       apply auto
       subgoal premises pre
     proof(cases vsp)
      case (Pair v s)
      then show ?thesis
        apply auto
        unfolding T_tassn_def P_tassn_def
         apply (auto simp add: pre)
        subgoal
           apply (rule entails_tassn_trans)
         apply (rule combine_assn_wait_in)
             apply auto
          apply (rule entails_tassn_conj)
        subgoal
            using Cons1(2) apply (auto simp add: pure_assn_def entails_tassn_def)
            done
          apply (rule entails_tassn_cancel_left)
          apply (rule entails_tassn_trans)
         apply (rule combine_assn_out_in)
           apply (auto simp add:T_t_def pre loop_once.simps)
          apply (rule entails_tassn_cancel_left)
          apply (rule entails_tassn_trans)
           apply (rule combine_assn_out_in)
           apply auto
          apply (rule entails_tassn_cancel_left)
          apply (rule entails_tassn_trans)
           apply (rule combine_assn_in_out)
           apply auto
          apply (rule entails_tassn_cancel_left)
          using Cons1(2) by auto
        subgoal
          apply (rule entails_tassn_trans)
          apply(subst join_assoc)
         apply (rule combine_assn_wait_in)
             apply auto
          apply (rule entails_tassn_conj)
          subgoal
            using Cons1(2) apply (auto simp add: pure_assn_def entails_tassn_def)
            done
          apply(subst join_assoc)
          apply (rule entails_tassn_cancel_left)
          apply (rule entails_tassn_trans)
         apply (rule combine_assn_wait_in)
            apply auto
          apply (rule entails_tassn_cancel_left)
          apply (rule entails_tassn_trans)
           apply (rule combine_assn_out_in)
           apply auto
          apply (subst loop_once_prop1)
           apply auto
          apply (rule entails_tassn_cancel_left)
          apply (rule entails_tassn_trans)
           apply (rule combine_assn_out_in)
           apply auto
          apply (subst loop_once_prop1)
           apply auto
          apply (rule entails_tassn_cancel_left)
          apply (rule entails_tassn_trans)
           apply (rule combine_assn_in_out)
           apply auto
          apply (subst loop_once_prop1)
           apply auto
          apply (subst loop_once_prop1)
           apply auto
          apply (rule entails_tassn_cancel_left)
          apply (subst loop_once_prop1)
           apply auto
          subgoal premises pref
          proof-
            have 1:"(s0 + v0 * T_t v0 (com_a s0 v0) + com_a s0 v0 * T_t v0 (com_a s0 v0) * T_t v0 (com_a s0 v0) / 2,v0 + com_a s0 v0 * T_t v0 (com_a s0 v0)) = loop_once(s0,v0)"
              using loop_once_prop1[of v0 s0] pref by auto
            have 2:"loop_invariant(s0,v0)"
              using Cons1 by auto
            have 3:"loop_invariant(s0 + v0 * T_t v0 (com_a s0 v0) + com_a s0 v0 * T_t v0 (com_a s0 v0) * T_t v0 (com_a s0 v0) / 2,v0 + com_a s0 v0 * T_t v0 (com_a s0 v0))"
              using loop_once_invariant'[OF 2 1] by auto
            then show ?thesis using pref unfolding loop_invariant.simps by auto
          qed
          done
        subgoal
          apply (rule entails_tassn_trans)
         apply (rule combine_assn_wait_in)
             apply auto
          apply (rule entails_tassn_conj)
          subgoal
            using Cons1(2) apply (auto simp add: pure_assn_def entails_tassn_def)
            done
          apply (rule entails_tassn_cancel_left)
          apply (rule entails_tassn_trans)
           apply (rule combine_assn_out_in)
           apply (auto simp add:T_t_def loop_once.simps)
          apply (rule entails_tassn_cancel_left)
          apply (rule entails_tassn_trans)
           apply (rule combine_assn_out_in)
           apply auto
          apply (rule entails_tassn_cancel_left)
          apply (rule entails_tassn_trans)
           apply (rule combine_assn_in_out)
           apply auto
          apply (rule entails_tassn_cancel_left)
          using Cons1 by auto
 subgoal
          apply (rule entails_tassn_trans)
          apply(subst join_assoc)
         apply (rule combine_assn_wait_in)
             apply auto
          apply (rule entails_tassn_conj)
          subgoal
            using Cons1(2) apply (auto simp add: pure_assn_def entails_tassn_def)
            done
          apply(subst join_assoc)
          apply (rule entails_tassn_cancel_left)
          apply (rule entails_tassn_trans)
         apply (rule combine_assn_wait_in)
            apply auto
          apply (rule entails_tassn_cancel_left)
          apply (rule entails_tassn_trans)
           apply (rule combine_assn_out_in)
           apply auto
          apply (subst loop_once_prop1)
           apply auto
          apply (rule entails_tassn_cancel_left)
          apply (rule entails_tassn_trans)
           apply (rule combine_assn_out_in)
           apply auto
          apply (subst loop_once_prop1)
           apply auto
          apply (rule entails_tassn_cancel_left)
          apply (rule entails_tassn_trans)
           apply (rule combine_assn_in_out)
           apply auto
          apply (subst loop_once_prop1)
           apply auto
          apply (subst loop_once_prop1)
           apply auto
          apply (rule entails_tassn_cancel_left)
          apply (subst loop_once_prop1)
           apply auto
subgoal premises pref
          proof-
            have 1:"(s0 + v0 * T_t v0 (com_a s0 v0) + com_a s0 v0 * T_t v0 (com_a s0 v0) * T_t v0 (com_a s0 v0) / 2,v0 + com_a s0 v0 * T_t v0 (com_a s0 v0)) = loop_once(s0,v0)"
              using loop_once_prop1[of v0 s0] pref by auto
            have 2:"loop_invariant(s0,v0)"
              using Cons1 by auto
            have 3:"loop_invariant(s0 + v0 * T_t v0 (com_a s0 v0) + com_a s0 v0 * T_t v0 (com_a s0 v0) * T_t v0 (com_a s0 v0) / 2,v0 + com_a s0 v0 * T_t v0 (com_a s0 v0))"
              using loop_once_invariant'[OF 2 1] by auto
            then show ?thesis using Cons1 by auto
          qed
          done
        done
    qed
    done
qed
qed

lemma system_Prop:
  assumes "loop_invariant (s0, v0)"
  shows "\<Turnstile>\<^sub>p
    {pair_assn (\<lambda>s. s = ((\<lambda>_. 0)(V := v0, S := s0, A := com_a s0 v0, T := t0)))
               (\<lambda>s. s = ((\<lambda>_. 0)(V := v0, S := s0, Command_a := com_a s0 v0,
                                                   Level := 2.5, Next_seg_v := 0)))}
      system
    {\<exists>\<^sub>g n. trace_gassn (tot_block (s0,v0) n)}"
  unfolding system_def
  apply (rule ParValid_conseq')
    apply (rule ParValid_Parallel')
  apply (rule Train_prop)
  apply (rule Control_prop)
  apply (auto simp add: sing_gassn_split sing_gassn_ex)
  apply (rule sync_gassn_ex_pre_left)
  apply (rule sync_gassn_ex_pre_right)
  subgoal for xs as
    unfolding sync_gassn_state_left sync_gassn_state_right
    apply (rule entails_ex_gassn)
    apply (rule exI[where x="length xs"])
    apply (rule and_entails_gassn2[OF sync_gassn_traces])
    apply (rule and_entails_gassn2[OF entails_trace_gassn])
     apply (rule entails_tassn_trans)
      prefer 2 apply(rule combine[OF assms])
     apply (rule combine_assn_mono)
    by (auto simp add: entails_tassn_def entails_gassn_def and_gassn_def)
  done

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_QSortPermutes
  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 elem :: "'a => 'a list => bool" where
  "elem y (nil2) = False"
| "elem y (cons2 z2 xs) = ((z2 = y) | (elem y xs))"

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

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

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

end


theory WordInterval_Sorted
imports WordInterval
        "../Automatic_Refinement/Lib/Misc" (*Mergesort. TODO: dependnecy! we need a mergesort afp entry!!*)
        "~~/src/HOL/Library/Product_Lexorder"
begin

(*has afp mergesort dependency*)
text\<open>Use this and @{thm wordinterval_compress} before pretty-printing.\<close>
definition wordinterval_sort :: "'a::len wordinterval \<Rightarrow> 'a::len wordinterval" where
  "wordinterval_sort w \<equiv> l2wi (mergesort_remdups (wi2l w))"

lemma wordinterval_sort: "wordinterval_to_set (wordinterval_sort w) = wordinterval_to_set w"
  by (simp add: wordinterval_sort_def wi2l l2wi mergesort_remdups_correct)

(*A wordinterval is essentially a tree.
  We could vastly improve the computational complexity for all operations!*)

end


(*
 * Copyright (C) 2014 NICTA
 * All rights reserved.
 *)

(* Author: David Cock - David.Cock@nicta.com.au *)

section \<open>Miscellaneous Mathematics\<close>

theory Misc
imports
  "HOL-Analysis.Multivariate_Analysis"
begin

text_raw \<open>\label{s:misc}\<close>

lemma sum_UNIV:
  fixes S::"'a::finite set"
  assumes complete: "\<And>x. x\<notin>S \<Longrightarrow> f x = 0"
  shows "sum f S = sum f UNIV"
proof -
  from complete have "sum f S = sum f (UNIV - S) + sum f S" by(simp)
  also have "... = sum f UNIV"
    by(auto intro: sum.subset_diff[symmetric])
  finally show ?thesis .
qed

lemma cInf_mono:
  fixes A::"'a::conditionally_complete_lattice set"
  assumes lower: "\<And>b. b \<in> B \<Longrightarrow> \<exists>a\<in>A. a \<le> b"
      and bounded: "\<And>a. a \<in> A \<Longrightarrow> c \<le> a"
      and ne: "B \<noteq> {}"
  shows "Inf A \<le> Inf B"
proof(rule cInf_greatest[OF ne])
  fix b assume bin: "b \<in> B"
  with lower obtain a where ain: "a \<in> A" and le: "a \<le> b" by(auto)
  from ain bounded have "Inf A \<le> a" by(intro cInf_lower bdd_belowI, auto)
  also note le
  finally show "Inf A \<le> b" .
qed

lemma max_distrib:
  fixes c::real
  assumes nn: "0 \<le> c"
  shows "c * max a b = max (c * a) (c * b)"
proof(cases "a \<le> b")
  case True
  moreover with nn have "c * a \<le> c * b" by(auto intro:mult_left_mono)
  ultimately show ?thesis by(simp add:max.absorb2)
next
  case False then have "b \<le> a" by(auto)
  moreover with nn have "c * b \<le> c * a" by(auto intro:mult_left_mono)
  ultimately show ?thesis by(simp add:max.absorb1)
qed

lemma mult_div_mono_left:
  fixes c::real
  assumes nnc: "0 \<le> c" and nzc: "c \<noteq> 0"
      and inv: "a \<le> inverse c * b"
  shows "c * a \<le> b"
proof -
  from nnc inv have "c * a \<le> (c * inverse c) * b"
    by(auto simp:mult.assoc intro:mult_left_mono)
  also from nzc have "... = b" by(simp)
  finally show "c * a \<le> b" .
qed

lemma mult_div_mono_right:
  fixes c::real
  assumes nnc: "0 \<le> c" and nzc: "c \<noteq> 0"
      and inv: "inverse c * a \<le> b"
  shows "a \<le> c * b"
proof -
  from nzc have "a = (c * inverse c) * a " by(simp)
  also from nnc inv have "(c * inverse c) * a \<le> c * b"
    by(auto simp:mult.assoc intro:mult_left_mono)
  finally show "a \<le> c * b" .
qed

lemma min_distrib:
  fixes c::real
  assumes nnc: "0 \<le> c"
  shows "c * min a b = min (c * a) (c * b)"
proof(cases "a \<le> b")
  case True moreover with nnc have "c * a \<le> c * b"
    by(blast intro:mult_left_mono)
  ultimately show ?thesis by(auto)
next
  case False hence "b \<le> a" by(auto)
  moreover with nnc have "c * b \<le> c * a"
    by(blast intro:mult_left_mono)
  ultimately show ?thesis by(simp add:min.absorb2)
qed

lemma finite_set_least:
  fixes S::"'a::linorder set"
  assumes finite: "finite S"
      and ne: "S \<noteq> {}"
  shows "\<exists>x\<in>S. \<forall>y\<in>S. x \<le> y"
proof -
  have "S = {} \<or> (\<exists>x\<in>S. \<forall>y\<in>S. x \<le> y)"
  proof(rule finite_induct, simp_all add:assms)
    fix x::'a and S::"'a set"
    assume IH: "S = {} \<or> (\<exists>x\<in>S. \<forall>y\<in>S. x \<le> y)"
    show "(\<forall>y\<in>S. x \<le> y) \<or> (\<exists>x'\<in>S. x' \<le> x \<and> (\<forall>y\<in>S. x' \<le> y))"
    proof(cases "S={}")
      case True then show ?thesis by(auto)
    next
      case False with IH have "\<exists>x\<in>S. \<forall>y\<in>S. x \<le> y" by(auto)
      then obtain z where zin: "z \<in> S" and zmin: "\<forall>y\<in>S. z \<le> y" by(auto)
      thus ?thesis by(cases "z \<le> x", auto)
    qed
  qed
  with ne show ?thesis by(auto)
qed

lemma cSup_add:
  fixes c::real
  assumes ne: "S \<noteq> {}"
      and bS: "\<And>x. x\<in>S \<Longrightarrow> x \<le> b"
  shows "Sup S + c = Sup {x + c |x. x \<in> S}"
proof(rule antisym)
  from ne bS show "Sup {x + c |x. x \<in> S} \<le> Sup S + c"
    by(auto intro!:cSup_least add_right_mono cSup_upper bdd_aboveI)

  have "Sup S \<le> Sup {x + c |x. x \<in> S} - c"
  proof(intro cSup_least ne)
    fix x assume xin: "x \<in> S"
    from bS have "\<And>x. x\<in>S \<Longrightarrow> x + c \<le> b + c" by(auto intro:add_right_mono)
    hence "bdd_above {x + c |x. x \<in> S}" by(intro bdd_aboveI, blast)
    with xin have "x + c \<le> Sup {x + c |x. x \<in> S}" by(auto intro:cSup_upper)
    thus "x \<le> Sup {x + c |x. x \<in> S} - c" by(auto)
  qed
  thus "Sup S + c \<le> Sup {x + c |x. x \<in> S}" by(auto)
qed

lemma cSup_mult:
  fixes c::real
  assumes ne: "S \<noteq> {}"
      and bS: "\<And>x. x\<in>S \<Longrightarrow> x \<le> b"
      and nnc: "0 \<le> c"
  shows "c * Sup S = Sup {c * x |x. x \<in> S}"
proof(cases)
  assume "c = 0"
  moreover from ne have "\<exists>x. x \<in> S" by(auto)
  ultimately show ?thesis by(simp)
next
  assume cnz: "c \<noteq> 0"
  show ?thesis
  proof(rule antisym)
    from bS have baS: "bdd_above S" by(intro bdd_aboveI, auto)
    with ne nnc show "Sup {c * x |x. x \<in> S} \<le> c * Sup S"
      by(blast intro!:cSup_least mult_left_mono[OF cSup_upper])
    have "Sup S \<le> inverse c * Sup {c * x |x. x \<in> S}"
    proof(intro cSup_least ne)
      fix x assume xin: "x\<in>S"
      moreover from bS nnc have "\<And>x. x\<in>S \<Longrightarrow> c * x \<le> c * b" by(auto intro:mult_left_mono)
      ultimately have "c * x \<le> Sup {c * x |x. x \<in> S}"
        by(auto intro!:cSup_upper bdd_aboveI)
      moreover from nnc have "0 \<le> inverse c" by(auto)
      ultimately have "inverse c * (c * x) \<le> inverse c * Sup {c * x |x. x \<in> S}"
        by(auto intro:mult_left_mono)
      with cnz show "x \<le> inverse c * Sup {c * x |x. x \<in> S}"
        by(simp add:mult.assoc[symmetric])
    qed
    with nnc have "c * Sup S \<le> c * (inverse c * Sup {c * x |x. x \<in> S})"
      by(auto intro:mult_left_mono)
    with cnz show "c * Sup S \<le> Sup {c * x |x. x \<in> S}"
      by(simp add:mult.assoc[symmetric])
  qed
qed

lemma closure_contains_Sup:
  fixes S :: "real set"
  assumes neS: "S \<noteq> {}" and bS: "\<forall>x\<in>S. x \<le> B"
  shows "Sup S \<in> closure S"
proof -
  let ?T = "uminus ` S"
  from neS have neT: "?T \<noteq> {}" by(auto)
  from bS have bT: "\<forall>x\<in>?T. -B \<le> x" by(auto)
  hence bbT: "bdd_below ?T" by(intro bdd_belowI, blast)

  have "Sup S = - Inf ?T"
  proof(rule antisym)
    from neT bbT
    have "\<And>x. x\<in>S \<Longrightarrow> Inf (uminus ` S) \<le> -x"
      by(blast intro:cInf_lower)
    hence "\<And>x. x\<in>S \<Longrightarrow> -1 * -x \<le> -1 * Inf (uminus ` S)"
      by(rule mult_left_mono_neg, auto)
    hence lenInf: "\<And>x. x\<in>S \<Longrightarrow> x \<le> - Inf (uminus ` S)"
      by(simp)
    with neS bS show "Sup S \<le> - Inf ?T"
      by(blast intro:cSup_least)

    have "- Sup S \<le> Inf ?T"
    proof(rule cInf_greatest[OF neT])
      fix x assume "x \<in> uminus ` S"
      then obtain y where yin: "y \<in> S" and rwx: "x = -y" by(auto)
      from yin bS have "y \<le> Sup S"
        by(intro cSup_upper bdd_belowI, auto)
      hence "-1 * Sup S \<le> -1 * y"
        by(simp add:mult_left_mono_neg)
      with rwx show "- Sup S \<le> x" by(simp)
    qed
    hence "-1 * Inf ?T \<le> -1 * (- Sup S)"
      by(simp add:mult_left_mono_neg)
    thus "- Inf ?T \<le> Sup S" by(simp)
  qed
  also {
    from neT bbT have "Inf ?T \<in> closure ?T" by(rule closure_contains_Inf)
    hence "- Inf ?T \<in> uminus ` closure ?T" by(auto)
  }
  also {
    have "linear uminus" by(auto intro:linearI)
    hence "uminus ` closure ?T \<subseteq> closure (uminus ` ?T)"
      by(rule closure_linear_image_subset)
  }
  also {
    have "uminus ` ?T \<subseteq> S" by(auto)
    hence "closure (uminus ` ?T) \<subseteq> closure S" by(rule closure_mono)
  }
  finally show "Sup S \<in> closure S" .
qed

lemma tendsto_min:
  fixes x y::real
  assumes ta: "a \<longlonglongrightarrow> x"
      and tb: "b \<longlonglongrightarrow> y"
  shows "(\<lambda>i. min (a i) (b i)) \<longlonglongrightarrow> min x y"
proof(rule LIMSEQ_I, simp)
  fix e::real assume pe: "0 < e"

  from ta pe obtain noa where balla: "\<forall>n\<ge>noa. abs (a n - x) < e"
    by(auto dest:LIMSEQ_D)
  from tb pe obtain nob where ballb: "\<forall>n\<ge>nob. abs (b n - y) < e"
    by(auto dest:LIMSEQ_D)

  {
    fix n
    assume ge: "max noa nob \<le> n"
    hence gea: "noa \<le> n" and geb: "nob \<le> n" by(auto)
    have "abs (min (a n) (b n) - min x y) < e"
    proof cases
      assume le: "min (a n) (b n) \<le> min x y"
      show ?thesis
      proof cases
        assume "a n \<le> b n"
        hence rwmin: "min (a n) (b n) = a n" by(auto)
        with le have "a n \<le> min x y" by(simp)
        moreover from gea balla have "abs (a n - x) < e" by(simp)
        moreover have "min x y \<le> x" by(auto)
        ultimately have "abs (a n - min x y) < e" by(auto)
        with rwmin show "abs (min (a n) (b n) - min x y) < e" by(simp)
      next
        assume "\<not> a n \<le> b n"
        hence "b n \<le> a n" by(auto)
        hence rwmin: "min (a n) (b n) = b n" by(auto)
        with le have "b n \<le> min x y" by(simp)
        moreover from geb ballb have "abs (b n - y) < e" by(simp)
        moreover have "min x y \<le> y" by(auto)
        ultimately have "abs (b n - min x y) < e" by(auto)
        with rwmin show "abs (min (a n) (b n) - min x y) < e" by(simp)
      qed
    next
      assume "\<not> min (a n) (b n) \<le> min x y"
      hence le: "min x y \<le> min (a n) (b n)" by(auto)
      show ?thesis
      proof cases
        assume "x \<le> y"
        hence rwmin: "min x y = x" by(auto)
        with le have "x \<le> min (a n) (b n)" by(simp)
        moreover from gea balla have "abs (a n - x) < e" by(simp)
        moreover have "min (a n) (b n) \<le> a n" by(auto)
        ultimately have "abs (min (a n) (b n) - x) < e" by(auto)
        with rwmin show "abs (min (a n) (b n) - min x y) < e" by(simp)
      next
        assume "\<not> x \<le> y"
        hence "y \<le> x" by(auto)
        hence rwmin: "min x y = y" by(auto)
        with le have "y \<le> min (a n) (b n)" by(simp)
        moreover from geb ballb have "abs (b n - y) < e" by(simp)
        moreover have "min (a n) (b n) \<le> b n" by(auto)
        ultimately have "abs (min (a n) (b n) - y) < e" by(auto)
        with rwmin show "abs (min (a n) (b n) - min x y) < e" by(simp)
      qed
    qed
  }
  thus "\<exists>no. \<forall>n\<ge>no. \<bar>min (a n) (b n) - min x y\<bar> < e" by(blast)
qed

definition supp :: "('s \<Rightarrow> real) \<Rightarrow> 's set"
where "supp f = {x. f x \<noteq> 0}"

definition dist_remove :: "('s \<Rightarrow> real) \<Rightarrow> 's \<Rightarrow> 's \<Rightarrow> real"
where "dist_remove p x = (\<lambda>y. if y=x then 0 else p y / (1 - p x))"

lemma supp_dist_remove:
  "p x \<noteq> 0 \<Longrightarrow> p x \<noteq> 1 \<Longrightarrow> supp (dist_remove p x) = supp p - {x}"
  by(auto simp:dist_remove_def supp_def)

lemma supp_empty:
  "supp f = {} \<Longrightarrow> f x = 0"
  by(simp add:supp_def)

lemma nsupp_zero:
  "x \<notin> supp f \<Longrightarrow> f x = 0"
  by(simp add:supp_def)

lemma sum_supp:
  fixes f::"'a::finite \<Rightarrow> real"
  shows "sum f (supp f) = sum f UNIV"
proof -
  have "sum f (UNIV - supp f) = 0"
    by(simp add:supp_def)
  hence "sum f (supp f) = sum f (UNIV - supp f) + sum f (supp f)"
    by(simp)
  also have "... = sum f UNIV"
    by(simp add:sum.subset_diff[symmetric])
  finally show ?thesis .
qed

subsection \<open>Truncated Subtraction\<close>
text_raw \<open>\label{s:trunc_sub}\<close>

definition
  tminus :: "real \<Rightarrow> real \<Rightarrow> real" (infixl "\<ominus>" 60)
where
  "x \<ominus> y = max (x - y) 0"

lemma minus_le_tminus[intro!,simp]:
  "a - b \<le> a \<ominus> b"
  unfolding tminus_def by(auto)

lemma tminus_cancel_1:
  "0 \<le> a \<Longrightarrow> a + 1 \<ominus> 1 = a"
  unfolding tminus_def by(simp)

lemma tminus_zero_imp_le:
  "x \<ominus> y \<le> 0 \<Longrightarrow> x \<le> y"
  by(simp add:tminus_def)

lemma tminus_zero[simp]:
  "0 \<le> x \<Longrightarrow> x \<ominus> 0 = x"
  by(simp add:tminus_def)

lemma tminus_left_mono:
  "a \<le> b \<Longrightarrow> a \<ominus> c \<le> b \<ominus> c"
  unfolding tminus_def
  by(case_tac "a \<le> c", simp_all)

lemma tminus_less:
  "\<lbrakk> 0 \<le> a; 0 \<le> b \<rbrakk> \<Longrightarrow> a \<ominus> b \<le> a"
  unfolding tminus_def by(force)

lemma tminus_left_distrib:
  assumes nna: "0 \<le> a"
  shows "a * (b \<ominus> c) = a * b \<ominus> a * c"
proof(cases "b \<le> c")
  case True note le = this
  hence "a * max (b - c) 0 = 0" by(simp add:max.absorb2)
  also {
    from nna le have "a * b \<le> a * c" by(blast intro:mult_left_mono)
    hence "0 = max (a * b - a * c) 0" by(simp add:max.absorb1)
  }
  finally show ?thesis by(simp add:tminus_def)
next
  case False hence le: "c \<le> b" by(auto)
  hence "a * max (b - c) 0 = a * (b - c)" by(simp only:max.absorb1)
  also {
    from nna le have "a * c \<le> a * b" by(blast intro:mult_left_mono)
    hence "a * (b - c) = max (a * b - a * c) 0" by(simp add:max.absorb1 field_simps)
  }
  finally show ?thesis by(simp add:tminus_def)
qed

lemma tminus_le[simp]:
  "b \<le> a \<Longrightarrow> a \<ominus> b = a - b"
  unfolding tminus_def by(simp)

lemma tminus_le_alt[simp]:
  "a \<le> b \<Longrightarrow> a \<ominus> b = 0"
  by(simp add:tminus_def)

lemma tminus_add_mono:
  "(a+b) \<ominus> (c+d) \<le> (a\<ominus>c) + (b\<ominus>d)"
proof(cases "0 \<le> a - c")
  case True note pac = this
  show ?thesis
  proof(cases "0 \<le> b - d")
    case True note pbd = this
    from pac and pbd have "(c + d) \<le> (a + b)" by(simp)
    with pac and pbd show ?thesis by(simp)
  next
    case False with pac show ?thesis
      by(cases "c + d \<le> a + b", auto)
  qed
next
  case False note nac = this
  show ?thesis
  proof(cases "0 \<le> b - d")
    case True with nac show ?thesis
      by(cases "c + d \<le> a + b", auto)
  next
    case False note nbd = this
    with nac have "\<not>(c + d) \<le> (a + b)" by(simp)
    with nac and nbd show ?thesis by(simp)
  qed
qed

lemma tminus_sum_mono:
  assumes fS: "finite S"
  shows "sum f S \<ominus> sum g S \<le> sum (\<lambda>x. f x \<ominus> g x) S"
        (is "?X S")
proof(rule finite_induct)
  from fS show "finite S" .

  show "?X {}" by(simp)

  fix x and F
  assume fF: "finite F" and xniF: "x \<notin> F"
     and IH: "?X F"
  have "f x + sum f F \<ominus> g x + sum g F \<le>
        (f x \<ominus> g x) + (sum f F \<ominus> sum g F)"
    by(rule tminus_add_mono)
  also from IH have "... \<le> (f x \<ominus> g x) + (\<Sum>x\<in>F. f x \<ominus> g x)"
    by(rule add_left_mono)
  finally show "?X (insert x F)"
    by(simp add:sum.insert[OF fF xniF])
qed

lemma tminus_nneg[simp,intro]:
  "0 \<le> a \<ominus> b"
  by(cases "b \<le> a", auto)

lemma tminus_right_antimono:
  assumes clb: "c \<le> b"
  shows "a \<ominus> b \<le> a \<ominus> c"
proof(cases "b \<le> a")
  case True
  moreover with clb have "c \<le> a" by(auto)
  moreover note clb
  ultimately show ?thesis by(simp)
next
  case False then show ?thesis by(simp)
qed

lemma min_tminus_distrib:
  "min a b \<ominus> c = min (a \<ominus> c) (b \<ominus> c)"
  unfolding tminus_def by(auto)

end


(*<*)
theory GoedelGod
imports Main

begin
(*>*)

section {* Introduction *}

 text {* Dana Scott's version \cite{ScottNotes} (cf.~Fig.~1)
 of G\"odel's proof of God's existence \cite{GoedelNotes} is
 formalized in quantified modal logic KB (QML KB) within the proof assistant Isabelle/HOL.
 QML KB is  modeled as a fragment of classical higher-order logic (HOL);
 thus, the formalization is essentially a formalization in HOL. The employed embedding
 of QML KB in HOL is adapting the work of Benzm\"uller and Paulson \cite{J23,B9}.
 Note that the QML KB formalization employs quantification over individuals and
 quantification over sets of individuals (properties).

 The gaps in Scott's proof have been automated
 with Sledgehammer \cite{Sledgehammer}, performing remote calls to the higher-order automated
 theorem prover LEO-II \cite{LEO-II}. Sledgehammer suggests the
 Metis \cite{Metis} calls, which result in proofs that are verified by Isabelle/HOL.
 For consistency checking, the model finder Nitpick \cite{Nitpick} has been employed.
 The successfull calls to Sledgehammer
 are deliberately kept as comments in the file for demonstration purposes
 (normally, they are automatically eliminated by Isabelle/HOL).

 Isabelle is described in the textbook by Nipkow,
 Paulson, and Wenzel \cite{Isabelle} and in tutorials available
 at: @{url "http://isabelle.in.tum.de"}.

\subsection{Related Work}

 The formalization presented here is related to the THF \cite{J22} and
 Coq \cite{Coq} formalizations at
 @{url "https://github.com/FormalTheology/GoedelGod/tree/master/Formalizations/"}.

 An older ontological argument by Anselm was formalized in PVS by John Rushby \cite{rushby}.
*}

section {* An Embedding of QML KB in HOL *}

text {* The types @{text "i"} for possible worlds and $\mu$ for individuals are introduced. *}

  typedecl i    -- "the type for possible worlds"
  typedecl \<mu>    -- "the type for indiviuals"

text {* Possible worlds are connected by an accessibility relation @{text "r"}.*}

  consts r :: "i \<Rightarrow> i \<Rightarrow> bool" (infixr "r" 70)    -- "accessibility relation r"

text {* QML formulas are translated as HOL terms of type @{typ "i \<Rightarrow> bool"}.
This type is abbreviated as @{text "\<sigma>"}. *}

  type_synonym \<sigma> = "(i \<Rightarrow> bool)"

text {* The classical connectives $\neg, \wedge, \rightarrow$, and $\forall$
(over individuals and over sets of individuals) and $\exists$ (over individuals) are
lifted to type $\sigma$. The lifted connectives are @{text "m\<not>"}, @{text "m\<and>"}, @{text "m\<rightarrow>"},
@{text "\<forall>"}, and @{text "\<exists>"} (the latter two are modeled as constant symbols).
Other connectives can be introduced analogously. We exemplarily do this for @{text "m\<or>"} ,
@{text "m\<equiv>"}, and @{text "mL="} (Leibniz equality on individuals). Moreover, the modal
operators @{text "\<box>"} and @{text "\<diamond>"}  are introduced. Definitions could be used instead of
abbreviations. *}

  abbreviation mnot :: "\<sigma> \<Rightarrow> \<sigma>" ("m\<not>") where "m\<not> \<phi> \<equiv> (\<lambda>w. \<not> \<phi> w)"
  abbreviation mand :: "\<sigma> \<Rightarrow> \<sigma> \<Rightarrow> \<sigma>" (infixr "m\<and>" 65) where "\<phi> m\<and> \<psi> \<equiv> (\<lambda>w. \<phi> w \<and> \<psi> w)"
  abbreviation mor :: "\<sigma> \<Rightarrow> \<sigma> \<Rightarrow> \<sigma>" (infixr "m\<or>" 70) where "\<phi> m\<or> \<psi> \<equiv> (\<lambda>w. \<phi> w \<or> \<psi> w)"
  abbreviation mimplies :: "\<sigma> \<Rightarrow> \<sigma> \<Rightarrow> \<sigma>" (infixr "m\<rightarrow>" 74) where "\<phi> m\<rightarrow> \<psi> \<equiv> (\<lambda>w. \<phi> w \<longrightarrow> \<psi> w)"
  abbreviation mequiv:: "\<sigma> \<Rightarrow> \<sigma> \<Rightarrow> \<sigma>" (infixr "m\<equiv>" 76) where "\<phi> m\<equiv> \<psi> \<equiv> (\<lambda>w. \<phi> w \<longleftrightarrow> \<psi> w)"
  abbreviation mforall :: "('a \<Rightarrow> \<sigma>) \<Rightarrow> \<sigma>" ("\<forall>") where "\<forall> \<Phi> \<equiv> (\<lambda>w. \<forall>x. \<Phi> x w)"
  abbreviation mexists :: "('a \<Rightarrow> \<sigma>) \<Rightarrow> \<sigma>" ("\<exists>") where "\<exists> \<Phi> \<equiv> (\<lambda>w. \<exists>x. \<Phi> x w)"
  abbreviation mLeibeq :: "\<mu> \<Rightarrow> \<mu> \<Rightarrow> \<sigma>" (infixr "mL=" 90) where "x mL= y \<equiv> \<forall>(\<lambda>\<phi>. (\<phi> x m\<rightarrow> \<phi> y))"
  abbreviation mbox :: "\<sigma> \<Rightarrow> \<sigma>" ("\<box>") where "\<box> \<phi> \<equiv> (\<lambda>w. \<forall>v.  w r v \<longrightarrow> \<phi> v)"
  abbreviation mdia :: "\<sigma> \<Rightarrow> \<sigma>" ("\<diamond>") where "\<diamond> \<phi> \<equiv> (\<lambda>w. \<exists>v. w r v \<and> \<phi> v)"

text {* For grounding lifted formulas, the meta-predicate @{text "valid"} is introduced. *}

  (*<*) no_syntax "_list" :: "args \<Rightarrow> 'a list" ("[(_)]") (*>*)
  abbreviation valid :: "\<sigma> \<Rightarrow> bool" ("[_]") where "[p] \<equiv> \<forall>w. p w"

section {* G\"odel's Ontological Argument *}

text {* Constant symbol @{text "P"} (G\"odel's `Positive') is declared. *}

  consts P :: "(\<mu> \<Rightarrow> \<sigma>) \<Rightarrow> \<sigma>"

text {* The meaning of @{text "P"} is restricted by axioms @{text "A1(a/b)"}: $\all \phi
[P(\neg \phi) \biimp \neg P(\phi)]$ (Either a property or its negation is positive, but not both.)
and @{text "A2"}: $\all \phi \all \psi [(P(\phi) \wedge \nec \all x [\phi(x) \imp \psi(x)])
\imp P(\psi)]$ (A property necessarily implied by a positive property is positive). *}

  axiomatization where
    A1a: "[\<forall>(\<lambda>\<Phi>. P (\<lambda>x. m\<not> (\<Phi> x)) m\<rightarrow> m\<not> (P \<Phi>))]" and
    A1b: "[\<forall>(\<lambda>\<Phi>. m\<not> (P \<Phi>) m\<rightarrow> P (\<lambda>x. m\<not> (\<Phi> x)))]" and
    A2:  "[\<forall>(\<lambda>\<Phi>. \<forall>(\<lambda>\<Psi>. (P \<Phi> m\<and> \<box> (\<forall>(\<lambda>x. \<Phi> x m\<rightarrow> \<Psi> x))) m\<rightarrow> P \<Psi>))]"

text {* We prove theorem T1: $\all \phi [P(\phi) \imp \pos \ex x \phi(x)]$ (Positive
properties are possibly exemplified). T1 is proved directly by Sledgehammer with command @{text
"sledgehammer [provers = remote_leo2]"}.
Sledgehammer suggests to call Metis with axioms A1a and A2.
Metis sucesfully generates a proof object
that is verified in Isabelle/HOL's kernel. *}

  theorem T1: "[\<forall>(\<lambda>\<Phi>. P \<Phi> m\<rightarrow> \<diamond> (\<exists> \<Phi>))]"
  -- {* sledgehammer [provers = remote\_leo2] *}
  by (metis A1a A2)

text {* Next, the symbol @{text "G"} for `God-like'  is introduced and defined
as $G(x) \biimp \forall \phi [P(\phi) \to \phi(x)]$ \\ (A God-like being possesses
all positive properties). *}

  definition G :: "\<mu> \<Rightarrow> \<sigma>" where "G = (\<lambda>x. \<forall>(\<lambda>\<Phi>. P \<Phi> m\<rightarrow> \<Phi> x))"

text {* Axiom @{text "A3"} is added: $P(G)$ (The property of being God-like is positive).
Sledgehammer and Metis then prove corollary @{text "C"}: $\pos \ex x G(x)$
(Possibly, God exists). *}

  axiomatization where A3:  "[P G]"

  corollary C: "[\<diamond> (\<exists> G)]"
  -- {* sledgehammer [provers = remote\_leo2] *}
  by (metis A3 T1)

text {* Axiom @{text "A4"} is added: $\all \phi [P(\phi) \to \Box \; P(\phi)]$
(Positive properties are necessarily positive). *}

  axiomatization where A4:  "[\<forall>(\<lambda>\<Phi>. P \<Phi> m\<rightarrow> \<box> (P \<Phi>))]"

text {* Symbol @{text "ess"} for `Essence' is introduced and defined as
$$\ess{\phi}{x} \biimp \phi(x) \wedge \all \psi (\psi(x) \imp \nec \all y (\phi(y)
\imp \psi(y)))$$ (An \emph{essence} of an individual is a property possessed by it and necessarily implying any of its properties). *}

  definition ess :: "(\<mu> \<Rightarrow> \<sigma>) \<Rightarrow> \<mu> \<Rightarrow> \<sigma>" (infixr "ess" 85) where
    "\<Phi> ess x = \<Phi> x m\<and> \<forall>(\<lambda>\<Psi>. \<Psi> x m\<rightarrow> \<box> (\<forall>(\<lambda>y. \<Phi> y m\<rightarrow> \<Psi> y)))"

text {* Next, Sledgehammer and Metis prove theorem @{text "T2"}: $\all x [G(x) \imp \ess{G}{x}]$ \\
(Being God-like is an essence of any God-like being). *}

  theorem T2: "[\<forall>(\<lambda>x. G x m\<rightarrow> G ess x)]"
  -- {* sledgehammer [provers = remote\_leo2] *}
  by (metis A1b A4 G_def ess_def)

text {* Symbol @{text "NE"}, for `Necessary Existence', is introduced and
defined as $$\NE(x) \biimp \all \phi [\ess{\phi}{x} \imp \nec \ex y \phi(y)]$$ (Necessary
existence of an individual is the necessary exemplification of all its essences). *}

  definition NE :: "\<mu> \<Rightarrow> \<sigma>" where "NE = (\<lambda>x. \<forall>(\<lambda>\<Phi>. \<Phi> ess x m\<rightarrow> \<box> (\<exists> \<Phi>)))"

text {* Moreover, axiom @{text "A5"} is added: $P(\NE)$ (Necessary existence is a positive
property). *}

  axiomatization where A5:  "[P NE]"

text {* The @{text "B"} axiom (symmetry) for relation r is stated. @{text "B"} is needed only
for proving theorem T3 and for corollary C2. *}

  axiomatization where sym: "x r y \<longrightarrow> y r x"

text {* Finally, Sledgehammer and Metis prove the main theorem @{text "T3"}: $\nec \ex x G(x)$ \\
(Necessarily, God exists). *}

  theorem T3: "[\<box> (\<exists> G)]"
  -- {* sledgehammer [provers = remote\_leo2] *}
  by (metis A5 C T2 sym G_def NE_def)

text {* Surprisingly, the following corollary can be derived even without the @{text "T"} axiom
(reflexivity). *}

  corollary C2: "[\<exists> G]"
  -- {* sledgehammer [provers = remote\_leo2] *}
  by (metis T1 T3 G_def sym)

text {* The consistency of the entire theory is confirmed by Nitpick. *}

  lemma True nitpick [satisfy, user_axioms, expect = genuine] oops

section {* Additional Results on G\"odel's God. *}

text {* G\"odel's God is flawless: (s)he does not have non-positive properties. *}

  theorem Flawlessness: "[\<forall>(\<lambda>\<Phi>. \<forall>(\<lambda>x. (G x m\<rightarrow> (m\<not> (P \<Phi>) m\<rightarrow> m\<not> (\<Phi> x)))))]"
  -- {* sledgehammer [provers = remote\_leo2] *}
  by (metis A1b G_def)

text {* There is only one God: any two God-like beings are equal. *}

  theorem Monotheism: "[\<forall>(\<lambda>x.\<forall>(\<lambda>y. (G x m\<rightarrow> (G y m\<rightarrow> (x mL= y)))))]"
  -- {* sledgehammer [provers = remote\_leo2] *}
  by (metis Flawlessness G_def)

section {* Modal Collapse *}

text {* G\"odel's axioms have been criticized for entailing the so-called
modal collapse. The prover Satallax \cite{Satallax} confirms this.
However, sledgehammer is not able to determine which axioms,
definitions and previous theorems are used by Satallax;
hence it suggests to call Metis using everything, but this (unsurprinsingly) fails.
Attempting to use `Sledegehammer min' to minimize Sledgehammer's suggestion does not work.
Calling Metis with @{text "T2"}, @{text "T3"} and @{text "ess_def"} also does not work. *}

  lemma MC: "[\<forall>(\<lambda>\<Phi>.(\<Phi> m\<rightarrow> (\<box> \<Phi>)))]"
  -- {* sledgehammer [provers = remote\_satallax] *}
  -- {* by (metis T2 T3 ess\_def) *}
  oops
(*<*)
end
(*>*)


theory Formula_1_Rule
  imports Scoring_Rules
          "Compositional_Structures/Basic_Modules/Scoring_Module"
          "Compositional_Structures/Basic_Modules/Formula_1"
          "Compositional_Structures/Elect_Composition"

begin

lemma f1_elect:
  shows "electoral_module (elector F1)"
proof(unfold F1.simps)
  show "electoral_module (elector (max_eliminator (scoring vector_A_f1)))"
    using scoring_mod_A by blast
qed

lemma f1_hom:
  shows "homogeneity (elector F1)" unfolding F1.simps
  using scoring_rules_homogeneity
  by blast

lemma f1_reinforcement:
  shows "reinforcement_complete (elector F1)" unfolding F1.simps
  using scoring_module_rein
  by blast

end