(*  Title:       Affine systems of ODEs
    Author:      Jonathan Julián Huerta y Munive, 2020
    Maintainer:  Jonathan Julián Huerta y Munive <jonjulian23@gmail.com>
*)

section \<open> Affine systems of ODEs \<close>

text \<open>Affine systems of ordinary differential equations (ODEs) are those whose vector
fields are linear operators. Broadly speaking, if there are functions $A$ and $B$ such that the
system of ODEs $X'\, t = f\, (X\, t)$ turns into $X'\, t = (A\, t)\cdot (X\, t)+(B\, t)$, then it
is affine. The end goal of this section is to prove that every affine system of ODEs has a unique
solution, and to obtain a characterization of said solution. \<close>

theory MTX_Flows
  imports SQ_MTX "../HS_ODEs"

begin

subsection \<open> Existence and uniqueness for affine systems \<close>

definition matrix_continuous_on :: "real set \<Rightarrow> (real \<Rightarrow> ('a::real_normed_algebra_1)^'n^'m) \<Rightarrow> bool"
  where "matrix_continuous_on T A = (\<forall>t \<in> T. \<forall>\<epsilon> > 0. \<exists> \<delta> > 0. \<forall>\<tau>\<in>T. \<bar>\<tau> - t\<bar> < \<delta> \<longrightarrow> \<parallel>A \<tau> - A t\<parallel>\<^sub>o\<^sub>p \<le> \<epsilon>)"

lemma continuous_on_matrix_vector_multl:
  assumes "matrix_continuous_on T A"
  shows "continuous_on T (\<lambda>t. A t *v s)"
proof(rule continuous_onI, simp add: dist_norm)
  fix e t::real assume "0 < e" and "t \<in> T"
  let ?\<epsilon> = "e/(\<parallel>(if s = 0 then 1 else s)\<parallel>)"
  have "?\<epsilon> > 0"
    using \<open>0 < e\<close> by simp
  then obtain \<delta> where dHyp: "\<delta> > 0 \<and> (\<forall>\<tau>\<in>T. \<bar>\<tau> - t\<bar> < \<delta> \<longrightarrow> \<parallel>A \<tau> - A t\<parallel>\<^sub>o\<^sub>p \<le> ?\<epsilon>)"
    using assms \<open>t \<in> T\<close> unfolding dist_norm matrix_continuous_on_def by fastforce
  {fix \<tau> assume "\<tau> \<in> T" and "\<bar>\<tau> - t\<bar> < \<delta>"
    have obs: "?\<epsilon> * (\<parallel>s\<parallel>) = (if s = 0 then 0 else e)"
      by auto
    have "\<parallel>A \<tau> *v s - A t *v s\<parallel> = \<parallel>(A \<tau> - A t) *v s\<parallel>"
      by (simp add: matrix_vector_mult_diff_rdistrib)
    also have "... \<le> (\<parallel>A \<tau> - A t\<parallel>\<^sub>o\<^sub>p) * (\<parallel>s\<parallel>)"
      using norm_matrix_le_mult_op_norm by blast
    also have "... \<le> ?\<epsilon> * (\<parallel>s\<parallel>)"
      using dHyp \<open>\<tau> \<in> T\<close> \<open>\<bar>\<tau> - t\<bar> < \<delta>\<close> mult_right_mono norm_ge_zero by blast
    finally have "\<parallel>A \<tau> *v s - A t *v s\<parallel> \<le> e"
      by (subst (asm) obs) (metis (mono_tags, hide_lams) \<open>0 < e\<close> less_eq_real_def order_trans)}
  thus "\<exists>d>0. \<forall>\<tau>\<in>T. \<bar>\<tau> - t\<bar> < d \<longrightarrow> \<parallel>A \<tau> *v s - A t *v s\<parallel> \<le> e"
    using dHyp by blast
qed

lemma lipschitz_cond_affine:
  fixes A :: "real \<Rightarrow> 'a::real_normed_algebra_1^'n^'m" and T::"real set"
  defines "L \<equiv> Sup {\<parallel>A t\<parallel>\<^sub>o\<^sub>p |t. t \<in> T}"
  assumes "t \<in> T" and "bdd_above {\<parallel>A t\<parallel>\<^sub>o\<^sub>p |t. t \<in> T}"
  shows "\<parallel>A t *v x - A t *v y\<parallel> \<le> L * (\<parallel>x - y\<parallel>)"
proof-
  have obs: "\<parallel>A t\<parallel>\<^sub>o\<^sub>p \<le> Sup {\<parallel>A t\<parallel>\<^sub>o\<^sub>p |t. t \<in> T}"
    apply(rule cSup_upper)
    using continuous_on_subset assms by (auto simp: dist_norm)
  have "\<parallel>A t *v x - A t *v y\<parallel> = \<parallel>A t *v (x - y)\<parallel>"
    by (simp add: matrix_vector_mult_diff_distrib)
  also have "... \<le> (\<parallel>A t\<parallel>\<^sub>o\<^sub>p) * (\<parallel>x - y\<parallel>)"
    using norm_matrix_le_mult_op_norm by blast
  also have "... \<le> Sup {\<parallel>A t\<parallel>\<^sub>o\<^sub>p |t. t \<in> T} * (\<parallel>x - y\<parallel>)"
    using obs mult_right_mono norm_ge_zero by blast
  finally show "\<parallel>A t *v x - A t *v y\<parallel> \<le> L * (\<parallel>x - y\<parallel>)"
    unfolding assms .
qed

