(*  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
refinement and verification components.\<close>

theory HS_VC_KAT_Examples_ndfun
  imports
    HS_VC_KAT_ndfun
    "HOL-Eisbach.Eisbach"

begin

\<comment> \<open>A tactic for verification of hybrid programs \<close>

named_theorems hoare_intros

declare H_assignl [hoare_intros]
    and H_cond [hoare_intros]
    and local_flow.H_g_ode_subset [hoare_intros]
    and H_g_ode_inv [hoare_intros]

method body_hoare
  = (rule hoare_intros,(simp)?; body_hoare?)

method hyb_hoare for P::"'a pred"
  = (rule H_loopI, rule H_seq[where R=P]; body_hoare?)

\<comment> \<open>A tactic for refinement of hybrid programs \<close>

named_theorems refine_intros "selected refinement lemmas"

declare R_loopI [refine_intros]
    and R_loop_mono [refine_intros]
    and R_cond_law [refine_intros]
    and R_cond_mono [refine_intros]
    and R_while_law [refine_intros]
    and R_assignl [refine_intros]
    and R_seq_law [refine_intros]
    and R_seq_mono [refine_intros]
    and R_g_evol_law [refine_intros]
    and R_skip [refine_intros]
    and R_g_ode_inv [refine_intros]

method refinement
  = (rule refine_intros; (refinement)?)

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> \<tau> s \<equiv> (\<chi> i. if i = 1 then s$1 \<cdot> cos \<tau> + s$2 \<cdot> sin \<tau>
  else - s$1 \<cdot> sin \<tau> + s$2 \<cdot> cos \<tau>)"

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

lemma pendulum_dyn: "\<^bold>{\<lambda>s. r\<^sup>2 = (s $ 1)\<^sup>2 + (s $ 2)\<^sup>2\<^bold>} EVOL \<phi> G T \<^bold>{\<lambda>s. r\<^sup>2 = (s $ 1)\<^sup>2 + (s $ 2)\<^sup>2\<^bold>}"
  by simp

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

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

\<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: "\<^bold>{\<lambda>s. r\<^sup>2 = (s $ 1)\<^sup>2 + (s $ 2)\<^sup>2\<^bold>} (x\<acute>=f & G) \<^bold>{\<lambda>s. r\<^sup>2 = (s $ 1)\<^sup>2 + (s $ 2)\<^sup>2\<^bold>}"
  by (subst local_flow.sH_g_ode_subset[OF local_flow_pend], simp_all)

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 \<tau> s \<equiv> (\<chi> i. if i=1 then g \<cdot> \<tau> ^ 2/2 + s$2 \<cdot> \<tau> + s$1 else g \<cdot> \<tau> + s$2)"

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

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

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

lemma fball_invariant:
  fixes g h :: real
  defines dinv: "I \<equiv> (\<lambda>s. 2 \<cdot> g \<cdot> s$1 - 2 \<cdot> g \<cdot> h - (s$2 \<cdot> s$2) = 0)"
  shows "diff_invariant I (\<lambda>t. f g) (\<lambda>s. UNIV) UNIV 0 G"
  unfolding dinv apply(rule diff_invariant_rules, simp)
  by(auto intro!: poly_derivatives)

lemma bouncing_ball_inv: "g < 0 \<Longrightarrow> h \<ge> 0 \<Longrightarrow>
  \<^bold>{\<lambda>s. s$1 = h \<and> s$2 = 0\<^bold>}
  (LOOP
      ((x\<acute>= f g & (\<lambda> s. s$1 \<ge> 0) DINV (\<lambda>s. 2 \<cdot> g \<cdot> s$1 - 2 \<cdot> g \<cdot> h - s$2 \<cdot> 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 \<cdot> g \<cdot> s$1 = 2 \<cdot> g \<cdot> h + s$2 \<cdot> s$2)
  ) \<^bold>{\<lambda>s. 0 \<le> s$1 \<and> s$1 \<le> h\<^bold>}"
  apply(hyb_hoare "\<lambda>s::real^2. 0 \<le> s$1 \<and> 2 \<cdot> g \<cdot> s$1 = 2 \<cdot> g \<cdot> h + s$2 \<cdot> s$2")
  using fball_invariant by (auto simp: bb_real_arith intro!: poly_derivatives diff_invariant_rules)

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

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

lemma [bb_real_arith]:
  assumes invar: "2 \<cdot> g \<cdot> x = 2 \<cdot> g \<cdot> h + v \<cdot> v"
  shows "2 \<cdot> g \<cdot> (g \<cdot> \<tau>\<^sup>2 / 2 + v \<cdot> \<tau> + (x::real)) =
  2 \<cdot> g \<cdot> h + (g \<cdot> \<tau> \<cdot> (g \<cdot> \<tau> + v) + v \<cdot> (g \<cdot> \<tau> + v))" (is "?lhs = ?rhs")
proof-
  have "?lhs = g\<^sup>2 \<cdot> \<tau>\<^sup>2 + 2 \<cdot> g \<cdot> v \<cdot> \<tau> + 2 \<cdot> g \<cdot> x"
    by(auto simp: algebra_simps semiring_normalization_rules(29))
  also have "... = g\<^sup>2 \<cdot> \<tau>\<^sup>2 + 2 \<cdot> g \<cdot> v \<cdot> \<tau> + 2 \<cdot> g \<cdot> h + v \<cdot> v" (is "... = ?middle")
      by(subst invar, simp)
    finally have "?lhs = ?middle".
  moreover
  {have "?rhs = g \<cdot> g \<cdot> (\<tau> \<cdot> \<tau>) + 2 \<cdot> g \<cdot> v \<cdot> \<tau> + 2 \<cdot> g \<cdot> h + v \<cdot> 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: "g < 0 \<Longrightarrow> h \<ge> 0 \<Longrightarrow>
  \<^bold>{\<lambda>s. s$1 = h \<and> s$2 = 0\<^bold>}
  (LOOP
      ((EVOL (\<phi> g) (\<lambda> s. s$1 \<ge> 0) T);
       (IF (\<lambda> s. s$1 = 0) THEN (2 ::= (\<lambda>s. - s$2)) ELSE skip))
    INV (\<lambda>s. 0 \<le> s$1 \<and> 2 \<cdot> g \<cdot> s$1 = 2 \<cdot> g \<cdot> h + s$2 \<cdot> s$2)
  ) \<^bold>{\<lambda>s. 0 \<le> s$1 \<and> s$1 \<le> h\<^bold>}"
  apply(hyb_hoare "\<lambda>s::real^2. 0 \<le> s$1 \<and> 2 \<cdot> g \<cdot> s$1 = 2 \<cdot> g \<cdot> h + s$2 \<cdot> s$2")
  by (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: "g < 0 \<Longrightarrow> h \<ge> 0 \<Longrightarrow>
  \<^bold>{\<lambda>s. s$1 = h \<and> s$2 = 0\<^bold>}
  (LOOP
      ((x\<acute>= f g & (\<lambda> s. s$1 \<ge> 0));
       (IF (\<lambda> s. s$1 = 0) THEN (2 ::= (\<lambda>s. - s$2)) ELSE skip))
    INV (\<lambda>s. 0 \<le> s$1 \<and> 2 \<cdot> g \<cdot> s$1 = 2 \<cdot> g \<cdot> h + s$2 \<cdot> s$2)
  ) \<^bold>{\<lambda>s. 0 \<le> s$1 \<and> s$1 \<le> h\<^bold>}"
  apply(rule H_loopI; (rule H_seq[where R="\<lambda>s. 0 \<le> s$1 \<and> 2 \<cdot> g \<cdot> s$1 = 2 \<cdot> g \<cdot> h + s$2 \<cdot> s$2"])?)
     apply(subst local_flow.sH_g_ode_subset[OF local_flow_ball])
  by (auto simp: bb_real_arith)

\<comment> \<open>Refined with annotated dynamics \<close>

lemma R_bb_assign: "g < (0::real) \<Longrightarrow> 0 \<le> h \<Longrightarrow>
  2 ::= (\<lambda>s. - s$2) \<le> Ref
    \<lceil>\<lambda>s. s$1 = 0 \<and> 0 \<le> s$1 \<and> 2 \<cdot> g \<cdot> s$1 = 2 \<cdot> g \<cdot> h + s$2 \<cdot> s$2\<rceil>
    \<lceil>\<lambda>s. 0 \<le> s$1 \<and> 2 \<cdot> g \<cdot> s$1 = 2 \<cdot> g \<cdot> h + s$2 \<cdot> s$2\<rceil>"
  by (rule R_assign_law, auto)

lemma R_bouncing_ball_dyn:
  assumes "g < 0" and "h \<ge> 0"
  shows "Ref \<lceil>\<lambda>s. s$1 = h \<and> s$2 = 0\<rceil> \<lceil>\<lambda>s. 0 \<le> s$1 \<and> s$1 \<le> h\<rceil> \<ge>
  (LOOP
      ((EVOL (\<phi> g) (\<lambda> s. s$1 \<ge> 0) T);
       (IF (\<lambda> s. s$1 = 0) THEN (2 ::= (\<lambda>s. - s$2)) ELSE skip))
    INV (\<lambda>s. 0 \<le> s$1 \<and> 2 \<cdot> g \<cdot> s$1 = 2 \<cdot> g \<cdot> h + s$2 \<cdot> s$2))"
  apply(refinement; (rule R_bb_assign[OF assms])?)
  using assms 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 therm_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 therm_guard :: "real \<Rightarrow> real \<Rightarrow> real \<Rightarrow> real \<Rightarrow> real^4 \<Rightarrow> bool" ("G")
  where "G Tmin Tmax a L s \<equiv> (s$2 \<le> - (ln ((L-(if L=0 then Tmin else Tmax))/(L-s$3)))/a)"

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

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

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

lemma norm_diff_therm_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_therm_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_therm_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_therm: "a > 0 \<Longrightarrow> local_flow (f a L) UNIV UNIV (\<phi> a L)"
  by (unfold_locales, auto intro!: poly_derivatives local_lipschitz_therm_dyn
      simp: forall_4 vec_eq_iff)

lemma therm_dyn_down_real_arith:
  assumes "a > 0" and Thyps: "0 < Tmin" "Tmin \<le> T" "T \<le> Tmax"
    and thyps: "0 \<le> (\<tau>::real)" "\<forall>\<tau>\<in>{0..\<tau>}. \<tau> \<le> - (ln (Tmin / T) / a) "
  shows "Tmin \<le> exp (-a * \<tau>) * T" and "exp (-a * \<tau>) * T \<le> Tmax"
proof-
  have "0 \<le> \<tau> \<and> \<tau> \<le> - (ln (Tmin / T) / a)"
    using thyps by auto
  hence "ln (Tmin / T) \<le> - a * \<tau> \<and> - a * \<tau> \<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 * \<tau>)" "exp (-a * \<tau>) \<le> 1"
    using exp_ln exp_le_one_iff by (metis exp_less_cancel_iff not_less, simp)
  thus "Tmin \<le> exp (-a * \<tau>) * T"
    using Thyps by (simp add: pos_divide_le_eq)
  show "exp (-a * \<tau>) * 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 therm_dyn_up_real_arith:
  assumes "a > 0" and Thyps: "Tmin \<le> T" "T \<le> Tmax" "Tmax < (L::real)"
    and thyps: "0 \<le> \<tau>" "\<forall>\<tau>\<in>{0..\<tau>}. \<tau> \<le> - (ln ((L - Tmax) / (L - T)) / a) "
  shows "L - Tmax \<le> exp (-(a * \<tau>)) * (L - T)"
    and "L - exp (-(a * \<tau>)) * (L - T) \<le> Tmax"
    and "Tmin \<le> L - exp (-(a * \<tau>)) * (L - T)"
proof-
  have "0 \<le> \<tau> \<and> \<tau> \<le> - (ln ((L - Tmax) / (L - T)) / a)"
    using thyps by auto
  hence "ln ((L - Tmax) / (L - T)) \<le> - a * \<tau> \<and> - a * \<tau> \<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 * \<tau>) \<and> exp (-a * \<tau>) \<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 * \<tau>) * (L - T) \<and> exp (-a * \<tau>) * (L - T) \<le> (L - T)"
    by (simp add: pos_divide_le_eq)
  thus "(L - Tmax) \<le> exp (-(a * \<tau>)) * (L - T)"
    by auto
  thus "L - exp (-(a * \<tau>)) * (L - T) \<le> Tmax"
    by auto
  show "Tmin \<le> L - exp (-(a * \<tau>)) * (L - T)"
    using Thyps and obs by auto
qed

lemmas H_g_ode_therm = local_flow.sH_g_ode_ivl[OF local_flow_therm _ UNIV_I]

lemma thermostat_flow:
  assumes "0 < a" and "0 \<le> \<tau>" and "0 < Tmin" and "Tmax < L"
  shows "\<^bold>{I Tmin Tmax\<^bold>}
  (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>= (\<lambda>t. f a 0) & G Tmin Tmax a 0 on (\<lambda>s. {0..\<tau>}) UNIV @ 0)
    ELSE
      (x\<acute>= (\<lambda>t. f a L) & G Tmin Tmax a L on (\<lambda>s. {0..\<tau>}) UNIV @ 0))
  ) INV I Tmin Tmax)
   \<^bold>{I Tmin Tmax\<^bold>}"
  apply(rule H_loopI)
    apply(rule_tac R="\<lambda>s. I Tmin Tmax s \<and> s$2=0 \<and> s$3 = s$1" in H_seq)
     apply(rule_tac R="\<lambda>s. I Tmin Tmax s\<and> s$2=0 \<and> s$3 = s$1" in H_seq)
      apply(rule_tac R="\<lambda>s. I Tmin Tmax s \<and> s$2 = 0" in H_seq, simp, simp)
      apply(rule H_cond, simp_all add: H_g_ode_therm[OF assms(1,2)])+
  using therm_dyn_up_real_arith[OF assms(1) _ _ assms(4), of Tmin]
    and therm_dyn_down_real_arith[OF assms(1,3), of _ Tmax] by auto

\<comment> \<open>Refined with the flow \<close>

lemma R_therm_dyn_down:
  assumes "a > 0" and "0 \<le> \<tau>" and "0 < Tmin" and "Tmax < L"
  shows "Ref \<lceil>\<lambda>s. s$4 = 0 \<and> I Tmin Tmax s \<and> s$2 = 0 \<and> s$3 = s$1\<rceil> \<lceil>I Tmin Tmax\<rceil> \<ge>
    (x\<acute>= (\<lambda>t. f a 0) & G Tmin Tmax a 0 on (\<lambda>s. {0..\<tau>}) UNIV @ 0)"
  apply(rule local_flow.R_g_ode_ivl[OF local_flow_therm])
  using assms therm_dyn_down_real_arith[OF assms(1,3), of _ Tmax] by auto

lemma R_therm_dyn_up:
  assumes "a > 0" and "0 \<le> \<tau>" and "0 < Tmin" and "Tmax < L"
  shows "Ref \<lceil>\<lambda>s. s$4 \<noteq> 0 \<and> I Tmin Tmax s \<and> s$2 = 0 \<and> s$3 = s$1\<rceil> \<lceil>I Tmin Tmax\<rceil> \<ge>
    (x\<acute>= (\<lambda>t. f a L) & G Tmin Tmax a L on (\<lambda>s. {0..\<tau>}) UNIV @ 0)"
  apply(rule local_flow.R_g_ode_ivl[OF local_flow_therm])
  using assms therm_dyn_up_real_arith[OF assms(1) _ _ assms(4), of Tmin] by auto

lemma R_therm_dyn:
  assumes "a > 0" and "0 \<le> \<tau>" and "0 < Tmin" and "Tmax < L"
  shows "Ref \<lceil>\<lambda>s. I Tmin Tmax s \<and> s$2 = 0 \<and> s$3 = s$1\<rceil> \<lceil>I Tmin Tmax\<rceil> \<ge>
  (IF (\<lambda>s. s$4 = 0) THEN
    (x\<acute>= (\<lambda>t. f a 0) & G Tmin Tmax a 0 on (\<lambda>s. {0..\<tau>}) UNIV @ 0)
  ELSE
    (x\<acute>= (\<lambda>t. f a L) & G Tmin Tmax a L on (\<lambda>s. {0..\<tau>}) UNIV @ 0))"
  apply(rule order_trans, rule R_cond_mono)
  using R_therm_dyn_down[OF assms] R_therm_dyn_up[OF assms] by (auto intro!: R_cond)

lemma R_therm_assign1: "Ref \<lceil>I Tmin Tmax\<rceil> \<lceil>\<lambda>s. I Tmin Tmax s \<and> s$2 = 0\<rceil> \<ge> (2 ::= (\<lambda>s. 0))"
  by (auto simp: R_assign_law)

lemma R_therm_assign2:
  "Ref \<lceil>\<lambda>s. I Tmin Tmax s \<and> s$2 = 0\<rceil> \<lceil>\<lambda>s. I Tmin Tmax s \<and> s$2 = 0 \<and> s$3 = s$1\<rceil> \<ge> (3 ::= (\<lambda>s. s$1))"
  by (auto simp: R_assign_law)

lemma R_therm_ctrl:
  "Ref \<lceil>I Tmin Tmax\<rceil> \<lceil>\<lambda>s. I Tmin Tmax s \<and> s$2 = 0 \<and> s$3 = s$1\<rceil> \<ge>
  (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)"
  apply(refinement, rule R_therm_assign1, rule R_therm_assign2)
  by (rule R_assign_law, simp)+ auto

lemma R_therm_loop: "Ref \<lceil>I Tmin Tmax\<rceil> \<lceil>I Tmin Tmax\<rceil> \<ge>
  (LOOP
    Ref \<lceil>I Tmin Tmax\<rceil> \<lceil>\<lambda>s. I Tmin Tmax s \<and> s$2 = 0 \<and> s$3 = s$1\<rceil>;
    Ref \<lceil>\<lambda>s. I Tmin Tmax s \<and> s$2 = 0 \<and> s$3 = s$1\<rceil> \<lceil>I Tmin Tmax\<rceil>
  INV I Tmin Tmax)"
  by (intro R_loop R_seq, simp_all)

lemma R_thermostat_flow:
  assumes "a > 0" and "0 \<le> \<tau>" and "0 < Tmin" and "Tmax < L"
  shows "Ref \<lceil>I Tmin Tmax\<rceil> \<lceil>I Tmin Tmax\<rceil> \<ge>
  (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>= (\<lambda>t. f a 0) & G Tmin Tmax a 0 on (\<lambda>s. {0..\<tau>}) UNIV @ 0)
    ELSE
      (x\<acute>= (\<lambda>t. f a L) & G Tmin Tmax a L on (\<lambda>s. {0..\<tau>}) UNIV @ 0))
  ) INV I Tmin Tmax)"
  by (intro order_trans[OF _ R_therm_loop] R_loop_mono
      R_seq_mono R_therm_ctrl R_therm_dyn[OF assms])

