section \<open> Autonomous Marine Vehicle \<close>

text \<open> This theory accompanies the paper "Towards Deductive Verification of Control Algorithms for
  Autonomous Marine Vehicles" by Simon Foster, Mario Gleirscher, and Radu Calinescu.

  CC-NC-BY 4.0, Simon Foster. This version & any derivatives are for NON-MILITARY USE ONLY. \<close>

theory AMV
  imports "UTP-dL.utp_hyprog"
begin

subsection \<open> Preliminaries \<close>

no_notation (ASCII)
  comp  (infixl "o" 55)

lemma self_dot [simp]: "\<parallel>v\<parallel> * \<parallel>v\<parallel> = v \<bullet> v"
  by (metis norm_cauchy_schwarz_eq)

lemma orth_mag [simp]: "a \<bullet> b = \<parallel>a\<parallel> * \<parallel>b\<parallel> \<Longrightarrow> \<parallel>a + b\<parallel> = \<parallel>a\<parallel> + \<parallel>b\<parallel>"
  by (simp add: norm_cauchy_schwarz_eq norm_triangle_eq)

lemma orth_mag' [simp]: "b \<bullet> a = \<parallel>b\<parallel> * \<parallel>a\<parallel> \<Longrightarrow> \<parallel>a + b\<parallel> = \<parallel>a\<parallel> + \<parallel>b\<parallel>"
  by (simp add: norm_cauchy_schwarz_eq norm_triangle_eq)

lemma "a \<noteq> 0 \<Longrightarrow> \<parallel>sgn a\<parallel> = 1"
  by (simp add: norm_sgn)

lemma "a \<noteq> 0 \<Longrightarrow> sgn a \<bullet> sgn a = 1"
  by (meson norm_eq_1 norm_sgn)

lemma sgn_self_dot:
  assumes "a \<noteq> 0"
  shows "(sgn a) \<bullet> (sgn a) = 1"
  by (meson assms norm_eq_1 norm_sgn)

lemma "a \<noteq> 0 \<Longrightarrow> (a / \<parallel>a\<parallel>) \<bullet> (a / \<parallel>a\<parallel>) = 1"
  by simp

lemma "\<lbrakk> a \<ge> 0; a\<^sup>2 = b \<rbrakk> \<Longrightarrow> a = sqrt(b)"
  by (simp add: real_sqrt_unique)

lemma
  assumes "(a::'a::ordered_euclidean_space) \<noteq> 0"
  shows "a \<bullet> b / \<parallel>a\<parallel> = sgn a \<bullet> b"
  by (simp add: divide_inverse_commute sgn_div_norm)

lemma "v \<noteq> 0 \<Longrightarrow> arccos(v \<bullet> v / (\<parallel>v\<parallel> * \<parallel>v\<parallel>)) = 0"
  by (simp)

declare num1_eq1 [simp del]

lemma exhaust_2':
  fixes x :: 2
  shows "x = 0 \<or> x = 1"
  using exhaust_2 by fastforce