lemma local_lipschitz_affine:
  fixes A :: "real \<Rightarrow> 'a::real_normed_algebra_1^'n^'m"
  assumes "open T" and "open S"
    and Ahyp: "\<And>\<tau> \<epsilon>. \<epsilon> > 0 \<Longrightarrow> \<tau> \<in> T \<Longrightarrow> cball \<tau> \<epsilon> \<subseteq> T \<Longrightarrow> bdd_above {\<parallel>A t\<parallel>\<^sub>o\<^sub>p |t. t \<in> cball \<tau> \<epsilon>}"
  shows "local_lipschitz T S (\<lambda>t s. A t *v s + B t)"
proof(unfold local_lipschitz_def lipschitz_on_def, clarsimp)
  fix s t assume "s \<in> S" and "t \<in> T"
  then obtain e1 e2 where "cball t e1 \<subseteq> T" and "cball s e2 \<subseteq> S" and "min e1 e2 > 0"
    using open_cballE[OF _ \<open>open T\<close>] open_cballE[OF _ \<open>open S\<close>] by force
  hence obs: "cball t (min e1 e2) \<subseteq> T"
    by auto
  let ?L = "Sup {\<parallel>A \<tau>\<parallel>\<^sub>o\<^sub>p |\<tau>. \<tau> \<in> cball t (min e1 e2)}"
  have "\<parallel>A t\<parallel>\<^sub>o\<^sub>p \<in> {\<parallel>A \<tau>\<parallel>\<^sub>o\<^sub>p |\<tau>. \<tau> \<in> cball t (min e1 e2)}"
    using \<open>min e1 e2 > 0\<close> by auto
  moreover have bdd: "bdd_above {\<parallel>A \<tau>\<parallel>\<^sub>o\<^sub>p |\<tau>. \<tau> \<in> cball t (min e1 e2)}"
    by (rule Ahyp, simp only: \<open>min e1 e2 > 0\<close>, simp_all add: \<open>t \<in> T\<close> obs)
  moreover have "Sup {\<parallel>A \<tau>\<parallel>\<^sub>o\<^sub>p |\<tau>. \<tau> \<in> cball t (min e1 e2)} \<ge> 0"
    apply(rule order.trans[OF op_norm_ge_0[of "A t"]])
    by (rule cSup_upper[OF calculation])
  moreover have "\<forall>x\<in>cball s (min e1 e2) \<inter> S. \<forall>y\<in>cball s (min e1 e2) \<inter> S.
    \<forall>\<tau>\<in>cball t (min e1 e2) \<inter> T. dist (A \<tau> *v x) (A \<tau> *v y) \<le> ?L * dist x y"
    apply(clarify, simp only: dist_norm, rule lipschitz_cond_affine)
    using \<open>min e1 e2 > 0\<close> bdd by auto
  ultimately show "\<exists>e>0. \<exists>L. \<forall>t\<in>cball t e \<inter> T. 0 \<le> L \<and>
    (\<forall>x\<in>cball s e \<inter> S. \<forall>y\<in>cball s e \<inter> S. dist (A t *v x) (A t *v y) \<le> L * dist x y)"
    using \<open>min e1 e2 > 0\<close> by blast
qed

lemma picard_lindeloef_affine:
  fixes A :: "real \<Rightarrow> 'a::{banach,real_normed_algebra_1,heine_borel}^'n^'n"
  assumes Ahyp: "matrix_continuous_on T A"
      and "\<And>\<tau> \<epsilon>. \<tau> \<in> T \<Longrightarrow> \<epsilon> > 0 \<Longrightarrow> bdd_above {\<parallel>A t\<parallel>\<^sub>o\<^sub>p |t. dist \<tau> t \<le> \<epsilon>}"
      and Bhyp: "continuous_on T B" and "open S"
      and "t\<^sub>0 \<in> T" and Thyp: "open T" "is_interval T"
    shows "picard_lindeloef (\<lambda> t s. A t *v s + B t) T S t\<^sub>0"
  apply (unfold_locales, simp_all add: assms, clarsimp)
   apply (rule continuous_on_add[OF continuous_on_matrix_vector_multl[OF Ahyp] Bhyp])
  by (rule local_lipschitz_affine) (simp_all add: assms)

lemma picard_lindeloef_autonomous_affine:
  fixes A :: "'a::{banach,real_normed_field,heine_borel}^'n^'n"
  shows "picard_lindeloef (\<lambda> t s. A *v s + B) UNIV UNIV t\<^sub>0"
  using picard_lindeloef_affine[of _ "\<lambda>t. A" "\<lambda>t. B"]
  unfolding matrix_continuous_on_def by (simp only: diff_self op_norm0, auto)

lemma picard_lindeloef_autonomous_linear:
  fixes A :: "'a::{banach,real_normed_field,heine_borel}^'n^'n"
  shows "picard_lindeloef (\<lambda> t. (*v) A) UNIV UNIV t\<^sub>0"
  using picard_lindeloef_autonomous_affine[of A 0] by force

lemmas unique_sol_autonomous_affine = picard_lindeloef.ivp_unique_solution[OF
    picard_lindeloef_autonomous_affine UNIV_I _ subset_UNIV]

lemmas unique_sol_autonomous_linear = picard_lindeloef.ivp_unique_solution[OF
    picard_lindeloef_autonomous_linear UNIV_I _ subset_UNIV]

subsection \<open> Flow for affine systems \<close>

subsubsection \<open> Derivative rules for square matrices \<close>

lemma has_derivative_exp_scaleRl[derivative_intros]:
  fixes f::"real \<Rightarrow> real" (* by Fabian Immler and Johannes Hölzl *)
  assumes "D f \<mapsto> f' at t within T"
  shows "D (\<lambda>t. exp (f t *\<^sub>R A)) \<mapsto> (\<lambda>h. f' h *\<^sub>R (exp (f t *\<^sub>R A) * A)) at t within T"
proof -
  have "bounded_linear f'"
    using assms by auto
  then obtain m where obs: "f' = (\<lambda>h. h * m)"
    using real_bounded_linear by blast
  thus ?thesis
    using vector_diff_chain_within[OF _ exp_scaleR_has_vector_derivative_right]
      assms obs by (auto simp: has_vector_derivative_def comp_def)
