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

subsection \<open> Examples \<close>

text \<open> We prove partial correctness specifications of some hybrid systems with our
recently described verification components.\<close>

theory HS_VC_MKA_Examples_rel
  imports HS_VC_MKA_rel

begin

subsubsection\<open>Pendulum\<close>

text \<open> The ODEs @{text "x' t = y t"} and {text "y' t = - x t"} describe the circular motion of
a mass attached to a string looked from above. We use @{text "s$1"} to represent the x-coordinate
and @{text "s$2"} for the y-coordinate. We prove that this motion remains circular. \<close>

abbreviation fpend :: "real^2 \<Rightarrow> real^2" ("f")
  where "f s \<equiv> (\<chi> i. if i = 1 then s$2 else -s$1)"

abbreviation pend_flow :: "real \<Rightarrow> real^2 \<Rightarrow> real^2" ("\<phi>")
  where "\<phi> t s \<equiv> (\<chi> i. if i = 1 then s$1 * cos t + s$2 * sin t
  else - s$1 * sin t + s$2 * cos t)"

\<comment> \<open>Verified by providing dynamics. \<close>

lemma pendulum_dyn:
  "\<lceil>\<lambda>s. r\<^sup>2 = (s$1)\<^sup>2 + (s$2)\<^sup>2\<rceil> \<le> wp (EVOL \<phi> G T) \<lceil>\<lambda>s. r\<^sup>2 = (s$1)\<^sup>2 + (s$2)\<^sup>2\<rceil>"
  by simp

\<comment> \<open>Verified with differential invariants. \<close>

lemma pendulum_inv:
  "\<lceil>\<lambda>s. r\<^sup>2 = (s$1)\<^sup>2 + (s$2)\<^sup>2\<rceil> \<le> wp (x\<acute>= f & G) \<lceil>\<lambda>s. r\<^sup>2 = (s$1)\<^sup>2 + (s$2)\<^sup>2\<rceil>"
  by (auto intro!: poly_derivatives diff_invariant_rules)

\<comment> \<open>Verified with the flow. \<close>

lemma local_flow_pend: "local_flow f UNIV UNIV \<phi>"
  apply(unfold_locales, simp_all add: local_lipschitz_def lipschitz_on_def vec_eq_iff, clarsimp)
    apply(rule_tac x="1" in exI, clarsimp, rule_tac x=1 in exI)
    apply(simp add: dist_norm norm_vec_def L2_set_def power2_commute UNIV_2)
  by (auto simp: forall_2 intro!: poly_derivatives)

lemma pendulum_flow:
  "\<lceil>\<lambda>s. r\<^sup>2 = (s$1)\<^sup>2 + (s$2)\<^sup>2\<rceil> \<le> wp (x\<acute>= f & G) \<lceil>\<lambda>s. r\<^sup>2 = (s$1)\<^sup>2 + (s$2)\<^sup>2\<rceil>"
  by (simp add: local_flow.wp_g_ode_subset[OF local_flow_pend])

no_notation fpend ("f")
        and pend_flow ("\<phi>")

subsubsection\<open> Bouncing Ball \<close>

text \<open> A ball is dropped from rest at an initial height @{text "h"}. The motion is described with
the free-fall equations @{text "x' t = v t"} and @{text "v' t = g"} where @{text "g"} is the
constant acceleration due to gravity. The bounce is modelled with a variable assignment that
flips the velocity. That is, we model it as a completely elastic collision with the ground. We use
@{text "s$1"} to represent the ball's height and @{text "s$2"} for its velocity. We prove that the
ball remains above ground and below its initial resting position. \<close>

abbreviation fball :: "real \<Rightarrow> real^2 \<Rightarrow> real^2" ("f")
  where "f g s \<equiv> (\<chi> i. if i = 1 then s$2 else g)"

abbreviation ball_flow :: "real \<Rightarrow> real \<Rightarrow> real^2 \<Rightarrow> real^2" ("\<phi>")
  where "\<phi> g t s \<equiv> (\<chi> i. if i = 1 then g * t ^ 2/2 + s$2 * t + s$1 else g * t + s$2)"

\<comment> \<open>Verified with differential invariants. \<close>

named_theorems bb_real_arith "real arithmetic properties for the bouncing ball."

lemma inv_imp_pos_le[bb_real_arith]:
  assumes "0 > g" and inv: "2 * g * x - 2 * g * h = v * v"
  shows "(x::real) \<le> h"
proof-
  have "v * v = 2 * g * x - 2 * g * h \<and> 0 > g"
    using inv and \<open>0 > g\<close> by auto
  hence obs:"v * v = 2 * g * (x - h) \<and> 0 > g \<and> v * v \<ge> 0"
    using left_diff_distrib mult.commute by (metis zero_le_square)
  hence "(v * v)/(2 * g) = (x - h)"
    by auto
  also from obs have "(v * v)/(2 * g) \<le> 0"
    using divide_nonneg_neg by fastforce
  ultimately have "h - x \<ge> 0"
    by linarith
  thus ?thesis by auto
qed

lemma bouncing_ball_inv:
  fixes h::real
  shows "g < 0 \<Longrightarrow> h \<ge> 0 \<Longrightarrow> \<lceil>\<lambda>s. s$1 = h \<and> s$2 = 0\<rceil> \<le>
  wp
    (LOOP
      ((x\<acute>= f g & (\<lambda> s. s$1 \<ge> 0) DINV (\<lambda>s. 2 * g * s$1 - 2 * g * h - s$2 * s$2 = 0));
       (IF (\<lambda> s. s$1 = 0) THEN (2 ::= (\<lambda>s. - s$2)) ELSE skip))
    INV (\<lambda>s. 0 \<le> s$1 \<and> 2 * g * s$1 - 2 * g * h - s$2 * s$2 = 0)
  ) \<lceil>\<lambda>s. 0 \<le> s$1 \<and> s$1 \<le> h\<rceil>"
  apply(rule wp_loopI, simp_all, force simp: bb_real_arith)
  by (rule wp_g_odei) (auto intro!: poly_derivatives diff_invariant_rules)

\<comment> \<open>Verified with annotated dynamics. \<close>

lemma inv_conserv_at_ground[bb_real_arith]:
  assumes invar: "2 * g * x = 2 * g * h + v * v"
    and pos: "g * \<tau>\<^sup>2 / 2 + v * \<tau> + (x::real) = 0"
  shows "2 * g * h + (g * \<tau> * (g * \<tau> + v) + v * (g * \<tau> + v)) = 0"
proof-
  from pos have "g * \<tau>\<^sup>2  + 2 * v * \<tau> + 2 * x = 0" by auto
  then have "g\<^sup>2 * \<tau>\<^sup>2  + 2 * g * v * \<tau> + 2 * g * x = 0"
    by (metis (mono_tags, opaque_lifting) Groups.mult_ac(1,3) mult_zero_right
        monoid_mult_class.power2_eq_square semiring_class.distrib_left)
  hence "g\<^sup>2 * \<tau>\<^sup>2 + 2 * g * v * \<tau> + v\<^sup>2 + 2 * g * h = 0"
    using invar by (simp add: monoid_mult_class.power2_eq_square)
  hence obs: "(g * \<tau> + v)\<^sup>2 + 2 * g * h = 0"
    apply(subst power2_sum) by (metis (no_types, opaque_lifting) Groups.add_ac(2, 3)
        Groups.mult_ac(2, 3) monoid_mult_class.power2_eq_square nat_distrib(2))
  thus "2 * g * h + (g * \<tau> * (g * \<tau> + v) + v * (g * \<tau> + v)) = 0"
    by (simp add: monoid_mult_class.power2_eq_square)
qed

lemma inv_conserv_at_air[bb_real_arith]:
  assumes invar: "2 * g * x = 2 * g * h + v * v"
  shows "2 * g * (g * \<tau>\<^sup>2 / 2 + v * \<tau> + (x::real)) =
  2 * g * h + (g * \<tau> * (g * \<tau> + v) + v * (g * \<tau> + v))" (is "?lhs = ?rhs")
proof-
  have "?lhs = g\<^sup>2 * \<tau>\<^sup>2 + 2 * g * v * \<tau> + 2 * g * x"
    by(auto simp: algebra_simps semiring_normalization_rules(29))
  also have "... = g\<^sup>2 * \<tau>\<^sup>2 + 2 * g * v * \<tau> + 2 * g * h + v * v" (is "... = ?middle")
    by(subst invar, simp)
  finally have "?lhs = ?middle".
  moreover
  {have "?rhs = g * g * (\<tau> * \<tau>) + 2 * g * v * \<tau> + 2 * g * h + v * v"
    by (simp add: Groups.mult_ac(2,3) semiring_class.distrib_left)
  also have "... = ?middle"
    by (simp add: semiring_normalization_rules(29))
  finally have "?rhs = ?middle".}
  ultimately show ?thesis by auto
qed

lemma bouncing_ball_dyn:
  fixes h::real
  assumes "g < 0" and "h \<ge> 0"
  shows "g < 0 \<Longrightarrow> h \<ge> 0 \<Longrightarrow>
  \<lceil>\<lambda>s. s$1 = h \<and> s$2 = 0\<rceil> \<le> wp
    (LOOP
      ((EVOL (\<phi> g) (\<lambda>s. 0 \<le> s$1) T);
      (IF (\<lambda> s. s$1 = 0) THEN (2 ::= (\<lambda>s. - s$2)) ELSE skip))
    INV (\<lambda>s. 0 \<le> s$1 \<and> 2 * g * s$1 = 2 * g * h + s$2 * s$2))
  \<lceil>\<lambda>s. 0 \<le> s$1 \<and> s$1 \<le> h\<rceil>"
  by (rule wp_loopI) (auto simp: bb_real_arith)

\<comment> \<open>Verified with the flow. \<close>

lemma local_flow_ball: "local_flow (f g) UNIV UNIV (\<phi> g)"
  apply(unfold_locales, simp_all add: local_lipschitz_def lipschitz_on_def vec_eq_iff, clarsimp)
    apply(rule_tac x="1/2" in exI, clarsimp, rule_tac x=1 in exI)
    apply(simp add: dist_norm norm_vec_def L2_set_def UNIV_2)
  by (auto simp: forall_2 intro!: poly_derivatives)

lemma bouncing_ball_flow:
  fixes h::real
  assumes "g < 0" and "h \<ge> 0"
  shows "g < 0 \<Longrightarrow> h \<ge> 0 \<Longrightarrow>
  \<lceil>\<lambda>s. s$1 = h \<and> s$2 = 0\<rceil> \<le> wp
    (LOOP
      ((x\<acute>= (\<lambda>t. f g) & (\<lambda> s. s$1 \<ge> 0) on (\<lambda>s. UNIV) UNIV @ 0);
      (IF (\<lambda> s. s$1 = 0) THEN (2 ::= (\<lambda>s. - s$2)) ELSE skip))
    INV (\<lambda>s. 0 \<le> s$1 \<and> 2 * g * s$1 = 2 * g * h + s$2 * s$2))
  \<lceil>\<lambda>s. 0 \<le> s$1 \<and> s$1 \<le> h\<rceil>"
  apply(rule wp_loopI, simp_all add: local_flow.wp_g_ode_subset[OF local_flow_ball])
  by (auto simp: bb_real_arith)

no_notation fball ("f")
        and ball_flow ("\<phi>")

subsubsection\<open> Thermostat \<close>

text \<open> A thermostat has a chronometer, a thermometer and a switch to turn on and off a heater.
At most every @{text "t"} minutes, it sets its chronometer to @{term "0::real"}, it registers
the room temperature, and it turns the heater on (or off) based on this reading. The temperature
follows the ODE @{text "T' = - a * (T - U)"} where @{text "U"} is @{text "L \<ge> 0"} when the heater
is on, and @{text "0"} when it is off. We use @{term "1::4"} to denote the room's temperature,
@{term "2::4"} is time as measured by the thermostat's chronometer, @{term "3::4"} is the
temperature detected by the thermometer, and @{term "4::4"} states whether the heater is on
(@{text "s$4 = 1"}) or off (@{text "s$4 = 0"}). We prove that the thermostat keeps the room's
temperature between @{text "Tmin"} and @{text "Tmax"}. \<close>

abbreviation temp_vec_field :: "real \<Rightarrow> real \<Rightarrow> real^4 \<Rightarrow> real^4" ("f")
  where "f a L s \<equiv> (\<chi> i. if i = 2 then 1 else (if i = 1 then - a * (s$1 - L) else 0))"

abbreviation temp_flow :: "real \<Rightarrow> real \<Rightarrow> real \<Rightarrow> real^4 \<Rightarrow> real^4" ("\<phi>")
  where "\<phi> a L t s \<equiv> (\<chi> i. if i = 1 then - exp(-a * t) * (L - s$1) + L else
  (if i = 2 then t + s$2 else s$i))"