lemma forall_2': "(\<forall>i::2. P i) \<longleftrightarrow> P 0 \<and> P 1"
  by (metis exhaust_2')

declare UNIV_1 [simp del]
declare UNIV_2 [simp del]

lemma UNIV_1 [simp]: "(UNIV :: 1 set) = {0}"
  by (metis UNIV_1 num1_eq1)

lemma UNIV_2 [simp]: "(UNIV :: 2 set) = {0,1}"
  by (simp add: UNIV_eq_I exhaust_2')

subsection \<open> Vector Theorems and Simplifications \<close>

lemma vec_norm: "\<parallel>\<^bold>[[x, y]\<^bold>]\<parallel> = sqrt(x\<^sup>2 + y\<^sup>2)"
  by (simp add: norm_vec_def)

lemma vec_simps [simp]:
  "k *\<^sub>R \<^bold>[[x, y]\<^bold>] = \<^bold>[[k *\<^sub>R x, k *\<^sub>R y]\<^bold>]"
  "\<^bold>[[x\<^sub>1::real, y\<^sub>1]\<^bold>] \<bullet> \<^bold>[[x\<^sub>2, y\<^sub>2]\<^bold>] = x\<^sub>1 * x\<^sub>2 + y\<^sub>1 * y\<^sub>2"
  "\<^bold>[[x\<^sub>1, y\<^sub>1]\<^bold>] + \<^bold>[[x\<^sub>2, y\<^sub>2]\<^bold>] = \<^bold>[[x\<^sub>1 + x\<^sub>2, y\<^sub>1 + y\<^sub>2]\<^bold>]"
  "\<^bold>[[x\<^sub>1, y\<^sub>1]\<^bold>] - \<^bold>[[x\<^sub>2, y\<^sub>2]\<^bold>] = \<^bold>[[x\<^sub>1 - x\<^sub>2, y\<^sub>1 - y\<^sub>2]\<^bold>]"
  "\<^bold>[[0, 0]\<^bold>] = 0"
     apply (subst scaleR_Mat, simp_all)
  apply (simp add: inner_vec_def)
    apply (subst plus_Mat, simp_all)
   apply (subst minus_Mat, simp_all)
   apply (simp add: matrix_eq_iff nat_of_num1_def forall_2')
  done

lemma orient_vec_mag_1 [simp]: "\<parallel>\<^bold>[[sin \<theta> :: real, cos \<theta>]\<^bold>]\<parallel> = 1"
  by (simp add: vec_norm)

lemma orient_vec_mag_n [simp]:
  assumes "n \<ge> 0"
  shows "\<parallel>\<^bold>[[n * sin \<theta> :: real, n * cos \<theta>]\<^bold>]\<parallel> = n" (is "?P = ?Q")
proof -
  have "?P = \<parallel>\<^bold>[[n *\<^sub>R sin \<theta> :: real, n *\<^sub>R cos \<theta>]\<^bold>]\<parallel>"
    by (metis real_scaleR_def)
  also have "... = \<parallel>n *\<^sub>R \<^bold>[[sin \<theta> :: real, cos \<theta>]\<^bold>]\<parallel>"
    by simp
  also have "... = \<parallel>n\<parallel> * \<parallel>\<^bold>[[sin \<theta> :: real, cos \<theta>]\<^bold>]\<parallel>"
    by (metis norm_scaleR real_norm_def)
  also from assms have "... = n"
    by simp
  finally show ?thesis .
qed

lemma sin_cos_self_dot [simp]: "\<^bold>[[sin(\<theta>::real), cos(\<theta>)]\<^bold>] \<bullet> \<^bold>[[sin(\<theta>), cos(\<theta>)]\<^bold>] = 1"
  by (simp, metis power2_eq_square sin_cos_squared_add)

lemma vector_2_cases [cases type]:
  fixes x
  assumes "\<And> x\<^sub>1 x\<^sub>2. x = \<^bold>[[x\<^sub>1, x\<^sub>2]\<^bold>] \<Longrightarrow> P"
  shows "P"
proof -
  have "x = \<^bold>[[x 1 0, x 1 1]\<^bold>]"
    by (simp add: matrix_eq_iff nat_of_num1_def forall_2')
  thus ?thesis
    using assms by metis
qed

lemma cos_r1:
  assumes "- 1 \<le> y" "y < 1"
  shows "0 < arccos y"
proof -
  have "arccos 1 < arccos y"
    by (rule arccos_less_arccos, simp_all add: assms)
  thus ?thesis
    by simp
qed

lemma cos_r2:
  assumes "0 < x" "x \<le> 1"
  shows "arccos x * 2 < pi"
proof -
  have "arccos x < arccos 0"
    by (rule arccos_less_arccos, simp_all add: assms)
  thus ?thesis
    by simp
qed

lemma vec_2_eq_iff [simp]: "\<^bold>[[x\<^sub>1, y\<^sub>1]\<^bold>] = \<^bold>[[x\<^sub>2, y\<^sub>2]\<^bold>] \<longleftrightarrow> (x\<^sub>1 = x\<^sub>2 \<and> y\<^sub>1 = y\<^sub>2)"
  by (auto simp add: Mat_eq_iff')

lemma vec_2_eq_zero_off [simp]: "\<^bold>[[x, y]\<^bold>] = 0 \<longleftrightarrow> (x = 0 \<and> y = 0)"
  by (subst vec_simps(5) [THEN sym], simp only: vec_2_eq_iff)

subsection \<open> Angle Calculations \<close>

abbreviation "angOfVec \<equiv> vangle \<^bold>[[0::real,100]\<^bold>]"

abbreviation "\<phi>\<^sub>m\<^sub>a\<^sub>x \<equiv> pi / 3"

definition angDiff :: "real \<Rightarrow> real \<Rightarrow> bool \<Rightarrow> real" where
"angDiff \<phi>\<^sub>A \<phi>\<^sub>B rotRestr \<equiv>
  let dphi =
  (if (abs(\<phi>\<^sub>A - \<phi>\<^sub>B) <= pi) then
    \<phi>\<^sub>A - \<phi>\<^sub>B
  else
    -sgn(\<phi>\<^sub>A - \<phi>\<^sub>B) * (2 * pi - abs(\<phi>\<^sub>A - \<phi>\<^sub>B)))
  in
  if (rotRestr) then
    -sgn(dphi) * min(abs(dphi)) \<phi>\<^sub>m\<^sub>a\<^sub>x
  else dphi"

lemma "angOfVec (Matrix[[0,1]]) = 0" \<comment> \<open> 0 degree angOfVector \<close>
  by (simp add: vangle_def vec_norm)

lemma "angOfVec (Matrix[[1,0]]) = pi / 2" \<comment> \<open> 90 degree angOfVector \<close>
  by (simp add: vangle_def)

lemma arccos_inv_sqrt2: "arccos (1 / sqrt 2) = pi / 4"
  by (smt arccos_cos arccos_minus_1 arcsin_minus_1 arcsin_plus_arccos arctan arctan_less_pi4_pos arctan_one arctan_zero_zero cos_45 eq_divide_eq mult_cancel_left1 real_div_sqrt real_divide_square_eq)

lemma "angOfVec (Matrix[[1,1]]) = pi / 4" \<comment> \<open> 45 degree angOfVector \<close>
  by (simp add: vangle_def arccos_inv_sqrt2 vec_norm)

lemma "angDiff (pi/2) (pi/4) False = pi/4"
  by (simp add: angDiff_def)

lemma "angDiff (pi) (pi/4) False = 3 / 4 * pi"
  by (simp add: angDiff_def)

subsection \<open> AMV Constants \<close>

abbreviation "m \<equiv> 12"            \<comment> \<open> Mass \<close>
abbreviation "S \<equiv> 1.5"           \<comment> \<open> Maximum speed \<close>
abbreviation "f\<^sub>m\<^sub>a\<^sub>x \<equiv> 9 * 9.80665" \<comment> \<open> Maximum force \<close>
abbreviation "\<phi>\<^sub>\<epsilon> \<equiv> 0.001"        \<comment> \<open> Angular tolerance \<close>
abbreviation "s\<^sub>\<epsilon> \<equiv> 0.001"        \<comment> \<open> Linear tolerance \<close>

abbreviation "kp\<^sub>g\<^sub>v \<equiv> 5"
abbreviation "kp\<^sub>g\<^sub>r \<equiv> 5"

definition "(\<epsilon>::real) \<equiv> 0.1"

subsection \<open> AMV State Space \<close>

text \<open> Continuous state space type. \<close>

type_synonym 'a AMVc =
  "real vec[2] \<times> real vec[2] \<times> real vec[2] \<times> real \<times> real \<times> real \<times> 'a"

text \<open> Discrete state space type. \<close>

datatype OPMode = OCM | HCM | MOM

alphabet 'a::executable_euclidean_space AMVs = "'a AMVc hybs" +
  nextWP  :: "real vec[2]"
  obsReg  :: "(real vec[2]) set"
  rs  :: "real"
  rh :: "real"
  ft      :: "real"
  fl      :: "real"
  f       :: "real vec[2]"
  mode    :: OPMode

declare hybs.splits [alpha_splits del]
declare hybs.splits [alpha_splits]

translations
  (type) "AMVc" <= (type) "real vec[2] \<times> real vec['a] \<times> real vec['b] \<times> real \<times> real \<times> real"

text \<open> Variables as lenses. This boilerplate should be automatically generated
  in the future. \<close>

abbreviation "w\<^sub>x \<equiv> mat_lens 0 0 ;\<^sub>L nextWP"
abbreviation "w\<^sub>y \<equiv> mat_lens 0 1 ;\<^sub>L nextWP"

abbreviation p :: "real vec[2] \<Longrightarrow> 'a AMVc" where "p \<equiv> fst\<^sub>L"
abbreviation v :: "real vec[2] \<Longrightarrow> 'a AMVc" where "v \<equiv> fst\<^sub>L ;\<^sub>L snd\<^sub>L"
abbreviation a :: "real vec[2] \<Longrightarrow> 'a AMVc" where "a \<equiv> fst\<^sub>L ;\<^sub>L snd\<^sub>L ;\<^sub>L snd\<^sub>L"
abbreviation \<phi> :: "real \<Longrightarrow> 'a AMVc" where "\<phi> \<equiv> fst\<^sub>L ;\<^sub>L snd\<^sub>L ;\<^sub>L snd\<^sub>L ;\<^sub>L snd\<^sub>L"
abbreviation s :: "real \<Longrightarrow> 'a AMVc" where "s \<equiv> fst\<^sub>L ;\<^sub>L snd\<^sub>L ;\<^sub>L snd\<^sub>L ;\<^sub>L snd\<^sub>L ;\<^sub>L snd\<^sub>L"
abbreviation t :: "real \<Longrightarrow> 'a AMVc" where "t \<equiv> fst\<^sub>L ;\<^sub>L snd\<^sub>L ;\<^sub>L snd\<^sub>L ;\<^sub>L snd\<^sub>L ;\<^sub>L snd\<^sub>L ;\<^sub>L snd\<^sub>L"
abbreviation old :: "real AMVc \<Longrightarrow> real AMVc AMVc" where "old \<equiv> snd\<^sub>L ;\<^sub>L snd\<^sub>L ;\<^sub>L snd\<^sub>L ;\<^sub>L snd\<^sub>L ;\<^sub>L snd\<^sub>L ;\<^sub>L snd\<^sub>L"

abbreviation p\<^sub>x :: "real \<Longrightarrow> 'a AMVc" where "p\<^sub>x \<equiv> mat_lens 0 0 ;\<^sub>L fst\<^sub>L"
abbreviation p\<^sub>y :: "real \<Longrightarrow> 'a AMVc" where "p\<^sub>y \<equiv> mat_lens 0 1 ;\<^sub>L fst\<^sub>L"

abbreviation v\<^sub>x :: "real \<Longrightarrow> 'a AMVc" where "v\<^sub>x \<equiv> mat_lens 0 0 ;\<^sub>L fst\<^sub>L ;\<^sub>L snd\<^sub>L"
abbreviation v\<^sub>y :: "real \<Longrightarrow> 'a AMVc" where "v\<^sub>y \<equiv> mat_lens 0 1 ;\<^sub>L fst\<^sub>L ;\<^sub>L snd\<^sub>L"

abbreviation a\<^sub>x :: "real \<Longrightarrow> 'a AMVc" where "a\<^sub>x \<equiv> mat_lens 0 0 ;\<^sub>L fst\<^sub>L ;\<^sub>L snd\<^sub>L ;\<^sub>L snd\<^sub>L"
abbreviation a\<^sub>y :: "real \<Longrightarrow> 'a AMVc" where "a\<^sub>y \<equiv> mat_lens 0 1 ;\<^sub>L fst\<^sub>L ;\<^sub>L snd\<^sub>L ;\<^sub>L snd\<^sub>L"

abbreviation \<phi>\<^sub>A\<^sub>V :: "(real, 'a::executable_euclidean_space AMVs) uexpr" where "\<phi>\<^sub>A\<^sub>V \<equiv> U(angOfVec &\<^bold>c:v)"
abbreviation \<phi>\<^sub>W\<^sub>P :: "(real, 'a::executable_euclidean_space AMVs) uexpr" where "\<phi>\<^sub>W\<^sub>P \<equiv> U(angOfVec (&\<^bold>c:v - &nextWP))"

subsection \<open> AMV Hybrid Model \<close>

abbreviation "\<omega> \<equiv> U(arccos((v + a) \<bullet> v / (\<parallel>v + a\<parallel> * \<parallel>v\<parallel>)) \<triangleleft> \<not> \<parallel>v\<parallel> = 0 \<triangleright> 0)"

subsubsection \<open> AMV Dynamics \<close>

text \<open> Shows the derivative of each continuous variable. \<close>

abbreviation "dyn\<^sub>A\<^sub>V \<equiv>
  [ p \<mapsto>\<^sub>s v
  , v \<mapsto>\<^sub>s a
  , a \<mapsto>\<^sub>s 0
  , \<phi> \<mapsto>\<^sub>s \<omega>
  , s \<mapsto>\<^sub>s (v \<bullet> a) / s \<triangleleft> \<not> s = 0 \<triangleright> \<parallel>a\<parallel>
  , t \<mapsto>\<^sub>s 1
  , old \<mapsto>\<^sub>s 0 ]"

abbreviation
  "ax\<^sub>A\<^sub>V \<equiv> U(&\<^bold>c:t < \<epsilon> \<and> &\<^bold>c:s *\<^sub>R \<^bold>[[sin(&\<^bold>c:\<phi>),cos(&\<^bold>c:\<phi>)]\<^bold>] = &\<^bold>c:v
           \<and> 0 \<le> &\<^bold>c:s \<and> &\<^bold>c:s \<le> S)"

abbreviation "ODE \<equiv> ode dyn\<^sub>A\<^sub>V ax\<^sub>A\<^sub>V"

abbreviation "Dynamics \<equiv> \<^bold>c:t := 0 ;; ODE"

subsubsection \<open> Last Response Engine \<close>

abbreviation "steerToWP \<equiv> rh := angOfVec(nextWP - &\<^bold>c:p)" \<comment> \<open> Calculation of heading \<close>

abbreviation
  "LRE \<equiv> ((mode = HCM) \<longrightarrow>\<^sub>r rs := 0.1 ;; steerToWP)
       \<sqinter> ((mode = OCM) \<longrightarrow>\<^sub>r II)
       \<sqinter> ((mode = MOM) \<longrightarrow>\<^sub>r
             rs := 1 ;;
             steerToWP ;;
             if (\<exists> o. o \<in> obsReg \<and> \<parallel>&\<^bold>c:p - \<guillemotleft>o\<guillemotright>\<parallel> \<le> 7.5) then mode := HCM ;; rs := 0.1 fi
          )"

subsubsection \<open> Autopilot \<close>

abbreviation "AP \<equiv>
  if \<parallel>rs - &\<^bold>c:s\<parallel> > s\<^sub>\<epsilon>
    then ft := sgn(rs - &\<^bold>c:s)*min(kp\<^sub>g\<^sub>v * \<parallel>rs - &\<^bold>c:s\<parallel>) f\<^sub>m\<^sub>a\<^sub>x
    else ft := 0 fi ;;
  if \<parallel>rh - &\<^bold>c:\<phi>\<parallel> > \<phi>\<^sub>\<epsilon>
    then fl := sgn(rh - &\<^bold>c:\<phi>)*min(kp\<^sub>g\<^sub>r * \<parallel>rh - &\<^bold>c:\<phi>\<parallel>) f\<^sub>m\<^sub>a\<^sub>x
    else fl := 0 fi ;;
  f := fl *\<^sub>R \<^bold>[[cos(&\<^bold>c:\<phi>), sin(&\<^bold>c:\<phi>)]\<^bold>]
     + ft *\<^sub>R \<^bold>[[sin(&\<^bold>c:\<phi>), cos(&\<^bold>c:\<phi>)]\<^bold>] ;;
  \<^bold>c:a := f /\<^sub>R m"

subsubsection \<open> AMV System \<close>

abbreviation "AUV \<equiv> (LRE ;; AP ;; Dynamics)\<^sup>\<star>"

subsection \<open> Structural Properties \<close>

lemma LRE_nmods_cont: "LRE nmods \<^bold>c"
  apply (rule nmods_via_wp, simp_all add: wp usubst unrest, rel_auto)
  using OPMode.exhaust by blast

lemma AP_nmods_pos: "AP nmods &\<^bold>c:p"
  by (simp add: closure unrest)

lemma AP_nmods_vel: "AP nmods &\<^bold>c:v"
  by (simp add: closure unrest)

lemma AP_nmods_speed: "AP nmods &\<^bold>c:s"
  by (rule nmods_via_wp, simp_all add: wp usubst, rel_simp)

lemma AP_nmods_phi: "AP nmods &\<^bold>c:\<phi>"
  by (rule nmods_via_wp, simp_all add: wp usubst, rel_simp)

lemma "AP nmods &\<^bold>c:v"
  by (simp add: closure unrest)

lemma "LRE nmods &\<^bold>c:v"
   by (simp_all add: closure unrest)

lemma axAV_LRE_inv: "\<^bold>{ax\<^sub>A\<^sub>V\<^bold>}LRE\<^bold>{ax\<^sub>A\<^sub>V\<^bold>}"
  apply (rule nmods_invariant[of _ "\<^bold>c"])
   apply (rule nmods_via_wp, simp_all add: wp usubst unrest)
  apply (rel_simp)
  using OPMode.exhaust by auto

subsection \<open> Invariants \<close>

lemma time_pos:
"\<^bold>{&\<^bold>c:t \<ge> 0\<^bold>}
  ode dyn\<^sub>A\<^sub>V U(&\<^bold>c:a = 0 \<and> &\<^bold>c:v > 0)
 \<^bold>{&\<^bold>c:t \<ge> 0\<^bold>}"
  by dInduct

lemma "\<^bold>{&\<^bold>c:s = \<parallel>&\<^bold>c:v\<parallel>\<^bold>}ODE\<^bold>{&\<^bold>c:s = \<parallel>&\<^bold>c:v\<parallel>\<^bold>}"
  by (rule dWeakening, rel_simp')

lemma "\<^bold>{rs = &\<^bold>c:s \<and> rh = &\<^bold>c:\<phi>\<^bold>}AP\<^bold>{&\<^bold>c:a = 0\<^bold>}"
  by (hoare_auto)

lemma AP_no_accel: "\<^bold>{&\<^bold>c:s \<in> {rs - s\<^sub>\<epsilon>..rs + s\<^sub>\<epsilon>} \<and> rh = &\<^bold>c:\<phi>\<^bold>}AP\<^bold>{&\<^bold>c:a = 0\<^bold>}"
proof -
  have "\<^bold>{\<parallel>rs - &\<^bold>c:s\<parallel> \<le> s\<^sub>\<epsilon> \<and> rh = &\<^bold>c:\<phi>\<^bold>}AP\<^bold>{&\<^bold>c:a = 0\<^bold>}"
    by (hoare_auto)
  thus ?thesis
    apply (rule hoare_r_conseq)
    apply (rel_simp')
     apply (simp add: abs_diff_le_iff[THEN sym] abs_minus_commute)
    apply (rel_simp')
    done
qed

lemma "\<^bold>{rs < &\<^bold>c:s - s\<^sub>\<epsilon> \<and> rh = &\<^bold>c:\<phi>\<^bold>}AP\<^bold>{\<parallel>&\<^bold>c:a\<parallel> > 0\<^bold>}"
  using sin_zero_abs_cos_one by (hoare_auto, fastforce)

declare vec_simps [simp del]

lemma collinear_AP:
  "\<^bold>{&\<^bold>c:s \<ge> 0 \<and> rs \<ge> &\<^bold>c:s \<and> &\<^bold>c:v = &\<^bold>c:s *\<^sub>R \<^bold>[[sin(&\<^bold>c:\<phi>),cos(&\<^bold>c:\<phi>)]\<^bold>] \<and> \<parallel>rh - &\<^bold>c:\<phi>\<parallel> < \<phi>\<^sub>\<epsilon>\<^bold>}
   AP
   \<^bold>{&\<^bold>c:a \<bullet> &\<^bold>c:v = \<parallel>&\<^bold>c:a\<parallel> * \<parallel>&\<^bold>c:v\<parallel>\<^bold>}"
  by (hoare_auto)

declare vec_simps [simp]

text \<open> If the LRE is in MOM, the way point is in the north-east quadrant wrt. the AMV, and there
  are no nearby obstacles, then the LRE will stay in MOM and request maximum velocity and heading
  within the north-east quadrant. \<close>

lemma LRE_quad1_heading:
  "\<^bold>{mode = MOM \<and> w\<^sub>x > &\<^bold>c:p\<^sub>x \<and> w\<^sub>y > &\<^bold>c:p\<^sub>y \<and> (\<forall> o. o \<in> obsReg \<Rightarrow> \<parallel>&\<^bold>c:p - \<guillemotleft>o\<guillemotright>\<parallel> > 7.5)\<^bold>}
  LRE
  \<^bold>{mode = MOM \<and> rs = 1 \<and> rh \<in> {0<..<pi / 2}\<^bold>}"
  apply (hoare_auto)
   apply (rename_tac p w r)
   apply (case_tac p rule: vector_2_cases)
   apply (simp)
   apply (case_tac w rule: vector_2_cases)
   apply (simp)
   apply (auto simp add: vangle_def vec_norm)
  apply (rule cos_r1)
   apply (rename_tac x\<^sub>1 x\<^sub>2 x\<^sub>1' x\<^sub>2')
   apply (subgoal_tac "0 \<le> (100 * x\<^sub>2' - 100 * x\<^sub>2)")
  apply (subgoal_tac "0 \<le> (100 * sqrt ((x\<^sub>1' - x\<^sub>1)\<^sup>2 + (x\<^sub>2' - x\<^sub>2)\<^sup>2))")
  apply (smt divide_nonneg_nonneg mult_nonneg_nonneg norm_ge_zero vec_simps(2) vec_simps(4))
    apply (simp_all add: vec_simps)
  apply (subst divide_less_eq_1_pos)
  apply (simp_all)
  apply (simp add: sum_power2_gt_zero_iff)
  apply (smt sqrt_le_D zero_less_power)
   apply (rename_tac p w r)
   apply (case_tac p rule: vector_2_cases)
   apply (simp)
   apply (case_tac w rule: vector_2_cases)
   apply (simp)
   apply (auto simp add: vangle_def)
  apply (rule cos_r2)
    apply (simp_all add: vec_norm)
   apply (rename_tac x\<^sub>1 x\<^sub>2 x\<^sub>1' x\<^sub>2')
   apply (subgoal_tac "0 < (100 * x\<^sub>2' - 100 * x\<^sub>2)")
  apply (subgoal_tac "0 < (100 * sqrt ((x\<^sub>1' - x\<^sub>1)\<^sup>2 + (x\<^sub>2' - x\<^sub>2)\<^sup>2))")
  apply simp
  apply (simp add: power2_eq_square sum_squares_gt_zero_iff)
    apply (simp_all)
  apply (smt divide_le_eq_1_pos real_le_rsqrt zero_less_power)
  done

lemma "\<^bold>{mode = MOM \<and> (\<exists> o. o \<in> obsReg \<and> \<parallel>&\<^bold>c:p - \<guillemotleft>o\<guillemotright>\<parallel> \<le> 7.5) \<and>
        \<parallel>angOfVec(nextWP - &\<^bold>c:p) - &\<^bold>c:\<phi>\<parallel> < \<phi>\<^sub>\<epsilon>\<^bold>}
        LRE
       \<^bold>{mode = HCM \<and> rs = 0.1 \<and> \<parallel>rh - &\<^bold>c:\<phi>\<parallel> < \<phi>\<^sub>\<epsilon>\<^bold>}"
  by (hoare_auto)

lemma
  "\<^bold>{rs = &\<^bold>c:s \<and> &\<^bold>c:\<phi> = 0 \<and> rh = pi\<^bold>}
    AP
   \<^bold>{&\<^bold>c:a = \<^bold>[[kp\<^sub>g\<^sub>r * pi / m, 0]\<^bold>]\<^bold>}"
proof -
  have 1: "(kp\<^sub>g\<^sub>r * pi) < (1765197 / 20000)"
    by (approximation 20)
  show ?thesis
    using 1 apply (rel_simp, simp add: min_absorb1)
    using pi_gt3 by auto
qed

lemma [usubst]: "bounded_linear (get\<^bsub>x\<^esub>) \<Longrightarrow> \<langle>\<sigma>(old \<mapsto>\<^sub>s 0)\<rangle>\<^sub>s (x ;\<^sub>L old) = 0"
  apply (rel_simp)
  using linear_simps(3) by blast

lemma "\<^bold>{&\<^bold>c:t = 0 \<and> &\<^bold>c:v = &\<^bold>c:old:v\<^bold>}ODE\<^bold>{&\<^bold>c:v = &\<^bold>c:old:v + &\<^bold>c:t *\<^sub>R &\<^bold>c:a\<^bold>}"
proof -
  have 1: "\<^bold>{&\<^bold>c:v = &\<^bold>c:old:v + &\<^bold>c:t *\<^sub>R &\<^bold>c:a\<^bold>}ODE\<^bold>{&\<^bold>c:v = &\<^bold>c:old:v + &\<^bold>c:t *\<^sub>R &\<^bold>c:a\<^bold>}"
    by (dInduct, rel_simp)
  thus ?thesis
    by (rule hoare_r_conseq) (rel_simp'+)
qed

text \<open> If the AMV is accelerating in the same direction as the velocity, then it will continue
  to do so. \<close>

lemma collinear_vector_accel:
  "\<^bold>{&\<^bold>c:a \<bullet> &\<^bold>c:v = \<parallel>&\<^bold>c:a\<parallel> * \<parallel>&\<^bold>c:v\<parallel>\<^bold>}
    ODE
   \<^bold>{&\<^bold>c:a \<bullet> &\<^bold>c:v = \<parallel>&\<^bold>c:a\<parallel> * \<parallel>&\<^bold>c:v\<parallel>\<^bold>}"
proof -
  have "\<^bold>{&\<^bold>c:a \<bullet> &\<^bold>c:v \<ge> 0 \<and> (&\<^bold>c:a \<bullet> &\<^bold>c:v)\<^sup>2 = (&\<^bold>c:a \<bullet> &\<^bold>c:a) * (&\<^bold>c:v \<bullet> &\<^bold>c:v)\<^bold>}
        ODE
       \<^bold>{&\<^bold>c:a \<bullet> &\<^bold>c:v \<ge> 0 \<and> (&\<^bold>c:a \<bullet> &\<^bold>c:v)\<^sup>2 = (&\<^bold>c:a \<bullet> &\<^bold>c:a) * (&\<^bold>c:v \<bullet> &\<^bold>c:v)\<^bold>}"
    apply (rule dCut_split)
    apply (dInduct)
     apply (rel_simp)
    apply (dInduct)
     apply (rel_simp)
    using inner_commute by blast
  hence "\<^bold>{&\<^bold>c:a \<bullet> &\<^bold>c:v \<ge> 0 \<and> &\<^bold>c:a \<bullet> &\<^bold>c:v = \<parallel>&\<^bold>c:a\<parallel> * \<parallel>&\<^bold>c:v\<parallel>\<^bold>}
          ODE
         \<^bold>{&\<^bold>c:a \<bullet> &\<^bold>c:v \<ge> 0 \<and> &\<^bold>c:a \<bullet> &\<^bold>c:v = \<parallel>&\<^bold>c:a\<parallel> * \<parallel>&\<^bold>c:v\<parallel>\<^bold>}"
    apply (rule hoare_r_conseq)
    apply (rel_auto')
    apply (simp add: power2_norm_eq_inner power_mult_distrib)
    apply (smt norm_eq_square power2_norm_eq_inner real_sqrt_abs real_sqrt_mult)
    done

  thus ?thesis
    by (rule hoare_r_conseq) (rel_auto')
qed

text \<open> Collinearity of the acceleration and velocity implies no rotational velocity \<close>

lemma "`&\<^bold>c:a \<bullet> &\<^bold>c:v = \<parallel>&\<^bold>c:a\<parallel> * \<parallel>&\<^bold>c:v\<parallel> \<Rightarrow> \<omega> \<oplus>\<^sub>p \<^bold>c = 0`"
  apply (rel_simp)
  apply (drule sym)
  apply (simp add: algebra_simps)
  by (smt inner_gt_zero_iff mult_nonneg_nonneg norm_ge_zero)

lemma "\<^bold>{(&\<^bold>c:a \<bullet> &\<^bold>c:v = \<parallel>&\<^bold>c:a\<parallel> * \<parallel>&\<^bold>c:v\<parallel> \<and> &\<^bold>c:s = \<parallel>&\<^bold>c:v\<parallel>) \<and> &\<^bold>c:t \<ge> 0 \<and> &\<^bold>c:t < \<epsilon> \<and>
        &\<^bold>c:v = &\<^bold>c:t *\<^sub>R &\<^bold>c:a + &\<^bold>c:old:v \<and>
        &\<^bold>c:p = (&\<^bold>c:t\<^sup>2 * \<guillemotleft>0.5\<guillemotright>) *\<^sub>R &\<^bold>c:a + &\<^bold>c:t *\<^sub>R &\<^bold>c:old:v + &\<^bold>c:old:p\<^bold>}
        ODE
       \<^bold>{&\<^bold>c:t \<ge> 0 \<and> &\<^bold>c:t < \<epsilon> \<and>
        &\<^bold>c:v = &\<^bold>c:t *\<^sub>R &\<^bold>c:a + &\<^bold>c:old:v \<and>
        &\<^bold>c:p = (&\<^bold>c:t\<^sup>2 * \<guillemotleft>0.5\<guillemotright>) *\<^sub>R &\<^bold>c:a + &\<^bold>c:t *\<^sub>R &\<^bold>c:old:v + &\<^bold>c:old:p\<^bold>}"
  apply (rule dCut_split')
   apply (rule dCut_split)
    apply (fact collinear_vector_accel)
   apply (rule dWeakening, rel_simp')
   apply (rule dCut_split)
   apply (dInduct)
  apply (rule dCut_split)
   apply (rule dWeakening, rel_simp')
  apply (rule dCut_split)
  apply (dInduct)
   apply (rel_simp)
  apply (dInduct)
  apply (rel_simp)
  done

lemma "\<^bold>{&\<^bold>c:a = 0 \<and> &\<^bold>c:v = \<guillemotleft>V\<guillemotright>\<^bold>}ODE\<^bold>{&\<^bold>c:a = 0 \<and> &\<^bold>c:v = \<guillemotleft>V\<guillemotright>\<^bold>}"
  apply (rule dCut_split)
   apply (dInduct)
  apply (dInduct)
  apply (rel_simp)
  done

declare eq_divide_eq_numeral1 [simp del]

lemma [simp]: "sqrt (1/100) = 1/10"
  by (rule real_sqrt_unique, simp_all add: field_simps)

lemma [simp]: "sqrt (9 / 64) = 0.375"
  by (rule real_sqrt_unique, simp_all add: field_simps)

text \<open> If the AMV is on course then the calculate acceleration vector is always
  collinear with the velocity vector. \<close>

lemma "\<^bold>{&\<^bold>c:s \<ge> 0 \<and> rs > &\<^bold>c:s \<and> &\<^bold>c:\<phi> = pi / 2 \<and> rh = pi / 2
        \<and> &\<^bold>c:v = &\<^bold>c:s *\<^sub>R \<^bold>[[sin(&\<^bold>c:\<phi>),cos(&\<^bold>c:\<phi>)]\<^bold>]\<^bold>}
        AP
       \<^bold>{&\<^bold>c:a \<bullet> &\<^bold>c:v = \<parallel>&\<^bold>c:a\<parallel> * \<parallel>&\<^bold>c:v\<parallel>\<^bold>}"
  apply (hoare_auto)
  apply (rename_tac s rs)
  apply (simp add: vec_norm)
  done

declare vec_simps [simp del]

lemma vs1: "\<^bold>[[k * x, k * y]\<^bold>] = k *\<^sub>R \<^bold>[[x, y]\<^bold>]"
  by (simp add: vec_simps(1))

lemma "\<^bold>{&\<^bold>c:s \<ge> 0 \<and> rs > &\<^bold>c:s \<and> \<parallel>rh - &\<^bold>c:\<phi>\<parallel> < \<phi>\<^sub>\<epsilon>
        \<and> &\<^bold>c:v = &\<^bold>c:s *\<^sub>R \<^bold>[[sin(&\<^bold>c:\<phi>),cos(&\<^bold>c:\<phi>)]\<^bold>]\<^bold>}
        AP
       \<^bold>{&\<^bold>c:a \<bullet> &\<^bold>c:v = \<parallel>&\<^bold>c:a\<parallel> * \<parallel>&\<^bold>c:v\<parallel>\<^bold>}"
  by (hoare_auto)

text \<open> If the AMV is accelerating towards its orientation then the speed increases. \<close>

lemma
  "\<^bold>{(&\<^bold>c:a \<bullet> &\<^bold>c:v = \<parallel>&\<^bold>c:a\<parallel> * \<parallel>&\<^bold>c:v\<parallel> \<and> (&\<^bold>c:a \<bullet> &\<^bold>c:a) > 0) \<and> &\<^bold>c:s \<ge> &\<^bold>c:old:s\<^bold>}
    ODE
   \<^bold>{&\<^bold>c:s \<ge> &\<^bold>c:old:s\<^bold>}"
  apply (rule dCut_split')
  apply (rule dCut_split)
   apply (fact collinear_vector_accel)
   apply (dInduct)
   apply (rel_simp)
  apply (dInduct)
  apply (rel_simp)
  apply (simp add: inner_commute)
  done

lemma no_turn_no_accel:
"\<^bold>{&\<^bold>c:\<phi> = \<guillemotleft>X\<guillemotright>\<^bold>}
  ode dyn\<^sub>A\<^sub>V U(&\<^bold>c:a = 0 \<and> &\<^bold>c:v > 0)
 \<^bold>{&\<^bold>c:\<phi> = \<guillemotleft>X\<guillemotright>\<^bold>}"
  by (dInduct, rel_simp)

lemma no_turn_when_straight:
 "\<^bold>{&\<^bold>c:a \<bullet> &\<^bold>c:v = \<parallel>&\<^bold>c:a\<parallel> * \<parallel>&\<^bold>c:v\<parallel> \<and> &\<^bold>c:\<phi> = \<guillemotleft>X\<guillemotright>\<^bold>}
   ODE
  \<^bold>{&\<^bold>c:\<phi> = \<guillemotleft>X\<guillemotright>\<^bold>}"
  apply (rule dCut_split', fact collinear_vector_accel)
  apply (dInduct_auto)
  apply (smt norm_ge_zero)+
  done

text \<open> Link with CyPhyCircus. Differentiation on a domain. Unit vector d? DAEs via unknowns in ODE? \<close>

lemma [usubst]: "\<langle>\<sigma>(v \<mapsto>\<^sub>s &a)\<rangle>\<^sub>s v\<^sub>x = &a\<^sub>x"
  by (rel_simp)

lemma [usubst]: "\<langle>\<sigma>(v \<mapsto>\<^sub>s &a)\<rangle>\<^sub>s v\<^sub>y = &a\<^sub>y"
  by (rel_simp)

lemma translational_speed:
"\<^bold>{[&\<^bold>c:s\<^sup>2 =\<^sub>P (&\<^bold>c:v \<bullet> &\<^bold>c:v)]\<^sub>P\<^bold>}
  ode dyn\<^sub>A\<^sub>V U(&\<^bold>c:s \<noteq> 0)
 \<^bold>{[&\<^bold>c:s\<^sup>2 =\<^sub>P (&\<^bold>c:v \<bullet> &\<^bold>c:v)]\<^sub>P\<^bold>}"
  apply (dInduct)
  apply (rel_simp)
  apply (simp add: inner_commute)
  done

lemma translational_prop:
"\<^bold>{&\<^bold>c:s\<^sup>2 = (&\<^bold>c:v \<bullet> &\<^bold>c:v)\<^bold>}
  ode dyn\<^sub>A\<^sub>V U(&\<^bold>c:s > 0)
 \<^bold>{&\<^bold>c:s\<^sup>2 = (&\<^bold>c:v \<bullet> &\<^bold>c:v)\<^bold>}"
  by (dInduct, rel_simp, simp add: inner_commute)

lemma "`(&\<^bold>c:s > 0 \<and> [&\<^bold>c:s\<^sup>2 =\<^sub>P (&\<^bold>c:v \<bullet> &\<^bold>c:v)]\<^sub>P) \<Rightarrow> &\<^bold>c:s = \<parallel>&\<^bold>c:v\<parallel>`"
  apply (simp add: hyprop_pred_def)
  apply (rel_simp)
  by (metis less_eq_real_def norm_eq_square)

end


theory Auxiliary
  imports Main "HOL-Library.Extended_Nonnegative_Real"
begin

section \<open>Auxiliary Material\<close>

context
  fixes S :: "'s set"
  assumes "finite S"
begin

lemma Max_image_commute:
  "(MAX x \<in> S. MAX y \<in> S. f x y) = (MAX y \<in> S. MAX x \<in> S. f x y)"
proof (rule Max_eq_if, goal_cases)
  case 3
  { fix a assume "a \<in> S"
    with Max_in[OF finite_imageI[OF \<open>finite S\<close>], of "f a"] have "Max (f a ` S) \<in> f a ` S"
      by auto
    then obtain b where "f a b = Max (f a ` S)" "b \<in> S"
      by auto
    from \<open>a \<in> S\<close> have "f a b \<le> (MAX a \<in> S. f a b)"
      by (auto intro: Max_ge finite_imageI[OF \<open>finite S\<close>])
    with \<open>f a b = _\<close> \<open>b \<in> S\<close> have "\<exists>b\<in>S. Max (f a ` S) \<le> (MAX a \<in> S. f a b)"
      by auto
  }
  then show ?case
    by auto
next
  case 4
  { fix b assume "b \<in> S"
    with Max_in[OF finite_imageI[OF \<open>finite S\<close>], of "\<lambda> a. f a b"] have
      "(MAX a \<in> S. f a b) \<in> (\<lambda>a. f a b) ` S"
      by auto
    then obtain a where "f a b = (MAX a \<in> S. f a b)" "a \<in> S"
      by auto
    from \<open>b \<in> S\<close> have "f a b \<le> Max (f a ` S)"
      by (auto intro: Max_ge finite_imageI[OF \<open>finite S\<close>])
    with \<open>f a b = _\<close> \<open>a \<in> S\<close> have "\<exists>a\<in>S. (MAX a \<in> S. f a b) \<le> Max (f a ` S)"
      by auto
  }
    then show ?case
      by auto
  qed (use \<open>finite S\<close> in auto)

lemma Max_image_left_mult:
  "(MAX x \<in> S. c * f x) = (c :: ennreal) * (MAX x \<in> S. f x)" if "S \<noteq> {}"
  apply (rule Max_eqI)
  subgoal
    using \<open>finite S\<close> by auto
  subgoal for y
    using \<open>finite S\<close> by (auto intro: mult_left_mono)
  subgoal
    using Max_in[OF finite_imageI[OF \<open>finite S\<close>], of f] \<open>S \<noteq> {}\<close> by auto
  done

end (* Finite set *)

lemma Max_to_image:
  "Max {f t | t. t \<in> S} = Max (f ` S)"
  by (rule arg_cong[where f = Max]) auto

lemma Max_to_image2:
  "Max {f t | t. P t} = Max (f ` {t. P t})"
  by (rule arg_cong[where f = Max]) auto

lemma Max_image_cong:
  "Max (f ` S) = Max (g ` T)" if "S = T" "\<And>x. x \<in> T \<Longrightarrow> f x = g x"
  by (intro arg_cong[where f = Max] image_cong[OF that])

lemma Max_image_cong_simp:
  "Max (f ` S) = Max (g ` T)" if "S = T" "\<And>x. x \<in> T =simp=> f x = g x"
  using Max_image_cong[OF that[unfolded simp_implies_def]] .

lemma Max_eq_image_if:
  assumes
    "finite S" "finite T" "\<forall>x \<in> S. \<exists>y \<in> T. f x \<le> g y" "\<forall>x \<in> T. \<exists>y \<in> S. g x \<le> f y"
  shows "Max (f ` S) = Max (g ` T)"
  using assms by (auto intro: Max_eq_if)

theorem Max_in_image:
  assumes "finite A" and "A \<noteq> {}"
  obtains x where "x \<in> A" and "Max (f ` A) = f x"
proof -
  from Max_in[of "f ` A"] assms have "Max (f ` A) \<in> f ` A"
    by auto
  then show ?thesis
    by (auto intro: that)
qed

lemma Max_ge_image:
  "Max (f ` S) \<ge> f x" if "finite S" "x \<in> S"
  using that by (auto intro: Max_ge)

lemma Max_image_pair:
  assumes "finite S" "finite T" "T \<noteq> {}"
  shows "(MAX s \<in> S. MAX t \<in> T. f s t) = (MAX (s, t) \<in> S \<times> T. f s t)"
proof ((rule Max_eq_image_if; clarsimp?), goal_cases)
  case (3 x)
  from \<open>finite T\<close> \<open>T \<noteq> {}\<close> obtain y where "y \<in> T" and "Max (f x ` T) = f x y"
    by (rule Max_in_image)
  with \<open>x \<in> S\<close> show ?case
    by auto
next
  case (4 a b)
  with \<open>finite T\<close> show ?case
    by force
qed (use assms in auto)

fun argmax where
  "argmax f (x # xs) =
    List.fold (\<lambda> a (b, v). let w = f a in if w > v then (a, w) else (b, v)) xs (x, f x)"

lemma list_cases:
  assumes "xs = [] \<Longrightarrow> P []"
      and "\<And> x. xs = [x] \<Longrightarrow> P [x]"
      and "\<And> x y ys. xs = (x # y # ys) \<Longrightarrow> P (x # y # ys)"
    shows "P xs"
  apply (cases xs)
   apply (simp add: assms)
  subgoal for y ys
    by (cases ys; simp add: assms)
  done

lemma argmax:
  assumes "xs \<noteq> []"
  shows
    "fst (argmax f xs) \<in> set xs" (is "?A")
    "f (fst (argmax f xs)) = snd (argmax f xs)" (is "?B")
    "snd (argmax f xs) = (MAX x \<in> set xs. f x)" (is "?C")
proof -
  let ?f = "\<lambda> a (b, v). let w = f a in if w > v then (a, w) else (b, v)"
  have "fst (List.fold ?f xs (x, f x)) \<in> {x} \<union> set xs" if "xs \<noteq> []" for x xs
    using that by (induction xs arbitrary: x rule: list_nonempty_induct)(auto simp: Let_def max_def)
  with \<open>xs \<noteq> []\<close> show ?A
    by (cases xs rule: list_cases; fastforce)
  have "f (fst (List.fold ?f xs (x, f x))) = snd (List.fold ?f xs (x, f x))" if "xs \<noteq> []" for x xs
    using that by (induction xs arbitrary: x rule: list_nonempty_induct)(auto simp: Let_def max_def)
  with \<open>xs \<noteq> []\<close> show ?B
    by (cases xs rule: list_cases; fastforce)
  have "snd (List.fold ?f xs (x, f x)) = (MAX x \<in> {x} \<union> set xs. f x)"if "xs \<noteq> []" for x xs
    using that by (induction xs arbitrary: x rule: list_nonempty_induct)(auto simp: Let_def max_def)
  with \<open>xs \<noteq> []\<close> show ?C
    by (cases xs rule: list_cases; fastforce)
qed

end (* Theory *)


(* Title: Examples/SML_Relativization/Lattices/SML_Semilattices.thy
   Author: Mihails Milehins
   Copyright 2021 (C) Mihails Milehins
*)
section\<open>Relativization of the results about semilattices\<close>
theory SML_Semilattices
  imports
    "../Simple_Orders/SML_Simple_Orders"
    "../Algebra/SML_Monoids"
begin

subsection\<open>Commutative bands\<close>

subsubsection\<open>Definitions and common properties\<close>

locale semilattice_ow = abel_semigroup_ow U f
  for U :: "'al set" and f +
  assumes idem[simp]: "x \<in> U \<Longrightarrow> x \<^bold>*\<^sub>o\<^sub>w x = x"

locale semilattice_set_ow =
  semilattice_ow U f for U :: "'al set" and f (infixl \<open>\<^bold>*\<^sub>o\<^sub>w\<close> 70)

subsubsection\<open>Transfer rules\<close>

context
  includes lifting_syntax
begin

lemma semilattice_transfer[transfer_rule]:
  assumes [transfer_rule]: "bi_unique A" "right_total A"
  shows
    "((A ===> A ===> A) ===> (=))
      (\<lambda>f. semilattice_ow (Collect (Domainp A)) f) semilattice"
  unfolding
    semilattice_ow_def semilattice_def
    semilattice_ow_axioms_def semilattice_axioms_def
  apply transfer_prover_start
  apply transfer_step+
  by simp

lemma semilattice_set_transfer[transfer_rule]:
  assumes [transfer_rule]: "bi_unique A" "right_total A"
  shows
    "((A ===> A ===> A) ===> (=))
      (\<lambda>f. semilattice_set_ow (Collect (Domainp A)) f) semilattice_set"
  unfolding semilattice_set_ow_def semilattice_set_def by transfer_prover

end

subsubsection\<open>Relativization\<close>

context semilattice_ow
begin

tts_context
  tts: (?'a to U)
  substituting semilattice_ow_axioms
  eliminating through simp
begin

tts_lemma left_idem:
  assumes "a \<in> U" and "b \<in> U"
  shows "a \<^bold>*\<^sub>o\<^sub>w (a \<^bold>*\<^sub>o\<^sub>w b) = a \<^bold>*\<^sub>o\<^sub>w b"
    is semilattice.left_idem.

tts_lemma right_idem:
  assumes "a \<in> U" and "b \<in> U"
  shows "a \<^bold>*\<^sub>o\<^sub>w b \<^bold>*\<^sub>o\<^sub>w b = a \<^bold>*\<^sub>o\<^sub>w b"
    is semilattice.right_idem.

end

end

subsection\<open>Simple upper and lower semilattices\<close>

subsubsection\<open>Definitions and common properties\<close>

locale semilattice_order_ow = semilattice_ow U f
  for U :: "'al set" and f  +
  fixes le :: "['al, 'al] \<Rightarrow> bool" (infix \<open>\<le>\<^sub>o\<^sub>w\<close> 50)
    and ls :: "['al, 'al] \<Rightarrow> bool" (infix \<open><\<^sub>o\<^sub>w\<close> 50)
  assumes order_iff: "\<lbrakk> a \<in> U; b \<in> U \<rbrakk> \<Longrightarrow> a \<le>\<^sub>o\<^sub>w b \<longleftrightarrow> a = a \<^bold>*\<^sub>o\<^sub>w b"
    and strict_order_iff: "\<lbrakk> a \<in> U; b \<in> U \<rbrakk> \<Longrightarrow> a <\<^sub>o\<^sub>w b \<longleftrightarrow> a = a \<^bold>*\<^sub>o\<^sub>w b \<and> a \<noteq> b"
begin

sublocale ordering_ow U \<open>(\<le>\<^sub>o\<^sub>w)\<close> \<open>(<\<^sub>o\<^sub>w)\<close>
proof
  show "\<lbrakk>a \<in> U; b \<in> U\<rbrakk> \<Longrightarrow> (a <\<^sub>o\<^sub>w b) = (a \<le>\<^sub>o\<^sub>w b \<and> a \<noteq> b)" for a b
    apply standard
    subgoal by (auto simp: commute order_iff strict_order_iff)
    subgoal by (auto simp: order_iff strict_order_iff)
    done
  show "x \<in> U \<Longrightarrow> x \<le>\<^sub>o\<^sub>w x" for x by (simp add: order_iff)
  show "\<lbrakk> x \<in> U; y \<in> U; z \<in> U; x \<le>\<^sub>o\<^sub>w y; y \<le>\<^sub>o\<^sub>w z \<rbrakk> \<Longrightarrow> x \<le>\<^sub>o\<^sub>w z" for x y z
  proof-
    assume "x \<in> U" and "y \<in> U" and "z \<in> U" and "x \<le>\<^sub>o\<^sub>w y" and "y \<le>\<^sub>o\<^sub>w z"
    note xy = order_iff[THEN iffD1, OF \<open>x \<in> U\<close> \<open>y \<in> U\<close> \<open>x \<le>\<^sub>o\<^sub>w y\<close>]
    note yz = order_iff[THEN iffD1, OF \<open>y \<in> U\<close> \<open>z \<in> U\<close> \<open>y \<le>\<^sub>o\<^sub>w z\<close>]
    note xz = assoc[OF \<open>x \<in> U\<close> \<open>y \<in> U\<close> \<open>z \<in> U\<close>, folded xy yz, symmetric]
    show ?thesis by (rule order_iff[THEN iffD2, OF \<open>x \<in> U\<close> \<open>z \<in> U\<close> xz])
  qed
  show "\<lbrakk> x \<in> U; y \<in> U; x \<le>\<^sub>o\<^sub>w y; y \<le>\<^sub>o\<^sub>w x \<rbrakk> \<Longrightarrow> x = y" for x y
    by (fastforce simp: commute order_iff)
qed

notation le (infix "\<le>\<^sub>o\<^sub>w" 50)
  and ls (infix "<\<^sub>o\<^sub>w" 50)

end

locale semilattice_order_set_ow =
  semilattice_order_ow U f le ls + semilattice_set_ow U f
  for U :: "'al set" and f le ls

locale inf_ow =
  fixes U :: "'al set" and inf (infixl \<open>\<sqinter>\<^sub>o\<^sub>w\<close> 70)
  assumes inf_closed[simp]: "\<lbrakk> x \<in> U; y \<in> U \<rbrakk> \<Longrightarrow> x \<sqinter>\<^sub>o\<^sub>w y \<in> U"
begin

notation inf (infixl \<open>\<sqinter>\<^sub>o\<^sub>w\<close> 70)

lemma inf_closed'[simp]: "\<forall>x\<in>U. \<forall>y\<in>U. x \<sqinter>\<^sub>o\<^sub>w y \<in> U" by simp

end

locale inf_pair_ow = inf\<^sub>1: inf_ow U\<^sub>1 inf\<^sub>1 + inf\<^sub>2: inf_ow U\<^sub>2 inf\<^sub>2
  for U\<^sub>1 :: "'al set" and inf\<^sub>1
    and U\<^sub>2 :: "'bl set" and inf\<^sub>2
begin

notation inf\<^sub>1 (infixl \<open>\<sqinter>\<^sub>o\<^sub>w\<^sub>.\<^sub>1\<close> 70)
notation inf\<^sub>2 (infixl \<open>\<sqinter>\<^sub>o\<^sub>w\<^sub>.\<^sub>2\<close> 70)

end

locale semilattice_inf_ow = inf_ow U inf + order_ow U le ls
  for U :: "'al set" and inf le ls  +
  assumes inf_le1[simp]: "\<lbrakk> x \<in> U; y \<in> U \<rbrakk> \<Longrightarrow> x \<sqinter>\<^sub>o\<^sub>w y \<le>\<^sub>o\<^sub>w x"
    and inf_le2[simp]: "\<lbrakk> x \<in> U; y \<in> U \<rbrakk> \<Longrightarrow> x \<sqinter>\<^sub>o\<^sub>w y \<le>\<^sub>o\<^sub>w y"
    and inf_greatest:
      "\<lbrakk> x \<in> U; y \<in> U; z \<in> U; x \<le>\<^sub>o\<^sub>w y; x \<le>\<^sub>o\<^sub>w z \<rbrakk> \<Longrightarrow> x \<le>\<^sub>o\<^sub>w y \<sqinter>\<^sub>o\<^sub>w z"
begin

sublocale inf: semilattice_order_ow U \<open>(\<sqinter>\<^sub>o\<^sub>w)\<close> \<open>(\<le>\<^sub>o\<^sub>w)\<close> \<open>(<\<^sub>o\<^sub>w)\<close>
proof

  show *: "\<lbrakk> a \<in> U; b \<in> U \<rbrakk> \<Longrightarrow> a \<sqinter>\<^sub>o\<^sub>w b \<in> U" for a b by simp

  show **: "\<lbrakk> a \<in> U; b \<in> U; c \<in> U \<rbrakk> \<Longrightarrow> a \<sqinter>\<^sub>o\<^sub>w b \<sqinter>\<^sub>o\<^sub>w c = a \<sqinter>\<^sub>o\<^sub>w (b \<sqinter>\<^sub>o\<^sub>w c)"
    for a b c
  proof -

    assume "a \<in> U" and "b \<in> U" and "c \<in> U"
    from \<open>a \<in> U\<close> \<open>b \<in> U\<close> \<open>c \<in> U\<close> have ab_c: "a \<sqinter>\<^sub>o\<^sub>w b \<sqinter>\<^sub>o\<^sub>w c \<in> U" by simp
    from \<open>a \<in> U\<close> \<open>b \<in> U\<close> \<open>c \<in> U\<close> have a_bc: "a \<sqinter>\<^sub>o\<^sub>w (b \<sqinter>\<^sub>o\<^sub>w c) \<in> U" by simp

    from \<open>a \<in> U\<close> \<open>b \<in> U\<close> \<open>c \<in> U\<close> have "a \<sqinter>\<^sub>o\<^sub>w b \<sqinter>\<^sub>o\<^sub>w c \<le>\<^sub>o\<^sub>w b"
      by (meson * inf_le1 inf_le2 order_trans)
    moreover from \<open>a \<in> U\<close> \<open>b \<in> U\<close> \<open>c \<in> U\<close> have "a \<sqinter>\<^sub>o\<^sub>w b \<sqinter>\<^sub>o\<^sub>w c \<le>\<^sub>o\<^sub>w c" by simp
    ultimately have abc_le_bc: "a \<sqinter>\<^sub>o\<^sub>w b \<sqinter>\<^sub>o\<^sub>w c \<le>\<^sub>o\<^sub>w b \<sqinter>\<^sub>o\<^sub>w c"
      by (rule inf_greatest[OF ab_c \<open>b \<in> U\<close> \<open>c \<in> U\<close>])
    from \<open>a \<in> U\<close> \<open>b \<in> U\<close> \<open>c \<in> U\<close> have abc_le_a: "a \<sqinter>\<^sub>o\<^sub>w b \<sqinter>\<^sub>o\<^sub>w c \<le>\<^sub>o\<^sub>w a"
      by (meson inf_le1 order_trans inf_closed)
    note lhs =
      inf_greatest[OF ab_c \<open>a \<in> U\<close> *[OF \<open>b \<in> U\<close> \<open>c \<in> U\<close>] abc_le_a abc_le_bc]

    from \<open>a \<in> U\<close> \<open>b \<in> U\<close> \<open>c \<in> U\<close> have "a \<sqinter>\<^sub>o\<^sub>w (b \<sqinter>\<^sub>o\<^sub>w c) \<le>\<^sub>o\<^sub>w a"
      by (meson * inf_le1 order_trans)
    moreover from \<open>a \<in> U\<close> \<open>b \<in> U\<close> \<open>c \<in> U\<close> have "a \<sqinter>\<^sub>o\<^sub>w (b \<sqinter>\<^sub>o\<^sub>w c) \<le>\<^sub>o\<^sub>w b"
      by (meson * inf_le1 inf_le2 order_trans)
    ultimately have abc_le_bc: "a \<sqinter>\<^sub>o\<^sub>w (b \<sqinter>\<^sub>o\<^sub>w c) \<le>\<^sub>o\<^sub>w a \<sqinter>\<^sub>o\<^sub>w b"
      by (rule inf_greatest[OF a_bc \<open>a \<in> U\<close> \<open>b \<in> U\<close>])
    from \<open>a \<in> U\<close> \<open>b \<in> U\<close> \<open>c \<in> U\<close> have abc_le_a: "a \<sqinter>\<^sub>o\<^sub>w (b \<sqinter>\<^sub>o\<^sub>w c) \<le>\<^sub>o\<^sub>w c"
      by (meson inf_le2 order_trans inf_closed)
    note rhs =
      inf_greatest[OF a_bc *[OF \<open>a \<in> U\<close> \<open>b \<in> U\<close>] \<open>c \<in> U\<close> abc_le_bc abc_le_a]
    show "a \<sqinter>\<^sub>o\<^sub>w b \<sqinter>\<^sub>o\<^sub>w c = a \<sqinter>\<^sub>o\<^sub>w (b \<sqinter>\<^sub>o\<^sub>w c)"
      by (rule antisym[OF ab_c a_bc lhs rhs])

  qed

  show ***: "\<lbrakk> a \<in> U; b \<in> U \<rbrakk> \<Longrightarrow> a \<sqinter>\<^sub>o\<^sub>w b = b \<sqinter>\<^sub>o\<^sub>w a" for a b
    by (simp add: inf_greatest xt1(5))

  show ****: "x \<in> U \<Longrightarrow> x \<sqinter>\<^sub>o\<^sub>w x = x" for x
  proof-
    assume "x \<in> U"
    have "x \<sqinter>\<^sub>o\<^sub>w x \<le>\<^sub>o\<^sub>w x" by (simp add: \<open>x \<in> U\<close>)
    moreover have "x \<le>\<^sub>o\<^sub>w x \<sqinter>\<^sub>o\<^sub>w x" by (simp add: \<open>x \<in> U\<close> inf_greatest)
    ultimately show "x \<sqinter>\<^sub>o\<^sub>w x = x" by (simp add: \<open>x \<in> U\<close> antisym)
  qed

  show *****: "\<lbrakk> a \<in> U; b \<in> U \<rbrakk> \<Longrightarrow> (a \<le>\<^sub>o\<^sub>w b) = (a = a \<sqinter>\<^sub>o\<^sub>w b)" for a b
    by (metis * *** inf_greatest inf_le2 order.eq_iff)

  show "\<lbrakk> a \<in> U; b \<in> U \<rbrakk> \<Longrightarrow> (a <\<^sub>o\<^sub>w b) = (a = a \<sqinter>\<^sub>o\<^sub>w b \<and> a \<noteq> b)" for a b
    by (simp add: ***** less_le)

qed

sublocale Inf_fin: semilattice_order_set_ow U \<open>(\<sqinter>\<^sub>o\<^sub>w)\<close> \<open>(\<le>\<^sub>o\<^sub>w)\<close> \<open>(<\<^sub>o\<^sub>w)\<close> ..

end

locale semilattice_inf_pair_ow =
  sl_inf\<^sub>1: semilattice_inf_ow U\<^sub>1 inf\<^sub>1 le\<^sub>1 ls\<^sub>1 +
  sl_inf\<^sub>2: semilattice_inf_ow U\<^sub>2 inf\<^sub>2 le\<^sub>2 ls\<^sub>2
  for U\<^sub>1 :: "'al set" and inf\<^sub>1 le\<^sub>1 ls\<^sub>1
    and U\<^sub>2 :: "'bl set" and inf\<^sub>2 le\<^sub>2 ls\<^sub>2
begin

sublocale inf_pair_ow ..
sublocale order_pair_ow ..

end

locale sup_ow =
  fixes U :: "'ao set" and sup :: "['ao, 'ao] \<Rightarrow> 'ao" (infixl \<open>\<squnion>\<^sub>o\<^sub>w\<close> 70)
  assumes sup_closed[simp]: "\<lbrakk> x \<in> U; y \<in> U \<rbrakk> \<Longrightarrow> sup x y \<in> U"
begin

notation sup (infixl \<open>\<squnion>\<^sub>o\<^sub>w\<close> 70)

lemma sup_closed'[simp]: "\<forall>x\<in>U. \<forall>y\<in>U. x \<squnion>\<^sub>o\<^sub>w y \<in> U" by simp

end

locale sup_pair_ow = sup\<^sub>1: sup_ow U\<^sub>1 sup\<^sub>1 + sup\<^sub>2: sup_ow U\<^sub>2 sup\<^sub>2
  for U\<^sub>1 :: "'al set" and sup\<^sub>1
    and U\<^sub>2 :: "'bl set" and sup\<^sub>2
begin

notation sup\<^sub>1 (infixl \<open>\<squnion>\<^sub>o\<^sub>w\<^sub>.\<^sub>1\<close> 70)
notation sup\<^sub>2 (infixl \<open>\<squnion>\<^sub>o\<^sub>w\<^sub>.\<^sub>2\<close> 70)

end

locale semilattice_sup_ow = sup_ow U sup + order_ow U le ls
  for U :: "'al set" and sup le ls +
  assumes sup_ge1[simp]: "\<lbrakk> x \<in> U; y \<in> U \<rbrakk> \<Longrightarrow> x \<le>\<^sub>o\<^sub>w x \<squnion>\<^sub>o\<^sub>w y"
    and sup_ge2[simp]: "\<lbrakk> y \<in> U; x \<in> U \<rbrakk> \<Longrightarrow> y \<le>\<^sub>o\<^sub>w x \<squnion>\<^sub>o\<^sub>w y"
    and sup_least:
      "\<lbrakk> y \<in> U; x \<in> U; z \<in> U; y \<le>\<^sub>o\<^sub>w x; z \<le>\<^sub>o\<^sub>w x \<rbrakk> \<Longrightarrow> y \<squnion>\<^sub>o\<^sub>w z \<le>\<^sub>o\<^sub>w x"
begin

sublocale sup: semilattice_order_ow U \<open>(\<squnion>\<^sub>o\<^sub>w)\<close> \<open>(\<ge>\<^sub>o\<^sub>w)\<close> \<open>(>\<^sub>o\<^sub>w)\<close>
proof

  show *: "\<lbrakk> a \<in> U; b \<in> U \<rbrakk> \<Longrightarrow> a \<squnion>\<^sub>o\<^sub>w b \<in> U" for a b by simp

  show **:
    "\<lbrakk> a \<in> U; b \<in> U; c \<in> U \<rbrakk> \<Longrightarrow> a \<squnion>\<^sub>o\<^sub>w b \<squnion>\<^sub>o\<^sub>w c = a \<squnion>\<^sub>o\<^sub>w (b \<squnion>\<^sub>o\<^sub>w c)" for a b c
  proof -

    assume "a \<in> U" and "b \<in> U" and "c \<in> U"
    from \<open>a \<in> U\<close> \<open>b \<in> U\<close> \<open>c \<in> U\<close> have ab_c: "a \<squnion>\<^sub>o\<^sub>w b \<squnion>\<^sub>o\<^sub>w c \<in> U" by simp
    from \<open>a \<in> U\<close> \<open>b \<in> U\<close> \<open>c \<in> U\<close> have a_bc: "a \<squnion>\<^sub>o\<^sub>w (b \<squnion>\<^sub>o\<^sub>w c) \<in> U" by simp

    from \<open>a \<in> U\<close> \<open>b \<in> U\<close> \<open>c \<in> U\<close> have "b \<le>\<^sub>o\<^sub>w a \<squnion>\<^sub>o\<^sub>w b \<squnion>\<^sub>o\<^sub>w c"
      by (meson order_trans sup_ge1 sup_ge2 sup_closed')
    moreover from \<open>a \<in> U\<close> \<open>b \<in> U\<close> \<open>c \<in> U\<close> have "c \<le>\<^sub>o\<^sub>w a \<squnion>\<^sub>o\<^sub>w b \<squnion>\<^sub>o\<^sub>w c" by simp
    ultimately have ab_le_abc: "b \<squnion>\<^sub>o\<^sub>w c \<le>\<^sub>o\<^sub>w a \<squnion>\<^sub>o\<^sub>w b \<squnion>\<^sub>o\<^sub>w c"
      by (rule sup_least[OF \<open>b \<in> U\<close> ab_c \<open>c \<in> U\<close>])
    from \<open>a \<in> U\<close> \<open>b \<in> U\<close> \<open>c \<in> U\<close> have a_le_abc: "a \<le>\<^sub>o\<^sub>w a \<squnion>\<^sub>o\<^sub>w b \<squnion>\<^sub>o\<^sub>w c"
      by (meson "*" order_trans sup_ge1)
    note rhs =
      sup_least[OF \<open>a \<in> U\<close> ab_c *[OF \<open>b \<in> U\<close> \<open>c \<in> U\<close>] a_le_abc ab_le_abc]

    from \<open>a \<in> U\<close> \<open>b \<in> U\<close> \<open>c \<in> U\<close> have "a \<le>\<^sub>o\<^sub>w a \<squnion>\<^sub>o\<^sub>w (b \<squnion>\<^sub>o\<^sub>w c)" by simp
    moreover from \<open>a \<in> U\<close> \<open>b \<in> U\<close> \<open>c \<in> U\<close> have "b \<le>\<^sub>o\<^sub>w a \<squnion>\<^sub>o\<^sub>w (b \<squnion>\<^sub>o\<^sub>w c)"
      by (meson order_trans sup_ge1 sup_ge2 sup_closed')
    ultimately have ab_le_abc: "a \<squnion>\<^sub>o\<^sub>w b \<le>\<^sub>o\<^sub>w a \<squnion>\<^sub>o\<^sub>w (b \<squnion>\<^sub>o\<^sub>w c)"
      by (rule sup_least[OF \<open>a \<in> U\<close> a_bc \<open>b \<in> U\<close>])
    from \<open>a \<in> U\<close> \<open>b \<in> U\<close> \<open>c \<in> U\<close> have c_le_abc: "c \<le>\<^sub>o\<^sub>w a \<squnion>\<^sub>o\<^sub>w (b \<squnion>\<^sub>o\<^sub>w c)"
      by (meson "*" order_trans sup_ge2)
    note lhs =
      sup_least[OF *[OF \<open>a \<in> U\<close> \<open>b \<in> U\<close>] a_bc \<open>c \<in> U\<close> ab_le_abc c_le_abc]
    show "a \<squnion>\<^sub>o\<^sub>w b \<squnion>\<^sub>o\<^sub>w c = a \<squnion>\<^sub>o\<^sub>w (b \<squnion>\<^sub>o\<^sub>w c)"
      by (rule antisym[OF ab_c a_bc lhs rhs])

  qed

  show ***: "\<lbrakk> a \<in> U; b \<in> U \<rbrakk> \<Longrightarrow> a \<squnion>\<^sub>o\<^sub>w b = b \<squnion>\<^sub>o\<^sub>w a" for a b
    by (simp add: antisym sup_least)

  show ****: "x \<in> U \<Longrightarrow> x \<squnion>\<^sub>o\<^sub>w x = x" for x
  proof-
    assume "x \<in> U"
    have "x \<le>\<^sub>o\<^sub>w x \<squnion>\<^sub>o\<^sub>w x" by (simp add: \<open>x \<in> U\<close>)
    moreover have "x \<squnion>\<^sub>o\<^sub>w x \<le>\<^sub>o\<^sub>w x" by (simp add: \<open>x \<in> U\<close> sup_least)
    ultimately show "x \<squnion>\<^sub>o\<^sub>w x = x" by (simp add: \<open>x \<in> U\<close> antisym)
  qed

  show *****: "\<lbrakk> a \<in> U; b \<in> U \<rbrakk> \<Longrightarrow> (a \<ge>\<^sub>o\<^sub>w b) = (a = a \<squnion>\<^sub>o\<^sub>w b)" for a b
    by (metis *** order.eq_iff sup_ge2 sup_least sup_closed)

  show "\<lbrakk> a \<in> U; b \<in> U \<rbrakk> \<Longrightarrow> (a >\<^sub>o\<^sub>w b) = (a = a \<squnion>\<^sub>o\<^sub>w b \<and> a \<noteq> b)" for a b
    by (auto simp: ***** less_le)

qed

sublocale Sup_fin: semilattice_order_set_ow U sup "(\<ge>\<^sub>o\<^sub>w)" "(>\<^sub>o\<^sub>w)" ..

end

locale semilattice_sup_pair_ow =
  sl_sup\<^sub>1: semilattice_sup_ow U\<^sub>1 sup\<^sub>1 le\<^sub>1 ls\<^sub>1 +
  sl_sup\<^sub>2: semilattice_sup_ow U\<^sub>2 sup\<^sub>2 le\<^sub>2 ls\<^sub>2
  for U\<^sub>1 :: "'al set" and sup\<^sub>1 le\<^sub>1 ls\<^sub>1
    and U\<^sub>2 :: "'bl set" and sup\<^sub>2 le\<^sub>2 ls\<^sub>2
begin

sublocale sup_pair_ow ..
sublocale order_pair_ow ..

end

subsubsection\<open>Transfer rules\<close>

context
  includes lifting_syntax
begin

lemma semilattice_order_transfer[transfer_rule]:
  assumes [transfer_rule]: "bi_unique A" "right_total A"
  shows
    "(
      (A ===> A ===> A) ===>
      (A ===> A ===> (=)) ===>
      (A ===> A ===> (=)) ===>
      (=)
    ) (semilattice_order_ow (Collect (Domainp A))) semilattice_order"
  unfolding
    semilattice_order_ow_def semilattice_order_def
    semilattice_order_ow_axioms_def semilattice_order_axioms_def
  apply transfer_prover_start
  apply transfer_step+
  by simp

lemma semilattice_order_set_transfer[transfer_rule]:
  assumes [transfer_rule]: "bi_unique A" "right_total A"
  shows
    "(
      (A ===> A ===> A) ===>
      (A ===> A ===> (=)) ===>
      (A ===> A ===> (=)) ===>
      (=)
    ) (semilattice_order_set_ow (Collect (Domainp A))) semilattice_order_set"
  unfolding semilattice_order_set_ow_def semilattice_order_set_def
  apply transfer_prover_start
  apply transfer_step+
  by simp

lemma semilattice_inf_transfer[transfer_rule]:
  assumes [transfer_rule]: "bi_unique A" "right_total A"
  shows
    "(
      (A ===> A ===> A) ===>
      (A ===> A ===> (=)) ===>
      (A ===> A ===> (=)) ===>
      (=)
    ) (semilattice_inf_ow (Collect (Domainp A))) class.semilattice_inf"
proof -
  let ?P =
    "(
      (A ===> A ===> A) ===>
      (A ===> A ===> (=)) ===>
      (A ===> A ===> (=)) ===>
      (=)
    )"
  let ?semilattice_ow = "semilattice_inf_ow (Collect (Domainp A))"
  let ?rf_UNIV =
    "(\<lambda>inf::['b, 'b] \<Rightarrow> 'b. (\<forall>x y. x \<in> UNIV \<longrightarrow> y \<in> UNIV \<longrightarrow> inf x y \<in> UNIV))"
  have
    "?P
    ?semilattice_ow
    (\<lambda>inf le ls. ?rf_UNIV inf \<and> class.semilattice_inf inf le ls)"
    unfolding
      class.semilattice_inf_def semilattice_inf_ow_def
      class.semilattice_inf_axioms_def semilattice_inf_ow_axioms_def
      inf_ow_def
    apply transfer_prover_start
    apply transfer_step+
    unfolding Ball_def by fastforce
  then show ?thesis by simp
qed

lemma semilattice_sup_transfer[transfer_rule]:
  assumes [transfer_rule]: "bi_unique A" "right_total A"
  shows
    "(
      (A ===> A ===> A) ===>
      (A ===> A ===> (=)) ===>
      (A ===> A ===> (=)) ===>
      (=)
    ) (semilattice_sup_ow (Collect (Domainp A))) class.semilattice_sup"
proof -
  let ?P =
    "(
      (A ===> A ===> A) ===>
      (A ===> A ===> (=)) ===>
      (A ===> A ===> (=)) ===>
      (=)
    )"
  let ?semilattice_ow = "semilattice_sup_ow (Collect (Domainp A))"
  let ?rf_UNIV =
    "(\<lambda>sup::['b, 'b] \<Rightarrow> 'b. (\<forall>x y. x \<in> UNIV \<longrightarrow> y \<in> UNIV \<longrightarrow> sup x y \<in> UNIV))"
  have
    "?P
    ?semilattice_ow
    (\<lambda>sup le ls. ?rf_UNIV sup \<and> class.semilattice_sup sup le ls)"
  unfolding
    class.semilattice_sup_def semilattice_sup_ow_def
    class.semilattice_sup_axioms_def semilattice_sup_ow_axioms_def
    sup_ow_def
  apply transfer_prover_start
  apply transfer_step+
  unfolding Ball_def by fastforce
  then show ?thesis by simp
qed

end

subsubsection\<open>Relativization\<close>

context semilattice_order_ow
begin

tts_context
  tts: (?'a to U)
  rewriting ctr_simps
  substituting semilattice_order_ow_axioms
  eliminating through simp
begin

tts_lemma cobounded1:
  assumes "a \<in> U" and "b \<in> U"
  shows "a \<^bold>*\<^sub>o\<^sub>w b \<le>\<^sub>o\<^sub>w a"
    is semilattice_order.cobounded1.

tts_lemma cobounded2:
  assumes "a \<in> U" and "b \<in> U"
  shows "a \<^bold>*\<^sub>o\<^sub>w b \<le>\<^sub>o\<^sub>w b"
    is semilattice_order.cobounded2.

tts_lemma absorb_iff1:
  assumes "a \<in> U" and "b \<in> U"
  shows "(a \<le>\<^sub>o\<^sub>w b) = (a \<^bold>*\<^sub>o\<^sub>w b = a)"
    is semilattice_order.absorb_iff1.

tts_lemma absorb_iff2:
  assumes "b \<in> U" and "a \<in> U"
  shows "(b \<le>\<^sub>o\<^sub>w a) = (a \<^bold>*\<^sub>o\<^sub>w b = b)"
    is semilattice_order.absorb_iff2.

tts_lemma strict_coboundedI1:
  assumes "a \<in> U" and "c \<in> U" and "b \<in> U" and "a <\<^sub>o\<^sub>w c"
  shows "a \<^bold>*\<^sub>o\<^sub>w b <\<^sub>o\<^sub>w c"
    is semilattice_order.strict_coboundedI1.

tts_lemma strict_coboundedI2:
  assumes "b \<in> U" and "c \<in> U" and "a \<in> U" and "b <\<^sub>o\<^sub>w c"
  shows "a \<^bold>*\<^sub>o\<^sub>w b <\<^sub>o\<^sub>w c"
    is semilattice_order.strict_coboundedI2.

tts_lemma absorb1:
  assumes "a \<in> U" and "b \<in> U" and "a \<le>\<^sub>o\<^sub>w b"
  shows "a \<^bold>*\<^sub>o\<^sub>w b = a"
    is semilattice_order.absorb1.

tts_lemma coboundedI1:
  assumes "a \<in> U" and "c \<in> U" and "b \<in> U" and "a \<le>\<^sub>o\<^sub>w c"
  shows "a \<^bold>*\<^sub>o\<^sub>w b \<le>\<^sub>o\<^sub>w c"
    is semilattice_order.coboundedI1.

tts_lemma absorb2:
  assumes "b \<in> U" and "a \<in> U" and "b \<le>\<^sub>o\<^sub>w a"
  shows "a \<^bold>*\<^sub>o\<^sub>w b = b"
    is semilattice_order.absorb2.

tts_lemma coboundedI2:
  assumes "b \<in> U" and "c \<in> U" and "a \<in> U" and "b \<le>\<^sub>o\<^sub>w c"
  shows "a \<^bold>*\<^sub>o\<^sub>w b \<le>\<^sub>o\<^sub>w c"
    is semilattice_order.coboundedI2.

tts_lemma orderI:
  assumes "a \<in> U" and "b \<in> U" and "a = a \<^bold>*\<^sub>o\<^sub>w b"
  shows "a \<le>\<^sub>o\<^sub>w b"
    is semilattice_order.orderI.

tts_lemma bounded_iff:
  assumes "a \<in> U" and "b \<in> U" and "c \<in> U"
  shows "(a \<le>\<^sub>o\<^sub>w b \<^bold>*\<^sub>o\<^sub>w c) = (a \<le>\<^sub>o\<^sub>w b \<and> a \<le>\<^sub>o\<^sub>w c)"
    is semilattice_order.bounded_iff.

tts_lemma boundedI:
  assumes "a \<in> U" and "b \<in> U" and "c \<in> U" and "a \<le>\<^sub>o\<^sub>w b" and "a \<le>\<^sub>o\<^sub>w c"
  shows "a \<le>\<^sub>o\<^sub>w b \<^bold>*\<^sub>o\<^sub>w c"
    is semilattice_order.boundedI.

tts_lemma orderE:
  assumes "a \<in> U" and "b \<in> U"  and "a \<le>\<^sub>o\<^sub>w b" and "a = a \<^bold>*\<^sub>o\<^sub>w b \<Longrightarrow> thesis"
  shows thesis
    is semilattice_order.orderE.

tts_lemma mono:
  assumes "a \<in> U"
    and "c \<in> U"
    and "b \<in> U"
    and "d \<in> U"
    and "a \<le>\<^sub>o\<^sub>w c"
    and "b \<le>\<^sub>o\<^sub>w d"
  shows "a \<^bold>*\<^sub>o\<^sub>w b \<le>\<^sub>o\<^sub>w c \<^bold>*\<^sub>o\<^sub>w d"
    is semilattice_order.mono.

tts_lemma strict_boundedE:
  assumes "a \<in> U"
    and "b \<in> U"
    and "c \<in> U"
    and "a <\<^sub>o\<^sub>w b \<^bold>*\<^sub>o\<^sub>w c"
  obtains "a <\<^sub>o\<^sub>w b" and "a <\<^sub>o\<^sub>w c"
    given semilattice_order.strict_boundedE by auto

tts_lemma boundedE:
  assumes "a \<in> U"
    and "b \<in> U"
    and "c \<in> U"
    and "a \<le>\<^sub>o\<^sub>w b \<^bold>*\<^sub>o\<^sub>w c"
  obtains "a \<le>\<^sub>o\<^sub>w b" and "a \<le>\<^sub>o\<^sub>w c"
    given semilattice_order.boundedE by auto

end

end

context semilattice_inf_ow
begin

tts_context
  tts: (?'a to U)
  rewriting ctr_simps
  substituting semilattice_inf_ow_axioms
  eliminating through simp
begin

tts_lemma le_iff_inf:
  assumes "x \<in> U" and "y \<in> U"
  shows "(x \<le>\<^sub>o\<^sub>w y) = (x \<sqinter>\<^sub>o\<^sub>w y = x)"
    is semilattice_inf_class.le_iff_inf.

tts_lemma less_infI1:
  assumes "a \<in> U" and "x \<in> U" and "b \<in> U" and "a <\<^sub>o\<^sub>w x"
  shows "a \<sqinter>\<^sub>o\<^sub>w b <\<^sub>o\<^sub>w x"
    is semilattice_inf_class.less_infI1.

tts_lemma less_infI2:
  assumes "b \<in> U" and "x \<in> U" and "a \<in> U" and "b <\<^sub>o\<^sub>w x"
  shows "a \<sqinter>\<^sub>o\<^sub>w b <\<^sub>o\<^sub>w x"
    is semilattice_inf_class.less_infI2.

tts_lemma le_infI1:
  assumes "a \<in> U" and "x \<in> U" and "b \<in> U" and "a \<le>\<^sub>o\<^sub>w x"
  shows "a \<sqinter>\<^sub>o\<^sub>w b \<le>\<^sub>o\<^sub>w x"
    is semilattice_inf_class.le_infI1.

tts_lemma le_infI2:
  assumes "b \<in> U" and "x \<in> U" and "a \<in> U" and "b \<le>\<^sub>o\<^sub>w x"
  shows "a \<sqinter>\<^sub>o\<^sub>w b \<le>\<^sub>o\<^sub>w x"
    is semilattice_inf_class.le_infI2.

tts_lemma le_inf_iff:
  assumes "x \<in> U" and "y \<in> U" and "z \<in> U"
  shows "(x \<le>\<^sub>o\<^sub>w y \<sqinter>\<^sub>o\<^sub>w z) = (x \<le>\<^sub>o\<^sub>w y \<and> x \<le>\<^sub>o\<^sub>w z)"
    is semilattice_inf_class.le_inf_iff.

tts_lemma le_infI:
  assumes "x \<in> U" and "a \<in> U" and "b \<in> U" and "x \<le>\<^sub>o\<^sub>w a" and "x \<le>\<^sub>o\<^sub>w b"
  shows "x \<le>\<^sub>o\<^sub>w a \<sqinter>\<^sub>o\<^sub>w b"
    is semilattice_inf_class.le_infI.

tts_lemma le_infE:
  assumes "x \<in> U"
    and "a \<in> U"
    and "b \<in> U"
    and "x \<le>\<^sub>o\<^sub>w a \<sqinter>\<^sub>o\<^sub>w b"
    and "\<lbrakk>x \<le>\<^sub>o\<^sub>w a; x \<le>\<^sub>o\<^sub>w b\<rbrakk> \<Longrightarrow> P"
  shows P
    is semilattice_inf_class.le_infE.

tts_lemma inf_mono:
  assumes "a \<in> U"
    and "c \<in> U"
    and "b \<in> U"
    and "d \<in> U"
    and "a \<le>\<^sub>o\<^sub>w c"
    and "b \<le>\<^sub>o\<^sub>w d"
  shows "a \<sqinter>\<^sub>o\<^sub>w b \<le>\<^sub>o\<^sub>w c \<sqinter>\<^sub>o\<^sub>w d"
    is semilattice_inf_class.inf_mono.

end

end

context semilattice_sup_ow
begin

tts_context
  tts: (?'a to U)
  rewriting ctr_simps
  substituting semilattice_sup_ow_axioms
  eliminating through simp
begin

tts_lemma le_iff_sup:
  assumes "x \<in> U" and "y \<in> U"
  shows "(x \<le>\<^sub>o\<^sub>w y) = (x \<squnion>\<^sub>o\<^sub>w y = y)"
    is semilattice_sup_class.le_iff_sup.

tts_lemma less_supI1:
  assumes "x \<in> U" and "a \<in> U" and "b \<in> U" and "x <\<^sub>o\<^sub>w a"
  shows "x <\<^sub>o\<^sub>w a \<squnion>\<^sub>o\<^sub>w b"
    is semilattice_sup_class.less_supI1.

tts_lemma less_supI2:
  assumes "x \<in> U" and "b \<in> U" and "a \<in> U" and "x <\<^sub>o\<^sub>w b"
  shows "x <\<^sub>o\<^sub>w a \<squnion>\<^sub>o\<^sub>w b"
    is semilattice_sup_class.less_supI2.

tts_lemma le_supI1:
  assumes "x \<in> U" and "a \<in> U" and "b \<in> U" and "x \<le>\<^sub>o\<^sub>w a"
  shows "x \<le>\<^sub>o\<^sub>w a \<squnion>\<^sub>o\<^sub>w b"
    is semilattice_sup_class.le_supI1.

tts_lemma le_supI2:
  assumes "x \<in> U" and "b \<in> U" and "a \<in> U" and "x \<le>\<^sub>o\<^sub>w b"
  shows "x \<le>\<^sub>o\<^sub>w a \<squnion>\<^sub>o\<^sub>w b"
    is semilattice_sup_class.le_supI2.

tts_lemma le_sup_iff:
  assumes "x \<in> U" and "y \<in> U" and "z \<in> U"
  shows "(x \<squnion>\<^sub>o\<^sub>w y \<le>\<^sub>o\<^sub>w z) = (x \<le>\<^sub>o\<^sub>w z \<and> y \<le>\<^sub>o\<^sub>w z)"
    is semilattice_sup_class.le_sup_iff.

tts_lemma le_supI:
  assumes "a \<in> U" and "x \<in> U" and "b \<in> U" and "a \<le>\<^sub>o\<^sub>w x" and "b \<le>\<^sub>o\<^sub>w x"
  shows "a \<squnion>\<^sub>o\<^sub>w b \<le>\<^sub>o\<^sub>w x"
    is semilattice_sup_class.le_supI.

tts_lemma le_supE:
  assumes "a \<in> U"
    and "b \<in> U"
    and "x \<in> U"
    and "a \<squnion>\<^sub>o\<^sub>w b \<le>\<^sub>o\<^sub>w x"
    and "\<lbrakk>a \<le>\<^sub>o\<^sub>w x; b \<le>\<^sub>o\<^sub>w x\<rbrakk> \<Longrightarrow> P"
  shows P
    is semilattice_sup_class.le_supE.

tts_lemma sup_unique:
  assumes "\<forall>x\<in>U. \<forall>y\<in>U. f x y \<in> U"
    and "x \<in> U"
    and "y \<in> U"
    and "\<And>x y. \<lbrakk>x \<in> U; y \<in> U\<rbrakk> \<Longrightarrow> x \<le>\<^sub>o\<^sub>w f x y"
    and "\<And>x y. \<lbrakk>x \<in> U; y \<in> U\<rbrakk> \<Longrightarrow> y \<le>\<^sub>o\<^sub>w f x y"
    and "\<And>x y z. \<lbrakk>x \<in> U; y \<in> U; z \<in> U; y \<le>\<^sub>o\<^sub>w x; z \<le>\<^sub>o\<^sub>w x\<rbrakk> \<Longrightarrow> f y z \<le>\<^sub>o\<^sub>w x"
  shows "x \<squnion>\<^sub>o\<^sub>w y = f x y"
    is semilattice_sup_class.sup_unique.

tts_lemma sup_mono:
  assumes "a \<in> U"
    and "c \<in> U"
    and "b \<in> U"
    and "d \<in> U"
    and "a \<le>\<^sub>o\<^sub>w c"
    and "b \<le>\<^sub>o\<^sub>w d"
  shows "a \<squnion>\<^sub>o\<^sub>w b \<le>\<^sub>o\<^sub>w c \<squnion>\<^sub>o\<^sub>w d"
    is semilattice_sup_class.sup_mono.

end

end

subsection\<open>Bounded semilattices\<close>

subsubsection\<open>Definitions and common properties\<close>

locale semilattice_neutral_ow = semilattice_ow U f + comm_monoid_ow U f z
  for U :: "'al set" and f z

locale semilattice_neutral_order_ow =
  sl_neut: semilattice_neutral_ow U f z +
  sl_ord: semilattice_order_ow U f le ls
  for U :: "'al set" and f z le ls
begin

sublocale order_top_ow U \<open>(\<le>\<^sub>o\<^sub>w)\<close> \<open>(<\<^sub>o\<^sub>w)\<close> \<open>\<^bold>1\<^sub>o\<^sub>w\<close>
  apply unfold_locales
  subgoal by (auto simp: antisym sl_ord.strict_iff_order sl_ord.antisym)
  subgoal by (auto simp: sl_ord.order_iff)
  subgoal by (auto intro: sl_ord.trans)
  subgoal by (auto simp: sl_ord.antisym)
  subgoal by auto
  subgoal by (simp add: sl_ord.absorb_iff1)
  done

end

locale bounded_semilattice_inf_top_ow =
  semilattice_inf_ow U inf le ls + order_top_ow U le ls top
  for U :: "'al set" and inf le ls top
begin

sublocale inf_top: semilattice_neutral_order_ow U \<open>(\<sqinter>\<^sub>o\<^sub>w)\<close> \<open>\<top>\<^sub>o\<^sub>w\<close> \<open>(\<le>\<^sub>o\<^sub>w)\<close> \<open>(<\<^sub>o\<^sub>w)\<close>
  apply unfold_locales
  subgoal by simp
  subgoal using top_greatest by (simp add: inf.order_iff)
  done

end

locale bounded_semilattice_sup_bot_ow =
  semilattice_sup_ow U sup le ls + order_bot_ow U bot le ls
  for U :: "'al set" and sup le ls bot
begin

sublocale sup_bot: semilattice_neutral_order_ow U \<open>(\<squnion>\<^sub>o\<^sub>w)\<close> \<open>\<bottom>\<^sub>o\<^sub>w\<close> \<open>(\<ge>\<^sub>o\<^sub>w)\<close> \<open>(>\<^sub>o\<^sub>w)\<close>
  by unfold_locales (simp_all add: sup.absorb1)

end

subsubsection\<open>Transfer rules\<close>

context
  includes lifting_syntax
begin

lemma semilattice_neutral_transfer[transfer_rule]:
  assumes [transfer_rule]: "bi_unique A" "right_total A"
  shows
    "((A ===> A ===> A) ===> A ===> (=))
      (semilattice_neutral_ow (Collect (Domainp A))) semilattice_neutr"
  unfolding semilattice_neutral_ow_def semilattice_neutr_def by transfer_prover

lemma semilattice_neutr_order_transfer[transfer_rule]:
  assumes [transfer_rule]: "bi_unique A" "right_total A"
  shows
    "(
      (A ===> A ===> A) ===>
      A ===>
      (A ===> A ===> (=)) ===>
      (A ===> A ===> (=)) ===>
      (=)
    )
    (semilattice_neutral_order_ow (Collect (Domainp A)))
    semilattice_neutr_order"
  unfolding semilattice_neutral_order_ow_def semilattice_neutr_order_def
  by transfer_prover

lemma bounded_semilattice_inf_top_transfer[transfer_rule]:
  assumes [transfer_rule]: "bi_unique A" "right_total A"
  shows
    "(
      (A ===> A ===> A) ===>
      (A ===> A ===> (=)) ===>
      (A ===> A ===> (=)) ===>
      A ===>
      (=)
    )
    (bounded_semilattice_inf_top_ow (Collect (Domainp A)))
    class.bounded_semilattice_inf_top"
  unfolding
    bounded_semilattice_inf_top_ow_def class.bounded_semilattice_inf_top_def
  by transfer_prover

lemma bounded_semilattice_sup_bot_transfer[transfer_rule]:
  assumes [transfer_rule]: "bi_unique A" "right_total A"
  shows
    "(
      (A ===> A ===> A) ===>
      (A ===> A ===> (=)) ===>
      (A ===> A ===> (=)) ===>
      A ===>
      (=)
    )
    (bounded_semilattice_sup_bot_ow (Collect (Domainp A)))
    class.bounded_semilattice_sup_bot"
  unfolding
    bounded_semilattice_sup_bot_ow_def class.bounded_semilattice_sup_bot_def
  by transfer_prover

end

text\<open>\newpage\<close>

end


theory Ex005
imports Main
begin

lemma "(A \<and> (B \<longrightarrow> \<not>A)) \<longrightarrow> (A \<and> \<not>B)"
proof -
{
  assume "A \<and> (B \<longrightarrow> \<not>A)"
  hence "B \<longrightarrow> \<not>A" by (rule conjE)
  from \<open>A \<and> (B \<longrightarrow> \<not>A)\<close> have A by (rule conjE)
  {
    assume B
    with \<open>B \<longrightarrow> \<not>A\<close> have "\<not>A" by (rule impE)
    with \<open>A\<close>  have False by contradiction
  }
  hence "\<not>B" by (rule notI)
  with \<open>A\<close> have "A \<and> \<not>B" by (rule conjI)
}
thus ?thesis by (rule impI)
qed


theory IHOML imports Main
begin
  typedecl i (*Possible worlds*)  typedecl e (*Individuals*)
  type_synonym \<delta> = "e\<Rightarrow>bool" (*Type of ordinary predicates*)
  type_synonym \<sigma> = "i\<Rightarrow>bool" (*Type of world-lifted propositions, truth-sets*)
  type_synonym \<tau> = "i\<Rightarrow>i\<Rightarrow>bool" (*Type of accessibility relations*)
  type_synonym \<gamma> = "e\<Rightarrow>\<sigma>" (*Type of lifted predicates*)
(**Logical operators lifted to truth-sets**)
  abbreviation mbot::"\<sigma>" ("\<^bold>\<bottom>") where "\<^bold>\<bottom> \<equiv> \<lambda>w. False"
  abbreviation mtop::"\<sigma>" ("\<^bold>\<top>") where "\<^bold>\<top> \<equiv> \<lambda>w. True"
  abbreviation mnot::"\<sigma>\<Rightarrow>\<sigma>" ("\<^bold>\<not>_"[52]53) where "\<^bold>\<not>\<phi> \<equiv> \<lambda>w. \<not>(\<phi> w)"
  abbreviation negpred::"\<delta>\<Rightarrow>\<delta>" ("\<rightharpoondown>_"[52]53) where "\<rightharpoondown>\<Phi> \<equiv> \<lambda>x. \<not>(\<Phi> x)"
  abbreviation mnegpred::"\<gamma>\<Rightarrow>\<gamma>" ("\<^bold>\<rightharpoondown>_"[52]53) where "\<^bold>\<rightharpoondown>\<Phi> \<equiv> \<lambda>x.\<lambda>w. \<not>(\<Phi> x w)"
  abbreviation mand::"\<sigma>\<Rightarrow>\<sigma>\<Rightarrow>\<sigma>" (infixr"\<^bold>\<and>"51) where "\<phi>\<^bold>\<and>\<psi> \<equiv> \<lambda>w. (\<phi> w)\<and>(\<psi> w)"
  abbreviation mor::"\<sigma>\<Rightarrow>\<sigma>\<Rightarrow>\<sigma>" (infixr"\<^bold>\<or>"50) where "\<phi>\<^bold>\<or>\<psi> \<equiv> \<lambda>w. (\<phi> w)\<or>(\<psi> w)"
  abbreviation mimp::"\<sigma>\<Rightarrow>\<sigma>\<Rightarrow>\<sigma>" (infixr"\<^bold>\<rightarrow>"49) where "\<phi>\<^bold>\<rightarrow>\<psi> \<equiv> \<lambda>w. (\<phi> w)\<longrightarrow>(\<psi> w)"
  abbreviation mequ::"\<sigma>\<Rightarrow>\<sigma>\<Rightarrow>\<sigma>" (infixr"\<^bold>\<leftrightarrow>"48) where "\<phi>\<^bold>\<leftrightarrow>\<psi> \<equiv> \<lambda>w. (\<phi> w)\<longleftrightarrow>(\<psi> w)"
(**Polymorphic possibilist quantification**)
  abbreviation mforall::"('a\<Rightarrow>\<sigma>)\<Rightarrow>\<sigma>" ("\<^bold>\<forall>") where "\<^bold>\<forall>\<Phi> \<equiv> \<lambda>w.\<forall>x. (\<Phi> x w)"
  abbreviation mforallB (binder"\<^bold>\<forall>"[8]9) where "\<^bold>\<forall>x. \<phi>(x) \<equiv> \<^bold>\<forall>\<phi>"
  abbreviation mexists::"('a\<Rightarrow>\<sigma>)\<Rightarrow>\<sigma>" ("\<^bold>\<exists>") where "\<^bold>\<exists>\<Phi> \<equiv> \<lambda>w.\<exists>x. (\<Phi> x w)"
  abbreviation mexistsB (binder"\<^bold>\<exists>"[8]9) where "\<^bold>\<exists>x. \<phi>(x) \<equiv> \<^bold>\<exists>\<phi>"
(**Actualist quantification for individuals**)
  consts Exists::\<gamma> ("existsAt")
  abbreviation mforallAct::"\<gamma>\<Rightarrow>\<sigma>" ("\<^bold>\<forall>\<^sup>E") where "\<^bold>\<forall>\<^sup>E\<Phi> \<equiv> \<lambda>w.\<forall>x. (existsAt x w)\<longrightarrow>(\<Phi> x w)"
  abbreviation mforallActB (binder"\<^bold>\<forall>\<^sup>E"[8]9) where "\<^bold>\<forall>\<^sup>Ex. \<phi>(x) \<equiv> \<^bold>\<forall>\<^sup>E\<phi>"
  abbreviation mexistsAct::"\<gamma>\<Rightarrow>\<sigma>" ("\<^bold>\<exists>\<^sup>E") where "\<^bold>\<exists>\<^sup>E\<Phi> \<equiv> \<lambda>w.\<exists>x. (existsAt x w) \<and> (\<Phi> x w)"
  abbreviation mexistsActB (binder"\<^bold>\<exists>\<^sup>E"[8]9) where "\<^bold>\<exists>\<^sup>Ex. \<phi>(x) \<equiv> \<^bold>\<exists>\<^sup>E\<phi>"
(**Modal operators**)
  consts aRel::\<tau> (infixr "r" 70)  (*Accessibility Relation r*)
  abbreviation mbox::"\<sigma>\<Rightarrow>\<sigma>" ("\<^bold>\<box>_"[52]53) where "\<^bold>\<box>\<phi> \<equiv> \<lambda>w.\<forall>v. (w r v)\<longrightarrow>(\<phi> v)"
  abbreviation mdia::"\<sigma>\<Rightarrow>\<sigma>" ("\<^bold>\<diamond>_"[52]53) where "\<^bold>\<diamond>\<phi> \<equiv> \<lambda>w.\<exists>v. (w r v)\<and>(\<phi> v)"
(**Meta-logical predicates**)
  abbreviation globalvalid::"\<sigma>\<Rightarrow>bool" ("\<lfloor>_\<rfloor>"[8]) where "\<lfloor>\<psi>\<rfloor> \<equiv>  \<forall>w.(\<psi> w)"
(**Definition of rigidly intensionalised predicates**)
  (*\<lparr>\<phi>\<rparr> converts an extensional object \<phi> into `rigid' intensional one*)
  abbreviation trivialConversion::"bool\<Rightarrow>\<sigma>" ("\<lparr>_\<rparr>") where "\<lparr>\<phi>\<rparr> \<equiv> (\<lambda>w. \<phi>)"
  (*Q\<^bold>\<down>\<phi>: the extension of a (possibly) non-rigid predicate \<phi> is turned into a rigid intensional
   one and Q is applied to the latter; \<down>\<phi> is read as "the rigidly intensionalised predicate \<phi>"*)
  abbreviation mextPredArg::"(\<gamma>\<Rightarrow>\<sigma>)\<Rightarrow>\<gamma>\<Rightarrow>\<sigma>" (infix"\<^bold>\<down>"60) where "\<phi>\<^bold>\<down>P \<equiv> \<lambda>w. \<phi> (\<lambda>x. \<lparr>P x w\<rparr>) w"
  lemma "\<forall>\<phi> P. \<phi> P = \<phi>\<^bold>\<down>P" nitpick[user_axioms] oops (*Countermodel: notions are not the same*)
(**Some further definitions required for Fitting's variant**)
  (*\<phi>'s argument is a relativized term of extensional type derived from an intensional predicate*)
  abbreviation extPredArg::"(\<delta>\<Rightarrow>\<sigma>)=>\<gamma>=>\<sigma>" (infix"\<down>"60) where "\<phi>\<down>P \<equiv> \<lambda>w. \<phi> (\<lambda>x. P x w) w"
  (*Another variant where \<phi> has two arguments (the first one being relativized)*)
  abbreviation extPredArg1::"(\<delta>\<Rightarrow>\<gamma>)=>\<gamma>=>\<gamma>" (infix"\<down>\<^sub>1"60) where "\<phi>\<down>\<^sub>1P \<equiv> \<lambda>z. \<lambda>w. \<phi> (\<lambda>x. P x w) z w"
(**Consistency**)
  lemma True nitpick[satisfy] oops  (*Model found by Nitpick*)
end


subsection \<open>Mod is Diophantine\<close>

theory Modulo_Divisibility
  imports Existential_Quantifier
begin

text \<open> Divisibility is diophantine \<close>
definition dvd ("DVD _ _" 1000) where "DVD Q R \<equiv> (BINARY (dvd) Q R)"

lemma dvd_repr:
  fixes a b :: nat
  shows "a dvd b \<longleftrightarrow> (\<exists>x. x * a = b)"
  using dvd_class.dvd_def by auto

lemma dvd_dioph[dioph]: "is_dioph_rel (DVD Q R)"
proof -
  define Q' R' where pushed_defs: "Q' \<equiv> push_param Q 1" "R' \<equiv> push_param R 1"
  define D where "D \<equiv> [\<exists>] (Param 0 [*] Q' [=] R')"

  have "eval (DVD Q R) a = eval D a" for a
    unfolding D_def pushed_defs defs using push_push1 apply (auto simp: push0)
    unfolding dvd_def by (auto simp: dvd_repr binary_eval)

  moreover have "is_dioph_rel D"
    unfolding D_def by (auto simp: dioph)

  ultimately show ?thesis
    by (auto simp: is_dioph_rel_def)
qed

declare dvd_def[defs]

(* Congruence is diophantine *)
definition mod ("MOD _ _ _" 1000)
  where "MOD A B C \<equiv> (TERNARY (\<lambda>a b c. a mod b = c mod b) A B C)"
declare mod_def[defs]

lemma mod_repr:
  fixes a b c :: nat
  shows "a mod b = c mod b \<longleftrightarrow> (\<exists>x y. c + x*b = a + y*b)"
  by (metis mult.commute nat_mod_eq_iff)

lemma mod_dioph[dioph]:
  fixes A B C
  defines "D \<equiv> (MOD A B C)"
  shows "is_dioph_rel D"
proof -
  define A' B' C' where pushed_defs: "A' \<equiv> push_param A 2" "B' \<equiv> push_param B 2" "C' \<equiv> push_param C 2"
  define DS where "DS \<equiv> [\<exists>2] (Param 0 [*] B' [+] C' [=] Param 1 [*] B' [+] A')"

  have "eval DS a = eval D a" for a
  proof
    show "eval DS a \<Longrightarrow> eval D a"
    unfolding DS_def defs D_def mod_def
      by auto (metis mod_mult_self3 push_push_simp pushed_defs(1) pushed_defs(2) pushed_defs(3))
    show "eval D a \<Longrightarrow> eval DS a"
      unfolding DS_def defs D_def mod_def
      apply (auto simp add: mod_repr)
      subgoal for x y
        apply (rule exI[of _ "[x, y]"])
        unfolding pushed_defs by (simp add: push_push[where ?n = 2] push_list_eval)
      done
  qed

  moreover have "is_dioph_rel DS"
    unfolding DS_def by (simp add: dioph)

  ultimately show ?thesis
    by (auto simp: is_dioph_rel_def)
qed

declare mod_def[defs]

end


(*  Title:      ZF/IMP/Denotation.thy
    Author:     Heiko Loetzbeyer and Robert Sandner, TU München
*)

section \<open>Denotational semantics of expressions and commands\<close>

theory Denotation imports Com begin

subsection \<open>Definitions\<close>

consts
  A     :: "i => i => i"
  B     :: "i => i => i"
  C     :: "i => i"

definition
  Gamma :: "[i,i,i] => i"  (\<open>\<Gamma>\<close>) where
  "\<Gamma>(b,cden) ==
    (\<lambda>phi. {io \<in> (phi O cden). B(b,fst(io))=1} \<union>
           {io \<in> id(loc->nat). B(b,fst(io))=0})"

primrec
  "A(N(n), sigma) = n"
  "A(X(x), sigma) = sigma`x"
  "A(Op1(f,a), sigma) = f`A(a,sigma)"
  "A(Op2(f,a0,a1), sigma) = f`<A(a0,sigma),A(a1,sigma)>"

primrec
  "B(true, sigma) = 1"
  "B(false, sigma) = 0"
  "B(ROp(f,a0,a1), sigma) = f`<A(a0,sigma),A(a1,sigma)>"
  "B(noti(b), sigma) = not(B(b,sigma))"
  "B(b0 andi b1, sigma) = B(b0,sigma) and B(b1,sigma)"
  "B(b0 ori b1, sigma) = B(b0,sigma) or B(b1,sigma)"

primrec
  "C(\<SKIP>) = id(loc->nat)"
  "C(x \<ASSN> a) =
    {io \<in> (loc->nat) \<times> (loc->nat). snd(io) = fst(io)(x := A(a,fst(io)))}"
  "C(c0\<SEQ> c1) = C(c1) O C(c0)"
  "C(\<IF> b \<THEN> c0 \<ELSE> c1) =
    {io \<in> C(c0). B(b,fst(io)) = 1} \<union> {io \<in> C(c1). B(b,fst(io)) = 0}"
  "C(\<WHILE> b \<DO> c) = lfp((loc->nat) \<times> (loc->nat), \<Gamma>(b,C(c)))"

subsection \<open>Misc lemmas\<close>

lemma A_type [TC]: "[|a \<in> aexp; sigma \<in> loc->nat|] ==> A(a,sigma) \<in> nat"
  by (erule aexp.induct) simp_all

lemma B_type [TC]: "[|b \<in> bexp; sigma \<in> loc->nat|] ==> B(b,sigma) \<in> bool"
by (erule bexp.induct, simp_all)

lemma C_subset: "c \<in> com ==> C(c) \<subseteq> (loc->nat) \<times> (loc->nat)"
  apply (erule com.induct)
      apply simp_all
      apply (blast dest: lfp_subset [THEN subsetD])+
  done

lemma C_type_D [dest]:
    "[| <x,y> \<in> C(c); c \<in> com |] ==> x \<in> loc->nat & y \<in> loc->nat"
  by (blast dest: C_subset [THEN subsetD])

lemma C_type_fst [dest]: "[| x \<in> C(c); c \<in> com |] ==> fst(x) \<in> loc->nat"
  by (auto dest!: C_subset [THEN subsetD])

lemma Gamma_bnd_mono:
  "cden \<subseteq> (loc->nat) \<times> (loc->nat)
    ==> bnd_mono ((loc->nat) \<times> (loc->nat), \<Gamma>(b,cden))"
  by (unfold bnd_mono_def Gamma_def) blast

end


(*  Title:      ZF/UNITY/FP.thy
    Author:     Sidi O Ehmety, Computer Laboratory
    Copyright   2001  University of Cambridge

From Misra, "A Logic for Concurrent Programming", 1994

Theory ported from HOL.
*)

section{*Fixed Point of a Program*}

theory FP imports UNITY begin

definition
  FP_Orig :: "i=>i"  where
    "FP_Orig(F) == \<Union>({A \<in> Pow(state). \<forall>B. F \<in> stable(A \<inter> B)})"

definition
  FP :: "i=>i"  where
    "FP(F) == {s\<in>state. F \<in> stable({s})}"

lemma FP_Orig_type: "FP_Orig(F) \<subseteq> state"
by (unfold FP_Orig_def, blast)

lemma st_set_FP_Orig [iff]: "st_set(FP_Orig(F))"
apply (unfold st_set_def)
apply (rule FP_Orig_type)
done

lemma FP_type: "FP(F) \<subseteq> state"
by (unfold FP_def, blast)

lemma st_set_FP [iff]: "st_set(FP(F))"
apply (unfold st_set_def)
apply (rule FP_type)
done

lemma stable_FP_Orig_Int: "F \<in> program ==> F \<in> stable(FP_Orig(F) \<inter> B)"
apply (simp only: FP_Orig_def stable_def Int_Union2)
apply (blast intro: constrains_UN)
done

lemma FP_Orig_weakest2:
    "[| \<forall>B. F \<in> stable (A \<inter> B); st_set(A) |]  ==> A \<subseteq> FP_Orig(F)"
by (unfold FP_Orig_def stable_def st_set_def, blast)

lemmas FP_Orig_weakest = allI [THEN FP_Orig_weakest2]

lemma stable_FP_Int: "F \<in> program ==> F \<in> stable (FP(F) \<inter> B)"
apply (subgoal_tac "FP (F) \<inter> B = (\<Union>x\<in>B. FP (F) \<inter> {x}) ")
 prefer 2 apply blast
apply (simp (no_asm_simp) add: Int_cons_right)
apply (unfold FP_def stable_def)
apply (rule constrains_UN)
apply (auto simp add: cons_absorb)
done

lemma FP_subset_FP_Orig: "F \<in> program ==> FP(F) \<subseteq> FP_Orig(F)"
by (rule stable_FP_Int [THEN FP_Orig_weakest], auto)

lemma FP_Orig_subset_FP: "F \<in> program ==> FP_Orig(F) \<subseteq> FP(F)"
apply (unfold FP_Orig_def FP_def, clarify)
apply (drule_tac x = "{x}" in spec)
apply (simp add: Int_cons_right)
apply (frule stableD2)
apply (auto simp add: cons_absorb st_set_def)
done

lemma FP_equivalence: "F \<in> program ==> FP(F) = FP_Orig(F)"
by (blast intro!: FP_Orig_subset_FP FP_subset_FP_Orig)

lemma FP_weakest [rule_format]:
     "[| \<forall>B. F \<in> stable(A \<inter> B); F \<in> program; st_set(A) |] ==> A \<subseteq> FP(F)"
by (simp add: FP_equivalence FP_Orig_weakest)

lemma Diff_FP:
     "[| F \<in> program;  st_set(A) |]
      ==> A-FP(F) = (\<Union>act \<in> Acts(F). A - {s \<in> state. act``{s} \<subseteq> {s}})"
by (unfold FP_def stable_def constrains_def st_set_def, blast)

end