qed

lemma vderiv_on_exp_scaleRlI[poly_derivatives]:
  assumes "D f = f' on T" and "g' = (\<lambda>x. f' x *\<^sub>R exp (f x *\<^sub>R A) * A)"
  shows "D (\<lambda>x. exp (f x *\<^sub>R A)) = g' on T"
  using assms unfolding has_vderiv_on_def has_vector_derivative_def apply clarsimp
  by (rule has_derivative_exp_scaleRl, auto simp: fun_eq_iff)

lemma has_derivative_mtx_ith[derivative_intros]:
  fixes t::real and T :: "real set"
  defines "t\<^sub>0 \<equiv> netlimit (at t within T)"
  assumes "D A \<mapsto> (\<lambda>h. h *\<^sub>R A' t) at t within T"
  shows "D (\<lambda>t. A t $$ i) \<mapsto> (\<lambda>h. h *\<^sub>R A' t $$ i) at t within T"
  using assms unfolding has_derivative_def apply safe
   apply(force simp: bounded_linear_def bounded_linear_axioms_def)
  apply(rule_tac F="\<lambda>\<tau>. (A \<tau> - A t\<^sub>0 - (\<tau> - t\<^sub>0) *\<^sub>R A' t) /\<^sub>R (\<parallel>\<tau> - t\<^sub>0\<parallel>)" in tendsto_zero_norm_bound)
  by (clarsimp, rule mult_left_mono, metis (no_types, lifting) norm_column_le_norm
      sq_mtx_minus_ith sq_mtx_scaleR_ith) simp_all

lemmas has_derivative_mtx_vec_mult[derivative_intros] =
  bounded_bilinear.FDERIV[OF bounded_bilinear_sq_mtx_vec_mult]

lemma vderiv_on_mtx_vec_multI[poly_derivatives]:
  assumes "D u = u' on T" and "D A = A' on T"
      and "g = (\<lambda>t. A t *\<^sub>V u' t + A' t *\<^sub>V u t )"
    shows "D (\<lambda>t. A t *\<^sub>V u t) = g on T"
  using assms unfolding has_vderiv_on_def has_vector_derivative_def apply clarsimp
  apply(erule_tac x=x in ballE, simp_all)+
  apply(rule derivative_eq_intros(142))
  by (auto simp: fun_eq_iff mtx_vec_scaleR_commute pth_6 scaleR_mtx_vec_assoc)

lemmas has_vderiv_on_ivl_integral = ivl_integral_has_vderiv_on[OF vderiv_on_continuous_on]

declare has_vderiv_on_ivl_integral [poly_derivatives]

lemma has_derivative_mtx_vec_multl[derivative_intros]:
  assumes "\<And> i j. D (\<lambda>t. (A t) $$ i $ j) \<mapsto> (\<lambda>\<tau>. \<tau> *\<^sub>R (A' t) $$ i $ j) (at t within T)"
  shows "D (\<lambda>t. A t *\<^sub>V x) \<mapsto> (\<lambda>\<tau>. \<tau> *\<^sub>R (A' t) *\<^sub>V x) at t within T"
  unfolding sq_mtx_vec_mult_sum_cols
  apply(rule_tac f'1="\<lambda>i \<tau>. \<tau> *\<^sub>R  (x $ i *\<^sub>R \<c>\<o>\<l> i (A' t))" in derivative_eq_intros(10))
   apply(simp_all add: scaleR_right.sum)
  apply(rule_tac g'1="\<lambda>\<tau>. \<tau> *\<^sub>R \<c>\<o>\<l> i (A' t)" in derivative_eq_intros(4), simp_all add: mult.commute)
  using assms unfolding sq_mtx_col_def column_def apply(transfer, simp)
  apply(rule has_derivative_vec_lambda)
  by (simp add: scaleR_vec_def)

lemma continuous_on_mtx_vec_multr: "continuous_on S ((*\<^sub>V) A)"
  by transfer (simp add: matrix_vector_mult_linear_continuous_on)

\<comment> \<open>Automatically generated derivative rules from this subsubsection \<close>

thm derivative_eq_intros(140,141,142,143)

subsubsection \<open> Existence and uniqueness with square matrices \<close>

text \<open>Finally, we can use the @{term exp} operation to characterize the general solutions for affine
systems of ODEs. We show that they satisfy the @{term "local_flow"} locale.\<close>

lemma continuous_on_sq_mtx_vec_multl:
  fixes A :: "real \<Rightarrow> ('n::finite) sq_mtx"
  assumes "continuous_on T A"
  shows "continuous_on T (\<lambda>t. A t *\<^sub>V s)"
proof-
  have "matrix_continuous_on T (\<lambda>t. to_vec (A t))"
    using assms by (force simp: continuous_on_iff dist_norm norm_sq_mtx_def matrix_continuous_on_def)
  hence "continuous_on T (\<lambda>t. to_vec (A t) *v s)"
    by (rule continuous_on_matrix_vector_multl)
  thus ?thesis
    by transfer
qed

lemmas continuous_on_affine = continuous_on_add[OF continuous_on_sq_mtx_vec_multl]

lemma local_lipschitz_sq_mtx_affine:
  fixes A :: "real \<Rightarrow> ('n::finite) sq_mtx"
  assumes "continuous_on T A" "open T" "open S"
  shows "local_lipschitz T S (\<lambda>t s. A t *\<^sub>V s + B t)"