\<comment> \<open>Verified with the flow. \<close>

lemma norm_diff_temp_dyn: "0 < a \<Longrightarrow> \<parallel>f a L s\<^sub>1 - f a L s\<^sub>2\<parallel> = \<bar>a\<bar> * \<bar>s\<^sub>1$1 - s\<^sub>2$1\<bar>"
proof(simp add: norm_vec_def L2_set_def, unfold UNIV_4, simp)
  assume a1: "0 < a"
  have f2: "\<And>r ra. \<bar>(r::real) + - ra\<bar> = \<bar>ra + - r\<bar>"
    by (metis abs_minus_commute minus_real_def)
  have "\<And>r ra rb. (r::real) * ra + - (r * rb) = r * (ra + - rb)"
    by (metis minus_real_def right_diff_distrib)
  hence "\<bar>a * (s\<^sub>1$1 + - L) + - (a * (s\<^sub>2$1 + - L))\<bar> = a * \<bar>s\<^sub>1$1 + - s\<^sub>2$1\<bar>"
    using a1 by (simp add: abs_mult)
  thus "\<bar>a * (s\<^sub>2$1 - L) - a * (s\<^sub>1$1 - L)\<bar> = a * \<bar>s\<^sub>1$1 - s\<^sub>2$1\<bar>"
    using f2 minus_real_def by presburger
qed

lemma local_lipschitz_temp_dyn:
  assumes "0 < (a::real)"
  shows "local_lipschitz UNIV UNIV (\<lambda>t::real. f a L)"
  apply(unfold local_lipschitz_def lipschitz_on_def dist_norm)
  apply(clarsimp, rule_tac x=1 in exI, clarsimp, rule_tac x=a in exI)
  using assms
  apply(simp_all add: norm_diff_temp_dyn)
  apply(simp add: norm_vec_def L2_set_def, unfold UNIV_4, clarsimp)
  unfolding real_sqrt_abs[symmetric] by (rule real_le_lsqrt) auto

lemma local_flow_temp: "a > 0 \<Longrightarrow> local_flow (f a L) UNIV UNIV (\<phi> a L)"
  by (unfold_locales, auto intro!: poly_derivatives local_lipschitz_temp_dyn simp: forall_4 vec_eq_iff)

lemma temp_dyn_down_real_arith:
  assumes "a > 0" and Thyps: "0 < Tmin" "Tmin \<le> T" "T \<le> Tmax"
    and thyps: "0 \<le> (t::real)" "\<forall>\<tau>\<in>{0..t}. \<tau> \<le> - (ln (Tmin / T) / a) "
  shows "Tmin \<le> exp (-a * t) * T" and "exp (-a * t) * T \<le> Tmax"
proof-
  have "0 \<le> t \<and> t \<le> - (ln (Tmin / T) / a)"
    using thyps by auto
  hence "ln (Tmin / T) \<le> - a * t \<and> - a * t \<le> 0"
    using assms(1) divide_le_cancel by fastforce
  also have "Tmin / T > 0"
    using Thyps by auto
  ultimately have obs: "Tmin / T \<le> exp (-a * t)" "exp (-a * t) \<le> 1"
    using exp_ln exp_le_one_iff by (metis exp_less_cancel_iff not_less, simp)
  thus "Tmin \<le> exp (-a * t) * T"
    using Thyps by (simp add: pos_divide_le_eq)
  show "exp (-a * t) * T \<le> Tmax"
    using Thyps mult_left_le_one_le[OF _ exp_ge_zero obs(2), of T]
      less_eq_real_def order_trans_rules(23) by blast
qed

lemma temp_dyn_up_real_arith:
  assumes "a > 0" and Thyps: "Tmin \<le> T" "T \<le> Tmax" "Tmax < (L::real)"
    and thyps: "0 \<le> t" "\<forall>\<tau>\<in>{0..t}. \<tau> \<le> - (ln ((L - Tmax) / (L - T)) / a) "
  shows "L - Tmax \<le> exp (-(a * t)) * (L - T)"
    and "L - exp (-(a * t)) * (L - T) \<le> Tmax"
    and "Tmin \<le> L - exp (-(a * t)) * (L - T)"
proof-
  have "0 \<le> t \<and> t \<le> - (ln ((L - Tmax) / (L - T)) / a)"
    using thyps by auto
  hence "ln ((L - Tmax) / (L - T)) \<le> - a * t \<and> - a * t \<le> 0"
    using assms(1) divide_le_cancel by fastforce
  also have "(L - Tmax) / (L - T) > 0"
    using Thyps by auto
  ultimately have "(L - Tmax) / (L - T) \<le> exp (-a * t) \<and> exp (-a * t) \<le> 1"
    using exp_ln exp_le_one_iff by (metis exp_less_cancel_iff not_less)
  moreover have "L - T > 0"
    using Thyps by auto
  ultimately have obs: "(L - Tmax) \<le> exp (-a * t) * (L - T) \<and> exp (-a * t) * (L - T) \<le> (L - T)"
    by (simp add: pos_divide_le_eq)
  thus "(L - Tmax) \<le> exp (-(a * t)) * (L - T)"
    by auto
  thus "L - exp (-(a * t)) * (L - T) \<le> Tmax"
    by auto
  show "Tmin \<le> L - exp (-(a * t)) * (L - T)"
    using Thyps and obs by auto
qed

lemmas fbox_temp_dyn = local_flow.wp_g_ode_subset[OF local_flow_temp]

lemma thermostat:
  assumes "a > 0" and "0 < Tmin" and "Tmax < L"
  shows "\<lceil>\<lambda>s. Tmin \<le> s$1 \<and> s$1 \<le> Tmax \<and> s$4 = 0\<rceil> \<le> wp
  (LOOP
    \<comment> \<open>control\<close>
    ((2 ::= (\<lambda>s. 0));(3 ::= (\<lambda>s. s$1));
    (IF (\<lambda>s. s$4 = 0 \<and> s$3 \<le> Tmin + 1) THEN (4 ::= (\<lambda>s.1)) ELSE
    (IF (\<lambda>s. s$4 = 1 \<and> s$3 \<ge> Tmax - 1) THEN (4 ::= (\<lambda>s.0)) ELSE skip));
    \<comment> \<open>dynamics\<close>
    (IF (\<lambda>s. s$4 = 0) THEN (x\<acute>= f a 0 & (\<lambda>s. s$2 \<le> - (ln (Tmin/s$3))/a))
    ELSE (x\<acute>= f a L & (\<lambda>s. s$2 \<le> - (ln ((L-Tmax)/(L-s$3)))/a))) )
  INV (\<lambda>s. Tmin \<le>s$1 \<and> s$1 \<le> Tmax \<and> (s$4 = 0 \<or> s$4 = 1)))
  \<lceil>\<lambda>s. Tmin \<le> s$1 \<and> s$1 \<le> Tmax\<rceil>"
  apply(rule wp_loopI, simp_all add: fbox_temp_dyn[OF assms(1)])
  using temp_dyn_up_real_arith[OF assms(1) _ _ assms(3), of Tmin]
    and temp_dyn_down_real_arith[OF assms(1,2), of _ Tmax] by auto

no_notation temp_vec_field ("f")
        and temp_flow ("\<phi>")

subsubsection \<open> Tank \<close>

text \<open> A controller turns a water pump on and off to keep the level of water @{text "h"} in a tank
within an acceptable range @{text "hmin \<le> h \<le> hmax"}. Just like in the previous example, after
each intervention, the controller registers the current level of water and resets its chronometer,
then it changes the status of the water pump accordingly. The level of water grows linearly
@{text "h' = k"} at a rate of @{text "k = c\<^sub>i-c\<^sub>o"} if the pump is on, and at a rate of
@{text "k = -c\<^sub>o"} if the pump is off. We use @{term "1::4"} to denote the tank's level of water,
@{term "2::4"} is time as measured by the controller's chronometer, @{term "3::4"} is the
level of water measured by the chronometer, and @{term "4::4"} states whether the pump is on
(@{text "s$4 = 1"}) or off (@{text "s$4 = 0"}). We prove that the controller keeps the level of
water between @{text "hmin"} and @{text "hmax"}. \<close>

abbreviation tank_vec_field :: "real \<Rightarrow> real^4 \<Rightarrow> real^4" ("f")
  where "f k s \<equiv> (\<chi> i. if i = 2 then 1 else (if i = 1 then k else 0))"

abbreviation tank_flow :: "real \<Rightarrow> real \<Rightarrow> real^4 \<Rightarrow> real^4" ("\<phi>")
  where "\<phi> k \<tau> s \<equiv> (\<chi> i. if i = 1 then k * \<tau> + s$1 else
  (if i = 2 then \<tau> + s$2 else s$i))"

abbreviation tank_guard :: "real \<Rightarrow> real \<Rightarrow> real^4 \<Rightarrow> bool" ("G")
  where "G Hm k s \<equiv> s$2 \<le> (Hm - s$3)/k"

abbreviation tank_loop_inv :: "real \<Rightarrow> real \<Rightarrow> real^4 \<Rightarrow> bool" ("I")
  where "I hmin hmax s \<equiv> hmin \<le> s$1 \<and> s$1 \<le> hmax \<and> (s$4 = 0 \<or> s$4 = 1)"

abbreviation tank_diff_inv :: "real \<Rightarrow> real \<Rightarrow> real \<Rightarrow> real^4 \<Rightarrow> bool" ("dI")
  where "dI hmin hmax k s \<equiv> s$1 = k * s$2 + s$3 \<and> 0 \<le> s$2 \<and>
    hmin \<le> s$3 \<and> s$3 \<le> hmax \<and> (s$4 =0 \<or> s$4 = 1)"

lemma local_flow_tank: "local_flow (f k) UNIV UNIV (\<phi> k)"
  apply (unfold_locales, unfold local_lipschitz_def lipschitz_on_def, simp_all, clarsimp)
  apply(rule_tac x="1/2" in exI, clarsimp, rule_tac x=1 in exI)
  apply(simp add: dist_norm norm_vec_def L2_set_def, unfold UNIV_4)
  by (auto intro!: poly_derivatives simp: vec_eq_iff)

lemma tank_arith:
  assumes "0 \<le> (\<tau>::real)" and "0 < c\<^sub>o" and "c\<^sub>o < c\<^sub>i"
  shows "\<forall>\<tau>\<in>{0..\<tau>}. \<tau> \<le> - ((hmin - y) / c\<^sub>o) \<Longrightarrow>  hmin \<le> y - c\<^sub>o * \<tau>"
    and "\<forall>\<tau>\<in>{0..\<tau>}. \<tau> \<le> (hmax - y) / (c\<^sub>i - c\<^sub>o) \<Longrightarrow>  (c\<^sub>i - c\<^sub>o) * \<tau> + y \<le> hmax"
    and "hmin \<le> y \<Longrightarrow> hmin \<le> (c\<^sub>i - c\<^sub>o) * \<tau> + y"
    and "y \<le> hmax \<Longrightarrow> y - c\<^sub>o * \<tau> \<le> hmax"
  apply(simp_all add: field_simps le_divide_eq assms)
  using assms apply (meson add_mono less_eq_real_def mult_left_mono)
  using assms by (meson add_increasing2 less_eq_real_def mult_nonneg_nonneg)

lemma tank_flow:
  assumes "0 < c\<^sub>o" and "c\<^sub>o < c\<^sub>i"
  shows "\<lceil>\<lambda>s. I hmin hmax s\<rceil> \<le> wp
  (LOOP
    \<comment> \<open>control\<close>
    ((2 ::=(\<lambda>s.0));(3 ::=(\<lambda>s. s$1));
    (IF (\<lambda>s. s$4 = 0 \<and> s$3 \<le> hmin + 1) THEN (4 ::= (\<lambda>s.1)) ELSE
    (IF (\<lambda>s. s$4 = 1 \<and> s$3 \<ge> hmax - 1) THEN (4 ::= (\<lambda>s.0)) ELSE skip));
    \<comment> \<open>dynamics\<close>
    (IF (\<lambda>s. s$4 = 0) THEN (x\<acute>= f (c\<^sub>i-c\<^sub>o) & (G hmax (c\<^sub>i-c\<^sub>o)))
     ELSE (x\<acute>= f (-c\<^sub>o) & (G hmin (-c\<^sub>o)))) ) INV I hmin hmax)
  \<lceil>\<lambda>s. I hmin hmax s\<rceil>"
  apply(rule wp_loopI, simp_all add: local_flow.wp_g_ode_subset[OF local_flow_tank])
  using assms tank_arith[OF _ assms] by auto

no_notation tank_vec_field ("f")
        and tank_flow ("\<phi>")
        and tank_loop_inv ("I")
        and tank_diff_inv ("dI")
        and tank_guard ("G")

end