no_notation therm_vec_field ("f")
        and therm_flow ("\<phi>")
        and therm_guard ("G")
        and therm_loop_inv ("I")

subsubsection \<open> Water tank \<close> \<comment> \<open> Variation of Hespanha and Alur's tank \<close>

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 \<cdot> 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)"

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

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) \<cdot> \<tau> + y"
    and "y \<le> hmax \<Longrightarrow> y - c\<^sub>o \<cdot> \<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)

lemmas H_g_ode_tank = local_flow.sH_g_ode_ivl[OF local_flow_tank _ UNIV_I]

lemma tank_flow:
  assumes "0 \<le> \<tau>" and "0 < c\<^sub>o" and "c\<^sub>o < c\<^sub>i"
  shows "\<^bold>{I hmin hmax\<^bold>}
  (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>= (\<lambda>t. f (c\<^sub>i-c\<^sub>o)) & G hmax (c\<^sub>i-c\<^sub>o) on (\<lambda>s. {0..\<tau>}) UNIV @ 0)
     ELSE (x\<acute>= (\<lambda>t. f (-c\<^sub>o)) & G hmin (-c\<^sub>o) on (\<lambda>s. {0..\<tau>}) UNIV @ 0)) )
  INV I hmin hmax)
  \<^bold>{I hmin hmax\<^bold>}"
  apply(rule H_loopI)
    apply(rule_tac R="\<lambda>s. I hmin hmax s \<and> s$2=0 \<and> s$3 = s$1" in H_seq)
     apply(rule_tac R="\<lambda>s. I hmin hmax s \<and> s$2=0 \<and> s$3 = s$1" in H_seq)
      apply(rule_tac R="\<lambda>s. I hmin hmax s \<and> s$2=0" in H_seq, simp, simp)
     apply(rule H_cond, simp_all add: H_g_ode_tank[OF assms(1)])
  using assms tank_arith[OF _ assms(2,3)] by auto

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

lemma tank_diff_inv:
  "0 \<le> \<tau> \<Longrightarrow> diff_invariant (dI hmin hmax k) (\<lambda>t. f k) (\<lambda>s. {0..\<tau>}) UNIV 0 Guard"
  apply(intro diff_invariant_conj_rule)
      apply(force intro!: poly_derivatives diff_invariant_rules)
     apply(rule_tac \<nu>'="\<lambda>t. 0" and \<mu>'="\<lambda>t. 1" in diff_invariant_leq_rule, simp_all, presburger)
    apply(rule_tac \<nu>'="\<lambda>t. 0" and \<mu>'="\<lambda>t. 0" in diff_invariant_leq_rule, simp_all)
    apply(force intro!: poly_derivatives)+
  by (auto intro!: poly_derivatives diff_invariant_rules)

lemma tank_inv_arith1:
  assumes "0 \<le> (\<tau>::real)" and "c\<^sub>o < c\<^sub>i" and b: "hmin \<le> y\<^sub>0" and g: "\<tau> \<le> (hmax - y\<^sub>0) / (c\<^sub>i - c\<^sub>o)"
  shows "hmin \<le> (c\<^sub>i - c\<^sub>o) \<cdot> \<tau> + y\<^sub>0" and "(c\<^sub>i - c\<^sub>o) \<cdot> \<tau> + y\<^sub>0 \<le> hmax"
proof-
  have "(c\<^sub>i - c\<^sub>o) \<cdot> \<tau> \<le> (hmax - y\<^sub>0)"
    using g assms(2,3) by (metis diff_gt_0_iff_gt mult.commute pos_le_divide_eq)
  thus "(c\<^sub>i - c\<^sub>o) \<cdot> \<tau> + y\<^sub>0 \<le> hmax"
    by auto
  show "hmin \<le> (c\<^sub>i - c\<^sub>o) \<cdot> \<tau> + y\<^sub>0"
    using b assms(1,2) by (metis add.commute add_increasing2 diff_ge_0_iff_ge
        less_eq_real_def mult_nonneg_nonneg)
qed

lemma tank_inv_arith2:
  assumes "0 \<le> (\<tau>::real)" and "0 < c\<^sub>o" and b: "y\<^sub>0 \<le> hmax" and g: "\<tau> \<le> - ((hmin - y\<^sub>0) / c\<^sub>o)"
  shows "hmin \<le> y\<^sub>0 - c\<^sub>o \<cdot> \<tau>" and "y\<^sub>0 - c\<^sub>o \<cdot> \<tau> \<le> hmax"
proof-
  have "\<tau> \<cdot> c\<^sub>o \<le> y\<^sub>0 - hmin"
    using g \<open>0 < c\<^sub>o\<close> pos_le_minus_divide_eq by fastforce
  thus "hmin \<le> y\<^sub>0 - c\<^sub>o \<cdot> \<tau>"
    by (auto simp: mult.commute)
  show "y\<^sub>0 - c\<^sub>o \<cdot> \<tau> \<le> hmax"
    using b assms(1,2) by (smt mult_nonneg_nonneg)
qed

lemma tank_inv:
  assumes "0 \<le> \<tau>" and "0 < c\<^sub>o" and "c\<^sub>o < c\<^sub>i"
  shows "\<^bold>{I hmin hmax\<^bold>}
  (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>= (\<lambda>t. f (c\<^sub>i-c\<^sub>o)) & G hmax (c\<^sub>i-c\<^sub>o) on (\<lambda>s. {0..\<tau>}) UNIV @ 0 DINV (dI hmin hmax (c\<^sub>i-c\<^sub>o)))
     ELSE
      (x\<acute>= (\<lambda>t. f (-c\<^sub>o)) & G hmin (-c\<^sub>o) on (\<lambda>s. {0..\<tau>}) UNIV @ 0 DINV (dI hmin hmax (-c\<^sub>o)))) )
  INV I hmin hmax)
  \<^bold>{I hmin hmax\<^bold>}"
  apply(rule H_loopI)
    apply(rule_tac R="\<lambda>s. I hmin hmax s \<and> s$2=0 \<and> s$3 = s$1" in H_seq)
     apply(rule_tac R="\<lambda>s. I hmin hmax s \<and> s$2=0 \<and> s$3 = s$1" in H_seq)
      apply(rule_tac R="\<lambda>s. I hmin hmax s \<and> s$2=0" in H_seq, simp, simp)
     apply(rule H_cond, simp, simp)+
    apply(rule H_cond, rule H_g_ode_inv)
  using assms tank_inv_arith1 apply(force simp: tank_diff_inv, simp, clarsimp)
    apply(rule H_g_ode_inv)
  using assms tank_diff_inv[of _ "-c\<^sub>o" hmin hmax] tank_inv_arith2 by auto