proof-
  have obs: "\<And>\<tau> \<epsilon>. 0 < \<epsilon> \<Longrightarrow>  \<tau> \<in> T \<Longrightarrow> cball \<tau> \<epsilon> \<subseteq> T \<Longrightarrow> bdd_above {\<parallel>A t\<parallel> |t. t \<in> cball \<tau> \<epsilon>}"
    by (rule bdd_above_norm_cont_comp, rule continuous_on_subset[OF assms(1)], simp_all)
  hence "\<And>\<tau> \<epsilon>. 0 < \<epsilon> \<Longrightarrow> \<tau> \<in> T \<Longrightarrow> cball \<tau> \<epsilon> \<subseteq> T \<Longrightarrow> bdd_above {\<parallel>to_vec (A t)\<parallel>\<^sub>o\<^sub>p |t. t \<in> cball \<tau> \<epsilon>}"
    by (simp add: norm_sq_mtx_def)
  hence "local_lipschitz T S (\<lambda>t s. to_vec (A t) *v s + B t)"
    using local_lipschitz_affine[OF assms(2,3), of "\<lambda>t. to_vec (A t)"] by force
  thus ?thesis
    by transfer
qed

lemmas sq_mtx_unique_sol_autonomous_affine = picard_lindeloef.ivp_unique_solution[OF
    picard_lindeloef_sq_mtx_affine[OF
      continuous_on_const
      continuous_on_const
      UNIV_I is_interval_univ
      open_UNIV open_UNIV]
    UNIV_I _ subset_UNIV]

lemma has_vderiv_on_sq_mtx_linear:
  "D (\<lambda>t. exp ((t - t\<^sub>0) *\<^sub>R A) *\<^sub>V s) = (\<lambda>t. A *\<^sub>V (exp ((t - t\<^sub>0) *\<^sub>R A) *\<^sub>V s)) on {t\<^sub>0--t}"
  by (rule poly_derivatives)+ (auto simp: exp_times_scaleR_commute sq_mtx_times_vec_assoc)

lemma has_vderiv_on_sq_mtx_affine:
  fixes t\<^sub>0::real and A :: "('a::finite) sq_mtx"
  defines "lSol c t \<equiv> exp ((c * (t - t\<^sub>0)) *\<^sub>R A)"
  shows "D (\<lambda>t. lSol 1 t *\<^sub>V s + lSol 1 t *\<^sub>V (\<integral>\<^sub>t\<^sub>0\<^sup>t (lSol (-1) \<tau> *\<^sub>V B) \<partial>\<tau>)) =
  (\<lambda>t. A *\<^sub>V (lSol 1 t *\<^sub>V s + lSol 1 t *\<^sub>V (\<integral>\<^sub>t\<^sub>0\<^sup>t (lSol (-1) \<tau> *\<^sub>V B) \<partial>\<tau>)) + B) on {t\<^sub>0--t}"
  unfolding assms apply(simp only: mult.left_neutral mult_minus1)
  apply(rule poly_derivatives, (force)?, (force)?, (force)?, (force)?)+
  by (simp add: mtx_vec_mult_add_rdistl sq_mtx_times_vec_assoc[symmetric]
      exp_minus_inverse exp_times_scaleR_commute mult_exp_exp  scale_left_distrib[symmetric])

lemma autonomous_linear_sol_is_exp:
  assumes "D X = (\<lambda>t. A *\<^sub>V X t) on {t\<^sub>0--t}" and "X t\<^sub>0 = s"
  shows "X t = exp ((t - t\<^sub>0) *\<^sub>R A) *\<^sub>V s"
  apply(rule sq_mtx_unique_sol_autonomous_affine[of "\<lambda>s. {t\<^sub>0--t}" _ t X A 0])
  using assms apply(simp_all add: ivp_sols_def)
  using has_vderiv_on_sq_mtx_linear by force+

lemma autonomous_affine_sol_is_exp_plus_int:
  assumes "D X = (\<lambda>t. A *\<^sub>V X t + B) on {t\<^sub>0--t}" and "X t\<^sub>0 = s"
  shows "X t = exp ((t - t\<^sub>0) *\<^sub>R A) *\<^sub>V s + exp ((t - t\<^sub>0) *\<^sub>R A) *\<^sub>V (\<integral>\<^sub>t\<^sub>0\<^sup>t(exp (- (\<tau> - t\<^sub>0) *\<^sub>R A) *\<^sub>V B)\<partial>\<tau>)"
  apply(rule sq_mtx_unique_sol_autonomous_affine[of "\<lambda>s. {t\<^sub>0--t}" _ t X A B])
  using assms apply(simp_all add: ivp_sols_def)
  using has_vderiv_on_sq_mtx_affine by force+

lemma local_flow_sq_mtx_linear: "local_flow ((*\<^sub>V) A) UNIV UNIV (\<lambda>t s. exp (t *\<^sub>R A) *\<^sub>V s)"
  unfolding local_flow_def local_flow_axioms_def apply safe
  using picard_lindeloef_sq_mtx_affine[of _ "\<lambda>t. A" "\<lambda>t. 0"] apply force
  using has_vderiv_on_sq_mtx_linear[of 0] by auto

lemma local_flow_sq_mtx_affine: "local_flow (\<lambda>s. A *\<^sub>V s + B) UNIV UNIV
  (\<lambda>t s. exp (t *\<^sub>R A) *\<^sub>V s + exp (t *\<^sub>R A) *\<^sub>V (\<integral>\<^sub>0\<^sup>t(exp (- \<tau> *\<^sub>R A) *\<^sub>V B)\<partial>\<tau>))"
  unfolding local_flow_def local_flow_axioms_def apply safe
  using picard_lindeloef_sq_mtx_affine[of _ "\<lambda>t. A" "\<lambda>t. B"] apply force
  using has_vderiv_on_sq_mtx_affine[of 0 A] by auto

end


(*  Title:       Inductive definition of Hoare logic
    Author:      Tobias Nipkow, 2001/2006
    Maintainer:  Tobias Nipkow
*)