(* Property from Productive Use of Failure in Inductive Proof,
   Andrew Ireland and Alan Bundy, JAR 1996.
   This Isabelle theory is produced using the TIP tool offered at the following website:
     https://github.com/tip-org/tools
   This file was originally provided as part of TIP benchmark at the following website:
     https://github.com/tip-org/benchmarks
   Yutaka Nagashima at CIIRC, CTU changed the TIP output theory file slightly
   to make it compatible with Isabelle2017.
   Some proofs were added by Yutaka Nagashima.*)
theory TIP_prop_08
  imports "../../Test_Base"
begin

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

datatype Nat = Z | S "Nat"

fun drop :: "Nat => 'a list => 'a list" where
  "drop (Z) y = y"
| "drop (S z) (nil2) = nil2"
| "drop (S z) (cons2 x2 x3) = drop z x3"

lemma drop_nil: "drop n nil2 = nil2"
  by(case_tac n, auto)

(*
lemma drop_succ: "drop (S n) (drop m l) = drop n (drop (S m) l)"
  apply(induction l)
   apply(simp add: drop_nil, simp)
  apply(induction m, auto)
  apply(case_tac l, simp add: drop_nil, auto)
  done

theorem property0 :
  "((drop x (drop y z)) = (drop y (drop x z)))"
  apply(induct z rule: drop.induct, auto)
  apply(case_tac y, auto)
  apply(simp add: drop_succ)
  done
*)

lemma bottom_up_nested_drop_and_S:
  "drop (S n) (drop m l) = drop n (drop (S m) l)"
  apply(induct l)
   apply (simp add: drop_nil)
  apply clarsimp
  apply(induct m)
   apply fastforce
  apply clarsimp
  apply(case_tac l)(*sledgehammer can solve this as well*)
   apply(simp add: drop_nil)+
  done

(* declare [[show_types]] *)
(* Due to the fixed type variable caused by the "assumes" keyword, we cannot use the standard
 * technique for abductive reasoning. *)
(*
lemma subgoal_as_a_separate_lemma:
 (*assumes "TIP_prop_08.drop (S (n::Nat)) (TIP_prop_08.drop (m::Nat) (l::'a TIP_prop_08.list)) = TIP_prop_08.drop n (TIP_prop_08.drop (S m) l)"*)
  shows "drop    z  (drop y           x3 ) = drop y (drop z x3) \<Longrightarrow>
         drop (S z) (drop y (cons2 x2 x3)) = drop y (drop z x3)"
  apply(simp add: bottom_up_nested_drop_and_S)
  done
*)
theorem property: "((drop x (drop y z)) = (drop y (drop x z)))"
  apply(induct z rule: drop.induct)
    apply (simp add: drop_nil)
   apply (simp add: drop_nil)
  apply clarsimp
  by (simp add: bottom_up_nested_drop_and_S)

end


section\<open>T1 and Hausdorff spaces\<close>

theory T1_Spaces
imports Product_Topology
begin

section\<open>T1 spaces with equivalences to many naturally "nice" properties. \<close>

definition t1_space where
 "t1_space X \<equiv> \<forall>x \<in> topspace X. \<forall>y \<in> topspace X. x\<noteq>y \<longrightarrow> (\<exists>U. openin X U \<and> x \<in> U \<and> y \<notin> U)"

lemma t1_space_expansive:
   "\<lbrakk>topspace Y = topspace X; \<And>U. openin X U \<Longrightarrow> openin Y U\<rbrakk> \<Longrightarrow> t1_space X \<Longrightarrow> t1_space Y"
  by (metis t1_space_def)

lemma t1_space_alt:
   "t1_space X \<longleftrightarrow> (\<forall>x \<in> topspace X. \<forall>y \<in> topspace X. x\<noteq>y \<longrightarrow> (\<exists>U. closedin X U \<and> x \<in> U \<and> y \<notin> U))"
 by (metis DiffE DiffI closedin_def openin_closedin_eq t1_space_def)

lemma t1_space_empty: "topspace X = {} \<Longrightarrow> t1_space X"
  by (simp add: t1_space_def)

lemma t1_space_derived_set_of_singleton:
  "t1_space X \<longleftrightarrow> (\<forall>x \<in> topspace X. X derived_set_of {x} = {})"
  apply (simp add: t1_space_def derived_set_of_def, safe)
   apply (metis openin_topspace)
  by force

lemma t1_space_derived_set_of_finite:
   "t1_space X \<longleftrightarrow> (\<forall>S. finite S \<longrightarrow> X derived_set_of S = {})"
proof (intro iffI allI impI)
  fix S :: "'a set"
  assume "finite S"
  then have fin: "finite ((\<lambda>x. {x}) ` (topspace X \<inter> S))"
    by blast
  assume "t1_space X"
  then have "X derived_set_of (\<Union>x \<in> topspace X \<inter> S. {x}) = {}"
    unfolding derived_set_of_Union [OF fin]
    by (auto simp: t1_space_derived_set_of_singleton)
  then have "X derived_set_of (topspace X \<inter> S) = {}"
    by simp
  then show "X derived_set_of S = {}"
    by simp
qed (auto simp: t1_space_derived_set_of_singleton)

lemma t1_space_closedin_singleton:
   "t1_space X \<longleftrightarrow> (\<forall>x \<in> topspace X. closedin X {x})"
  apply (rule iffI)
  apply (simp add: closedin_contains_derived_set t1_space_derived_set_of_singleton)
  using t1_space_alt by auto

lemma closedin_t1_singleton:
   "\<lbrakk>t1_space X; a \<in> topspace X\<rbrakk> \<Longrightarrow> closedin X {a}"
  by (simp add: t1_space_closedin_singleton)

lemma t1_space_closedin_finite:
   "t1_space X \<longleftrightarrow> (\<forall>S. finite S \<and> S \<subseteq> topspace X \<longrightarrow> closedin X S)"
  apply (rule iffI)
  apply (simp add: closedin_contains_derived_set t1_space_derived_set_of_finite)
  by (simp add: t1_space_closedin_singleton)

lemma closure_of_singleton:
   "t1_space X \<Longrightarrow> X closure_of {a} = (if a \<in> topspace X then {a} else {})"
  by (simp add: closure_of_eq t1_space_closedin_singleton closure_of_eq_empty_gen)

lemma separated_in_singleton:
  assumes "t1_space X"
  shows "separatedin X {a} S \<longleftrightarrow> a \<in> topspace X \<and> S \<subseteq> topspace X \<and> (a \<notin> X closure_of S)"
        "separatedin X S {a} \<longleftrightarrow> a \<in> topspace X \<and> S \<subseteq> topspace X \<and> (a \<notin> X closure_of S)"
  unfolding separatedin_def
  using assms closure_of closure_of_singleton by fastforce+

lemma t1_space_openin_delete:
   "t1_space X \<longleftrightarrow> (\<forall>U x. openin X U \<and> x \<in> U \<longrightarrow> openin X (U - {x}))"
  apply (rule iffI)
  apply (meson closedin_t1_singleton in_mono openin_diff openin_subset)
  by (simp add: closedin_def t1_space_closedin_singleton)

lemma t1_space_openin_delete_alt:
   "t1_space X \<longleftrightarrow> (\<forall>U x. openin X U \<longrightarrow> openin X (U - {x}))"
  by (metis Diff_empty Diff_insert0 t1_space_openin_delete)

lemma t1_space_singleton_Inter_open:
      "t1_space X \<longleftrightarrow> (\<forall>x \<in> topspace X. \<Inter>{U. openin X U \<and> x \<in> U} = {x})"  (is "?P=?Q")
  and t1_space_Inter_open_supersets:
     "t1_space X \<longleftrightarrow> (\<forall>S. S \<subseteq> topspace X \<longrightarrow> \<Inter>{U. openin X U \<and> S \<subseteq> U} = S)" (is "?P=?R")
proof -
  have "?R \<Longrightarrow> ?Q"
    apply clarify
    apply (drule_tac x="{x}" in spec, simp)
    done
  moreover have "?Q \<Longrightarrow> ?P"
    apply (clarsimp simp add: t1_space_def)
    apply (drule_tac x=x in bspec)
     apply (simp_all add: set_eq_iff)
    by (metis (no_types, lifting))
  moreover have "?P \<Longrightarrow> ?R"
  proof (clarsimp simp add: t1_space_closedin_singleton, rule subset_antisym)
    fix S
    assume S: "\<forall>x\<in>topspace X. closedin X {x}" "S \<subseteq> topspace X"
    then show "\<Inter> {U. openin X U \<and> S \<subseteq> U} \<subseteq> S"
      apply clarsimp
      by (metis Diff_insert_absorb Set.set_insert closedin_def openin_topspace subset_insert)
  qed force
  ultimately show "?P=?Q" "?P=?R"
    by auto
qed

lemma t1_space_derived_set_of_infinite_openin:
   "t1_space X \<longleftrightarrow>
        (\<forall>S. X derived_set_of S =
             {x \<in> topspace X. \<forall>U. x \<in> U \<and> openin X U \<longrightarrow> infinite(S \<inter> U)})"
         (is "_ = ?rhs")
proof
  assume "t1_space X"
  show ?rhs
  proof safe
    fix S x U
    assume "x \<in> X derived_set_of S" "x \<in> U" "openin X U" "finite (S \<inter> U)"
    with \<open>t1_space X\<close> show "False"
      apply (simp add: t1_space_derived_set_of_finite)
      by (metis IntI empty_iff empty_subsetI inf_commute openin_Int_derived_set_of_subset subset_antisym)
  next
    fix S x
    have eq: "(\<exists>y. (y \<noteq> x) \<and> y \<in> S \<and> y \<in> T) \<longleftrightarrow> ~((S \<inter> T) \<subseteq> {x})" for x S T
      by blast
    assume "x \<in> topspace X" "\<forall>U. x \<in> U \<and> openin X U \<longrightarrow> infinite (S \<inter> U)"
    then show "x \<in> X derived_set_of S"
      apply (clarsimp simp add: derived_set_of_def eq)
      by (meson finite.emptyI finite.insertI finite_subset)
  qed (auto simp: in_derived_set_of)
qed (auto simp: t1_space_derived_set_of_singleton)

lemma finite_t1_space_imp_discrete_topology:
   "\<lbrakk>topspace X = U; finite U; t1_space X\<rbrakk> \<Longrightarrow> X = discrete_topology U"
  by (metis discrete_topology_unique_derived_set t1_space_derived_set_of_finite)

lemma t1_space_subtopology: "t1_space X \<Longrightarrow> t1_space(subtopology X U)"
  by (simp add: derived_set_of_subtopology t1_space_derived_set_of_finite)

lemma closedin_derived_set_of_gen:
   "t1_space X \<Longrightarrow> closedin X (X derived_set_of S)"
  apply (clarsimp simp add: in_derived_set_of closedin_contains_derived_set derived_set_of_subset_topspace)
  by (metis DiffD2 insert_Diff insert_iff t1_space_openin_delete)

lemma derived_set_of_derived_set_subset_gen:
   "t1_space X \<Longrightarrow> X derived_set_of (X derived_set_of S) \<subseteq> X derived_set_of S"
  by (meson closedin_contains_derived_set closedin_derived_set_of_gen)

lemma subtopology_eq_discrete_topology_gen_finite:
   "\<lbrakk>t1_space X; finite S\<rbrakk> \<Longrightarrow> subtopology X S = discrete_topology(topspace X \<inter> S)"
  by (simp add: subtopology_eq_discrete_topology_gen t1_space_derived_set_of_finite)

lemma subtopology_eq_discrete_topology_finite:
   "\<lbrakk>t1_space X; S \<subseteq> topspace X; finite S\<rbrakk>
        \<Longrightarrow> subtopology X S = discrete_topology S"
  by (simp add: subtopology_eq_discrete_topology_eq t1_space_derived_set_of_finite)

lemma t1_space_closed_map_image:
   "\<lbrakk>closed_map X Y f; f ` (topspace X) = topspace Y; t1_space X\<rbrakk> \<Longrightarrow> t1_space Y"
  by (metis closed_map_def finite_subset_image t1_space_closedin_finite)

lemma homeomorphic_t1_space: "X homeomorphic_space Y \<Longrightarrow> (t1_space X \<longleftrightarrow> t1_space Y)"
  apply (clarsimp simp add: homeomorphic_space_def)
  by (meson homeomorphic_eq_everything_map homeomorphic_maps_map t1_space_closed_map_image)

proposition t1_space_product_topology:
   "t1_space (product_topology X I)
\<longleftrightarrow> topspace(product_topology X I) = {} \<or> (\<forall>i \<in> I. t1_space (X i))"
proof (cases "topspace(product_topology X I) = {}")
  case True
  then show ?thesis
    using True t1_space_empty by blast