\<comment> \<open>Refined with differential invariants \<close>

abbreviation tank_ctrl :: "real \<Rightarrow> real \<Rightarrow> (real^4) nd_fun" ("ctrl")
  where "ctrl hmin hmax \<equiv> ((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)))"

abbreviation tank_dyn_dinv :: "real \<Rightarrow> real \<Rightarrow> real \<Rightarrow> real \<Rightarrow> real \<Rightarrow> (real^4) nd_fun" ("dyn")
  where "dyn c\<^sub>i c\<^sub>o hmin hmax \<tau> \<equiv> (IF (\<lambda>s. s$4 = 0) THEN
      (x\<acute>= (\<lambda>t. f (c\<^sub>i-c\<^sub>o)) & G hmax (c\<^sub>i-c\<^sub>o) on (\<lambda>s. {0..\<tau>}) UNIV @ 0 DINV (dI hmin hmax (c\<^sub>i-c\<^sub>o)))
     ELSE
      (x\<acute>= (\<lambda>t. f (-c\<^sub>o)) & G hmin (-c\<^sub>o) on (\<lambda>s. {0..\<tau>}) UNIV @ 0 DINV (dI hmin hmax (-c\<^sub>o))))"

abbreviation "tank_dinv c\<^sub>i c\<^sub>o hmin hmax \<tau> \<equiv> LOOP (ctrl hmin hmax ; dyn c\<^sub>i c\<^sub>o hmin hmax \<tau>) INV (I hmin hmax)"

lemma R_tank_inv:
  assumes "0 \<le> \<tau>" and "0 < c\<^sub>o" and "c\<^sub>o < c\<^sub>i"
  shows "Ref \<lceil>I hmin hmax\<rceil> \<lceil>I hmin hmax\<rceil> \<ge>
  (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>= (\<lambda>t. f (c\<^sub>i-c\<^sub>o)) & G hmax (c\<^sub>i-c\<^sub>o) on (\<lambda>s. {0..\<tau>}) UNIV @ 0 DINV (dI hmin hmax (c\<^sub>i-c\<^sub>o)))
     ELSE
      (x\<acute>= (\<lambda>t. f (-c\<^sub>o)) & G hmin (-c\<^sub>o) on (\<lambda>s. {0..\<tau>}) UNIV @ 0 DINV (dI hmin hmax (-c\<^sub>o)))) )
  INV I hmin hmax)"
proof-
  have "Ref \<lceil>I hmin hmax\<rceil> \<lceil>I hmin hmax\<rceil> \<ge>
    LOOP (
      (2 ::= (\<lambda>s. 0)); (Ref \<lceil>\<lambda>s. I hmin hmax s \<and> s$2 = 0\<rceil> \<lceil>I hmin hmax\<rceil>)
    ) INV I hmin hmax" (is "_ \<ge> ?R")
    by (refinement, auto)
  moreover have
    "?R \<ge> LOOP (
      (2 ::= (\<lambda>s. 0));(3 ::=(\<lambda>s. s$1));
      (Ref \<lceil>\<lambda>s. I hmin hmax s \<and> s$2 = 0 \<and> s$3=s$1\<rceil> \<lceil>I hmin hmax\<rceil>)
    ) INV I hmin hmax" (is "_ \<ge> ?R")
    by (simp only: mult.assoc, refinement, auto)
  moreover have
    "?R \<ge> LOOP (
      ctrl hmin hmax;
      (Ref \<lceil>\<lambda>s. I hmin hmax s \<and> s$2 = 0 \<and> s$3=s$1\<rceil> \<lceil>I hmin hmax\<rceil>)
    ) INV I hmin hmax" (is "_ \<ge> ?R")
    by (simp only: mult.assoc, refinement; (force)?, (rule R_assign_law)?) auto
  moreover have
    "?R \<ge> LOOP (ctrl hmin hmax; dyn c\<^sub>i c\<^sub>o hmin hmax \<tau>) INV I hmin hmax"
    apply(simp only: mult.assoc, refinement; ((rule tank_diff_inv[OF assms(1)])? | (simp)?))
    using tank_inv_arith1 tank_inv_arith2 assms by auto
  ultimately show ?thesis
    by auto
qed

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

end


(*  File:       Drop_Module.thy
    Copyright   2021  Karlsruhe Institute of Technology (KIT)
*)
\<^marker>\<open>creator "Karsten Diekhoff, Karlsruhe Institute of Technology (KIT)"\<close>
\<^marker>\<open>contributor "Jonas Kraemer, Karlsruhe Institute of Technology (KIT)"\<close>
\<^marker>\<open>contributor "Michael Kirsten, Karlsruhe Institute of Technology (KIT)"\<close>

section \<open>Drop Module\<close>

theory Drop_Module
  imports "Component_Types/Electoral_Module"
begin

text
\<open>This is a family of electoral modules. For a natural number n and a
lexicon (linear order) r of all alternatives, the according drop module
rejects the lexicographically first n alternatives (from A) and
defers the rest.
It is primarily used as counterpart to the pass module in a
parallel composition, in order to segment the alternatives into
two groups.\<close>

subsection \<open>Definition\<close>

fun drop_module :: "nat \<Rightarrow> 'a Preference_Relation \<Rightarrow> 'a Electoral_Module" where
  "drop_module n r A p =
    ({},
    {a \<in> A. card(above (limit A r) a) \<le> n},
    {a \<in> A. card(above (limit A r) a) > n})"

subsection \<open>Soundness\<close>

theorem drop_mod_sound[simp]:
  assumes order: "linear_order r"
  shows "electoral_module (drop_module n r)"
proof -
  let ?mod = "drop_module n r"
  have
    "\<forall>A p. finite_profile A p \<longrightarrow>
        (\<forall>a \<in> A. a \<in> {x \<in> A. card(above (limit A r) x) \<le> n} \<or>
            a \<in> {x \<in> A. card(above (limit A r) x) > n})"
    by auto
  hence
    "\<forall>A p. finite_profile A p \<longrightarrow>
        {a \<in> A. card(above (limit A r) a) \<le> n} \<union>
        {a \<in> A. card(above (limit A r) a) > n} = A"
    by blast
  hence 0:
    "\<forall>A p. finite_profile A p \<longrightarrow>
        set_equals_partition A (drop_module n r A p)"
    by simp
  have
    "\<forall>A p. finite_profile A p \<longrightarrow>
        (\<forall>a \<in> A. \<not>(a \<in> {x \<in> A. card(above (limit A r) x) \<le> n} \<and>
            a \<in> {x \<in> A. card(above (limit A r) x) > n}))"
    by auto
  hence
    "\<forall>A p. finite_profile A p \<longrightarrow>
        {a \<in> A. card(above (limit A r) a) \<le> n} \<inter>
        {a \<in> A. card(above (limit A r) a) > n} = {}"
    by blast
  hence 1: "\<forall>A p. finite_profile A p \<longrightarrow> disjoint3 (?mod A p)"
    by simp
  from 0 1 have
    "\<forall>A p. finite_profile A p \<longrightarrow>
        well_formed A (?mod A p)"
    by simp
  hence
    "\<forall>A p. finite_profile A p \<longrightarrow>
        well_formed A (?mod A p)"
    by simp
  thus ?thesis
    using electoral_modI
    by metis
qed

subsection \<open>Non-Electing\<close>

(*The drop module is non-electing.*)
theorem drop_mod_non_electing[simp]:
  assumes order: "linear_order r"
  shows "non_electing (drop_module n r)"
  by (simp add: non_electing_def order)

subsection \<open>Properties\<close>

(*The drop module is strictly defer-monotone.*)
theorem drop_mod_def_lift_inv[simp]:
  assumes order: "linear_order r"
  shows "defer_lift_invariance (drop_module n r)"
  by (simp add: order defer_lift_invariance_def)

end


(*  Title:      HOL/Imperative_HOL/ex/List_Sublist.thy
    Author:     Lukas Bulwahn, TU Muenchen
*)

section \<open>Slices of lists\<close>

theory List_Sublist
imports "~~/src/HOL/Library/Multiset"
begin

lemma sublist_split: "i \<le> j \<and> j \<le> k \<Longrightarrow> sublist xs {i..<j} @ sublist xs {j..<k} = sublist xs {i..<k}"
apply (induct xs arbitrary: i j k)
apply simp
apply (simp only: sublist_Cons)
apply simp
apply safe
apply simp
apply (erule_tac x="0" in meta_allE)
apply (erule_tac x="j - 1" in meta_allE)
apply (erule_tac x="k - 1" in meta_allE)
apply (subgoal_tac "0 \<le> j - 1 \<and> j - 1 \<le> k - 1")
apply simp
apply (subgoal_tac "{ja. Suc ja < j} = {0..<j - Suc 0}")
apply (subgoal_tac "{ja. j \<le> Suc ja \<and> Suc ja < k} = {j - Suc 0..<k - Suc 0}")
apply (subgoal_tac "{j. Suc j < k} = {0..<k - Suc 0}")
apply simp
apply fastforce
apply fastforce
apply fastforce
apply fastforce
apply (erule_tac x="i - 1" in meta_allE)
apply (erule_tac x="j - 1" in meta_allE)
apply (erule_tac x="k - 1" in meta_allE)
apply (subgoal_tac " {ja. i \<le> Suc ja \<and> Suc ja < j} = {i - 1 ..<j - 1}")
apply (subgoal_tac " {ja. j \<le> Suc ja \<and> Suc ja < k} = {j - 1..<k - 1}")
apply (subgoal_tac "{j. i \<le> Suc j \<and> Suc j < k} = {i - 1..<k - 1}")
apply (subgoal_tac " i - 1 \<le> j - 1 \<and> j - 1 \<le> k - 1")
apply simp
apply fastforce
apply fastforce
apply fastforce
apply fastforce
done

lemma sublist_update1: "i \<notin> inds \<Longrightarrow> sublist (xs[i := v]) inds = sublist xs inds"
apply (induct xs arbitrary: i inds)
apply simp
apply (case_tac i)
apply (simp add: sublist_Cons)
apply (simp add: sublist_Cons)
done

lemma sublist_update2: "i \<in> inds \<Longrightarrow> sublist (xs[i := v]) inds = (sublist xs inds)[(card {k \<in> inds. k < i}):= v]"
proof (induct xs arbitrary: i inds)
  case Nil thus ?case by simp