theory Hoare imports Lang begin

subsection\<open>Hoare logic for partial correctness\<close>

text\<open>We continue our semantic approach by modelling assertions just
like boolean expressions, i.e.\ as functions:\<close>

type_synonym assn = "state \<Rightarrow> bool"

text\<open>Hoare triples are triples of the form \<open>{P} c {Q}\<close>, where
the assertions \<open>P\<close> and \<open>Q\<close> are the so-called pre and
postconditions. Such a triple is \emph{valid} (denoted by \<open>\<Turnstile>\<close>)
iff every (terminating) execution starting in a state satisfying \<open>P\<close>
ends up in a state satisfying \<open>Q\<close>:\<close>

definition
 hoare_valid :: "assn \<Rightarrow> com \<Rightarrow> assn \<Rightarrow> bool" ("\<Turnstile> {(1_)}/ (_)/ {(1_)}" 50) where
 "\<Turnstile> {P}c{Q} \<longleftrightarrow> (\<forall>s t. s -c\<rightarrow> t \<longrightarrow> P s \<longrightarrow> Q t)"

text\<open>\noindent
This notion of validity is called \emph{partial correctness} because
it does not require termination of @{term c}.

Provability in Hoare logic is indicated by \<open>\<turnstile>\<close> and defined
inductively:\<close>

inductive
  hoare :: "assn \<Rightarrow> com \<Rightarrow> assn \<Rightarrow> bool" ("\<turnstile> ({(1_)}/ (_)/ {(1_)})" 50)
where
  (*<*)Do:(*>*)"\<turnstile> {\<lambda>s. \<forall>t \<in> f s. P t} Do f {P}"

| (*<*)Semi:(*>*)"\<lbrakk> \<turnstile> {P}c1{Q};  \<turnstile> {Q}c2{R} \<rbrakk>  \<Longrightarrow>  \<turnstile> {P} c1;c2 {R}"

| (*<*)If:(*>*)"\<lbrakk> \<turnstile> {\<lambda>s. P s \<and> b s} c1 {Q};  \<turnstile> {\<lambda>s. P s \<and> \<not>b s} c2 {Q} \<rbrakk>
  \<Longrightarrow> \<turnstile> {P} IF b THEN c1 ELSE c2 {Q}"

| (*<*)While:(*>*)"\<turnstile> {\<lambda>s. P s \<and> b s} c {P}  \<Longrightarrow>  \<turnstile> {P} WHILE b DO c {\<lambda>s. P s \<and> \<not>b s}"

| (*<*)Conseq:(*>*)"\<lbrakk> \<forall>s. P' s \<longrightarrow> P s;  \<turnstile> {P}c{Q};  \<forall>s. Q s \<longrightarrow> Q' s  \<rbrakk>  \<Longrightarrow>  \<turnstile> {P'}c{Q'}"

| (*<*)Local:(*>*) "\<lbrakk> \<And>s. P s \<Longrightarrow> P' s (f s); \<forall>s. \<turnstile> {P' s} c {Q \<circ> (g s)} \<rbrakk> \<Longrightarrow>
        \<turnstile> {P} LOCAL f;c;g {Q}"