next
  case False
  then obtain f where f: "f \<in> (\<Pi>\<^sub>E i\<in>I. topspace(X i))"
    by fastforce
  have "t1_space (product_topology X I) \<longleftrightarrow> (\<forall>i\<in>I. t1_space (X i))"
  proof (intro iffI ballI)
    show "t1_space (X i)" if "t1_space (product_topology X I)" and "i \<in> I" for i
    proof -
      have clo: "\<And>h. h \<in> (\<Pi>\<^sub>E i\<in>I. topspace (X i)) \<Longrightarrow> closedin (product_topology X I) {h}"
        using that by (simp add: t1_space_closedin_singleton)
      show ?thesis
        unfolding t1_space_closedin_singleton
      proof clarify
        show "closedin (X i) {xi}" if "xi \<in> topspace (X i)" for xi
          using clo [of "\<lambda>j \<in> I. if i=j then xi else f j"] f that \<open>i \<in> I\<close>
          by (fastforce simp add: closedin_product_topology_singleton)
      qed
    qed
  next
  next
    show "t1_space (product_topology X I)" if "\<forall>i\<in>I. t1_space (X i)"
      using that
      by (simp add: t1_space_closedin_singleton Ball_def PiE_iff closedin_product_topology_singleton)
  qed
  then show ?thesis
    using False by blast
qed

lemma t1_space_prod_topology:
   "t1_space(prod_topology X Y) \<longleftrightarrow> topspace(prod_topology X Y) = {} \<or> t1_space X \<and> t1_space Y"
proof (cases "topspace (prod_topology X Y) = {}")
  case True then show ?thesis
  by (auto simp: t1_space_empty)
next
  case False
  have eq: "{(x,y)} = {x} \<times> {y}" for x y
    by simp
  have "t1_space (prod_topology X Y) \<longleftrightarrow> (t1_space X \<and> t1_space Y)"
    using False
    by (force simp: t1_space_closedin_singleton closedin_prod_Times_iff eq simp del: insert_Times_insert)
  with False show ?thesis
    by simp
qed

subsection\<open>Hausdorff Spaces\<close>

definition Hausdorff_space
  where
 "Hausdorff_space X \<equiv>
        \<forall>x y. x \<in> topspace X \<and> y \<in> topspace X \<and> (x \<noteq> y)
              \<longrightarrow> (\<exists>U V. openin X U \<and> openin X V \<and> x \<in> U \<and> y \<in> V \<and> disjnt U V)"

lemma Hausdorff_space_expansive:
   "\<lbrakk>Hausdorff_space X; topspace X = topspace Y; \<And>U. openin X U \<Longrightarrow> openin Y U\<rbrakk> \<Longrightarrow> Hausdorff_space Y"
  by (metis Hausdorff_space_def)

lemma Hausdorff_space_topspace_empty:
   "topspace X = {} \<Longrightarrow> Hausdorff_space X"
  by (simp add: Hausdorff_space_def)

lemma Hausdorff_imp_t1_space:
   "Hausdorff_space X \<Longrightarrow> t1_space X"
  by (metis Hausdorff_space_def disjnt_iff t1_space_def)

lemma closedin_derived_set_of:
   "Hausdorff_space X \<Longrightarrow> closedin X (X derived_set_of S)"
  by (simp add: Hausdorff_imp_t1_space closedin_derived_set_of_gen)

lemma t1_or_Hausdorff_space:
   "t1_space X \<or> Hausdorff_space X \<longleftrightarrow> t1_space X"
  using Hausdorff_imp_t1_space by blast

lemma Hausdorff_space_sing_Inter_opens:
   "\<lbrakk>Hausdorff_space X; a \<in> topspace X\<rbrakk> \<Longrightarrow> \<Inter>{u. openin X u \<and> a \<in> u} = {a}"
  using Hausdorff_imp_t1_space t1_space_singleton_Inter_open by force

lemma Hausdorff_space_subtopology:
  assumes "Hausdorff_space X" shows "Hausdorff_space(subtopology X S)"
proof -
  have *: "disjnt U V \<Longrightarrow> disjnt (S \<inter> U) (S \<inter> V)" for U V
    by (simp add: disjnt_iff)
  from assms show ?thesis
    apply (simp add: Hausdorff_space_def openin_subtopology_alt)
    apply (fast intro: * elim!: all_forward)
    done
qed

lemma Hausdorff_space_compact_separation:
  assumes X: "Hausdorff_space X" and S: "compactin X S" and T: "compactin X T" and "disjnt S T"
  obtains U V where "openin X U" "openin X V" "S \<subseteq> U" "T \<subseteq> V" "disjnt U V"
proof (cases "S = {}")
  case True
  then show thesis
    by (metis \<open>compactin X T\<close> compactin_subset_topspace disjnt_empty1 empty_subsetI openin_empty openin_topspace that)