next
  case (Cons x xs)
  thus ?case
  proof (cases i)
    case 0 with Cons show ?thesis by (simp add: sublist_Cons)
  next
    case (Suc i')
    with Cons show ?thesis
      apply simp
      apply (simp add: sublist_Cons)
      apply auto
      apply (auto simp add: nat.split)
      apply (simp add: card_less_Suc[symmetric])
      apply (simp add: card_less_Suc2)
      done
  qed
qed

lemma sublist_update: "sublist (xs[i := v]) inds = (if i \<in> inds then (sublist xs inds)[(card {k \<in> inds. k < i}) := v] else sublist xs inds)"
by (simp add: sublist_update1 sublist_update2)

lemma sublist_take: "sublist xs {j. j < m} = take m xs"
apply (induct xs arbitrary: m)
apply simp
apply (case_tac m)
apply simp
apply (simp add: sublist_Cons)
done

lemma sublist_take': "sublist xs {0..<m} = take m xs"
apply (induct xs arbitrary: m)
apply simp
apply (case_tac m)
apply simp
apply (simp add: sublist_Cons sublist_take)
done

lemma sublist_all[simp]: "sublist xs {j. j < length xs} = xs"
apply (induct xs)
apply simp
apply (simp add: sublist_Cons)
done

lemma sublist_all'[simp]: "sublist xs {0..<length xs} = xs"
apply (induct xs)
apply simp
apply (simp add: sublist_Cons)
done

lemma sublist_single: "a < length xs \<Longrightarrow> sublist xs {a} = [xs ! a]"
apply (induct xs arbitrary: a)
apply simp
apply(case_tac aa)
apply simp
apply (simp add: sublist_Cons)
apply simp
apply (simp add: sublist_Cons)
done

lemma sublist_is_Nil: "\<forall>i \<in> inds. i \<ge> length xs \<Longrightarrow> sublist xs inds = []"
apply (induct xs arbitrary: inds)
apply simp
apply (simp add: sublist_Cons)
apply auto
apply (erule_tac x="{j. Suc j \<in> inds}" in meta_allE)
apply auto
done

lemma sublist_Nil': "sublist xs inds = [] \<Longrightarrow> \<forall>i \<in> inds. i \<ge> length xs"
apply (induct xs arbitrary: inds)
apply simp
apply (simp add: sublist_Cons)
apply (auto split: if_splits)
apply (erule_tac x="{j. Suc j \<in> inds}" in meta_allE)
apply (case_tac x, auto)
done

lemma sublist_Nil[simp]: "(sublist xs inds = []) = (\<forall>i \<in> inds. i \<ge> length xs)"
apply (induct xs arbitrary: inds)
apply simp
apply (simp add: sublist_Cons)
apply auto
apply (erule_tac x="{j. Suc j \<in> inds}" in meta_allE)
apply (case_tac x, auto)
done

lemma sublist_eq_subseteq: " \<lbrakk> inds' \<subseteq> inds; sublist xs inds = sublist ys inds \<rbrakk> \<Longrightarrow> sublist xs inds' = sublist ys inds'"
apply (induct xs arbitrary: ys inds inds')
apply simp
apply (drule sym, rule sym)
apply (simp add: sublist_Nil, fastforce)
apply (case_tac ys)
apply (simp add: sublist_Nil, fastforce)
apply (auto simp add: sublist_Cons)
apply (erule_tac x="list" in meta_allE)
apply (erule_tac x="{j. Suc j \<in> inds}" in meta_allE)
apply (erule_tac x="{j. Suc j \<in> inds'}" in meta_allE)
apply fastforce
apply (erule_tac x="list" in meta_allE)
apply (erule_tac x="{j. Suc j \<in> inds}" in meta_allE)
apply (erule_tac x="{j. Suc j \<in> inds'}" in meta_allE)
apply fastforce
done

lemma sublist_eq: "\<lbrakk> \<forall>i \<in> inds. ((i < length xs) \<and> (i < length ys)) \<or> ((i \<ge> length xs ) \<and> (i \<ge> length ys)); \<forall>i \<in> inds. xs ! i = ys ! i \<rbrakk> \<Longrightarrow> sublist xs inds = sublist ys inds"
apply (induct xs arbitrary: ys inds)
apply simp
apply (rule sym, simp add: sublist_Nil)
apply (case_tac ys)
apply (simp add: sublist_Nil)
apply (auto simp add: sublist_Cons)
apply (erule_tac x="list" in meta_allE)
apply (erule_tac x="{j. Suc j \<in> inds}" in meta_allE)
apply fastforce
apply (erule_tac x="list" in meta_allE)
apply (erule_tac x="{j. Suc j \<in> inds}" in meta_allE)
apply fastforce
done

lemma sublist_eq_samelength: "\<lbrakk> length xs = length ys; \<forall>i \<in> inds. xs ! i = ys ! i \<rbrakk> \<Longrightarrow> sublist xs inds = sublist ys inds"
by (rule sublist_eq, auto)

lemma sublist_eq_samelength_iff: "length xs = length ys \<Longrightarrow> (sublist xs inds = sublist ys inds) = (\<forall>i \<in> inds. xs ! i = ys ! i)"
apply (induct xs arbitrary: ys inds)
apply simp
apply (rule sym, simp add: sublist_Nil)
apply (case_tac ys)
apply (simp add: sublist_Nil)
apply (auto simp add: sublist_Cons)
apply (case_tac i)
apply auto
apply (case_tac i)
apply auto
done

section \<open>Another sublist function\<close>

function sublist' :: "nat \<Rightarrow> nat \<Rightarrow> 'a list \<Rightarrow> 'a list"
where
  "sublist' n m [] = []"
| "sublist' n 0 xs = []"
| "sublist' 0 (Suc m) (x#xs) = (x#sublist' 0 m xs)"
| "sublist' (Suc n) (Suc m) (x#xs) = sublist' n m xs"
by pat_completeness auto
termination by lexicographic_order

subsection \<open>Proving equivalence to the other sublist command\<close>

lemma sublist'_sublist: "sublist' n m xs = sublist xs {j. n \<le> j \<and> j < m}"
apply (induct xs arbitrary: n m)
apply simp
apply (case_tac n)
apply (case_tac m)
apply simp
apply (simp add: sublist_Cons)
apply (case_tac m)
apply simp
apply (simp add: sublist_Cons)
done

lemma "sublist' n m xs = sublist xs {n..<m}"
apply (induct xs arbitrary: n m)
apply simp
apply (case_tac n, case_tac m)
apply simp
apply simp
apply (simp add: sublist_take')
apply (case_tac m)
apply simp
apply (simp add: sublist_Cons sublist'_sublist)
done

subsection \<open>Showing equivalence to use of drop and take for definition\<close>

lemma "sublist' n m xs = take (m - n) (drop n xs)"
apply (induct xs arbitrary: n m)
apply simp
apply (case_tac m)
apply simp
apply (case_tac n)
apply simp
apply simp
done

subsection \<open>General lemma about sublist\<close>

lemma sublist'_Nil[simp]: "sublist' i j [] = []"
by simp

lemma sublist'_Cons[simp]: "sublist' i (Suc j) (x#xs) = (case i of 0 \<Rightarrow> (x # sublist' 0 j xs) | Suc i' \<Rightarrow>  sublist' i' j xs)"
by (cases i) auto

lemma sublist'_Cons2[simp]: "sublist' i j (x#xs) = (if (j = 0) then [] else ((if (i = 0) then [x] else []) @ sublist' (i - 1) (j - 1) xs))"
apply (cases j)
apply auto
apply (cases i)
apply auto
done

lemma sublist_n_0: "sublist' n 0 xs = []"
by (induct xs, auto)

lemma sublist'_Nil': "n \<ge> m \<Longrightarrow> sublist' n m xs = []"
apply (induct xs arbitrary: n m)
apply simp
apply (case_tac m)
apply simp
apply (case_tac n)
apply simp
apply simp
done

lemma sublist'_Nil2: "n \<ge> length xs \<Longrightarrow> sublist' n m xs = []"
apply (induct xs arbitrary: n m)
apply simp
apply (case_tac m)
apply simp
apply (case_tac n)
apply simp
apply simp
done

lemma sublist'_Nil3: "(sublist' n m xs = []) = ((n \<ge> m) \<or> (n \<ge> length xs))"
apply (induct xs arbitrary: n m)
apply simp
apply (case_tac m)
apply simp
apply (case_tac n)
apply simp
apply simp
done

lemma sublist'_notNil: "\<lbrakk> n < length xs; n < m \<rbrakk> \<Longrightarrow> sublist' n m xs \<noteq> []"
apply (induct xs arbitrary: n m)
apply simp
apply (case_tac m)
apply simp
apply (case_tac n)
apply simp
apply simp
done

lemma sublist'_single: "n < length xs \<Longrightarrow> sublist' n (Suc n) xs = [xs ! n]"
apply (induct xs arbitrary: n)
apply simp
apply simp
apply (case_tac n)
apply (simp add: sublist_n_0)
apply simp
done

lemma sublist'_update1: "i \<ge> m \<Longrightarrow> sublist' n m (xs[i:=v]) = sublist' n m xs"
apply (induct xs arbitrary: n m i)
apply simp
apply simp
apply (case_tac i)
apply simp
apply simp
done

lemma sublist'_update2: "i < n \<Longrightarrow> sublist' n m (xs[i:=v]) = sublist' n m xs"
apply (induct xs arbitrary: n m i)
apply simp
apply simp
apply (case_tac i)
apply simp
apply simp
done

lemma sublist'_update3: "\<lbrakk>n \<le> i; i < m\<rbrakk> \<Longrightarrow> sublist' n m (xs[i := v]) = (sublist' n m xs)[i - n := v]"
proof (induct xs arbitrary: n m i)
  case Nil thus ?case by auto
next
  case (Cons x xs)
  thus ?case
    apply -
    apply auto
    apply (cases i)
    apply auto
    apply (cases i)
    apply auto
    done
qed

lemma "\<lbrakk> sublist' i j xs = sublist' i j ys; n \<ge> i; m \<le> j \<rbrakk> \<Longrightarrow> sublist' n m xs = sublist' n m ys"
proof (induct xs arbitrary: i j ys n m)
  case Nil
  thus ?case
    apply -
    apply (rule sym, drule sym)
    apply (simp add: sublist'_Nil)
    apply (simp add: sublist'_Nil3)
    apply arith
    done
next
  case (Cons x xs i j ys n m)
  note c = this
  thus ?case
  proof (cases m)
    case 0 thus ?thesis by (simp add: sublist_n_0)
  next
    case (Suc m')
    note a = this
    thus ?thesis
    proof (cases n)
      case 0 note b = this
      show ?thesis
      proof (cases ys)
        case Nil  with a b Cons.prems show ?thesis by (simp add: sublist'_Nil3)
      next
        case (Cons y ys)
        show ?thesis
        proof (cases j)
          case 0 with a b Cons.prems show ?thesis by simp
        next
          case (Suc j') with a b Cons.prems Cons show ?thesis
            apply -
            apply (simp, rule Cons.hyps [of "0" "j'" "ys" "0" "m'"], auto)
            done
        qed
      qed
    next
      case (Suc n')
      show ?thesis
      proof (cases ys)
        case Nil with Suc a Cons.prems show ?thesis by (auto simp add: sublist'_Nil3)
      next
        case (Cons y ys) with Suc a Cons.prems show ?thesis
          apply -
          apply simp
          apply (cases j)
          apply simp
          apply (cases i)
          apply simp
          apply (rule_tac j="nat" in Cons.hyps [of "0" _ "ys" "n'" "m'"])
          apply simp
          apply simp
          apply simp
          apply simp
          apply (rule_tac i="nata" and j="nat" in Cons.hyps [of _ _ "ys" "n'" "m'"])
          apply simp
          apply simp
          apply simp
          done
      qed
    qed
  qed
qed

lemma length_sublist': "j \<le> length xs \<Longrightarrow> length (sublist' i j xs) = j - i"
by (induct xs arbitrary: i j, auto)

lemma sublist'_front: "\<lbrakk> i < j; i < length xs \<rbrakk> \<Longrightarrow> sublist' i j xs = xs ! i # sublist' (Suc i) j xs"
apply (induct xs arbitrary: i j)
apply simp
apply (case_tac j)
apply simp
apply (case_tac i)
apply simp
apply simp
done

lemma sublist'_back: "\<lbrakk> i < j; j \<le> length xs \<rbrakk> \<Longrightarrow> sublist' i j xs = sublist' i (j - 1) xs @ [xs ! (j - 1)]"
apply (induct xs arbitrary: i j)
apply simp
apply simp
done

(* suffices that j \<le> length xs and length ys *)
lemma sublist'_eq_samelength_iff: "length xs = length ys \<Longrightarrow> (sublist' i j xs  = sublist' i j ys) = (\<forall>i'. i \<le> i' \<and> i' < j \<longrightarrow> xs ! i' = ys ! i')"
proof (induct xs arbitrary: ys i j)
  case Nil thus ?case by simp
next
  case (Cons x xs)
  thus ?case
    apply -
    apply (cases ys)
    apply simp
    apply simp
    apply auto
    apply (case_tac i', auto)
    apply (erule_tac x="Suc i'" in allE, auto)
    apply (erule_tac x="i' - 1" in allE, auto)
    apply (erule_tac x="Suc i'" in allE, auto)
    done
qed

lemma sublist'_all[simp]: "sublist' 0 (length xs) xs = xs"
by (induct xs, auto)

lemma sublist'_sublist': "sublist' n m (sublist' i j xs) = sublist' (i + n) (min (i + m) j) xs"
by (induct xs arbitrary: i j n m) (auto simp add: min_diff)

lemma sublist'_append: "\<lbrakk> i \<le> j; j \<le> k \<rbrakk> \<Longrightarrow>(sublist' i j xs) @ (sublist' j k xs) = sublist' i k xs"
by (induct xs arbitrary: i j k) auto

lemma nth_sublist': "\<lbrakk> k < j - i; j \<le> length xs \<rbrakk> \<Longrightarrow> (sublist' i j xs) ! k = xs ! (i + k)"
apply (induct xs arbitrary: i j k)
apply simp
apply (case_tac k)
apply auto
done

lemma set_sublist': "set (sublist' i j xs) = {x. \<exists>k. i \<le> k \<and> k < j \<and> k < List.length xs \<and> x = xs ! k}"
apply (simp add: sublist'_sublist)
apply (simp add: set_sublist)
apply auto
done

lemma all_in_set_sublist'_conv: "(\<forall>j. j \<in> set (sublist' l r xs) \<longrightarrow> P j) = (\<forall>k. l \<le> k \<and> k < r \<and> k < List.length xs \<longrightarrow> P (xs ! k))"
unfolding set_sublist' by blast

lemma ball_in_set_sublist'_conv: "(\<forall>j \<in> set (sublist' l r xs). P j) = (\<forall>k. l \<le> k \<and> k < r \<and> k < List.length xs \<longrightarrow> P (xs ! k))"
unfolding set_sublist' by blast

lemma mset_sublist:
assumes l_r: "l \<le> r \<and> r \<le> List.length xs"
assumes left: "\<forall> i. i < l \<longrightarrow> (xs::'a list) ! i = ys ! i"
assumes right: "\<forall> i. i \<ge> r \<longrightarrow> (xs::'a list) ! i = ys ! i"
assumes multiset: "mset xs = mset ys"
  shows "mset (sublist' l r xs) = mset (sublist' l r ys)"
proof -
  from l_r have xs_def: "xs = (sublist' 0 l xs) @ (sublist' l r xs) @ (sublist' r (List.length xs) xs)" (is "_ = ?xs_long")
    by (simp add: sublist'_append)
  from multiset have length_eq: "List.length xs = List.length ys" by (rule mset_eq_length)
  with l_r have ys_def: "ys = (sublist' 0 l ys) @ (sublist' l r ys) @ (sublist' r (List.length ys) ys)" (is "_ = ?ys_long")
    by (simp add: sublist'_append)
  from xs_def ys_def multiset have "mset ?xs_long = mset ?ys_long" by simp
  moreover
  from left l_r length_eq have "sublist' 0 l xs = sublist' 0 l ys"
    by (auto simp add: length_sublist' nth_sublist' intro!: nth_equalityI)
  moreover
  from right l_r length_eq have "sublist' r (List.length xs) xs = sublist' r (List.length ys) ys"
    by (auto simp add: length_sublist' nth_sublist' intro!: nth_equalityI)
  ultimately show ?thesis by (simp add: mset_append)
qed

end


theory Type_Graph_Combination
  imports
    Type_Graph
begin

section "Combining type graphs"

definition tg_combine_mult :: "('lt LabDef \<times> 'lt LabDef \<times> 'lt LabDef) set \<Rightarrow> (('lt LabDef \<times> 'lt LabDef \<times> 'lt LabDef) \<Rightarrow> multiplicity_pair) \<Rightarrow>
                   ('lt LabDef \<times> 'lt LabDef \<times> 'lt LabDef) set \<Rightarrow> (('lt LabDef \<times> 'lt LabDef \<times> 'lt LabDef) \<Rightarrow> multiplicity_pair) \<Rightarrow>
                   ('lt LabDef \<times> 'lt LabDef \<times> 'lt LabDef) \<Rightarrow> multiplicity_pair" where
  "tg_combine_mult E1 mult1 E2 mult2 e = (if e \<in> E1 \<inter> E2 then mult_pair_intersect (mult1 e) (mult2 e) else if e \<in> E1 then mult1 e else if e \<in> E2 then mult2 e else undefined)"

definition tg_combine :: "('lt) type_graph \<Rightarrow> ('lt) type_graph \<Rightarrow> ('lt) type_graph" where
  "tg_combine TG1 TG2 \<equiv> \<lparr>
    NT = NT TG1 \<union> NT TG2,
    ET = ET TG1 \<union> ET TG2,
    inh = (inh TG1 \<union> inh TG2)\<^sup>+,
    abs = (abs TG1 - NT TG2) \<union> (abs TG2 - NT TG1) \<union> (abs TG1 \<inter> abs TG2),
    mult = tg_combine_mult (ET TG1) (mult TG1) (ET TG2) (mult TG2),
    contains = contains TG1 \<union> contains TG2
  \<rparr>"

lemma tg_combine_identity:
  assumes structure_mult_domain: "\<And>e. e \<notin> ET TG \<Longrightarrow> mult TG e = undefined"
  assumes validity_inh_trans: "trans (inh TG)"
  shows "tg_combine tg_empty TG = truncate TG"
  unfolding truncate_def tg_combine_def tg_combine_mult_def tg_empty_def
  using validity_inh_trans structure_mult_domain
  by fastforce

lemma tg_combine_identity_alt:
  assumes type_graph_correct: "type_graph TG"
  shows "tg_combine tg_empty TG = truncate TG"
  using tg_combine_identity type_graph.structure_mult_domain type_graph.validity_inh_trans type_graph_correct
  by blast

lemma tg_combine_commute[simp]: "tg_combine TG1 TG2 = tg_combine TG2 TG1"
  unfolding tg_combine_def tg_combine_mult_def
  by (auto simp add: Un_commute)

lemma tg_combine_assoc[simp]: "tg_combine (tg_combine TG1 TG2) TG3 = tg_combine TG1 (tg_combine TG2 TG3)"
  unfolding tg_combine_def
proof (auto)
  fix a b
  assume "(a, b) \<in> ((inh TG1 \<union> inh TG2)\<^sup>+ \<union> inh TG3)\<^sup>+"
  then show "(a, b) \<in> (inh TG1 \<union> (inh TG2 \<union> inh TG3)\<^sup>+)\<^sup>+"
  proof (induct)
    case (base w)
    then have "(a, w) \<in> (inh TG1 \<union> inh TG2)\<^sup>+ \<or> (a, w) \<in> inh TG3"
      by simp
    then show ?case
    proof (elim disjE)
      assume "(a, w) \<in> (inh TG1 \<union> inh TG2)\<^sup>+"
      then show "(a, w) \<in> (inh TG1 \<union> (inh TG2 \<union> inh TG3)\<^sup>+)\<^sup>+"
      proof (induct)
        case (base y)
        then show ?case
          by blast
      next
        case (step y z)
        then show ?case
          using Un_iff r_into_trancl' trancl.trancl_into_trancl
          by metis
      qed
    next
      assume "(a, w) \<in> inh TG3"
      then show "(a, w) \<in> (inh TG1 \<union> (inh TG2 \<union> inh TG3)\<^sup>+)\<^sup>+"
        by blast
    qed
  next
    case (step w x)
    then have "(w, x) \<in> (inh TG1 \<union> inh TG2)\<^sup>+ \<or> (w, x) \<in> inh TG3"
      by blast
    then show ?case
    proof (elim disjE)
      assume "(w, x) \<in> (inh TG1 \<union> inh TG2)\<^sup>+"
      then show "(a, x) \<in> (inh TG1 \<union> (inh TG2 \<union> inh TG3)\<^sup>+)\<^sup>+"
      proof (induct)
        case (base y)
        then show ?case
          using Un_iff step.hyps(3) trancl.trancl_into_trancl trancl_unfold
          by metis
      next
        case (step y z)
        then show ?case
          using Un_iff r_into_trancl' trancl.trancl_into_trancl
          by metis
      qed
    next
      assume "(w, x) \<in> inh TG3"
      then show "(a, x) \<in> (inh TG1 \<union> (inh TG2 \<union> inh TG3)\<^sup>+)\<^sup>+"
        using Un_iff step.hyps(3) trancl.trancl_into_trancl trancl_unfold
        by metis
    qed
  qed
next
  fix a b
  assume "(a, b) \<in> (inh TG1 \<union> (inh TG2 \<union> inh TG3)\<^sup>+)\<^sup>+"
  then show "(a, b) \<in> ((inh TG1 \<union> inh TG2)\<^sup>+ \<union> inh TG3)\<^sup>+"
  proof (induct)
    case (base w)
    then have "(a, w) \<in> inh TG1 \<or> (a, w) \<in> (inh TG2 \<union> inh TG3)\<^sup>+"
      by simp
    then show ?case
    proof (elim disjE)
      assume "(a, w) \<in> inh TG1"
      then show "(a, w) \<in> ((inh TG1 \<union> inh TG2)\<^sup>+ \<union> inh TG3)\<^sup>+"
        by blast
    next
      assume "(a, w) \<in> (inh TG2 \<union> inh TG3)\<^sup>+"
      then show "(a, w) \<in> ((inh TG1 \<union> inh TG2)\<^sup>+ \<union> inh TG3)\<^sup>+"
      proof (induct)
        case (base y)
        then show ?case
          by blast
      next
        case (step y z)
        then show ?case
          using Un_iff r_into_trancl' trancl.trancl_into_trancl
          by metis
      qed
    qed
  next
    case (step w x)
    then have "(w, x) \<in> inh TG1 \<or> (w, x) \<in> (inh TG2 \<union> inh TG3)\<^sup>+"
      by simp
    then show ?case
    proof (elim disjE)
      assume "(w, x) \<in> inh TG1"
      then show "(a, x) \<in> ((inh TG1 \<union> inh TG2)\<^sup>+ \<union> inh TG3)\<^sup>+"
        using Un_iff step.hyps(3) trancl.trancl_into_trancl trancl_unfold
        by metis
    next
      assume "(w, x) \<in> (inh TG2 \<union> inh TG3)\<^sup>+"
      then show "(a, x) \<in> ((inh TG1 \<union> inh TG2)\<^sup>+ \<union> inh TG3)\<^sup>+"
      proof (induct)
        case (base y)
        then show ?case
          using Un_iff r_into_trancl' step.hyps(3) trancl.trancl_into_trancl
          by metis
      next
        case (step y z)
        then show ?case
          using Un_iff r_into_trancl' trancl.trancl_into_trancl
          by metis
      qed
    qed
  qed
next
  show "tg_combine_mult (ET TG1 \<union> ET TG2) (tg_combine_mult (ET TG1) (mult TG1) (ET TG2) (mult TG2)) (ET TG3) (mult TG3) =
      tg_combine_mult (ET TG1) (mult TG1) (ET TG2 \<union> ET TG3) (tg_combine_mult (ET TG2) (mult TG2) (ET TG3) (mult TG3))"
  proof
    fix x
    show "tg_combine_mult (ET TG1 \<union> ET TG2) (tg_combine_mult (ET TG1) (mult TG1) (ET TG2) (mult TG2)) (ET TG3) (mult TG3) x =
        tg_combine_mult (ET TG1) (mult TG1) (ET TG2 \<union> ET TG3) (tg_combine_mult (ET TG2) (mult TG2) (ET TG3) (mult TG3)) x"
      unfolding tg_combine_mult_def
      using mult_pair_intersect_assoc
      by auto
  qed
qed

lemma tg_combine_idemp:
  assumes structure_mult_domain: "\<And>e. e \<notin> ET TG \<Longrightarrow> mult TG e = undefined"
  assumes validity_inh_trans: "trans (inh TG)"
  shows "tg_combine TG TG = truncate TG"
  unfolding truncate_def tg_combine_def tg_combine_mult_def
  using validity_inh_trans structure_mult_domain
  by fastforce

lemma tg_combine_idemp_alt[simp]:
  assumes type_graph_correct: "type_graph TG"
  shows "tg_combine TG TG = truncate TG"
proof (intro tg_combine_idemp)
  show "\<And>e. e \<notin> ET TG \<Longrightarrow> mult TG e = undefined"
    using type_graph_correct type_graph.structure_mult_domain
    by blast
next
  show "trans (inh TG)"
    using type_graph_correct type_graph.validity_inh_trans
    by blast
qed

lemma tg_combine_idemp'[simp]:
  assumes structure_mult_domain: "\<And>e. e \<notin> ET TG2 \<Longrightarrow> mult TG2 e = undefined"
  assumes validity_inh_trans: "trans (inh TG2)"
  shows "tg_combine (tg_combine TG1 TG2) TG2 = tg_combine TG1 TG2"
proof-
  have assoc_rule: "tg_combine (tg_combine TG1 TG2) TG2 = tg_combine TG1 (tg_combine TG2 TG2)"
    by (fact tg_combine_assoc)
  have "tg_combine TG2 TG2 = truncate TG2"
    using tg_combine_idemp validity_inh_trans structure_mult_domain
    by blast
  then have "tg_combine TG2 TG2 = TG2"
    unfolding truncate_def
    by simp
  then show "tg_combine (tg_combine TG1 TG2) TG2 = tg_combine TG1 TG2"
    using assoc_rule
    by simp
qed

lemma tg_combine_idemp'_alt[simp]:
  assumes type_graph_correct: "type_graph TG2"
  shows "tg_combine (tg_combine TG1 TG2) TG2 = tg_combine TG1 TG2"
proof (intro tg_combine_idemp')
  show "\<And>e. e \<notin> ET TG2 \<Longrightarrow> mult TG2 e = undefined"
    using type_graph_correct type_graph.structure_mult_domain
    by blast
next
  show "trans (inh TG2)"
    using type_graph_correct type_graph.validity_inh_trans
    by blast
qed

subsection "Correctness of combining type graphs"

lemma tg_combine_correct[intro]:
  assumes first_type_graph_correct: "type_graph TG1"
  assumes second_type_graph_correct: "type_graph TG2"
  assumes edges_inheritance_correct_src_tg1: "\<And>l s1 t1 s2 t2. (s1, l, t1) \<in> ET TG1 \<Longrightarrow> (s2, l, t2) \<in> ET TG1 \<Longrightarrow>
    (s1, s2) \<in> (inh TG1 \<union> inh TG2)\<^sup>+ - inh TG1 \<or> (s2, s1) \<in> (inh TG1 \<union> inh TG2)\<^sup>+ - inh TG1 \<Longrightarrow>
    (t1, t2) \<in> (inh TG1 \<union> inh TG2)\<^sup>+ \<or> (t2, t1) \<in> (inh TG1 \<union> inh TG2)\<^sup>+ \<Longrightarrow> s1 = s2 \<and> t1 = t2"
  assumes edges_inheritance_correct_tgt_tg1: "\<And>l s1 t1 s2 t2. (s1, l, t1) \<in> ET TG1 \<Longrightarrow> (s2, l, t2) \<in> ET TG1 \<Longrightarrow>
    (s1, s2) \<in> (inh TG1 \<union> inh TG2)\<^sup>+ \<or> (s2, s1) \<in> (inh TG1 \<union> inh TG2)\<^sup>+ \<Longrightarrow>
    (t1, t2) \<in> (inh TG1 \<union> inh TG2)\<^sup>+ - inh TG1 \<or> (t2, t1) \<in> (inh TG1 \<union> inh TG2)\<^sup>+ - inh TG1 \<Longrightarrow> s1 = s2 \<and> t1 = t2"
  assumes edges_inheritance_correct_src_tg2: "\<And>l s1 t1 s2 t2. (s1, l, t1) \<in> ET TG2 \<Longrightarrow> (s2, l, t2) \<in> ET TG2 \<Longrightarrow>
    (s1, s2) \<in> (inh TG1 \<union> inh TG2)\<^sup>+ - inh TG2 \<or> (s2, s1) \<in> (inh TG1 \<union> inh TG2)\<^sup>+ - inh TG2 \<Longrightarrow>
    (t1, t2) \<in> (inh TG1 \<union> inh TG2)\<^sup>+ \<or> (t2, t1) \<in> (inh TG1 \<union> inh TG2)\<^sup>+ \<Longrightarrow> s1 = s2 \<and> t1 = t2"
  assumes edges_inheritance_correct_tgt_tg2: "\<And>l s1 t1 s2 t2. (s1, l, t1) \<in> ET TG2 \<Longrightarrow> (s2, l, t2) \<in> ET TG2 \<Longrightarrow>
    (s1, s2) \<in> (inh TG1 \<union> inh TG2)\<^sup>+ \<or> (s2, s1) \<in> (inh TG1 \<union> inh TG2)\<^sup>+ \<Longrightarrow>
    (t1, t2) \<in> (inh TG1 \<union> inh TG2)\<^sup>+ - inh TG2 \<or> (t2, t1) \<in> (inh TG1 \<union> inh TG2)\<^sup>+ - inh TG2 \<Longrightarrow> s1 = s2 \<and> t1 = t2"
  assumes edges_inheritance_correct_tg1_tg2: "\<And>l s1 t1 s2 t2. (s1, l, t1) \<in> ET TG1 \<Longrightarrow> (s2, l, t2) \<in> ET TG2 \<Longrightarrow>
    (s1, s2) \<in> (inh TG1 \<union> inh TG2)\<^sup>+ \<or> (s2, s1) \<in> (inh TG1 \<union> inh TG2)\<^sup>+ \<Longrightarrow>
    (t1, t2) \<in> (inh TG1 \<union> inh TG2)\<^sup>+ \<or> (t2, t1) \<in> (inh TG1 \<union> inh TG2)\<^sup>+ \<Longrightarrow> s1 = s2 \<and> t1 = t2"
  assumes multiplicity_intersection_correct: "\<And>e. e \<in> ET TG1 \<inter> ET TG2 \<Longrightarrow> multiplicity_pair (mult_pair_intersect (mult TG1 e) (mult TG2 e))"
  assumes inheritance_antisymmetry: "antisym ((inh TG1 \<union> inh TG2)\<^sup>+)"
  (* assumes first_type_graph_contains_mult: "\<And>e. e \<in> contains TG1 \<Longrightarrow> e \<notin> contains TG2 \<Longrightarrow> e \<in> ET TG2 \<Longrightarrow> lower (m_in (mult TG2 e)) = \<^bold>0"
  assumes second_type_graph_contains_mult: "\<And>e. e \<in> contains TG2 \<Longrightarrow> e \<notin> contains TG1 \<Longrightarrow> e \<in> ET TG1 \<Longrightarrow> lower (m_in (mult TG1 e)) = \<^bold>0" *)
  shows "type_graph (tg_combine TG1 TG2)"
proof (intro Type_Graph.type_graph.intro)
  fix n
  assume "n \<in> NT (tg_combine TG1 TG2)"
  then have "n \<in> NT TG1 \<union> NT TG2"
    by (simp add: tg_combine_def)
  then show "n \<in> Lab\<^sub>t \<union> Lab\<^sub>p"
    using first_type_graph_correct second_type_graph_correct type_graph.structure_nodes_wellformed by auto
next
  fix s l t
  assume "(s, l, t) \<in> ET (tg_combine TG1 TG2)"
  then have edges_tg_combined: "(s, l, t) \<in> ET TG1 \<union> ET TG2"
    by (simp add: tg_combine_def)
  then have "s \<in> NT TG1 \<union> NT TG2 \<and> l \<in> Lab\<^sub>e \<union> Lab\<^sub>f \<and> t \<in> NT TG1 \<union> NT TG2"
    using first_type_graph_correct second_type_graph_correct type_graph.structure_edges_wellformed by auto
  then show "s \<in> NT (tg_combine TG1 TG2) \<and> l \<in> Lab\<^sub>e \<union> Lab\<^sub>f \<and> t \<in> NT (tg_combine TG1 TG2)"
    by (simp add: tg_combine_def)
next
  have "Field ((inh TG1 \<union> inh TG2)\<^sup>+) = NT TG1 \<union> NT TG2"
    by (simp add: Domain_Un_eq Field_def Range_Un_eq first_type_graph_correct second_type_graph_correct type_graph.validity_inh_domain type_graph.validity_inh_range)
  then show "Field (inh (tg_combine TG1 TG2)) = NT (tg_combine TG1 TG2)"
    by (simp add: tg_combine_def)
next
  fix n
  assume "n \<in> type_graph.abs (tg_combine TG1 TG2)"
  then have "n \<in> abs TG1 \<union> abs TG2"
    using Diff_iff Int_iff UnE UnI1 UnI2 tg_combine_def type_graph.simps(4)
    by metis
  then have "n \<in> NT TG1 \<union> NT TG2"
    using first_type_graph_correct second_type_graph_correct type_graph.structure_abstract_wellformed by auto
  then show "n \<in> NT (tg_combine TG1 TG2)"
    by (simp add: tg_combine_def)
next
  fix e
  assume "e \<in> ET (tg_combine TG1 TG2)"
  then have "e \<in> ET TG1 \<union> ET TG2"
    by (simp add: tg_combine_def)
  then have "multiplicity_pair (tg_combine_mult (ET TG1) (mult TG1) (ET TG2) (mult TG2) e)"
    using Un_iff first_type_graph_correct multiplicity_intersection_correct second_type_graph_correct tg_combine_mult_def type_graph.structure_mult_wellformed
    by metis
  then show "multiplicity_pair (mult (tg_combine TG1 TG2) e)"
    by (simp add: tg_combine_def)
next
  fix e
  assume "e \<notin> ET (tg_combine TG1 TG2)"
  then show "mult (tg_combine TG1 TG2) e = undefined"
    by (simp add: tg_combine_def tg_combine_mult_def)
next
  fix e
  assume "e \<in> contains (tg_combine TG1 TG2)"
  then have "e \<in> contains TG1 \<union> contains TG2"
    by (simp add: tg_combine_def)
  then have "e \<in> ET TG1 \<union> ET TG2"
    using Un_iff first_type_graph_correct second_type_graph_correct type_graph.structure_contains_wellformed
    by metis
  then show "e \<in> ET (tg_combine TG1 TG2)"
    by (simp add: tg_combine_def)
next
  fix l s1 t1 s2 t2
  assume "(s1, l, t1) \<in> ET (tg_combine TG1 TG2)"
  then have edge1: "(s1, l, t1) \<in> ET TG1 \<union> ET TG2"
    by (simp add: tg_combine_def)
  assume "(s2, l, t2) \<in> ET (tg_combine TG1 TG2)"
  then have edge2: "(s2, l, t2) \<in> ET TG1 \<union> ET TG2"
    by (simp add: tg_combine_def)
  assume "(s1, s2) \<in> inh (tg_combine TG1 TG2) \<or> (s2, s1) \<in> inh (tg_combine TG1 TG2)"
  then have src_inh: "(s1, s2) \<in> (inh TG1 \<union> inh TG2)\<^sup>+ \<or> (s2, s1) \<in> (inh TG1 \<union> inh TG2)\<^sup>+"
    by (simp add: tg_combine_def)
  assume "(t1, t2) \<in> inh (tg_combine TG1 TG2) \<or> (t2, t1) \<in> inh (tg_combine TG1 TG2)"
  then have tgt_inh: "(t1, t2) \<in> (inh TG1 \<union> inh TG2)\<^sup>+ \<or> (t2, t1) \<in> (inh TG1 \<union> inh TG2)\<^sup>+"
    by (simp add: tg_combine_def)
  show "s1 = s2 \<and> t1 = t2"
    using edge1 edge2
  proof (elim UnE)
    assume first_edge_in_tg: "(s1, l, t1) \<in> ET TG1"
    assume second_edge_in_tg: "(s2, l, t2) \<in> ET TG1"
    show ?thesis
      using src_inh tgt_inh
    proof (induct "(s1, s2) \<in> inh TG1 \<or> (s2, s1) \<in> inh TG1")
      case True
      then show ?case
      proof (induct "(t1, t2) \<in> inh TG1 \<or> (t2, t1) \<in> inh TG1")
        case True
        then show ?case
          using first_edge_in_tg second_edge_in_tg first_type_graph_correct type_graph.validity_edges_inh
          by blast
      next
        case False
        then show ?case
          using edges_inheritance_correct_tgt_tg1 first_edge_in_tg second_edge_in_tg
          by blast
      qed
    next
      case False
      then show ?case
        using edges_inheritance_correct_src_tg1 first_edge_in_tg second_edge_in_tg
        by blast
    qed
  next
    assume first_edge_in_tg: "(s1, l, t1) \<in> ET TG1"
    assume second_edge_in_tg: "(s2, l, t2) \<in> ET TG2"
    show ?thesis
      using edges_inheritance_correct_tg1_tg2 first_edge_in_tg second_edge_in_tg src_inh tgt_inh
      by blast
  next
    assume first_edge_in_tg: "(s1, l, t1) \<in> ET TG2"
    assume second_edge_in_tg: "(s2, l, t2) \<in> ET TG1"
    show ?thesis
      using edges_inheritance_correct_tg1_tg2 first_edge_in_tg second_edge_in_tg src_inh tgt_inh
      by blast
  next
    assume first_edge_in_tg: "(s1, l, t1) \<in> ET TG2"
    assume second_edge_in_tg: "(s2, l, t2) \<in> ET TG2"
    show ?thesis
      using src_inh tgt_inh
    proof (induct "(s1, s2) \<in> inh TG2 \<or> (s2, s1) \<in> inh TG2")
      case True
      then show ?case
      proof (induct "(t1, t2) \<in> inh TG2 \<or> (t2, t1) \<in> inh TG2")
        case True
        then show ?case
          using first_edge_in_tg second_edge_in_tg second_type_graph_correct type_graph.validity_edges_inh
          by blast
      next
        case False
        then show ?case
          using edges_inheritance_correct_tgt_tg2 first_edge_in_tg second_edge_in_tg
          by blast
      qed
    next
      case False
      then show ?case
        using edges_inheritance_correct_src_tg2 first_edge_in_tg second_edge_in_tg
        by blast
    qed
  qed
next
  fix s l t
  assume "(s, l, t) \<in> ET (tg_combine TG1 TG2)"
  then have edge_in_edges: "(s, l, t) \<in> ET TG1 \<union> ET TG2"
    by (simp add: tg_combine_def)
  assume "l \<in> Lab\<^sub>f"
  then show "s = t"
    using edge_in_edges first_type_graph_correct second_type_graph_correct type_graph.validity_flags by auto
next
  have "Partial_order ((inh TG1 \<union> inh TG2)\<^sup>+)"
    unfolding partial_order_on_def preorder_on_def
  proof (intro conjI)
    have trancl_subset: "(inh TG1 \<union> inh TG2) \<subseteq> (inh TG1 \<union> inh TG2)\<^sup>+"
      by auto
    have "Refl (inh TG1 \<union> inh TG2)"
      by (simp add: first_type_graph_correct second_type_graph_correct type_graph.validity_inh_refl refl_on_Un)
    then show "Refl ((inh TG1 \<union> inh TG2)\<^sup>+)"
      unfolding refl_on_def
    proof (intro conjI)
      assume refl_assump: "inh TG1 \<union> inh TG2 \<subseteq> Field (inh TG1 \<union> inh TG2) \<times> Field (inh TG1 \<union> inh TG2) \<and> (\<forall>x\<in>Field (inh TG1 \<union> inh TG2). (x, x) \<in> inh TG1 \<union> inh TG2)"
      have "inh TG1 \<union> inh TG2 \<subseteq> Field (inh TG1 \<union> inh TG2) \<times> Field (inh TG1 \<union> inh TG2)"
        using refl_assump
        by blast
      then show "(inh TG1 \<union> inh TG2)\<^sup>+ \<subseteq> Field ((inh TG1 \<union> inh TG2)\<^sup>+) \<times> Field ((inh TG1 \<union> inh TG2)\<^sup>+)"
        by (simp add: FieldI1 FieldI2 subrelI)
      have "(\<forall>x\<in>Field (inh TG1 \<union> inh TG2). (x, x) \<in> inh TG1 \<union> inh TG2)"
        using refl_assump
        by blast
      then show "\<forall>x\<in>Field ((inh TG1 \<union> inh TG2)\<^sup>+). (x, x) \<in> (inh TG1 \<union> inh TG2)\<^sup>+"
        using Field_square mono_Field set_mp set_mp trancl_subset trancl_subset_Field2
        by metis
    qed
    show "trans ((inh TG1 \<union> inh TG2)\<^sup>+)"
      by auto
    show "antisym ((inh TG1 \<union> inh TG2)\<^sup>+)"
      using assms by simp
  qed
  then show "Partial_order (inh (tg_combine TG1 TG2))"
    by (simp add: tg_combine_def)
next
  fix e
  assume "e \<in> contains (tg_combine TG1 TG2)"
  then have "e \<in> contains TG1 \<union> contains TG2"
    by (simp add: tg_combine_def)
  then have "e \<in> contains TG1 \<inter> contains TG2 \<or> e \<in> contains TG1 - contains TG2 \<or> e \<in> contains TG2 - contains TG1"
    by blast
  then have "upper (m_in (tg_combine_mult (ET TG1) (mult TG1) (ET TG2) (mult TG2) e)) = \<^bold>1"
  proof (elim disjE)
    assume e_in_intersection: "e \<in> contains TG1 \<inter> contains TG2"
    have e_in_tg1: "e \<in> contains TG1"
      using e_in_intersection
      by auto
    have e_in_tg2: "e \<in> contains TG2"
      using e_in_intersection
      by auto
    have "upper (m_in (mult_pair_intersect (mult TG1 e) (mult TG2 e))) = \<^bold>1"
      using e_in_tg1 e_in_tg2 first_type_graph_correct second_type_graph_correct type_graph.validity_mult_containment
      using fstI m_in_def min_def mult_intersect_def mult_pair_intersect_def sndI upper_def
      by metis
    then show "upper (m_in (tg_combine_mult (ET TG1) (mult TG1) (ET TG2) (mult TG2) e)) = \<^bold>1"
      unfolding tg_combine_mult_def
      by (simp add: e_in_tg1 e_in_tg2 first_type_graph_correct second_type_graph_correct type_graph.structure_contains_wellformed)
  next
    assume e_in_contains: "e \<in> contains TG1 - contains TG2"
    have e_not_in_tg2: "e \<notin> contains TG2"
      using e_in_contains by simp
    have e_in_tg1: "e \<in> contains TG1"
      using e_in_contains by simp
    have contains_mult_e: "upper (m_in (mult TG1 e)) = \<^bold>1"
      using e_in_tg1 first_type_graph_correct type_graph.validity_mult_containment by blast
    have "e \<in> ET TG2 \<Longrightarrow> upper (m_in (mult TG2 e)) \<ge> \<^bold>1"
      using second_type_graph_correct type_graph.structure_mult_wellformed multiplicity_pair.in_mult_is_mult multiplicity.upper_bound_valid_alt
      by blast
    then have upper_intersect_one: "e \<in> ET TG2 \<Longrightarrow> upper (m_in (mult_pair_intersect (mult TG1 e) (mult TG2 e))) = \<^bold>1"
      unfolding mult_pair_intersect_def mult_intersect_def
      using contains_mult_e min.absorb1 by auto
    then show "upper (m_in (tg_combine_mult (ET TG1) (mult TG1) (ET TG2) (mult TG2) e)) = \<^bold>1"
      unfolding tg_combine_mult_def
      using e_in_tg1 first_type_graph_correct contains_mult_e type_graph.structure_contains_wellformed by fastforce
  next
    assume e_in_contains: "e \<in> contains TG2 - contains TG1"
    have e_not_in_tg1: "e \<notin> contains TG1"
      using e_in_contains by simp
    have e_in_tg2: "e \<in> contains TG2"
      using e_in_contains by simp
    have contains_mult_e: "upper (m_in (mult TG2 e)) = \<^bold>1"
      using e_in_tg2 second_type_graph_correct type_graph.validity_mult_containment by blast
    have "e \<in> ET TG1 \<Longrightarrow> upper (m_in (mult TG1 e)) \<ge> \<^bold>1"
      using first_type_graph_correct type_graph.structure_mult_wellformed multiplicity_pair.in_mult_is_mult multiplicity.upper_bound_valid_alt
      by blast
    then have upper_intersect_one: "e \<in> ET TG1 \<Longrightarrow> upper (m_in (mult_pair_intersect (mult TG1 e) (mult TG2 e))) = \<^bold>1"
      unfolding mult_pair_intersect_def mult_intersect_def
      using contains_mult_e min.absorb2 by auto
    then show "upper (m_in (tg_combine_mult (ET TG1) (mult TG1) (ET TG2) (mult TG2) e)) = \<^bold>1"
      unfolding tg_combine_mult_def
      using e_in_tg2 second_type_graph_correct contains_mult_e type_graph.structure_contains_wellformed by fastforce
  qed
  then show "upper (m_in (mult (tg_combine TG1 TG2) e)) = \<^bold>1"
    by (simp add: tg_combine_def)
qed

lemma tg_combine_merge_correct[intro]:
  assumes first_type_graph_correct: "type_graph TG1"
  assumes second_type_graph_correct: "type_graph TG2"
  assumes combine_edges_distinct: "ET TG1 \<inter> ET TG2 = {}"
  assumes edges_inheritance_correct_src_tg1: "\<And>l s1 t1 s2 t2. (s1, l, t1) \<in> ET TG1 \<Longrightarrow> (s2, l, t2) \<in> ET TG1 \<Longrightarrow>
    (s1, s2) \<in> (inh TG1 \<union> inh TG2)\<^sup>+ - inh TG1 \<or> (s2, s1) \<in> (inh TG1 \<union> inh TG2)\<^sup>+ - inh TG1 \<Longrightarrow>
    (t1, t2) \<in> (inh TG1 \<union> inh TG2)\<^sup>+ \<or> (t2, t1) \<in> (inh TG1 \<union> inh TG2)\<^sup>+ \<Longrightarrow> s1 = s2 \<and> t1 = t2"
  assumes edges_inheritance_correct_tgt_tg1: "\<And>l s1 t1 s2 t2. (s1, l, t1) \<in> ET TG1 \<Longrightarrow> (s2, l, t2) \<in> ET TG1 \<Longrightarrow>
    (s1, s2) \<in> (inh TG1 \<union> inh TG2)\<^sup>+ \<or> (s2, s1) \<in> (inh TG1 \<union> inh TG2)\<^sup>+ \<Longrightarrow>
    (t1, t2) \<in> (inh TG1 \<union> inh TG2)\<^sup>+ - inh TG1 \<or> (t2, t1) \<in> (inh TG1 \<union> inh TG2)\<^sup>+ - inh TG1 \<Longrightarrow> s1 = s2 \<and> t1 = t2"
  assumes edges_inheritance_correct_src_tg2: "\<And>l s1 t1 s2 t2. (s1, l, t1) \<in> ET TG2 \<Longrightarrow> (s2, l, t2) \<in> ET TG2 \<Longrightarrow>
    (s1, s2) \<in> (inh TG1 \<union> inh TG2)\<^sup>+ - inh TG2 \<or> (s2, s1) \<in> (inh TG1 \<union> inh TG2)\<^sup>+ - inh TG2 \<Longrightarrow>
    (t1, t2) \<in> (inh TG1 \<union> inh TG2)\<^sup>+ \<or> (t2, t1) \<in> (inh TG1 \<union> inh TG2)\<^sup>+ \<Longrightarrow> s1 = s2 \<and> t1 = t2"
  assumes edges_inheritance_correct_tgt_tg2: "\<And>l s1 t1 s2 t2. (s1, l, t1) \<in> ET TG2 \<Longrightarrow> (s2, l, t2) \<in> ET TG2 \<Longrightarrow>
    (s1, s2) \<in> (inh TG1 \<union> inh TG2)\<^sup>+ \<or> (s2, s1) \<in> (inh TG1 \<union> inh TG2)\<^sup>+ \<Longrightarrow>
    (t1, t2) \<in> (inh TG1 \<union> inh TG2)\<^sup>+ - inh TG2 \<or> (t2, t1) \<in> (inh TG1 \<union> inh TG2)\<^sup>+ - inh TG2 \<Longrightarrow> s1 = s2 \<and> t1 = t2"
  assumes edges_inheritance_correct_tg1_tg2: "\<And>l s1 t1 s2 t2. (s1, l, t1) \<in> ET TG1 \<Longrightarrow> (s2, l, t2) \<in> ET TG2 \<Longrightarrow>
    (s1, s2) \<in> (inh TG1 \<union> inh TG2)\<^sup>+ \<or> (s2, s1) \<in> (inh TG1 \<union> inh TG2)\<^sup>+ \<Longrightarrow>
    (t1, t2) \<in> (inh TG1 \<union> inh TG2)\<^sup>+ \<or> (t2, t1) \<in> (inh TG1 \<union> inh TG2)\<^sup>+ \<Longrightarrow> s1 = s2 \<and> t1 = t2"
  assumes inheritance_antisymmetry: "antisym ((inh TG1 \<union> inh TG2)\<^sup>+)"
  shows "type_graph (tg_combine TG1 TG2)"
proof (intro tg_combine_correct)
  fix e
  assume "e \<in> ET TG1 \<inter> ET TG2"
  then show "multiplicity_pair (mult_pair_intersect (mult TG1 e) (mult TG2 e))"
    using combine_edges_distinct
    by blast
qed (simp_all only: assms)

lemma tg_combine_distinct_inh[simp]:
  assumes first_type_graph_correct: "type_graph TG1"
  assumes second_type_graph_correct: "type_graph TG2"
  assumes combine_nodes_distinct: "NT TG1 \<inter> NT TG2 = {}"
  shows "(inh TG1 \<union> inh TG2)\<^sup>+ = inh TG1 \<union> inh TG2"
proof
  show "(inh TG1 \<union> inh TG2)\<^sup>+ \<subseteq> inh TG1 \<union> inh TG2"
  proof
    fix x
    assume "x \<in> (inh TG1 \<union> inh TG2)\<^sup>+"
    then show "x \<in> inh TG1 \<union> inh TG2"
    proof (induct x)
      case (Pair a b)
      then show ?case
      proof (induct)
        case (base y)
        then show ?case
          by simp
      next
        case (step y z)
        then show ?case
        proof (induct "(a, y) \<in> inh TG1")
          case True
          then have "(y, z) \<notin> inh TG2"
            using combine_nodes_distinct disjoint_iff_not_equal first_type_graph_correct
            using second_type_graph_correct type_graph.structure_inheritance_wellformed_first_node
            using type_graph.structure_inheritance_wellformed_second_node
            by metis
          then have "(y, z) \<in> inh TG1"
            using step.hyps(2) by blast
          then have "(a, z) \<in> inh TG1"
            using True.hyps first_type_graph_correct transE type_graph.validity_inh_trans
            by metis
          then show ?case
            by simp
        next
          case False
          then have ay_in_tg2: "(a, y) \<in> inh TG2"
            by simp
          then have "(y, z) \<notin> inh TG1"
            using combine_nodes_distinct disjoint_iff_not_equal first_type_graph_correct
            using second_type_graph_correct type_graph.structure_inheritance_wellformed_first_node
            using type_graph.structure_inheritance_wellformed_second_node
            by metis
          then have "(y, z) \<in> inh TG2"
            using step.hyps(2) by blast
          then have "(a, z) \<in> inh TG2"
            using ay_in_tg2 second_type_graph_correct transE type_graph.validity_inh_trans
            by metis
          then show ?case
            by simp
        qed
      qed
    qed
  qed
next
  show "inh TG1 \<union> inh TG2 \<subseteq> (inh TG1 \<union> inh TG2)\<^sup>+"
    by auto
qed

lemma tg_combine_distinct_correct[simp]:
  assumes first_type_graph_correct: "type_graph TG1"
  assumes second_type_graph_correct: "type_graph TG2"
  assumes combine_nodes_distinct: "NT TG1 \<inter> NT TG2 = {}"
  shows "type_graph (tg_combine TG1 TG2)"
proof (intro tg_combine_merge_correct)
  show "ET TG1 \<inter> ET TG2 = {}"
    using combine_nodes_distinct disjoint_iff_not_equal first_type_graph_correct second_type_graph_correct type_graph.structure_edges_wellformed_src_node_alt
    by metis
next
  fix l s1 t1 s2 t2
  assume first_edge_in_tg: "(s1, l, t1) \<in> ET TG1"
  assume second_edge_in_tg: "(s2, l, t2) \<in> ET TG1"
  assume "(s1, s2) \<in> (inh TG1 \<union> inh TG2)\<^sup>+ - inh TG1 \<or> (s2, s1) \<in> (inh TG1 \<union> inh TG2)\<^sup>+ - inh TG1"
  then have src_inh: "(s1, s2) \<in> inh TG2 \<or> (s2, s1) \<in> inh TG2"
    using combine_nodes_distinct first_type_graph_correct second_type_graph_correct
    by auto
  assume "(t1, t2) \<in> (inh TG1 \<union> inh TG2)\<^sup>+ \<or> (t2, t1) \<in> (inh TG1 \<union> inh TG2)\<^sup>+"
  then have tgt_inh: "(t1, t2) \<in> inh TG1 \<union> inh TG2 \<or> (t2, t1) \<in> inh TG1 \<union> inh TG2"
    by (simp add: combine_nodes_distinct first_type_graph_correct second_type_graph_correct)
  then show "s1 = s2 \<and> t1 = t2"
    using FieldI1 FieldI2 combine_nodes_distinct disjoint_iff_not_equal first_edge_in_tg first_type_graph_correct second_type_graph_correct src_inh type_graph.structure_edges_wellformed type_graph.structure_inheritance_wellformed
    by metis
next
  fix l s1 t1 s2 t2
  assume first_edge_in_tg: "(s1, l, t1) \<in> ET TG1"
  assume second_edge_in_tg: "(s2, l, t2) \<in> ET TG1"
  assume "(s1, s2) \<in> (inh TG1 \<union> inh TG2)\<^sup>+ \<or> (s2, s1) \<in> (inh TG1 \<union> inh TG2)\<^sup>+"
  then have src_inh: "(s1, s2) \<in> inh TG1 \<union> inh TG2 \<or> (s2, s1) \<in> inh TG1 \<union> inh TG2"
    by (simp add: combine_nodes_distinct first_type_graph_correct second_type_graph_correct)
  assume "(t1, t2) \<in> (inh TG1 \<union> inh TG2)\<^sup>+ - inh TG1 \<or> (t2, t1) \<in> (inh TG1 \<union> inh TG2)\<^sup>+ - inh TG1"
  then have tgt_inh: "(t1, t2) \<in> inh TG2 \<or> (t2, t1) \<in> inh TG2"
    using combine_nodes_distinct first_type_graph_correct second_type_graph_correct
    by auto
  then show "s1 = s2 \<and> t1 = t2"
    using FieldI1 FieldI2 combine_nodes_distinct disjoint_iff_not_equal first_edge_in_tg first_type_graph_correct second_type_graph_correct src_inh type_graph.structure_edges_wellformed type_graph.structure_inheritance_wellformed
    by metis
next
  fix l s1 t1 s2 t2
  assume first_edge_in_tg: "(s1, l, t1) \<in> ET TG2"
  assume second_edge_in_tg: "(s2, l, t2) \<in> ET TG2"
  assume "(s1, s2) \<in> (inh TG1 \<union> inh TG2)\<^sup>+ - inh TG2 \<or> (s2, s1) \<in> (inh TG1 \<union> inh TG2)\<^sup>+ - inh TG2"
  then have src_inh: "(s1, s2) \<in> inh TG1 \<or> (s2, s1) \<in> inh TG1"
    using combine_nodes_distinct first_type_graph_correct second_type_graph_correct
    by auto
  assume "(t1, t2) \<in> (inh TG1 \<union> inh TG2)\<^sup>+ \<or> (t2, t1) \<in> (inh TG1 \<union> inh TG2)\<^sup>+"
  then have tgt_inh: "(t1, t2) \<in> inh TG1 \<union> inh TG2 \<or> (t2, t1) \<in> inh TG1 \<union> inh TG2"
    by (simp add: combine_nodes_distinct first_type_graph_correct second_type_graph_correct)
  then show "s1 = s2 \<and> t1 = t2"
    using FieldI1 FieldI2 combine_nodes_distinct disjoint_iff_not_equal first_edge_in_tg first_type_graph_correct second_type_graph_correct src_inh type_graph.structure_edges_wellformed type_graph.structure_inheritance_wellformed
    by metis
next
  fix l s1 t1 s2 t2
  assume first_edge_in_tg: "(s1, l, t1) \<in> ET TG2"
  assume second_edge_in_tg: "(s2, l, t2) \<in> ET TG2"
  assume "(s1, s2) \<in> (inh TG1 \<union> inh TG2)\<^sup>+ \<or> (s2, s1) \<in> (inh TG1 \<union> inh TG2)\<^sup>+"
  then have src_inh: "(s1, s2) \<in> inh TG1 \<union> inh TG2 \<or> (s2, s1) \<in> inh TG1 \<union> inh TG2"
    by (simp add: combine_nodes_distinct first_type_graph_correct second_type_graph_correct)
  assume "(t1, t2) \<in> (inh TG1 \<union> inh TG2)\<^sup>+ - inh TG2 \<or> (t2, t1) \<in> (inh TG1 \<union> inh TG2)\<^sup>+ - inh TG2"
  then have tgt_inh: "(t1, t2) \<in> inh TG1 \<or> (t2, t1) \<in> inh TG1"
    using combine_nodes_distinct first_type_graph_correct second_type_graph_correct
    by auto
  then show "s1 = s2 \<and> t1 = t2"
    using FieldI1 FieldI2 combine_nodes_distinct disjoint_iff_not_equal first_edge_in_tg first_type_graph_correct second_type_graph_correct src_inh type_graph.structure_edges_wellformed type_graph.structure_inheritance_wellformed
    by metis
next
  fix l s1 t1 s2 t2
  assume first_edge_in_tg: "(s1, l, t1) \<in> ET TG1"
  assume second_edge_in_tg: "(s2, l, t2) \<in> ET TG2"
  assume "(s1, s2) \<in> (inh TG1 \<union> inh TG2)\<^sup>+ \<or> (s2, s1) \<in> (inh TG1 \<union> inh TG2)\<^sup>+"
  then have src_inh: "(s1, s2) \<in> inh TG1 \<union> inh TG2 \<or> (s2, s1) \<in> inh TG1 \<union> inh TG2"
    by (simp add: combine_nodes_distinct first_type_graph_correct second_type_graph_correct)
  assume "(t1, t2) \<in> (inh TG1 \<union> inh TG2)\<^sup>+ \<or> (t2, t1) \<in> (inh TG1 \<union> inh TG2)\<^sup>+"
  then have tgt_inh: "(t1, t2) \<in> inh TG1 \<union> inh TG2 \<or> (t2, t1) \<in> inh TG1 \<union> inh TG2"
    by (simp add: combine_nodes_distinct first_type_graph_correct second_type_graph_correct)
  then show "s1 = s2 \<and> t1 = t2"
  proof-
    have "\<And>l. l \<notin> NT TG2 \<or> l \<notin> NT TG1"
      using combine_nodes_distinct by blast
    then show ?thesis
      using Un_iff first_edge_in_tg first_type_graph_correct second_edge_in_tg second_type_graph_correct tgt_inh type_graph.structure_edges_wellformed type_graph.structure_inheritance_wellformed_first_node type_graph.structure_inheritance_wellformed_second_node
      by metis
  qed
next
  have "antisym (inh TG1 \<union> inh TG2)"
  proof
    fix x y
    assume xy_in_merged_inh: "(x, y) \<in> inh TG1 \<union> inh TG2"
    assume yx_in_merged_inh: "(y, x) \<in> inh TG1 \<union> inh TG2"
    show "x = y"
      using xy_in_merged_inh yx_in_merged_inh
    proof (elim UnE)
      assume xy: "(x, y) \<in> inh TG1"
      assume yx: "(y, x) \<in> inh TG1"
      then show "x = y"
        using xy yx antisymD first_type_graph_correct type_graph.validity_inh_antisym
        by metis
    next
      assume xy: "(x, y) \<in> inh TG1"
      assume yx: "(y, x) \<in> inh TG2"
      then show "x = y"
        using combine_nodes_distinct disjoint_iff_not_equal first_type_graph_correct
        using second_type_graph_correct type_graph.structure_inheritance_wellformed_first_node
        using type_graph.structure_inheritance_wellformed_second_node xy
        by metis
    next
      assume xy: "(x, y) \<in> inh TG2"
      assume yx: "(y, x) \<in> inh TG2"
      then show "x = y"
        using xy yx antisymD second_type_graph_correct type_graph.validity_inh_antisym
        by metis
    next
      assume xy: "(x, y) \<in> inh TG2"
      assume yx: "(y, x) \<in> inh TG1"
      then show "x = y"
        using combine_nodes_distinct disjoint_iff_not_equal first_type_graph_correct
        using second_type_graph_correct type_graph.structure_inheritance_wellformed_first_node
        using type_graph.structure_inheritance_wellformed_second_node xy
        by metis
    qed
  qed
  then show "antisym ((inh TG1 \<union> inh TG2)\<^sup>+)"
    by (simp add: combine_nodes_distinct first_type_graph_correct second_type_graph_correct)
qed (simp_all only: assms)

lemma tg_combine_empty_correct1[simp]:
  assumes second_type_graph_correct: "type_graph TG2"
  shows "type_graph (tg_combine tg_empty TG2)"
proof (intro tg_combine_distinct_correct)
  show "type_graph tg_empty"
    by (fact Type_Graph.tg_empty_correct)
qed (simp_all add: assms)

lemma tg_combine_empty_correct2[simp]:
  assumes first_type_graph_correct: "type_graph TG1"
  shows "type_graph (tg_combine TG1 tg_empty)"
  using first_type_graph_correct tg_combine_empty_correct1
  by simp

end