text\<open>Soundness is proved by induction on the derivation of @{prop"\<turnstile>
{P} c {Q}"}:\<close>

text\<open>
Completeness is not quite as straightforward, but still easy. The
proof is best explained in terms of the \emph{weakest precondition}:\<close>

definition
 wp :: "com \<Rightarrow> assn \<Rightarrow> assn" where
 "wp c Q = (\<lambda>s. \<forall>t. s -c\<rightarrow> t \<longrightarrow> Q t)"

text\<open>\noindent Dijkstra calls this the weakest \emph{liberal}
precondition to emphasize that it corresponds to partial
correctness. We use ``weakest precondition'' all the time and let the
context determine if we talk about partial or total correctness ---
the latter is introduced further below.

The following lemmas about @{term wp} are easily derived:
\<close>

lemma [simp]: "wp (c\<^sub>1;c\<^sub>2) R = wp c\<^sub>1 (wp c\<^sub>2 R)"
apply(unfold wp_def)
apply(rule ext)
apply blast
done

lemma [simp]:
 "wp (IF b THEN c\<^sub>1 ELSE c\<^sub>2) Q = (\<lambda>s. wp (if b s then c\<^sub>1 else c\<^sub>2) Q s)"
apply(unfold wp_def)
apply(rule ext)
apply auto
done

lemma wp_while:
 "wp (WHILE b DO c) Q =
           (\<lambda>s. if b s then wp (c;WHILE b DO c) Q s else Q s)"
apply(rule ext)
apply(unfold wp_def)
apply auto
apply(blast intro:exec.intros)
apply(simp add:unfold_while)
apply(blast intro:exec.intros)
apply(simp add:unfold_while)
done

lemma [simp]:
 "wp (LOCAL f;c;g) Q = (\<lambda>s. wp c (Q o (g s)) (f s))"
apply(unfold wp_def)
apply(rule ext)
apply auto
done

text\<open>By induction on @{term c} one can easily prove\<close>

lemma wp_is_pre[rule_format]: "\<turnstile> {wp c Q} c {Q}"
apply (induct c arbitrary: Q)
apply simp_all

apply(blast intro:hoare.Do hoare.Conseq)

apply(blast intro:hoare.Semi hoare.Conseq)

apply(blast intro:hoare.If hoare.Conseq)

apply(rule weaken_post)
apply(rule hoare.While)
apply(rule strengthen_pre)
prefer 2
apply blast
apply(clarify)
apply(drule fun_eq_iff[THEN iffD1, OF wp_while, THEN spec, THEN iffD1])
apply simp
apply(clarify)
apply(drule fun_eq_iff[THEN iffD1, OF wp_while, THEN spec, THEN iffD1])
apply(simp split:if_split_asm)

apply(fast intro!: hoare.Local)
done

text\<open>\noindent
from which completeness follows more or less directly via the
rule of consequence:\<close>

theorem hoare_relative_complete: "\<Turnstile> {P}c{Q}  \<Longrightarrow>  \<turnstile> {P}c{Q}"
apply (rule strengthen_pre[OF _ wp_is_pre])
apply(unfold hoare_valid_def wp_def)
apply blast
done

end


(*<*)
theory GoedelProof_P1
imports IHOML
begin
nitpick_params[user_axioms=true, show_all, expect=genuine, format = 3,  atoms e = a b c d]
sledgehammer_params[verbose=true]
(*>*)

section \<open>G\"odel's Argument, Formally\<close>

text\<open>
 "G\"odel's particular version of the argument is a direct descendent of that of Leibniz, which in turn derives
  from one of Descartes. These arguments all have a two-part structure: prove God's existence is necessary,
  if possible; and prove God's existence is possible." \<^cite>\<open>"Fitting"\<close>, p. 138. \<close>

subsection \<open>Part I - God's Existence is Possible\<close>

text\<open>  We separate G\"odel's Argument as presented in Fitting's textbook (ch. 11) in two parts. For the first one, while Leibniz provides
  some kind of proof for the compatibility of all perfections, G\"odel goes on to prove an analogous result:
 \emph{(T1) Every positive property is possibly instantiated}, which together with \emph{(T2) God is a positive property}
  directly implies the conclusion. In order to prove \emph{T1}, G\"odel assumes \emph{A2: Any property entailed by a positive property is positive}. \<close>
text\<open>  We are currently contemplating a follow-up analysis of the philosophical implications of these axioms,
 which encompasses some criticism of the notion of \emph{property entailment} used by G\"odel throughout the argument. \<close>

subsubsection \<open>General Definitions\<close>

abbreviation existencePredicate::"\<up>\<langle>\<zero>\<rangle>" ("E!")
  where "E! x  \<equiv> \<lambda>w. (\<^bold>\<exists>\<^sup>Ey. y\<^bold>\<approx>x) w" \<comment> \<open>existence predicate in object language\<close>

lemma "E! x w \<longleftrightarrow> existsAt x w"
  by simp \<comment> \<open>safety check: @{text "E!"} correctly matches its meta-logical counterpart\<close>

consts positiveProperty::"\<up>\<langle>\<up>\<langle>\<zero>\<rangle>\<rangle>" ("\<P>") \<comment> \<open>positiveness/perfection\<close>

text\<open>  Definitions of God (later shown to be equivalent under axiom \emph{A1b}):  \<close>
abbreviation God::"\<up>\<langle>\<zero>\<rangle>" ("G") where "G \<equiv> (\<lambda>x. \<^bold>\<forall>Y. \<P> Y \<^bold>\<rightarrow> Y x)"
abbreviation God_star::"\<up>\<langle>\<zero>\<rangle>" ("G*") where "G* \<equiv> (\<lambda>x. \<^bold>\<forall>Y. \<P> Y \<^bold>\<leftrightarrow> Y x)"

text\<open>  Definitions needed to formalise \emph{A3}:  \<close>
abbreviation appliesToPositiveProps::"\<up>\<langle>\<up>\<langle>\<up>\<langle>\<zero>\<rangle>\<rangle>\<rangle>" ("pos") where
  "pos Z \<equiv>  \<^bold>\<forall>X. Z X \<^bold>\<rightarrow> \<P> X"
abbreviation intersectionOf::"\<up>\<langle>\<up>\<langle>\<zero>\<rangle>,\<up>\<langle>\<up>\<langle>\<zero>\<rangle>\<rangle>\<rangle>" ("intersec") where
  "intersec X Z \<equiv>  \<^bold>\<box>(\<^bold>\<forall>x.(X x \<^bold>\<leftrightarrow> (\<^bold>\<forall>Y. (Z Y) \<^bold>\<rightarrow> (Y x))))" \<comment> \<open>quantifier is possibilist\<close>
abbreviation Entailment::"\<up>\<langle>\<up>\<langle>\<zero>\<rangle>,\<up>\<langle>\<zero>\<rangle>\<rangle>" (infix "\<Rrightarrow>" 60) where
  "X \<Rrightarrow> Y \<equiv>  \<^bold>\<box>(\<^bold>\<forall>\<^sup>Ez. X z \<^bold>\<rightarrow> Y z)"
text\<open> \bigbreak \<close>

subsubsection \<open>Axioms\<close>

axiomatization where
  A1a:"\<lfloor>\<^bold>\<forall>X. \<P> (\<^bold>\<rightharpoondown>X) \<^bold>\<rightarrow> \<^bold>\<not>(\<P> X) \<rfloor>" and      \<comment> \<open>axiom 11.3A\<close>
  A1b:"\<lfloor>\<^bold>\<forall>X. \<^bold>\<not>(\<P> X) \<^bold>\<rightarrow> \<P> (\<^bold>\<rightharpoondown>X)\<rfloor>" and       \<comment> \<open>axiom 11.3B\<close>
  A2: "\<lfloor>\<^bold>\<forall>X Y. (\<P> X \<^bold>\<and> (X \<Rrightarrow> Y)) \<^bold>\<rightarrow> \<P> Y\<rfloor>" and   \<comment> \<open>axiom 11.5\<close>
  A3: "\<lfloor>\<^bold>\<forall>Z X. (pos Z \<^bold>\<and> intersec X Z) \<^bold>\<rightarrow> \<P> X\<rfloor>" \<comment> \<open>axiom 11.10\<close>

lemma True nitpick[satisfy] oops       \<comment> \<open>model found: axioms are consistent\<close>

lemma "\<lfloor>D\<rfloor>"  using A1a A1b A2 by blast \<comment> \<open>axioms already imply \emph{D} axiom\<close>
lemma "\<lfloor>D\<rfloor>" using A1a A3 by metis

subsubsection \<open>Theorems\<close>

lemma "\<lfloor>\<^bold>\<exists>X. \<P> X\<rfloor>" using A1b by auto
lemma "\<lfloor>\<^bold>\<exists>X. \<P> X \<^bold>\<and>  \<^bold>\<diamond>\<^bold>\<exists>\<^sup>E X\<rfloor>" using A1a A1b A2 by metis

text\<open>  Being self-identical is a positive property:  \<close>
lemma "\<lfloor>(\<^bold>\<exists>X. \<P> X \<^bold>\<and>  \<^bold>\<diamond>\<^bold>\<exists>\<^sup>E X) \<^bold>\<rightarrow> \<P> (\<lambda>x w. x = x)\<rfloor>" using A2 by fastforce

text\<open>  Proposition 11.6  \<close>
lemma "\<lfloor>(\<^bold>\<exists>X. \<P> X) \<^bold>\<rightarrow> \<P> (\<lambda>x w. x = x)\<rfloor>" using A2 by fastforce

lemma "\<lfloor>\<P> (\<lambda>x w. x = x)\<rfloor>" using A1b A2  by blast
lemma "\<lfloor>\<P> (\<lambda>x w. x = x)\<rfloor>" using A3 by metis

text\<open>  Being non-self-identical is a negative property: \<close>
lemma "\<lfloor>(\<^bold>\<exists>X. \<P> X  \<^bold>\<and> \<^bold>\<diamond>\<^bold>\<exists>\<^sup>E X) \<^bold>\<rightarrow>  \<P> (\<^bold>\<rightharpoondown> (\<lambda>x w. \<not>x = x))\<rfloor>"
  using A2 by fastforce

lemma "\<lfloor>(\<^bold>\<exists>X. \<P> X) \<^bold>\<rightarrow>  \<P> (\<^bold>\<rightharpoondown> (\<lambda>x w. \<not>x = x))\<rfloor>" using A2 by fastforce
lemma "\<lfloor>(\<^bold>\<exists>X. \<P> X) \<^bold>\<rightarrow>  \<P> (\<^bold>\<rightharpoondown> (\<lambda>x w. \<not>x = x))\<rfloor>" using A3 by metis

text\<open>  Proposition 11.7  \<close>
lemma "\<lfloor>(\<^bold>\<exists>X. \<P> X) \<^bold>\<rightarrow> \<^bold>\<not>\<P> ((\<lambda>x w. \<not>x = x))\<rfloor>"  using A1a A2 by blast
lemma "\<lfloor>\<^bold>\<not>\<P> (\<lambda>x w. \<not>x = x)\<rfloor>"  using A1a A2 by blast

text\<open>  Proposition 11.8 (Informal Proposition 1) - Positive properties are possibly instantiated:  \<close>
theorem T1: "\<lfloor>\<^bold>\<forall>X. \<P> X \<^bold>\<rightarrow> \<^bold>\<diamond>\<^bold>\<exists>\<^sup>E X\<rfloor>" using A1a A2 by blast

text\<open>  Proposition 11.14 - Both defs (\emph{God/God*}) are equivalent. For improved performance we may prefer to use one or the other:  \<close>
lemma GodDefsAreEquivalent: "\<lfloor>\<^bold>\<forall>x. G x \<^bold>\<leftrightarrow> G* x\<rfloor>" using A1b by force

text\<open>  Proposition 11.15 - Possibilist existence of \emph{God} directly implies \emph{A1b}:  \<close>
lemma "\<lfloor>\<^bold>\<exists> G* \<^bold>\<rightarrow> (\<^bold>\<forall>X. \<^bold>\<not>(\<P> X) \<^bold>\<rightarrow> \<P> (\<^bold>\<rightharpoondown>X))\<rfloor>" by meson

text\<open>  Proposition 11.16 - \emph{A3} implies \emph{P(G)} (local consequence):   \<close>
lemma A3implT2_local: "\<lfloor>(\<^bold>\<forall>Z X. (pos Z \<^bold>\<and> intersec X Z) \<^bold>\<rightarrow> \<P> X) \<^bold>\<rightarrow> \<P> G\<rfloor>"
proof -
  {
  fix w
  have 1: "pos \<P> w" by simp
  have 2: "intersec G \<P> w" by simp
  {
    assume "(\<^bold>\<forall>Z X. (pos Z \<^bold>\<and> intersec X Z) \<^bold>\<rightarrow> \<P> X) w"
    hence "(\<^bold>\<forall>X. ((pos \<P>) \<^bold>\<and> (intersec X \<P>)) \<^bold>\<rightarrow> \<P> X) w"  by (rule allE)
    hence "(((pos \<P>) \<^bold>\<and> (intersec G \<P>)) \<^bold>\<rightarrow> \<P> G) w" by (rule allE)
    hence 3: "((pos \<P> \<^bold>\<and> intersec G \<P>) w) \<longrightarrow> \<P> G w" by simp
    hence 4: "((pos \<P>) \<^bold>\<and> (intersec G \<P>)) w" using 1 2 by simp
    from 3 4 have "\<P> G w" by (rule mp)
  }
  hence "(\<^bold>\<forall>Z X. (pos Z \<^bold>\<and> intersec X Z) \<^bold>\<rightarrow> \<P> X) w  \<longrightarrow> \<P> G w" by (rule impI)
  }
  thus ?thesis by (rule allI)
qed

text\<open>  \emph{A3} implies \<open>P(G)\<close> (as global consequence): \<close>
lemma A3implT2_global: "\<lfloor>\<^bold>\<forall>Z X. (pos Z \<^bold>\<and> intersec X Z) \<^bold>\<rightarrow> \<P> X\<rfloor> \<longrightarrow> \<lfloor>\<P> G\<rfloor>"
  using A3implT2_local by (rule localImpGlobalCons)

text\<open>  Being Godlike is a positive property. Note that this theorem can be axiomatized directly,
as noted by Dana Scott (see \<^cite>\<open>"Fitting"\<close>, p. 152). We will do so for the second part. \<close>
theorem T2: "\<lfloor>\<P> G\<rfloor>" using A3implT2_global A3 by simp

text\<open>  Theorem 11.17 (Informal Proposition 3) - Possibly God exists: \<close>
theorem T3: "\<lfloor>\<^bold>\<diamond>\<^bold>\<exists>\<^sup>E G\<rfloor>"  using T1 T2 by simp

(*<*)
end
(*>*)


(*<*)
theory Fundata imports Main begin
(*>*)
datatype (dead 'a,'i) bigtree = Tip | Br 'a "'i \<Rightarrow> ('a,'i)bigtree"

text{*\noindent
Parameter @{typ"'a"} is the type of values stored in
the @{term Br}anches of the tree, whereas @{typ"'i"} is the index
type over which the tree branches. If @{typ"'i"} is instantiated to
@{typ"bool"}, the result is a binary tree; if it is instantiated to
@{typ"nat"}, we have an infinitely branching tree because each node
has as many subtrees as there are natural numbers. How can we possibly
write down such a tree? Using functional notation! For example, the term
@{term[display]"Br (0::nat) (\<lambda>i. Br i (\<lambda>n. Tip))"}
of type @{typ"(nat,nat)bigtree"} is the tree whose
root is labeled with 0 and whose $i$th subtree is labeled with $i$ and
has merely @{term"Tip"}s as further subtrees.

Function @{term"map_bt"} applies a function to all labels in a @{text"bigtree"}:
*}

primrec map_bt :: "('a \<Rightarrow> 'b) \<Rightarrow> ('a,'i)bigtree \<Rightarrow> ('b,'i)bigtree"
where
"map_bt f Tip      = Tip" |
"map_bt f (Br a F) = Br (f a) (\<lambda>i. map_bt f (F i))"

text{*\noindent This is a valid \isacommand{primrec} definition because the
recursive calls of @{term"map_bt"} involve only subtrees of
@{term"F"}, which is itself a subterm of the left-hand side. Thus termination
is assured.  The seasoned functional programmer might try expressing
@{term"%i. map_bt f (F i)"} as @{term"map_bt f o F"}, which Isabelle
however will reject.  Applying @{term"map_bt"} to only one of its arguments
makes the termination proof less obvious.

The following lemma has a simple proof by induction:  *}

lemma "map_bt (g o f) T = map_bt g (map_bt f T)"
apply(induct_tac T, simp_all)
done
(*<*)lemma "map_bt (g o f) T = map_bt g (map_bt f T)"
apply(induct_tac T, rename_tac[2] F)(*>*)
txt{*\noindent
Because of the function type, the proof state after induction looks unusual.
Notice the quantified induction hypothesis:
@{subgoals[display,indent=0]}
*}
(*<*)
oops
end
(*>*)


theory Prefixes
  imports Main Seq2less Subseq Subst Permute
begin

(* Begin with zero and other prefix substitutions *)

(* (0,0,0) ... *)

lemma begin_zero:
  "is_2less (h#t) \<longrightarrow> is_2less ((0,0,0)#t)"
  apply (induction t)
  apply simp
  using lt.elims(2)
  by fastforce

(* (0,0,0) (1,0,1) ... *)
(* possible minimal candidates: (1,0,1) (0,1,1) (1,1,0) *)

lemma begin_prefix_2a:
  "is_2less ((0,0,0)#(0,1,1)#t) \<longrightarrow> is_2less ((0,0,0)#(1,0,1)#(permute (perm Swap12) t))"
  apply (induction t)
  apply simp
  by (metis Perm.simps(21) perm.elims permute.simps(2) permutability_is_2less swap_12.simps)

lemma begin_prefix_2b:
  "is_2less ((0,0,0)#(1,1,0)#t) \<longrightarrow> is_2less ((0,0,0)#(1,0,1)#(permute (perm Swap23) t))"
  apply (induction t)
  apply simp
  by (metis Perm.simps(23) perm.simps permute.simps(2) permutability_is_2less swap_23.simps)

(* (0,0,0) (1,0,1) (0,1,2) ... *)
(* possible minimal candidates: (0,1,2) (2,1,0) (2,0,2) *)

lemma begin_prefix_3_lt_all_0:
  "lt_all (0,0,0) t \<longrightarrow> lt_all (0,0,0) (permute (perm Swap13) t)"
  apply (induction t)
  apply simp
  by auto

lemma begin_prefix_3_lt_all_1:
  "lt_all (1,0,1) t \<longrightarrow> lt_all (1,0,1) (permute (perm Swap13) t)"
  apply (induction t)
  apply simp
  by auto

lemma begin_prefix_3_lt_all_2:
  "lt_all (2,1,0) t \<longrightarrow> lt_all (0,1,2) (permute (perm Swap13) t)"
  apply (induction t)
  apply simp
  by auto

corollary begin_prefix:
  "is_2less ((0,0,0)#(1,0,1)#(2,1,0)#t) \<longrightarrow> is_2less ((0,0,0)#(1,0,1)#(0,1,2)#(permute (perm Swap13) t))"
  apply (induction t)
   apply simp
  using begin_prefix_3_lt_all_0 begin_prefix_3_lt_all_1 begin_prefix_3_lt_all_2
  by (meson is_2less.simps(2) lt_all.simps(2) permutability_is_2less)

(* TODO: (2,0,2) *)

end