next
  case False
  have "\<forall>x \<in> S. \<exists>U V. openin X U \<and> openin X V \<and> x \<in> U \<and> T \<subseteq> V \<and> disjnt U V"
  proof
    fix a
    assume "a \<in> S"
    then have "a \<notin> T"
      by (meson assms(4) disjnt_iff)
    have a: "a \<in> topspace X"
      using S \<open>a \<in> S\<close> compactin_subset_topspace by blast
    show "\<exists>U V. openin X U \<and> openin X V \<and> a \<in> U \<and> T \<subseteq> V \<and> disjnt U V"
    proof (cases "T = {}")
      case True
      then show ?thesis
        using a disjnt_empty2 openin_empty by blast
    next
      case False
      have "\<forall>x \<in> topspace X - {a}. \<exists>U V. openin X U \<and> openin X V \<and> x \<in> U \<and> a \<in> V \<and> disjnt U V"
        using X a by (simp add: Hausdorff_space_def)
      then obtain U V where UV: "\<forall>x \<in> topspace X - {a}. openin X (U x) \<and> openin X (V x) \<and> x \<in> U x \<and> a \<in> V x \<and> disjnt (U x) (V x)"
        by metis
      with \<open>a \<notin> T\<close> compactin_subset_topspace [OF T]
      have Topen: "\<forall>W \<in> U ` T. openin X W" and Tsub: "T \<subseteq> \<Union> (U ` T)"
        by auto
      then obtain \<F> where \<F>: "finite \<F>" "\<F> \<subseteq> U ` T" and "T \<subseteq> \<Union>\<F>"
        using T unfolding compactin_def by meson
      then obtain F where F: "finite F" "F \<subseteq> T" "\<F> = U ` F" and SUF: "T \<subseteq> \<Union>(U ` F)" and "a \<notin> F"
        using finite_subset_image [OF \<F>] \<open>a \<notin> T\<close> by (metis subsetD)
      have U: "\<And>x. \<lbrakk>x \<in> topspace X; x \<noteq> a\<rbrakk> \<Longrightarrow> openin X (U x)"
        and V: "\<And>x. \<lbrakk>x \<in> topspace X; x \<noteq> a\<rbrakk> \<Longrightarrow> openin X (V x)"
        and disj: "\<And>x. \<lbrakk>x \<in> topspace X; x \<noteq> a\<rbrakk> \<Longrightarrow> disjnt (U x) (V x)"
        using UV by blast+
      show ?thesis
      proof (intro exI conjI)
        have "F \<noteq> {}"
          using False SUF by blast
        with \<open>a \<notin> F\<close> show "openin X (\<Inter>(V ` F))"
          using F compactin_subset_topspace [OF T] by (force intro: V)
        show "openin X (\<Union>(U ` F))"
          using F Topen Tsub by (force intro: U)
        show "disjnt (\<Inter>(V ` F)) (\<Union>(U ` F))"
          using disj
          apply (auto simp: disjnt_def)
          using \<open>F \<subseteq> T\<close> \<open>a \<notin> F\<close> compactin_subset_topspace [OF T] by blast
        show "a \<in> (\<Inter>(V ` F))"
          using \<open>F \<subseteq> T\<close> T UV \<open>a \<notin> T\<close> compactin_subset_topspace by blast
      qed (auto simp: SUF)
    qed
  qed
  then obtain U V where UV: "\<forall>x \<in> S. openin X (U x) \<and> openin X (V x) \<and> x \<in> U x \<and> T \<subseteq> V x \<and> disjnt (U x) (V x)"
    by metis
  then have "S \<subseteq> \<Union> (U ` S)"
    by auto
  moreover have "\<forall>W \<in> U ` S. openin X W"
    using UV by blast
  ultimately obtain I where I: "S \<subseteq> \<Union> (U ` I)" "I \<subseteq> S" "finite I"
    by (metis S compactin_def finite_subset_image)
  show thesis
  proof
    show "openin X (\<Union>(U ` I))"
      using \<open>I \<subseteq> S\<close> UV by blast
    show "openin X (\<Inter> (V ` I))"
      using False UV \<open>I \<subseteq> S\<close> \<open>S \<subseteq> \<Union> (U ` I)\<close> \<open>finite I\<close> by blast
    show "disjnt (\<Union>(U ` I)) (\<Inter> (V ` I))"
      by simp (meson UV \<open>I \<subseteq> S\<close> disjnt_subset2 in_mono le_INF_iff order_refl)
  qed (use UV I in auto)
qed

lemma Hausdorff_space_compact_sets:
  "Hausdorff_space X \<longleftrightarrow>
    (\<forall>S T. compactin X S \<and> compactin X T \<and> disjnt S T
           \<longrightarrow> (\<exists>U V. openin X U \<and> openin X V \<and> S \<subseteq> U \<and> T \<subseteq> V \<and> disjnt U V))"
  (is "?lhs = ?rhs")
proof
  assume ?lhs
  then show ?rhs
    by (meson Hausdorff_space_compact_separation)
next
  assume R [rule_format]: ?rhs
  show ?lhs
  proof (clarsimp simp add: Hausdorff_space_def)
    fix x y
    assume "x \<in> topspace X" "y \<in> topspace X" "x \<noteq> y"
    then show "\<exists>U. openin X U \<and> (\<exists>V. openin X V \<and> x \<in> U \<and> y \<in> V \<and> disjnt U V)"
      using R [of "{x}" "{y}"] by auto
  qed
qed

lemma compactin_imp_closedin:
  assumes X: "Hausdorff_space X" and S: "compactin X S" shows "closedin X S"
proof -
  have "S \<subseteq> topspace X"
    by (simp add: assms compactin_subset_topspace)
  moreover
  have "\<exists>T. openin X T \<and> x \<in> T \<and> T \<subseteq> topspace X - S" if "x \<in> topspace X" "x \<notin> S" for x
    using Hausdorff_space_compact_separation [OF X _ S, of "{x}"] that
    apply (simp add: disjnt_def)
    by (metis Diff_mono Diff_triv openin_subset)
  ultimately show ?thesis
    using closedin_def openin_subopen by force
qed

lemma closedin_Hausdorff_singleton:
   "\<lbrakk>Hausdorff_space X; x \<in> topspace X\<rbrakk> \<Longrightarrow> closedin X {x}"
  by (simp add: Hausdorff_imp_t1_space closedin_t1_singleton)

lemma closedin_Hausdorff_sing_eq:
   "Hausdorff_space X \<Longrightarrow> closedin X {x} \<longleftrightarrow> x \<in> topspace X"
  by (meson closedin_Hausdorff_singleton closedin_subset insert_subset)

lemma Hausdorff_space_discrete_topology [simp]:
   "Hausdorff_space (discrete_topology U)"
  unfolding Hausdorff_space_def
  apply safe
  by (metis discrete_topology_unique_alt disjnt_empty2 disjnt_insert2 insert_iff mk_disjoint_insert topspace_discrete_topology)

lemma compactin_Int:
   "\<lbrakk>Hausdorff_space X; compactin X S; compactin X T\<rbrakk> \<Longrightarrow> compactin X (S \<inter> T)"
  by (simp add: closed_Int_compactin compactin_imp_closedin)

lemma finite_topspace_imp_discrete_topology:
   "\<lbrakk>topspace X = U; finite U; Hausdorff_space X\<rbrakk> \<Longrightarrow> X = discrete_topology U"
  using Hausdorff_imp_t1_space finite_t1_space_imp_discrete_topology by blast

lemma derived_set_of_finite:
   "\<lbrakk>Hausdorff_space X; finite S\<rbrakk> \<Longrightarrow> X derived_set_of S = {}"
  using Hausdorff_imp_t1_space t1_space_derived_set_of_finite by auto

lemma derived_set_of_singleton:
   "Hausdorff_space X \<Longrightarrow> X derived_set_of {x} = {}"
  by (simp add: derived_set_of_finite)

lemma closedin_Hausdorff_finite:
   "\<lbrakk>Hausdorff_space X; S \<subseteq> topspace X; finite S\<rbrakk> \<Longrightarrow> closedin X S"
  by (simp add: compactin_imp_closedin finite_imp_compactin_eq)

lemma open_in_Hausdorff_delete:
   "\<lbrakk>Hausdorff_space X; openin X S\<rbrakk> \<Longrightarrow> openin X (S - {x})"
  using Hausdorff_imp_t1_space t1_space_openin_delete_alt by auto

lemma closedin_Hausdorff_finite_eq:
   "\<lbrakk>Hausdorff_space X; finite S\<rbrakk> \<Longrightarrow> closedin X S \<longleftrightarrow> S \<subseteq> topspace X"
  by (meson closedin_Hausdorff_finite closedin_def)

lemma derived_set_of_infinite_openin:
   "Hausdorff_space X
        \<Longrightarrow> X derived_set_of S =
            {x \<in> topspace X. \<forall>U. x \<in> U \<and> openin X U \<longrightarrow> infinite(S \<inter> U)}"
  using Hausdorff_imp_t1_space t1_space_derived_set_of_infinite_openin by fastforce

lemma Hausdorff_space_discrete_compactin:
   "Hausdorff_space X
        \<Longrightarrow> S \<inter> X derived_set_of S = {} \<and> compactin X S \<longleftrightarrow> S \<subseteq> topspace X \<and> finite S"
  using derived_set_of_finite discrete_compactin_eq_finite by fastforce

lemma Hausdorff_space_finite_topspace:
   "Hausdorff_space X \<Longrightarrow> X derived_set_of (topspace X) = {} \<and> compact_space X \<longleftrightarrow> finite(topspace X)"
  using derived_set_of_finite discrete_compact_space_eq_finite by auto

lemma derived_set_of_derived_set_subset:
   "Hausdorff_space X \<Longrightarrow> X derived_set_of (X derived_set_of S) \<subseteq> X derived_set_of S"
  by (simp add: Hausdorff_imp_t1_space derived_set_of_derived_set_subset_gen)

lemma Hausdorff_space_injective_preimage:
  assumes "Hausdorff_space Y" and cmf: "continuous_map X Y f" and "inj_on f (topspace X)"
  shows "Hausdorff_space X"
  unfolding Hausdorff_space_def
proof clarify
  fix x y
  assume x: "x \<in> topspace X" and y: "y \<in> topspace X" and "x \<noteq> y"
  then obtain U V where "openin Y U" "openin Y V" "f x \<in> U" "f y \<in> V" "disjnt U V"
    using assms unfolding Hausdorff_space_def continuous_map_def by (meson inj_onD)
  show "\<exists>U V. openin X U \<and> openin X V \<and> x \<in> U \<and> y \<in> V \<and> disjnt U V"
  proof (intro exI conjI)
    show "openin X {x \<in> topspace X. f x \<in> U}"
      using \<open>openin Y U\<close> cmf continuous_map by fastforce
    show "openin X {x \<in> topspace X. f x \<in> V}"
      using \<open>openin Y V\<close> cmf openin_continuous_map_preimage by blast
    show "disjnt {x \<in> topspace X. f x \<in> U} {x \<in> topspace X. f x \<in> V}"
      using \<open>disjnt U V\<close> by (auto simp add: disjnt_def)
  qed (use x \<open>f x \<in> U\<close> y \<open>f y \<in> V\<close> in auto)
qed

lemma homeomorphic_Hausdorff_space:
   "X homeomorphic_space Y \<Longrightarrow> Hausdorff_space X \<longleftrightarrow> Hausdorff_space Y"
  unfolding homeomorphic_space_def homeomorphic_maps_map
  by (auto simp: homeomorphic_eq_everything_map Hausdorff_space_injective_preimage)

lemma Hausdorff_space_retraction_map_image:
   "\<lbrakk>retraction_map X Y r; Hausdorff_space X\<rbrakk> \<Longrightarrow> Hausdorff_space Y"
  unfolding retraction_map_def
  using Hausdorff_space_subtopology homeomorphic_Hausdorff_space retraction_maps_section_image2 by blast

lemma compact_Hausdorff_space_optimal:
  assumes eq: "topspace Y = topspace X" and XY: "\<And>U. openin X U \<Longrightarrow> openin Y U"
      and "Hausdorff_space X" "compact_space Y"
    shows "Y = X"
proof -
  have "\<And>U. closedin X U \<Longrightarrow> closedin Y U"
    using XY using topology_finer_closedin [OF eq]
    by metis
  have "openin Y S = openin X S" for S
    by (metis XY assms(3) assms(4) closedin_compact_space compactin_contractive compactin_imp_closedin eq openin_closedin_eq)
  then show ?thesis
    by (simp add: topology_eq)
qed

lemma continuous_map_imp_closed_graph:
  assumes f: "continuous_map X Y f" and Y: "Hausdorff_space Y"
  shows "closedin (prod_topology X Y) ((\<lambda>x. (x,f x)) ` topspace X)"
  unfolding closedin_def
proof
  show "(\<lambda>x. (x, f x)) ` topspace X \<subseteq> topspace (prod_topology X Y)"
    using continuous_map_def f by fastforce
  show "openin (prod_topology X Y) (topspace (prod_topology X Y) - (\<lambda>x. (x, f x)) ` topspace X)"
    unfolding openin_prod_topology_alt
  proof (intro allI impI)
    show "\<exists>U V. openin X U \<and> openin Y V \<and> x \<in> U \<and> y \<in> V \<and> U \<times> V \<subseteq> topspace (prod_topology X Y) - (\<lambda>x. (x, f x)) ` topspace X"
      if "(x,y) \<in> topspace (prod_topology X Y) - (\<lambda>x. (x, f x)) ` topspace X"
      for x y
    proof -
      have "x \<in> topspace X" "y \<in> topspace Y" "y \<noteq> f x"
        using that by auto
      moreover have "f x \<in> topspace Y"
        by (meson \<open>x \<in> topspace X\<close> continuous_map_def f)
      ultimately obtain U V where UV: "openin Y U" "openin Y V" "f x \<in> U" "y \<in> V" "disjnt U V"
        using Y Hausdorff_space_def by metis
      show ?thesis
      proof (intro exI conjI)
        show "openin X {x \<in> topspace X. f x \<in> U}"
          using \<open>openin Y U\<close> f openin_continuous_map_preimage by blast
        show "{x \<in> topspace X. f x \<in> U} \<times> V \<subseteq> topspace (prod_topology X Y) - (\<lambda>x. (x, f x)) ` topspace X"
          using UV by (auto simp: disjnt_iff dest: openin_subset)
      qed (use UV \<open>x \<in> topspace X\<close> in auto)
    qed
  qed
qed

lemma continuous_imp_closed_map:
   "\<lbrakk>continuous_map X Y f; compact_space X; Hausdorff_space Y\<rbrakk> \<Longrightarrow> closed_map X Y f"
  by (meson closed_map_def closedin_compact_space compactin_imp_closedin image_compactin)

lemma continuous_imp_quotient_map:
   "\<lbrakk>continuous_map X Y f; compact_space X; Hausdorff_space Y; f ` (topspace X) = topspace Y\<rbrakk>
        \<Longrightarrow> quotient_map X Y f"
  by (simp add: continuous_imp_closed_map continuous_closed_imp_quotient_map)

lemma continuous_imp_homeomorphic_map:
   "\<lbrakk>continuous_map X Y f; compact_space X; Hausdorff_space Y;
     f ` (topspace X) = topspace Y; inj_on f (topspace X)\<rbrakk>
        \<Longrightarrow> homeomorphic_map X Y f"
  by (simp add: continuous_imp_closed_map bijective_closed_imp_homeomorphic_map)

lemma continuous_imp_embedding_map:
   "\<lbrakk>continuous_map X Y f; compact_space X; Hausdorff_space Y; inj_on f (topspace X)\<rbrakk>
        \<Longrightarrow> embedding_map X Y f"
  by (simp add: continuous_imp_closed_map injective_closed_imp_embedding_map)

lemma continuous_inverse_map:
  assumes "compact_space X" "Hausdorff_space Y"
    and cmf: "continuous_map X Y f" and gf: "\<And>x. x \<in> topspace X \<Longrightarrow> g(f x) = x"
    and Sf:  "S \<subseteq> f ` (topspace X)"
  shows "continuous_map (subtopology Y S) X g"
proof (rule continuous_map_from_subtopology_mono [OF _ \<open>S \<subseteq> f ` (topspace X)\<close>])
  show "continuous_map (subtopology Y (f ` (topspace X))) X g"
    unfolding continuous_map_closedin
  proof (intro conjI ballI allI impI)
    fix x
    assume "x \<in> topspace (subtopology Y (f ` topspace X))"
    then show "g x \<in> topspace X"
      by (auto simp: gf)
  next
    fix C
    assume C: "closedin X C"
    show "closedin (subtopology Y (f ` topspace X))
           {x \<in> topspace (subtopology Y (f ` topspace X)). g x \<in> C}"
    proof (rule compactin_imp_closedin)
      show "Hausdorff_space (subtopology Y (f ` topspace X))"
        using Hausdorff_space_subtopology [OF \<open>Hausdorff_space Y\<close>] by blast
      have "compactin Y (f ` C)"
        using C cmf image_compactin closedin_compact_space [OF \<open>compact_space X\<close>] by blast
      moreover have "{x \<in> topspace Y. x \<in> f ` topspace X \<and> g x \<in> C} = f ` C"
        using closedin_subset [OF C] cmf by (auto simp: gf continuous_map_def)
      ultimately have "compactin Y {x \<in> topspace Y. x \<in> f ` topspace X \<and> g x \<in> C}"
        by simp
      then show "compactin (subtopology Y (f ` topspace X))
              {x \<in> topspace (subtopology Y (f ` topspace X)). g x \<in> C}"
        by (auto simp add: compactin_subtopology)
    qed
  qed
qed

lemma closed_map_paired_continuous_map_right:
   "\<lbrakk>continuous_map X Y f; Hausdorff_space Y\<rbrakk> \<Longrightarrow> closed_map X (prod_topology X Y) (\<lambda>x. (x,f x))"
  by (simp add: continuous_map_imp_closed_graph embedding_map_graph embedding_imp_closed_map)

lemma closed_map_paired_continuous_map_left:
  assumes f: "continuous_map X Y f" and Y: "Hausdorff_space Y"
  shows "closed_map X (prod_topology Y X) (\<lambda>x. (f x,x))"
proof -
  have eq: "(\<lambda>x. (f x,x)) = (\<lambda>(a,b). (b,a)) \<circ> (\<lambda>x. (x,f x))"
    by auto
  show ?thesis
    unfolding eq
  proof (rule closed_map_compose)
    show "closed_map X (prod_topology X Y) (\<lambda>x. (x, f x))"
      using Y closed_map_paired_continuous_map_right f by blast
    show "closed_map (prod_topology X Y) (prod_topology Y X) (\<lambda>(a, b). (b, a))"
      by (metis homeomorphic_map_swap homeomorphic_imp_closed_map)
  qed
qed

lemma proper_map_paired_continuous_map_right:
   "\<lbrakk>continuous_map X Y f; Hausdorff_space Y\<rbrakk>
        \<Longrightarrow> proper_map X (prod_topology X Y) (\<lambda>x. (x,f x))"
  using closed_injective_imp_proper_map closed_map_paired_continuous_map_right
  by (metis (mono_tags, lifting) Pair_inject inj_onI)

lemma proper_map_paired_continuous_map_left:
   "\<lbrakk>continuous_map X Y f; Hausdorff_space Y\<rbrakk>
        \<Longrightarrow> proper_map X (prod_topology Y X) (\<lambda>x. (f x,x))"
  using closed_injective_imp_proper_map closed_map_paired_continuous_map_left
  by (metis (mono_tags, lifting) Pair_inject inj_onI)

lemma Hausdorff_space_prod_topology:
  "Hausdorff_space(prod_topology X Y) \<longleftrightarrow> topspace(prod_topology X Y) = {} \<or> Hausdorff_space X \<and> Hausdorff_space Y"
  (is "?lhs = ?rhs")
proof
  assume ?lhs
  then show ?rhs
    by (rule topological_property_of_prod_component) (auto simp: Hausdorff_space_subtopology homeomorphic_Hausdorff_space)
next
  assume R: ?rhs
  show ?lhs
  proof (cases "(topspace X \<times> topspace Y) = {}")
    case False
    with R have ne: "topspace X \<noteq> {}" "topspace Y \<noteq> {}" and X: "Hausdorff_space X" and Y: "Hausdorff_space Y"
      by auto
    show ?thesis
      unfolding Hausdorff_space_def
    proof clarify
      fix x y x' y'
      assume xy: "(x, y) \<in> topspace (prod_topology X Y)"
        and xy': "(x',y') \<in> topspace (prod_topology X Y)"
        and *: "\<nexists>U V. openin (prod_topology X Y) U \<and> openin (prod_topology X Y) V
               \<and> (x, y) \<in> U \<and> (x', y') \<in> V \<and> disjnt U V"
      have False if "x \<noteq> x' \<or> y \<noteq> y'"
        using that
      proof
        assume "x \<noteq> x'"
        then obtain U V where "openin X U" "openin X V" "x \<in> U" "x' \<in> V" "disjnt U V"
          by (metis Hausdorff_space_def X mem_Sigma_iff topspace_prod_topology xy xy')
        let ?U = "U \<times> topspace Y"
        let ?V = "V \<times> topspace Y"
        have "openin (prod_topology X Y) ?U" "openin (prod_topology X Y) ?V"
          by (simp_all add: openin_prod_Times_iff \<open>openin X U\<close> \<open>openin X V\<close>)
        moreover have "disjnt ?U ?V"
          by (simp add: \<open>disjnt U V\<close>)
        ultimately show False
          using * \<open>x \<in> U\<close> \<open>x' \<in> V\<close> xy xy' by (metis SigmaD2 SigmaI topspace_prod_topology)
      next
        assume "y \<noteq> y'"
        then obtain U V where "openin Y U" "openin Y V" "y \<in> U" "y' \<in> V" "disjnt U V"
          by (metis Hausdorff_space_def Y mem_Sigma_iff topspace_prod_topology xy xy')
        let ?U = "topspace X \<times> U"
        let ?V = "topspace X \<times> V"
        have "openin (prod_topology X Y) ?U" "openin (prod_topology X Y) ?V"
          by (simp_all add: openin_prod_Times_iff \<open>openin Y U\<close> \<open>openin Y V\<close>)
        moreover have "disjnt ?U ?V"
          by (simp add: \<open>disjnt U V\<close>)
        ultimately show False
          using "*" \<open>y \<in> U\<close> \<open>y' \<in> V\<close> xy xy' by (metis SigmaD1 SigmaI topspace_prod_topology)
      qed
      then show "x = x' \<and> y = y'"
        by blast
    qed
  qed (simp add: Hausdorff_space_topspace_empty)
qed

lemma Hausdorff_space_product_topology:
   "Hausdorff_space (product_topology X I) \<longleftrightarrow> (\<Pi>\<^sub>E i\<in>I. topspace(X i)) = {} \<or> (\<forall>i \<in> I. Hausdorff_space (X i))"
  (is "?lhs = ?rhs")
proof
  assume ?lhs
  then show ?rhs
    apply (rule topological_property_of_product_component)
     apply (blast dest: Hausdorff_space_subtopology homeomorphic_Hausdorff_space)+
    done
next
  assume R: ?rhs
  show ?lhs
  proof (cases "(\<Pi>\<^sub>E i\<in>I. topspace(X i)) = {}")
    case True
    then show ?thesis
      by (simp add: Hausdorff_space_topspace_empty)
  next
    case False
    have "\<exists>U V. openin (product_topology X I) U \<and> openin (product_topology X I) V \<and> f \<in> U \<and> g \<in> V \<and> disjnt U V"
      if f: "f \<in> (\<Pi>\<^sub>E i\<in>I. topspace (X i))" and g: "g \<in> (\<Pi>\<^sub>E i\<in>I. topspace (X i))" and "f \<noteq> g"
      for f g :: "'a \<Rightarrow> 'b"
    proof -
      obtain m where "f m \<noteq> g m"
        using \<open>f \<noteq> g\<close> by blast
      then have "m \<in> I"
        using f g by fastforce
      then have "Hausdorff_space (X m)"
        using False that R by blast
      then obtain U V where U: "openin (X m) U" and V: "openin (X m) V" and "f m \<in> U" "g m \<in> V" "disjnt U V"
        by (metis Hausdorff_space_def PiE_mem \<open>f m \<noteq> g m\<close> \<open>m \<in> I\<close> f g)
      show ?thesis
      proof (intro exI conjI)
        let ?U = "(\<Pi>\<^sub>E i\<in>I. topspace(X i)) \<inter> {x. x m \<in> U}"
        let ?V = "(\<Pi>\<^sub>E i\<in>I. topspace(X i)) \<inter> {x. x m \<in> V}"
        show "openin (product_topology X I) ?U" "openin (product_topology X I) ?V"
          using \<open>m \<in> I\<close> U V
          by (force simp add: openin_product_topology intro: arbitrary_union_of_inc relative_to_inc finite_intersection_of_inc)+
        show "f \<in> ?U"
          using \<open>f m \<in> U\<close> f by blast
        show "g \<in> ?V"
          using \<open>g m \<in> V\<close> g by blast
        show "disjnt ?U ?V"
          using \<open>disjnt U V\<close> by (auto simp: PiE_def Pi_def disjnt_def)
        qed
    qed
    then show ?thesis
      by (simp add: Hausdorff_space_def)
  qed
qed

end


(* ---------------------------------------------------------------------------- *)
subsection \<open>Angle between two vectors\<close>
(* ---------------------------------------------------------------------------- *)

text \<open>In this section we introduce different measures of angle between two vectors (represented by complex numbers).\<close>

theory Angles
imports More_Transcendental Canonical_Angle More_Complex
begin

(* ---------------------------------------------------------------------------- *)
subsubsection \<open>Oriented angle\<close>
(* ---------------------------------------------------------------------------- *)

text \<open>Oriented angle between two vectors (it is always in the interval $(-\pi, \pi]$).\<close>
definition ang_vec ("\<angle>") where
  [simp]: "\<angle> z1 z2 \<equiv> \<downharpoonright>arg z2 - arg z1\<downharpoonleft>"

lemma ang_vec_bounded:
  shows "-pi < \<angle> z1 z2 \<and> \<angle> z1 z2 \<le> pi"
  by (simp add: canon_ang(1) canon_ang(2))

lemma ang_vec_sym:
  assumes "\<angle> z1 z2 \<noteq> pi"
  shows "\<angle> z1 z2 = - \<angle> z2 z1"
  using assms
  unfolding ang_vec_def
  using canon_ang_uminus[of "arg z2 - arg z1"]
  by simp

lemma ang_vec_sym_pi:
  assumes "\<angle> z1 z2 = pi"
  shows "\<angle> z1 z2 = \<angle> z2 z1"
  using assms
  unfolding ang_vec_def
  using canon_ang_uminus_pi[of "arg z2 - arg z1"]
  by simp

lemma ang_vec_plus_pi1:
  assumes "\<angle> z1 z2 > 0"
  shows "\<downharpoonright>\<angle> z1 z2 + pi\<downharpoonleft> = \<angle> z1 z2 - pi"
proof (rule canon_ang_eqI)
  show "\<exists> x::int. \<angle> z1 z2 - pi - (\<angle> z1 z2 + pi) = 2 * real_of_int x * pi"
    by (rule_tac x="-1" in exI) auto
next
  show "- pi < \<angle> z1 z2 - pi \<and> \<angle> z1 z2 - pi \<le> pi"
    using assms
    unfolding ang_vec_def
    using canon_ang(1)[of "arg z2 - arg z1"] canon_ang(2)[of "arg z2 - arg z1"]
    by auto
qed

lemma ang_vec_plus_pi2:
  assumes "\<angle> z1 z2 \<le> 0"
  shows "\<downharpoonright>\<angle> z1 z2 + pi\<downharpoonleft> = \<angle> z1 z2 + pi"
proof (rule canon_ang_id)
  show "- pi < \<angle> z1 z2 + pi \<and> \<angle> z1 z2 + pi \<le> pi"
    using assms
    unfolding ang_vec_def
    using canon_ang(1)[of "arg z2 - arg z1"] canon_ang(2)[of "arg z2 - arg z1"]
    by auto
qed

lemma ang_vec_opposite1:
  assumes "z1 \<noteq> 0"
  shows "\<angle> (-z1) z2 = \<downharpoonright>\<angle> z1 z2 - pi\<downharpoonleft>"
proof-
  have "\<angle> (-z1) z2 = \<downharpoonright>arg z2 - (arg z1 + pi)\<downharpoonleft>"
    unfolding ang_vec_def
    using arg_uminus[OF assms]
    using canon_ang_arg[of z2, symmetric]
    using canon_ang_diff[of "arg z2" "arg z1 + pi", symmetric]
    by simp
  moreover
  have "\<downharpoonright>\<angle> z1 z2 - pi\<downharpoonleft> = \<downharpoonright>arg z2 - arg z1 - pi\<downharpoonleft>"
    using canon_ang_id[of pi, symmetric]
    using canon_ang_diff[of "arg z2 - arg z1" "pi", symmetric]
    by simp_all
  ultimately
  show ?thesis
    by (simp add: field_simps)
qed

lemma ang_vec_opposite2:
  assumes "z2 \<noteq> 0"
  shows "\<angle> z1 (-z2) = \<downharpoonright>\<angle> z1 z2 + pi\<downharpoonleft>"
  unfolding ang_vec_def
  using arg_mult[of "-1" "z2"] assms
  using arg_complex_of_real_negative[of "-1"]
  using canon_ang_diff[of "arg (-1) + arg z2" "arg z1", symmetric]
  using canon_ang_sum[of "arg z2 - arg z1" "pi", symmetric]
  using canon_ang_id[of pi] canon_ang_arg[of z1]
  by (auto simp: algebra_simps)

lemma ang_vec_opposite_opposite:
  assumes "z1 \<noteq> 0" and "z2 \<noteq> 0"
  shows "\<angle> (-z1) (-z2) = \<angle> z1 z2"
proof-
  have "\<angle> (-z1) (-z2) = \<downharpoonright>\<downharpoonright>\<angle> z1 z2 + pi\<downharpoonleft> - \<downharpoonright>pi\<downharpoonleft>\<downharpoonleft>"
    using ang_vec_opposite1[OF assms(1)]
    using ang_vec_opposite2[OF assms(2)]
    using canon_ang_id[of pi, symmetric]
    by simp_all
  also have "... = \<downharpoonright>\<angle> z1 z2\<downharpoonleft>"
    by (subst canon_ang_diff[symmetric], simp)
  finally
  show ?thesis
    by (metis ang_vec_def canon_ang(1) canon_ang(2) canon_ang_id)
qed

lemma ang_vec_opposite_opposite':
  assumes "z1 \<noteq> z" and "z2 \<noteq> z"
  shows "\<angle> (z - z1) (z - z2) = \<angle> (z1 - z) (z2 - z)"
using ang_vec_opposite_opposite[of "z - z1" "z - z2"] assms
by (simp add: field_simps del: ang_vec_def)

text \<open>Cosine, scalar product and the law of cosines\<close>

lemma cos_cmod_scalprod:
  shows "cmod z1 * cmod z2 * (cos (\<angle> z1 z2)) = Re (scalprod z1 z2)"
proof (cases "z1 = 0 \<or> z2 = 0")
  case True
  thus ?thesis
    by auto
next
  case False
  thus ?thesis
    by (simp add: cos_diff cos_arg sin_arg field_simps)
qed

lemma cos0_scalprod0:
  assumes "z1 \<noteq> 0" and "z2 \<noteq> 0"
  shows "cos (\<angle> z1 z2) = 0 \<longleftrightarrow> scalprod z1 z2 = 0"
  using assms
  using cnj_mix_real[of z1 z2]
  using cos_cmod_scalprod[of z1 z2]
  by (auto simp add: complex_eq_if_Re_eq)

lemma ortho_scalprod0:
  assumes "z1 \<noteq> 0" and "z2 \<noteq> 0"
  shows "\<angle> z1 z2 = pi/2 \<or> \<angle> z1 z2 = -pi/2 \<longleftrightarrow> scalprod z1 z2 = 0"
  using cos0_scalprod0[OF assms]
  using ang_vec_bounded[of z1 z2]
  using cos_0_iff_canon[of "\<angle> z1 z2"]
  by (metis cos_minus cos_pi_half divide_minus_left)

lemma law_of_cosines:
  shows "(cdist B C)\<^sup>2 = (cdist A C)\<^sup>2 + (cdist A B)\<^sup>2 - 2*(cdist A C)*(cdist A B)*(cos (\<angle> (C-A) (B-A)))"
proof-
  let ?a = "C-B" and ?b = "C-A" and ?c = "B-A"
  have "?a = ?b - ?c"
    by simp
  hence "(cmod ?a)\<^sup>2 = (cmod (?b - ?c))\<^sup>2"
    by metis
  also have "... = Re (scalprod (?b-?c) (?b-?c))"
    by (simp add: cmod_square)
  also have "... = (cmod ?b)\<^sup>2 + (cmod ?c)\<^sup>2 - 2*Re (scalprod ?b ?c)"
    by (simp add: cmod_square field_simps)
  finally
  show ?thesis
    using cos_cmod_scalprod[of ?b ?c]
    by simp
qed

(* ---------------------------------------------------------------------------- *)
subsubsection \<open>Unoriented angle\<close>
(* ---------------------------------------------------------------------------- *)

text \<open>Convex unoriented angle between two vectors (it is always in the interval $[0, pi]$).\<close>
definition ang_vec_c ("\<angle>c") where
  [simp]:"\<angle>c z1 z2 \<equiv> abs (\<angle> z1 z2)"

lemma ang_vec_c_sym:
  shows "\<angle>c z1 z2 = \<angle>c z2 z1"
  unfolding ang_vec_c_def
  using ang_vec_sym_pi[of z1 z2] ang_vec_sym[of z1 z2]
  by (cases "\<angle> z1 z2 = pi") auto

lemma ang_vec_c_bounded: "0 \<le> \<angle>c z1 z2 \<and> \<angle>c z1 z2 \<le> pi"
  using canon_ang(1)[of "arg z2 - arg z1"] canon_ang(2)[of "arg z2 - arg z1"]
  by auto

text \<open>Cosine and scalar product\<close>

lemma cos_c_: "cos (\<angle>c z1 z2) = cos (\<angle> z1 z2)"
  unfolding ang_vec_c_def
  by (smt cos_minus)

lemma ortho_c_scalprod0:
  assumes "z1 \<noteq> 0" and "z2 \<noteq> 0"
  shows "\<angle>c z1 z2 = pi/2 \<longleftrightarrow> scalprod z1 z2 = 0"
proof-
  have "\<angle> z1 z2 = pi / 2 \<or> \<angle> z1 z2 = - pi / 2 \<longleftrightarrow> \<angle>c z1 z2 = pi/2"
    unfolding ang_vec_c_def
    using arctan
    by force
  thus ?thesis
    using ortho_scalprod0[OF assms]
    by simp
qed

(* ---------------------------------------------------------------------------- *)
subsubsection \<open>Acute angle\<close>
(* ---------------------------------------------------------------------------- *)

text \<open>Acute or right angle (non-obtuse) between two vectors (it is always in the interval $[0, \frac{\pi}{2}$]).
We will use this to measure angle between two circles, since it can always be acute (or right).\<close>

definition acute_ang where
  [simp]: "acute_ang \<alpha> = (if \<alpha> > pi / 2 then pi - \<alpha> else \<alpha>)"

definition ang_vec_a ("\<angle>a") where
  [simp]: "\<angle>a z1 z2 \<equiv> acute_ang (\<angle>c z1 z2)"

lemma ang_vec_a_sym:
  "\<angle>a z1 z2 = \<angle>a z2 z1"
  unfolding ang_vec_a_def
  using ang_vec_c_sym
  by auto

lemma ang_vec_a_opposite2:
  "\<angle>a z1 z2 = \<angle>a z1 (-z2)"
proof(cases "z2  = 0")
  case True
  thus ?thesis
    by (metis minus_zero)
next
  case False
  thus ?thesis
  proof(cases "\<angle> z1 z2 < -pi / 2")
    case True
    hence "\<angle> z1 z2 < 0"
      using pi_not_less_zero
      by linarith
    have "\<angle>a z1 z2 = pi + \<angle> z1 z2"
      using True \<open>\<angle> z1 z2 < 0\<close>
      unfolding ang_vec_a_def ang_vec_c_def ang_vec_a_def abs_real_def
      by auto
    moreover
    have "\<angle>a z1 (-z2) = pi + \<angle> z1 z2"
      unfolding ang_vec_a_def ang_vec_c_def abs_real_def
      using canon_ang(1)[of "arg z2 - arg z1"] canon_ang(2)[of "arg z2 - arg z1"]
      using ang_vec_plus_pi2[of z1 z2] True \<open>\<angle> z1 z2 < 0\<close> \<open>z2 \<noteq> 0\<close>
      using ang_vec_opposite2[of z2 z1]
      by auto
    ultimately
    show ?thesis
      by auto
  next
    case False
    show ?thesis
    proof (cases "\<angle> z1 z2 \<le> 0")
      case True
      have "\<angle>a z1 z2 = - \<angle> z1 z2"
        using \<open>\<not> \<angle> z1 z2 < - pi / 2\<close> True
        unfolding ang_vec_a_def ang_vec_c_def ang_vec_a_def abs_real_def
        by auto
      moreover
      have "\<angle>a z1 (-z2) = - \<angle> z1 z2"
        using \<open>\<not> \<angle> z1 z2 < - pi / 2\<close> True
        unfolding ang_vec_a_def ang_vec_c_def abs_real_def
        using ang_vec_plus_pi2[of z1 z2]
        using canon_ang(1)[of "arg z2 - arg z1"] canon_ang(2)[of "arg z2 - arg z1"]
        using \<open>z2 \<noteq> 0\<close> ang_vec_opposite2[of z2 z1]
        by auto
      ultimately
      show ?thesis
        by simp
    next
      case False
      show ?thesis
      proof (cases "\<angle> z1 z2 < pi / 2")
        case True
        have "\<angle>a z1 z2 = \<angle> z1 z2"
          using \<open>\<not> \<angle> z1 z2 \<le> 0\<close> True
          unfolding ang_vec_a_def ang_vec_c_def ang_vec_a_def abs_real_def
          by auto
        moreover
        have "\<angle>a z1 (-z2) = \<angle> z1 z2"
          using \<open>\<not> \<angle> z1 z2 \<le> 0\<close> True
          unfolding ang_vec_a_def ang_vec_c_def abs_real_def
          using ang_vec_plus_pi1[of z1 z2]
          using canon_ang(1)[of "arg z2 - arg z1"] canon_ang(2)[of "arg z2 - arg z1"]
          using \<open>z2 \<noteq> 0\<close> ang_vec_opposite2[of z2 z1]
          by auto
        ultimately
        show ?thesis
          by simp
      next
        case False
        have "\<angle> z1 z2 > 0"
          using False
          by (metis less_linear less_trans pi_half_gt_zero)
        have "\<angle>a z1 z2 = pi - \<angle> z1 z2"
          using False \<open>\<angle> z1 z2 > 0\<close>
          unfolding ang_vec_a_def ang_vec_c_def ang_vec_a_def abs_real_def
          by auto
        moreover
        have "\<angle>a z1 (-z2) = pi - \<angle> z1 z2"
          unfolding ang_vec_a_def ang_vec_c_def abs_real_def
          using False \<open>\<angle> z1 z2 > 0\<close>
          using ang_vec_plus_pi1[of z1 z2]
          using canon_ang(1)[of "arg z2 - arg z1"] canon_ang(2)[of "arg z2 - arg z1"]
          using \<open>z2 \<noteq> 0\<close> ang_vec_opposite2[of z2 z1]
          by auto
        ultimately
        show ?thesis
          by auto
      qed
    qed
  qed
qed

lemma ang_vec_a_opposite1:
  shows "\<angle>a z1 z2 = \<angle>a (-z1) z2"
  using ang_vec_a_sym[of "-z1" z2] ang_vec_a_opposite2[of z2 z1] ang_vec_a_sym[of z2 z1]
  by auto

lemma ang_vec_a_scale1:
  assumes "k \<noteq> 0"
  shows "\<angle>a (cor k * z1) z2 = \<angle>a z1 z2"
proof (cases "k > 0")
  case True
  thus ?thesis
    unfolding ang_vec_a_def ang_vec_c_def ang_vec_def
    using arg_mult_real_positive[of k z1]
    by auto
next
  case False
  hence "k < 0"
    using assms
    by auto
  thus ?thesis
    using arg_mult_real_negative[of k z1]
    using ang_vec_a_opposite1[of z1 z2]
    unfolding ang_vec_a_def ang_vec_c_def ang_vec_def
    by simp
qed

lemma ang_vec_a_scale2:
  assumes "k \<noteq> 0"
  shows "\<angle>a z1 (cor k * z2) = \<angle>a z1 z2"
  using ang_vec_a_sym[of z1 "complex_of_real k * z2"]
  using ang_vec_a_scale1[OF assms, of z2 z1]
  using ang_vec_a_sym[of z1 z2]
  by auto

lemma ang_vec_a_scale:
  assumes "k1 \<noteq> 0" and "k2 \<noteq> 0"
  shows "\<angle>a (cor k1 * z1) (cor k2 * z2) = \<angle>a z1 z2"
  using ang_vec_a_scale1[OF assms(1)] ang_vec_a_scale2[OF assms(2)]
  by auto

lemma ang_a_cnj_cnj:
  shows "\<angle>a z1 z2 = \<angle>a (cnj z1) (cnj z2)"
unfolding ang_vec_a_def ang_vec_c_def ang_vec_def
proof(cases "arg z1 \<noteq> pi \<and> arg z2 \<noteq> pi")
  case True
  thus "acute_ang \<bar>\<downharpoonright>arg z2 - arg z1\<downharpoonleft>\<bar> = acute_ang \<bar>\<downharpoonright>arg (cnj z2) - arg (cnj z1)\<downharpoonleft>\<bar>"
    using arg_cnj_not_pi[of z1] arg_cnj_not_pi[of z2]
    apply (auto simp del:acute_ang_def)
    proof(cases "\<downharpoonright>arg z2 - arg z1\<downharpoonleft> = pi")
      case True
      thus "acute_ang \<bar>\<downharpoonright>arg z2 - arg z1\<downharpoonleft>\<bar> = acute_ang \<bar>\<downharpoonright>arg z1 - arg z2\<downharpoonleft>\<bar>"
        using  canon_ang_uminus_pi[of "arg z2 - arg z1"]
        by (auto simp add:field_simps)
    next
      case False
      thus "acute_ang \<bar>\<downharpoonright>arg z2 - arg z1\<downharpoonleft>\<bar> = acute_ang \<bar>\<downharpoonright>arg z1 - arg z2\<downharpoonleft>\<bar>"
        using  canon_ang_uminus[of "arg z2 - arg z1"]
        by (auto simp add:field_simps)
    qed
  next
    case False
    thus "acute_ang \<bar>\<downharpoonright>arg z2 - arg z1\<downharpoonleft>\<bar> = acute_ang \<bar>\<downharpoonright>arg (cnj z2) - arg (cnj z1)\<downharpoonleft>\<bar>"
    proof(cases "arg z1 = pi")
      case False
      hence "arg z2 = pi"
        using \<open> \<not> (arg z1 \<noteq> pi \<and> arg z2 \<noteq> pi)\<close>
        by auto
      thus ?thesis
        using False
        using arg_cnj_not_pi[of z1] arg_cnj_pi[of z2]
        apply (auto simp del:acute_ang_def)
      proof(cases "arg z1 > 0")
          case True
          hence "-arg z1 \<le> 0"
            by auto
          thus "acute_ang \<bar>\<downharpoonright>pi - arg z1\<downharpoonleft>\<bar> = acute_ang \<bar>\<downharpoonright>pi + arg z1\<downharpoonleft>\<bar>"
            using True canon_ang_plus_pi1[of "arg z1"]
            using arg_bounded[of z1] canon_ang_plus_pi2[of "-arg z1"]
            by (auto simp add:field_simps)
        next
          case False
          hence "-arg z1 \<ge> 0"
             by simp
          thus "acute_ang \<bar>\<downharpoonright>pi - arg z1\<downharpoonleft>\<bar> = acute_ang \<bar>\<downharpoonright>pi + arg z1\<downharpoonleft>\<bar>"
          proof(cases "arg z1 = 0")
            case True
            thus ?thesis
              by (auto simp del:acute_ang_def)
          next
            case False
            hence "-arg z1 > 0"
              using \<open>-arg z1 \<ge> 0\<close>
              by auto
            thus ?thesis
            using False canon_ang_plus_pi1[of "-arg z1"]
            using arg_bounded[of z1] canon_ang_plus_pi2[of "arg z1"]
            by (auto simp add:field_simps)
        qed
      qed
    next
      case True
      thus ?thesis
        using arg_cnj_pi[of z1]
        apply (auto simp del:acute_ang_def)
      proof(cases "arg z2 = pi")
        case True
        thus "acute_ang \<bar>\<downharpoonright>arg z2 - pi\<downharpoonleft>\<bar> = acute_ang \<bar>\<downharpoonright>arg (cnj z2) - pi\<downharpoonleft>\<bar>"
          using arg_cnj_pi[of z2]
          by auto
      next
        case False
        thus "acute_ang \<bar>\<downharpoonright>arg z2 - pi\<downharpoonleft>\<bar> = acute_ang \<bar>\<downharpoonright>arg (cnj z2) - pi\<downharpoonleft>\<bar>"
          using arg_cnj_not_pi[of z2]
          apply (auto simp del:acute_ang_def)
        proof(cases "arg z2 > 0")
          case True
          hence "-arg z2 \<le> 0"
            by auto
          thus "acute_ang \<bar>\<downharpoonright>arg z2 - pi\<downharpoonleft>\<bar> = acute_ang \<bar>\<downharpoonright>- arg z2 - pi\<downharpoonleft>\<bar>"
            using True canon_ang_minus_pi1[of "arg z2"]
            using arg_bounded[of z2] canon_ang_minus_pi2[of "-arg z2"]
            by (auto simp add: field_simps)
        next
          case False
          hence "-arg z2 \<ge> 0"
             by simp
          thus "acute_ang \<bar>\<downharpoonright>arg z2 - pi\<downharpoonleft>\<bar> = acute_ang \<bar>\<downharpoonright>- arg z2 - pi\<downharpoonleft>\<bar>"
          proof(cases "arg z2 = 0")
            case True
            thus ?thesis
              by (auto simp del:acute_ang_def)
          next
            case False
            hence "-arg z2 > 0"
              using \<open>-arg z2 \<ge> 0\<close>
              by auto
            thus ?thesis
            using False canon_ang_minus_pi1[of "-arg z2"]
            using arg_bounded[of z2] canon_ang_minus_pi2[of "arg z2"]
            by (auto simp add:field_simps)
        qed
      qed
    qed
  qed
qed

text \<open>Cosine and scalar product\<close>

lemma ortho_a_scalprod0:
  assumes "z1 \<noteq> 0" and "z2 \<noteq> 0"
  shows "\<angle>a z1 z2 = pi/2 \<longleftrightarrow> scalprod z1 z2 = 0"
  unfolding ang_vec_a_def
  using assms ortho_c_scalprod0[of z1 z2]
  by auto

declare ang_vec_c_def[simp del]

lemma cos_a_c: "cos (\<angle>a z1 z2) = abs (cos (\<angle>c z1 z2))"
proof-
  have "0 \<le> \<angle>c z1 z2" "\<angle>c z1 z2 \<le> pi"
    using ang_vec_c_bounded[of z1 z2]
    by auto
  show ?thesis
  proof (cases "\<angle>c z1 z2 = pi/2")
    case True
    thus ?thesis
      unfolding ang_vec_a_def acute_ang_def
      by (smt cos_pi_half pi_def pi_half)
  next
    case False
    show ?thesis
    proof (cases "\<angle>c z1 z2 < pi / 2")
      case True
      thus ?thesis
        using `0 \<le> \<angle>c z1 z2`
        using cos_gt_zero_pi[of "\<angle>c z1 z2"]
        unfolding ang_vec_a_def
        by simp
    next
      case False
      hence "\<angle>c z1 z2 > pi/2"
        using `\<angle>c z1 z2 \<noteq> pi/2`
        by simp
      hence "cos (\<angle>c z1 z2) < 0"
        using `\<angle>c z1 z2 \<le> pi`
        using cos_lt_zero_on_pi2_pi[of "\<angle>c z1 z2"]
        by simp
      thus ?thesis
        using `\<angle>c z1 z2 > pi/2`
        unfolding ang_vec_a_def
        by simp
    qed
  qed
qed

end


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

Auxiliary definitions needed in Priority.thy
*)

theory PriorityAux
imports "../UNITY_Main"
begin

typedecl vertex

definition symcl :: "(vertex*vertex)set=>(vertex*vertex)set" where
  "symcl r == r \<union> (r^-1)"
    \<comment>\<open>symmetric closure: removes the orientation of a relation\<close>

definition neighbors :: "[vertex, (vertex*vertex)set]=>vertex set" where
  "neighbors i r == ((r \<union> r^-1)``{i}) - {i}"
    \<comment>\<open>Neighbors of a vertex i\<close>

definition R :: "[vertex, (vertex*vertex)set]=>vertex set" where
  "R i r == r``{i}"

definition A :: "[vertex, (vertex*vertex)set]=>vertex set" where
  "A i r == (r^-1)``{i}"

definition reach :: "[vertex, (vertex*vertex)set]=> vertex set" where
  "reach i r == (r^+)``{i}"
    \<comment>\<open>reachable and above vertices: the original notation was R* and A*\<close>

definition above :: "[vertex, (vertex*vertex)set]=> vertex set" where
  "above i r == ((r^-1)^+)``{i}"

definition reverse :: "[vertex, (vertex*vertex) set]=>(vertex*vertex)set" where
  "reverse i r == (r - {(x,y). x=i | y=i} \<inter> r) \<union> ({(x,y). x=i|y=i} \<inter> r)^-1"

definition derive1 :: "[vertex, (vertex*vertex)set, (vertex*vertex)set]=>bool" where
    \<comment>\<open>The original definition\<close>
  "derive1 i r q == symcl r = symcl q &
                    (\<forall>k k'. k\<noteq>i & k'\<noteq>i -->((k,k'):r) = ((k,k'):q)) &
                    A i r = {} & R i q = {}"

definition derive :: "[vertex, (vertex*vertex)set, (vertex*vertex)set]=>bool" where
    \<comment>\<open>Our alternative definition\<close>
  "derive i r q == A i r = {} & (q = reverse i r)"

axiomatization where
  finite_vertex_univ:  "finite (UNIV :: vertex set)"
    \<comment>\<open>we assume that the universe of vertices is finite\<close>

declare derive_def [simp] derive1_def [simp] symcl_def [simp]
        A_def [simp] R_def [simp]
        above_def [simp] reach_def [simp]
        reverse_def [simp] neighbors_def [simp]

text\<open>All vertex sets are finite\<close>
declare finite_subset [OF subset_UNIV finite_vertex_univ, iff]

text\<open>and relatons over vertex are finite too\<close>

lemmas finite_UNIV_Prod =
       finite_Prod_UNIV [OF finite_vertex_univ finite_vertex_univ]

declare finite_subset [OF subset_UNIV finite_UNIV_Prod, iff]

(* The equalities (above i r = {}) = (A i r = {})
   and (reach i r = {}) = (R i r) rely on the following theorem  *)

lemma image0_trancl_iff_image0_r: "((r^+)``{i} = {}) = (r``{i} = {})"
apply auto
apply (erule trancl_induct, auto)
done

(* Another form usefull in some situation *)
lemma image0_r_iff_image0_trancl: "(r``{i}={}) = (ALL x. ((i,x):r^+) = False)"
apply auto
apply (drule image0_trancl_iff_image0_r [THEN ssubst], auto)
done

(* In finite universe acyclic coincides with wf *)
lemma acyclic_eq_wf: "!!r::(vertex*vertex)set. acyclic r = wf r"
by (auto simp add: wf_iff_acyclic_if_finite)

(* derive and derive1 are equivalent *)
lemma derive_derive1_eq: "derive i r q = derive1 i r q"
by auto

(* Lemma 1 *)
lemma lemma1_a:
     "[| x \<in> reach i q; derive1 k r q |] ==> x\<noteq>k --> x \<in> reach i r"
apply (unfold reach_def)
apply (erule ImageE)
apply (erule trancl_induct)
 apply (cases "i=k", simp_all)
 apply (blast, blast, clarify)
apply (drule_tac x = y in spec)
apply (drule_tac x = z in spec)
apply (blast dest: r_into_trancl intro: trancl_trans)
done

lemma reach_lemma: "derive k r q ==> reach i q \<subseteq> (reach i r \<union> {k})"
apply clarify
apply (drule lemma1_a)
apply (auto simp add: derive_derive1_eq
            simp del: reach_def derive_def derive1_def)
done

(* An other possible formulation of the above theorem based on
   the equivalence x \<in> reach y r = y \<in> above x r                  *)
lemma reach_above_lemma:
      "(\<forall>i. reach i q \<subseteq> (reach i r \<union> {k})) =
       (\<forall>x. x\<noteq>k --> (\<forall>i. i \<notin> above x r --> i \<notin> above x q))"
by (auto simp add: trancl_converse)

(* Lemma 2 *)
lemma maximal_converse_image0:
     "(z, i):r^+ ==> (\<forall>y. (y, z):r --> (y,i) \<notin> r^+) = ((r^-1)``{z}={})"
apply auto
apply (frule_tac r = r in trancl_into_trancl2, auto)
done

lemma above_lemma_a:
     "acyclic r ==> A i r\<noteq>{}-->(\<exists>j \<in> above i r. A j r = {})"
apply (simp add: acyclic_eq_wf wf_eq_minimal)
apply (drule_tac x = " ((r^-1) ^+) ``{i}" in spec)
apply auto
apply (simp add: maximal_converse_image0 trancl_converse)
done

lemma above_lemma_b:
     "acyclic r ==> above i r\<noteq>{}-->(\<exists>j \<in> above i r. above j r = {})"
apply (drule above_lemma_a)
apply (auto simp add: image0_trancl_iff_image0_r)
done

end


theory QSort
imports Main
begin

(* first, define some rules about what it means to be sorted. *)

fun sorted :: "'a::ord list \<Rightarrow> bool" where
   "sorted [] = True"
 | "sorted [x] = True"
 | "sorted (x#y#zs) = ((x \<le> y) \<and> sorted (y#zs))"

lemma sorted_lt:
  assumes "sorted (x#y#zs)"
  shows "x \<le> y" using assms by auto

lemma sorted_behead:
  assumes "sorted (y#zs)"
  shows "sorted zs" using assms by (induction zs; auto)

lemma sorted_cons:
  fixes x y zs
  assumes "x\<le>y" and "sorted (y#zs)"
  shows "sorted (x#y#zs)" using assms by auto

lemma lt_trans:
  fixes x y z
  assumes "(x \<le> y)" and "(y \<le> z)"
  shows "(x \<le> z)"
  sorry

lemma sorted_nip:
  fixes x y zs z zz
  assumes a0:"sorted (x#y#zs)" and a1:"zs=(z#zz)"
  shows "sorted (x#zs)" using assms
proof -
  have "sorted zs"
    proof -
      from a0 have "sorted (y#zs)" by (rule sorted_behead)
      thus ?thesis by (rule sorted_behead)
    qed

  also have "x\<le>z"
    proof -
      have "x\<le>y" and "y\<le>z" using a0 a1 by auto
      thus ?thesis by (rule lt_trans)
    qed

  thus ?thesis using assms by (auto)
qed

lemma sorted_head_shrink:
  fixes x y zs z zz
  assumes "x \<le> y" and "sorted (y#zs)" and zz:"zs=(z#zz)"
  shows "sorted (x#zs)"
proof -
  have "sorted (x#y#zs)" using assms by auto
  from this and zz show ?thesis by (rule sorted_nip)
qed

(* rules about the minimum item in a list (and particularly a sorted list) *)

lemma minxy [simp]:
  assumes "x \<le> y" shows "(min x y) = x"
  using assms by (simp only: min_def; auto)

fun listmin :: "'a::ord list \<Rightarrow> 'a" where
   "listmin [] = undefined"
 | "listmin [x] = x"
 | "listmin (x#xs) = min x (listmin xs)"

lemma assumes "sorted (x#y#zs)" shows "listmin (x#y#zs) = x" using assms
by (induction zs arbitrary: x y rule: listmin.induct; auto)

lemma assumes "sorted (x#xs)" shows "listmin (x#xs) = x" using assms
by (induction xs arbitrary: x rule: listmin.induct; auto)

(* same for max item *)

lemma gt_vs_le:
  fixes x y
  assumes "x > y"
  shows "\<not>(x \<le> y)"
  sorry (* I have no idea yet why this isn't proved automatically :/ *)

lemma maxxy [simp]:
  fixes x y assumes "x > y"
  shows "(max x y) = x"
  using assms
proof -
  have  "(max x y)= (if x \<le> y then y else x)" by (rule max_def)
  hence "(max x y)= (if False then y else x)" using assms by (simp only: gt_vs_le)
  then show ?thesis by auto
qed

fun listmax :: "'a::ord list \<Rightarrow> 'a" where
   "listmax [] = undefined"
 | "listmax [x] = x"
 | "listmax (x#xs) = max x (listmax xs)"

lemma [simp]: "listmax [x,y] = max x y" by auto

lemma sorted_concat:
  assumes "sorted (y0#ys)"
      and "sorted xs"
      and "listmax(x) < y0"
    shows "sorted (xs @ ys)"
    sorry (* TODO *)

(* and now, the (functional-style) quicksort: *)

fun qsort :: "'a::ord list \<Rightarrow> 'a list" where
   "qsort [] = []"
 | "qsort (x#ys) = (qsort [y \<leftarrow> ys. y<x]) @ (x # qsort [y \<leftarrow> ys. y \<ge> x])"

value "qsort [ 5, 9, 2, 3, 4 ] :: int list"

lemma "sorted (qsort [])" by auto
lemma "sorted (qsort [x])" by auto

theorem "sorted (qsort (x#ys))"
sorry

(* proof (induct ys rule: qsort.induct)
  show "sorted (qsort [x])" by auto
next
  let ?lt = "[y \<leftarrow> ys. y < x]"
  let ?ge = "[y \<leftarrow> ys. y \<ge> x]"
  have  q0: "qsort (x#ys) = (qsort ?lt) @ (x # qsort ?ge)" by auto
  sorry
qed *)

end