(*  Author:  Sébastien Gouëzel   sebastien.gouezel@univ-rennes1.fr with additions from LCP
    License: BSD
*)

section \<open>Metrics on product spaces\<close>

theory Function_Metric
  imports
    Function_Topology
    Elementary_Metric_Spaces
begin

text \<open>In general, the product topology is not metrizable, unless the index set is countable.
When the index set is countable, essentially any (convergent) combination of the metrics on the
factors will do. We use below the simplest one, based on \<open>L\<^sup>1\<close>, but \<open>L\<^sup>2\<close> would also work,
for instance.

What is not completely trivial is that the distance thus defined induces the same topology
as the product topology. This is what we have to prove to show that we have an instance
of \<^class>\<open>metric_space\<close>.

The proofs below would work verbatim for general countable products of metric spaces. However,
since distances are only implemented in terms of type classes, we only develop the theory
for countable products of the same space.\<close>

instantiation "fun" :: (countable, metric_space) metric_space
begin

definition\<^marker>\<open>tag important\<close> dist_fun_def:
  "dist x y = (\<Sum>n. (1/2)^n * min (dist (x (from_nat n)) (y (from_nat n))) 1)"

definition\<^marker>\<open>tag important\<close> uniformity_fun_def:
  "(uniformity::(('a \<Rightarrow> 'b) \<times> ('a \<Rightarrow> 'b)) filter) = (INF e\<in>{0<..}. principal {(x, y). dist (x::('a\<Rightarrow>'b)) y < e})"

text \<open>Except for the first one, the auxiliary lemmas below are only useful when proving the
instance: once it is proved, they become trivial consequences of the general theory of metric
spaces. It would thus be desirable to hide them once the instance is proved, but I do not know how
to do this.\<close>

lemma dist_fun_le_dist_first_terms:
  "dist x y \<le> 2 * Max {dist (x (from_nat n)) (y (from_nat n))|n. n \<le> N} + (1/2)^N"
proof -
  have "(\<Sum>n. (1 / 2) ^ (n+Suc N) * min (dist (x (from_nat (n+Suc N))) (y (from_nat (n+Suc N)))) 1)
          = (\<Sum>n. (1 / 2) ^ (Suc N) * ((1/2) ^ n * min (dist (x (from_nat (n+Suc N))) (y (from_nat (n+Suc N)))) 1))"
    by (rule suminf_cong, simp add: power_add)
  also have "... = (1/2)^(Suc N) * (\<Sum>n. (1 / 2) ^ n * min (dist (x (from_nat (n+Suc N))) (y (from_nat (n+Suc N)))) 1)"
    apply (rule suminf_mult)
    by (rule summable_comparison_test'[of "\<lambda>n. (1/2)^n"], auto simp add: summable_geometric_iff)
  also have "... \<le> (1/2)^(Suc N) * (\<Sum>n. (1 / 2) ^ n)"
    apply (simp, rule suminf_le, simp)
    by (rule summable_comparison_test'[of "\<lambda>n. (1/2)^n"], auto simp add: summable_geometric_iff)
  also have "... = (1/2)^(Suc N) * 2"
    using suminf_geometric[of "1/2"] by auto
  also have "... = (1/2)^N"
    by auto
  finally have *: "(\<Sum>n. (1 / 2) ^ (n+Suc N) * min (dist (x (from_nat (n+Suc N))) (y (from_nat (n+Suc N)))) 1) \<le> (1/2)^N"
    by simp

  define M where "M = Max {dist (x (from_nat n)) (y (from_nat n))|n. n \<le> N}"
  have "dist (x (from_nat 0)) (y (from_nat 0)) \<le> M"
    unfolding M_def by (rule Max_ge, auto)
  then have [simp]: "M \<ge> 0" by (meson dual_order.trans zero_le_dist)
  have "dist (x (from_nat n)) (y (from_nat n)) \<le> M" if "n\<le>N" for n
    unfolding M_def apply (rule Max_ge) using that by auto
  then have i: "min (dist (x (from_nat n)) (y (from_nat n))) 1 \<le> M" if "n\<le>N" for n
    using that by force
  have "(\<Sum>n< Suc N. (1 / 2) ^ n * min (dist (x (from_nat n)) (y (from_nat n))) 1) \<le>
      (\<Sum>n< Suc N. M * (1 / 2) ^ n)"
    by (rule sum_mono, simp add: i)
  also have "... = M * (\<Sum>n<Suc N. (1 / 2) ^ n)"
    by (rule sum_distrib_left[symmetric])
  also have "... \<le> M * (\<Sum>n. (1 / 2) ^ n)"
    by (rule mult_left_mono, rule sum_le_suminf, auto simp add: summable_geometric_iff)
  also have "... = M * 2"
    using suminf_geometric[of "1/2"] by auto
  finally have **: "(\<Sum>n< Suc N. (1 / 2) ^ n * min (dist (x (from_nat n)) (y (from_nat n))) 1) \<le> 2 * M"
    by simp

  have "dist x y = (\<Sum>n. (1 / 2) ^ n * min (dist (x (from_nat n)) (y (from_nat n))) 1)"
    unfolding dist_fun_def by simp
  also have "... = (\<Sum>n. (1 / 2) ^ (n+Suc N) * min (dist (x (from_nat (n+Suc N))) (y (from_nat (n+Suc N)))) 1)
                  + (\<Sum>n<Suc N. (1 / 2) ^ n * min (dist (x (from_nat n)) (y (from_nat n))) 1)"
    apply (rule suminf_split_initial_segment)
    by (rule summable_comparison_test'[of "\<lambda>n. (1/2)^n"], auto simp add: summable_geometric_iff)
  also have "... \<le> 2 * M + (1/2)^N"
    using * ** by auto
  finally show ?thesis unfolding M_def by simp
qed

lemma open_fun_contains_ball_aux:
  assumes "open (U::(('a \<Rightarrow> 'b) set))"
          "x \<in> U"
  shows "\<exists>e>0. {y. dist x y < e} \<subseteq> U"
proof -
  have *: "openin (product_topology (\<lambda>i. euclidean) UNIV) U"
    using open_fun_def assms by auto
  obtain X where H: "Pi\<^sub>E UNIV X \<subseteq> U"
                    "\<And>i. openin euclidean (X i)"
                    "finite {i. X i \<noteq> topspace euclidean}"
                    "x \<in> Pi\<^sub>E UNIV X"
    using product_topology_open_contains_basis[OF * \<open>x \<in> U\<close>] by auto
  define I where "I = {i. X i \<noteq> topspace euclidean}"
  have "finite I" unfolding I_def using H(3) by auto
  {
    fix i
    have "x i \<in> X i" using \<open>x \<in> U\<close> H by auto
    then have "\<exists>e. e>0 \<and> ball (x i) e \<subseteq> X i"
      using \<open>openin euclidean (X i)\<close> open_openin open_contains_ball by blast
    then obtain e where "e>0" "ball (x i) e \<subseteq> X i" by blast
    define f where "f = min e (1/2)"
    have "f>0" "f<1" unfolding f_def using \<open>e>0\<close> by auto
    moreover have "ball (x i) f \<subseteq> X i" unfolding f_def using \<open>ball (x i) e \<subseteq> X i\<close> by auto
    ultimately have "\<exists>f. f > 0 \<and> f < 1 \<and> ball (x i) f \<subseteq> X i" by auto
  } note * = this
  have "\<exists>e. \<forall>i. e i > 0 \<and> e i < 1 \<and> ball (x i) (e i) \<subseteq> X i"
    by (rule choice, auto simp add: *)
  then obtain e where "\<And>i. e i > 0" "\<And>i. e i < 1" "\<And>i. ball (x i) (e i) \<subseteq> X i"
    by blast
  define m where "m = Min {(1/2)^(to_nat i) * e i|i. i \<in> I}"
  have "m > 0" if "I\<noteq>{}"
    unfolding m_def Min_gr_iff using \<open>finite I\<close> \<open>I \<noteq> {}\<close> \<open>\<And>i. e i > 0\<close> by auto
  moreover have "{y. dist x y < m} \<subseteq> U"
  proof (auto)
    fix y assume "dist x y < m"
    have "y i \<in> X i" if "i \<in> I" for i
    proof -
      have *: "summable (\<lambda>n. (1/2)^n * min (dist (x (from_nat n)) (y (from_nat n))) 1)"
        by (rule summable_comparison_test'[of "\<lambda>n. (1/2)^n"], auto simp add: summable_geometric_iff)
      define n where "n = to_nat i"
      have "(1/2)^n * min (dist (x (from_nat n)) (y (from_nat n))) 1 < m"
        using \<open>dist x y < m\<close> unfolding dist_fun_def using sum_le_suminf[OF *, of "{n}"] by auto
      then have "(1/2)^(to_nat i) * min (dist (x i) (y i)) 1 < m"
        using \<open>n = to_nat i\<close> by auto
      also have "... \<le> (1/2)^(to_nat i) * e i"
        unfolding m_def apply (rule Min_le) using \<open>finite I\<close> \<open>i \<in> I\<close> by auto
      ultimately have "min (dist (x i) (y i)) 1 < e i"
        by (auto simp add: field_split_simps)
      then have "dist (x i) (y i) < e i"
        using \<open>e i < 1\<close> by auto
      then show "y i \<in> X i" using \<open>ball (x i) (e i) \<subseteq> X i\<close> by auto
    qed
    then have "y \<in> Pi\<^sub>E UNIV X" using H(1) unfolding I_def topspace_euclidean by (auto simp add: PiE_iff)
    then show "y \<in> U" using \<open>Pi\<^sub>E UNIV X \<subseteq> U\<close> by auto
  qed
  ultimately have *: "\<exists>m>0. {y. dist x y < m} \<subseteq> U" if "I \<noteq> {}" using that by auto

  have "U = UNIV" if "I = {}"
    using that H(1) unfolding I_def topspace_euclidean by (auto simp add: PiE_iff)
  then have "\<exists>m>0. {y. dist x y < m} \<subseteq> U" if "I = {}" using that zero_less_one by blast
  then show "\<exists>m>0. {y. dist x y < m} \<subseteq> U" using * by blast
qed

lemma ball_fun_contains_open_aux:
  fixes x::"('a \<Rightarrow> 'b)" and e::real
  assumes "e>0"
  shows "\<exists>U. open U \<and> x \<in> U \<and> U \<subseteq> {y. dist x y < e}"
proof -
  have "\<exists>N::nat. 2^N > 8/e"
    by (simp add: real_arch_pow)
  then obtain N::nat where "2^N > 8/e" by auto
  define f where "f = e/4"
  have [simp]: "e>0" "f > 0" unfolding f_def using assms by auto
  define X::"('a \<Rightarrow> 'b set)" where "X = (\<lambda>i. if (\<exists>n\<le>N. i = from_nat n) then {z. dist (x i) z < f} else UNIV)"
  have "{i. X i \<noteq> UNIV} \<subseteq> from_nat`{0..N}"
    unfolding X_def by auto
  then have "finite {i. X i \<noteq> topspace euclidean}"
    unfolding topspace_euclidean using finite_surj by blast
  have "\<And>i. open (X i)"
    unfolding X_def using metric_space_class.open_ball open_UNIV by auto
  then have "\<And>i. openin euclidean (X i)"
    using open_openin by auto
  define U where "U = Pi\<^sub>E UNIV X"
  have "open U"
    unfolding open_fun_def product_topology_def apply (rule topology_generated_by_Basis)
    unfolding U_def using \<open>\<And>i. openin euclidean (X i)\<close> \<open>finite {i. X i \<noteq> topspace euclidean}\<close>
    by auto
  moreover have "x \<in> U"
    unfolding U_def X_def by (auto simp add: PiE_iff)
  moreover have "dist x y < e" if "y \<in> U" for y
  proof -
    have *: "dist (x (from_nat n)) (y (from_nat n)) \<le> f" if "n \<le> N" for n
      using \<open>y \<in> U\<close> unfolding U_def apply (auto simp add: PiE_iff)
      unfolding X_def using that by (metis less_imp_le mem_Collect_eq)
    have **: "Max {dist (x (from_nat n)) (y (from_nat n))|n. n \<le> N} \<le> f"
      apply (rule Max.boundedI) using * by auto

    have "dist x y \<le> 2 * Max {dist (x (from_nat n)) (y (from_nat n))|n. n \<le> N} + (1/2)^N"
      by (rule dist_fun_le_dist_first_terms)
    also have "... \<le> 2 * f + e / 8"
      apply (rule add_mono) using ** \<open>2^N > 8/e\<close> by(auto simp add: field_split_simps)
    also have "... \<le> e/2 + e/8"
      unfolding f_def by auto
    also have "... < e"
      by auto
    finally show "dist x y < e" by simp
  qed
  ultimately show ?thesis by auto
qed

lemma fun_open_ball_aux:
  fixes U::"('a \<Rightarrow> 'b) set"
  shows "open U \<longleftrightarrow> (\<forall>x\<in>U. \<exists>e>0. \<forall>y. dist x y < e \<longrightarrow> y \<in> U)"
proof (auto)
  assume "open U"
  fix x assume "x \<in> U"
  then show "\<exists>e>0. \<forall>y. dist x y < e \<longrightarrow> y \<in> U"
    using open_fun_contains_ball_aux[OF \<open>open U\<close> \<open>x \<in> U\<close>] by auto
next
  assume H: "\<forall>x\<in>U. \<exists>e>0. \<forall>y. dist x y < e \<longrightarrow> y \<in> U"
  define K where "K = {V. open V \<and> V \<subseteq> U}"
  {
    fix x assume "x \<in> U"
    then obtain e where e: "e>0" "{y. dist x y < e} \<subseteq> U" using H by blast
    then obtain V where V: "open V" "x \<in> V" "V \<subseteq> {y. dist x y < e}"
      using ball_fun_contains_open_aux[OF \<open>e>0\<close>, of x] by auto
    have "V \<in> K"
      unfolding K_def using e(2) V(1) V(3) by auto
    then have "x \<in> (\<Union>K)" using \<open>x \<in> V\<close> by auto
  }
  then have "(\<Union>K) = U"
    unfolding K_def by auto
  moreover have "open (\<Union>K)"
    unfolding K_def by auto
  ultimately show "open U" by simp
qed

instance proof
  fix x y::"'a \<Rightarrow> 'b" show "(dist x y = 0) = (x = y)"
  proof
    assume "x = y"
    then show "dist x y = 0" unfolding dist_fun_def using \<open>x = y\<close> by auto
  next
    assume "dist x y = 0"
    have *: "summable (\<lambda>n. (1/2)^n * min (dist (x (from_nat n)) (y (from_nat n))) 1)"
      by (rule summable_comparison_test'[of "\<lambda>n. (1/2)^n"], auto simp add: summable_geometric_iff)
    have "(1/2)^n * min (dist (x (from_nat n)) (y (from_nat n))) 1 = 0" for n
      using \<open>dist x y = 0\<close> unfolding dist_fun_def by (simp add: "*" suminf_eq_zero_iff)
    then have "dist (x (from_nat n)) (y (from_nat n)) = 0" for n
      by (metis div_0 min_def nonzero_mult_div_cancel_left power_eq_0_iff
                zero_eq_1_divide_iff zero_neq_numeral)
    then have "x (from_nat n) = y (from_nat n)" for n
      by auto
    then have "x i = y i" for i
      by (metis from_nat_to_nat)
    then show "x = y"
      by auto
  qed
next
  text\<open>The proof of the triangular inequality is trivial, modulo the fact that we are dealing
        with infinite series, hence we should justify the convergence at each step. In this
        respect, the following simplification rule is extremely handy.\<close>
  have [simp]: "summable (\<lambda>n. (1/2)^n * min (dist (u (from_nat n)) (v (from_nat n))) 1)" for u v::"'a \<Rightarrow> 'b"
    by (rule summable_comparison_test'[of "\<lambda>n. (1/2)^n"], auto simp add: summable_geometric_iff)
  fix x y z::"'a \<Rightarrow> 'b"
  {
    fix n
    have *: "dist (x (from_nat n)) (y (from_nat n)) \<le>
            dist (x (from_nat n)) (z (from_nat n)) + dist (y (from_nat n)) (z (from_nat n))"
      by (simp add: dist_triangle2)
    have "0 \<le> dist (y (from_nat n)) (z (from_nat n))"
      using zero_le_dist by blast
    moreover
    {
      assume "min (dist (y (from_nat n)) (z (from_nat n))) 1 \<noteq> dist (y (from_nat n)) (z (from_nat n))"
      then have "1 \<le> min (dist (x (from_nat n)) (z (from_nat n))) 1 + min (dist (y (from_nat n)) (z (from_nat n))) 1"
        by (metis (no_types) diff_le_eq diff_self min_def zero_le_dist zero_le_one)
    }
    ultimately have "min (dist (x (from_nat n)) (y (from_nat n))) 1 \<le>
            min (dist (x (from_nat n)) (z (from_nat n))) 1 + min (dist (y (from_nat n)) (z (from_nat n))) 1"
      using * by linarith
  } note ineq = this
  have "dist x y = (\<Sum>n. (1/2)^n * min (dist (x (from_nat n)) (y (from_nat n))) 1)"
    unfolding dist_fun_def by simp
  also have "... \<le> (\<Sum>n. (1/2)^n * min (dist (x (from_nat n)) (z (from_nat n))) 1
                        + (1/2)^n * min (dist (y (from_nat n)) (z (from_nat n))) 1)"
    apply (rule suminf_le)
    using ineq apply (metis (no_types, opaque_lifting) add.right_neutral distrib_left
      le_divide_eq_numeral1(1) mult_2_right mult_left_mono zero_le_one zero_le_power)
    by (auto simp add: summable_add)
  also have "... = (\<Sum>n. (1/2)^n * min (dist (x (from_nat n)) (z (from_nat n))) 1)
                  + (\<Sum>n. (1/2)^n * min (dist (y (from_nat n)) (z (from_nat n))) 1)"
    by (rule suminf_add[symmetric], auto)
  also have "... = dist x z + dist y z"
    unfolding dist_fun_def by simp
  finally show "dist x y \<le> dist x z + dist y z"
    by simp
next
  text\<open>Finally, we show that the topology generated by the distance and the product
        topology coincide. This is essentially contained in Lemma \<open>fun_open_ball_aux\<close>,
        except that the condition to prove is expressed with filters. To deal with this,
        we copy some mumbo jumbo from Lemma \<open>eventually_uniformity_metric\<close> in
        \<^file>\<open>~~/src/HOL/Real_Vector_Spaces.thy\<close>\<close>
  fix U::"('a \<Rightarrow> 'b) set"
  have "eventually P uniformity \<longleftrightarrow> (\<exists>e>0. \<forall>x (y::('a \<Rightarrow> 'b)). dist x y < e \<longrightarrow> P (x, y))" for P
  unfolding uniformity_fun_def apply (subst eventually_INF_base)
    by (auto simp: eventually_principal subset_eq intro: bexI[of _ "min _ _"])
  then show "open U = (\<forall>x\<in>U. \<forall>\<^sub>F (x', y) in uniformity. x' = x \<longrightarrow> y \<in> U)"
    unfolding fun_open_ball_aux by simp
qed (simp add: uniformity_fun_def)

end

text \<open>Nice properties of spaces are preserved under countable products. In addition
to first countability, second countability and metrizability, as we have seen above,
completeness is also preserved, and therefore being Polish.\<close>

instance "fun" :: (countable, complete_space) complete_space
proof
  fix u::"nat \<Rightarrow> ('a \<Rightarrow> 'b)" assume "Cauchy u"
  have "Cauchy (\<lambda>n. u n i)" for i
  unfolding cauchy_def proof (intro impI allI)
    fix e assume "e>(0::real)"
    obtain k where "i = from_nat k"
      using from_nat_to_nat[of i] by metis
    have "(1/2)^k * min e 1 > 0" using \<open>e>0\<close> by auto
    then have "\<exists>N. \<forall>m n. N \<le> m \<and> N \<le> n \<longrightarrow> dist (u m) (u n) < (1/2)^k * min e 1"
      using \<open>Cauchy u\<close> unfolding cauchy_def by blast
    then obtain N::nat where C: "\<forall>m n. N \<le> m \<and> N \<le> n \<longrightarrow> dist (u m) (u n) < (1/2)^k * min e 1"
      by blast
    have "\<forall>m n. N \<le> m \<and> N \<le> n \<longrightarrow> dist (u m i) (u n i) < e"
    proof (auto)
      fix m n::nat assume "m \<ge> N" "n \<ge> N"
      have "(1/2)^k * min (dist (u m i) (u n i)) 1
              = sum (\<lambda>p. (1/2)^p * min (dist (u m (from_nat p)) (u n (from_nat p))) 1) {k}"
        using \<open>i = from_nat k\<close> by auto
      also have "... \<le> (\<Sum>p. (1/2)^p * min (dist (u m (from_nat p)) (u n (from_nat p))) 1)"
        apply (rule sum_le_suminf)
        by (rule summable_comparison_test'[of "\<lambda>n. (1/2)^n"], auto simp add: summable_geometric_iff)
      also have "... = dist (u m) (u n)"
        unfolding dist_fun_def by auto
      also have "... < (1/2)^k * min e 1"
        using C \<open>m \<ge> N\<close> \<open>n \<ge> N\<close> by auto
      finally have "min (dist (u m i) (u n i)) 1 < min e 1"
        by (auto simp add: field_split_simps)
      then show "dist (u m i) (u n i) < e" by auto
    qed
    then show "\<exists>N. \<forall>m n. N \<le> m \<and> N \<le> n \<longrightarrow> dist (u m i) (u n i) < e"
      by blast
  qed
  then have "\<exists>x. (\<lambda>n. u n i) \<longlonglongrightarrow> x" for i
    using Cauchy_convergent convergent_def by auto
  then have "\<exists>x. \<forall>i. (\<lambda>n. u n i) \<longlonglongrightarrow> x i"
    using choice by force
  then obtain x where *: "\<And>i. (\<lambda>n. u n i) \<longlonglongrightarrow> x i" by blast
  have "u \<longlonglongrightarrow> x"
  proof (rule metric_LIMSEQ_I)
    fix e assume [simp]: "e>(0::real)"
    have i: "\<exists>K. \<forall>n\<ge>K. dist (u n i) (x i) < e/4" for i
      by (rule metric_LIMSEQ_D, auto simp add: *)
    have "\<exists>K. \<forall>i. \<forall>n\<ge>K i. dist (u n i) (x i) < e/4"
      apply (rule choice) using i by auto
    then obtain K where K: "\<And>i n. n \<ge> K i \<Longrightarrow> dist (u n i) (x i) < e/4"
      by blast

    have "\<exists>N::nat. 2^N > 4/e"
      by (simp add: real_arch_pow)
    then obtain N::nat where "2^N > 4/e" by auto
    define L where "L = Max {K (from_nat n)|n. n \<le> N}"
    have "dist (u k) x < e" if "k \<ge> L" for k
    proof -
      have *: "dist (u k (from_nat n)) (x (from_nat n)) \<le> e / 4" if "n \<le> N" for n
      proof -
        have "K (from_nat n) \<le> L"
          unfolding L_def apply (rule Max_ge) using \<open>n \<le> N\<close> by auto
        then have "k \<ge> K (from_nat n)" using \<open>k \<ge> L\<close> by auto
        then show ?thesis using K less_imp_le by auto
      qed
      have **: "Max {dist (u k (from_nat n)) (x (from_nat n)) |n. n \<le> N} \<le> e/4"
        apply (rule Max.boundedI) using * by auto
      have "dist (u k) x \<le> 2 * Max {dist (u k (from_nat n)) (x (from_nat n)) |n. n \<le> N} + (1/2)^N"
        using dist_fun_le_dist_first_terms by auto
      also have "... \<le> 2 * e/4 + e/4"
        apply (rule add_mono)
        using ** \<open>2^N > 4/e\<close> less_imp_le by (auto simp add: field_split_simps)
      also have "... < e" by auto
      finally show ?thesis by simp
    qed
    then show "\<exists>L. \<forall>k\<ge>L. dist (u k) x < e" by blast
  qed
  then show "convergent u" using convergent_def by blast
qed

instance "fun" :: (countable, polish_space) polish_space
  by standard

end


theory TeslDenotationalCore
imports Main HOL.Real
begin

text \<open>
  We define here the semantic domain of TESL.
\<close>

section \<open> Preliminaries \<close>

text \<open>
  The rank of a system of clocks is its number of elementary clocks.
\<close>

class rank =
  fixes   rank :: \<open>'a \<Rightarrow> nat\<close>
  assumes pos  : \<open>rank x > 0\<close>
    and   const: \<open>rank x = rank y\<close>

text \<open>
  Basic types are instances of rank.
\<close>

instantiation nat :: rank
begin
   definition rank_nat_def : \<open>rank (x::nat) = 1\<close>
   instance proof
     show \<open>\<And>x::nat. 0 < rank x\<close> using rank_nat_def by simp
     show \<open>\<And>(x::nat) (y::nat). rank x = rank y\<close> using rank_nat_def by simp
   qed
end

instantiation int :: rank
begin
   definition rank_int_def : \<open>rank (x::int) = 1\<close>
   instance proof
     show \<open>\<And>x::int. 0 < rank x\<close> using rank_int_def by simp
     show \<open>\<And>(x::int) (y::int). rank x = rank y\<close> using rank_int_def by simp
   qed
end

instantiation real :: rank
begin
   definition rank_real_def : \<open>rank (x::real) = 1\<close>
   instance proof
     show \<open>\<And>x::real. 0 < rank x\<close> using rank_real_def by simp
     show \<open>\<And>(x::real) (y::real). rank x = rank y\<close> using rank_real_def by simp
   qed
end

text \<open>
  The product of to rank types is a rank too.
\<close>

instantiation prod :: (rank,rank)rank
begin
  definition rank_prod_def : \<open>rank (x::'a\<times>'b) = rank(fst x) + rank(snd x)\<close>
  instance proof
    show \<open>\<And>(x::'a\<times>'b). 0 < rank x\<close> using rank_prod_def by (simp add:pos)

    { fix x y
      have \<open>rank x = rank (fst x) + rank (snd x)\<close> using rank_prod_def by simp
      moreover have \<open>rank y = rank (fst y) + rank (snd y)\<close> using rank_prod_def by simp
      moreover have \<open>rank (fst x) = rank (fst y)\<close> by (simp add: const)
      moreover have \<open>rank (snd x) = rank (snd y)\<close> by (simp add: const)
      ultimately have \<open>rank x = rank y\<close> by simp
    } thus \<open>\<And>(x::'a\<times>'b) (y::'a\<times>'b). rank x = rank y\<close> .
  qed
end

text \<open>
  The behavior of a TESL system of clocks is a series of instants where each clock
  has its own time. We define here an order on instants seen as tuples of dates.
  An instant is before another if all its components are less than the components of the other.
  An instant is strictly before another if it is before the other and at least one component
  is strictly less than the matching component in the other instant.
\<close>
instantiation prod :: (order,order)order
begin
   definition less_eq_prod_def :
             \<open>(s::('a::order \<times> 'b::order)) \<le> t \<equiv>
                    (fst s \<le> fst t \<and> snd s \<le> snd t)\<close>
   definition less_prod_def :
             \<open>(s::('a::order \<times> 'b::order)) < t \<equiv>
                       (s \<le> t \<and> (fst s < fst t \<or> snd s < snd t))\<close>
   instance proof
     fix x::\<open>('a::order \<times> 'b::order)\<close>
     fix y::\<open>('a::order \<times> 'b::order)\<close>
     show   \<open>(x < y) = (x \<le> y \<and> \<not> y \<le> x)\<close>
            unfolding less_eq_prod_def less_prod_def by (auto simp add: less_le_not_le)
   next
     fix x::\<open>('a::order \<times> 'b::order)\<close>
     show   \<open>x \<le> x\<close>
            unfolding less_eq_prod_def less_prod_def by auto
   next
     fix x::\<open>('a::order \<times> 'b::order)\<close>
     fix y::\<open>('a::order \<times> 'b::order)\<close>
     fix z::\<open>('a::order \<times> 'b::order)\<close>
     assume \<open>x \<le> y\<close>
      and   \<open>y \<le> z\<close>
     then show   \<open>x \<le> z\<close>
            unfolding less_eq_prod_def less_prod_def by auto
   next
     fix x::\<open>('a::order \<times> 'b::order)\<close>
     fix y::\<open>('a::order \<times> 'b::order)\<close>
     assume \<open>x \<le> y\<close>
     and    \<open>y \<le> x\<close>
     then show   \<open>x = y\<close>
            unfolding less_eq_prod_def less_prod_def by (auto simp add: prod.expand)
   qed
end

section\<open> Tesl Domain Foundation \<close>

text \<open> An instant is a list of booleans telling which clocks tick. \<close>
type_synonym event    = \<open>bool list\<close>
text \<open> The index of a clock in an instant is a nat. \<close>
type_synonym clockidx = \<open>nat\<close>
text \<open> The index of an instant in a run is a nat. \<close>
type_synonym instant  = \<open>nat\<close>

text \<open> The structure of time \<close>
type_synonym 'a time_structure = \<open>(instant \<Rightarrow> 'a)\<close>

text\<open> A hamlet associates an event to an instant: To tick or not to tick \<close>
type_synonym hamlet = \<open>instant \<Rightarrow> event\<close>

text\<open> Tell whether a tick occurs in an event. \<close>
definition tick_occurs :: \<open>bool list \<Rightarrow> bool\<close>
where
  \<open>tick_occurs l \<equiv> (\<exists>x \<in> set l. x)\<close>

definition tick_occurs_fun :: \<open>bool list \<Rightarrow> bool\<close>
where     \<open>tick_occurs_fun \<equiv> foldl disj False \<close>

lemma foldl_or:
  \<open>foldl disj False (b#l) = (b \<or> (foldl disj False l))\<close>
proof
  show \<open>foldl disj False (b # l) \<Longrightarrow> b \<or> foldl disj False l\<close>
    by (induction l, simp, case_tac b, simp+)
next
  show \<open>b \<or> foldl disj False l \<Longrightarrow> foldl disj False (b # l)\<close>
  proof -
    assume assm: \<open>b \<or> foldl disj False l\<close>
    { assume h:\<open>\<not> foldl disj False (b # l)\<close>
      hence \<open>\<not> foldl disj (False \<or> b) l\<close> using foldl_Cons by simp
      with assm have \<open>(False \<or> b)\<close> by fastforce
      hence \<open>foldl disj (False \<or> b) l\<close> by (simp add: rev_induct)
      with h have False by simp
    } thus ?thesis by blast
  qed
qed

lemma occurs_or: \<open>tick_occurs_fun (b # l) = (b \<or> (tick_occurs_fun l))\<close>
unfolding tick_occurs_fun_def using foldl_or .

lemma tick_occurs_is_fun: \<open>tick_occurs l = tick_occurs_fun l\<close>
proof (induction l)
  case Nil show ?case unfolding tick_occurs_def tick_occurs_fun_def by simp
next
  case (Cons b l)
    show ?case using occurs_or Cons.IH tick_occurs_def by simp
qed

text\<open>
The semantic domain of a single run consists of two components :
\<^enum> the time structure of the "global current time" evolution.
  The global current time is just the product of local effective times of the clocks of a
  specification. The time structure is monotonous because time cannot regress in a run.
\<^enum> an additional component that captures the \<^emph>\<open>ticks\<close> of the clocks,
  i.e. the moments when the event modeled by a clock occurs, which may force
  surrounding processes into synchronization.

The latter component is also called the "Hamlet component": to tick or not to tick.
\<close>

class orderedrank = order + rank

instance nat::orderedrank ..
instance int::orderedrank ..

text \<open>
  In all runs, time is monotonic and the size of the hamlet is always the number of clocks.
\<close>
definition \<open>run_rep_prop (t::(('a::orderedrank)time_structure)) (h::hamlet)
            \<equiv> mono t \<and> (\<forall>n. rank (t n) = length (h n))\<close>

typedef (overloaded) ('a) run = \<open>{(t::(('a::orderedrank)time_structure), (h::hamlet)).
                                      run_rep_prop t h
                                 }\<close>
proof -
  {
    fix c::\<open>'a::orderedrank\<close>
    fix r::\<open>'a time_structure \<times> hamlet\<close>
    assume assm: \<open>r = ((\<lambda>n::instant. c),  (\<lambda>n::instant. replicate (rank c) True))\<close>
      have \<open>mono (\<lambda>n::instant. c)\<close> by (simp add: monoI)
      moreover have \<open>length (replicate (rank c) True) = rank c\<close> by simp
      ultimately have \<open>r \<in> {(t, h). run_rep_prop t h}\<close> using assm by (simp add: run_rep_prop_def)
  }
  thus ?thesis by blast
qed

text \<open> Projection of a run onto its time structure. \<close>
definition time :: \<open>('a::orderedrank) run \<Rightarrow> 'a time_structure\<close>
where
  \<open>time r \<equiv> fst (Rep_run r)\<close>

text \<open> Projection of a run onto its events. \<close>
definition hamlet :: \<open>('a::orderedrank) run \<Rightarrow> hamlet\<close>
where
  \<open>hamlet r \<equiv> snd (Rep_run r)\<close>

lemma run_rep_has_prop[intro]:
  \<open>(t, h) = Rep_run (r::('a::orderedrank) run) \<Longrightarrow> run_rep_prop t h\<close>
using Rep_run[of \<open>r\<close>] by auto

lemma run_has_prop[intro]:
  \<open>run_rep_prop (time r) (hamlet r)\<close>
by (simp add: hamlet_def run_rep_has_prop time_def)

lemma mono_time_run[intro]:
  \<open>mono (time r)\<close>
using run_has_prop run_rep_prop_def by blast

lemma compat_time_hamlet[intro]:
  \<open>rank (time r n) = length (hamlet r n)\<close>
using run_rep_prop_def by blast

text \<open>
  The rank of a run is its number of clocks.
\<close>
instantiation run :: (orderedrank) rank
begin
  definition rank_run_def : \<open>rank (r::('a::orderedrank) run) = rank (time r 0)\<close>
  instance proof
    show \<open>\<And>r::('a::orderedrank) run. 0 < rank r\<close>
      unfolding rank_run_def using rank_class.pos .
    show \<open>\<And>(r\<^sub>1::('a::orderedrank) run) (r\<^sub>2::('a::orderedrank) run). rank r\<^sub>1 = rank r\<^sub>2\<close>
      unfolding rank_run_def by (simp add: rank_class.const)
  qed
end

lemma rank_any_time:\<open>rank r = rank (time r n)\<close>
using rank_run_def[of \<open>r\<close>] rank_class.const[of \<open>time r 0\<close> \<open>time r n\<close>] by simp

lemma rank_any_hamlet:\<open>length (hamlet r n) = rank r\<close>
proof -
  from rank_any_time have \<open>rank r = rank (time r n)\<close> .
  with run_has_prop have \<open>rank r = length (hamlet r n)\<close> using run_rep_prop_def by auto
  thus ?thesis ..
qed

instantiation prod :: (orderedrank, orderedrank) orderedrank
begin
  instance proof qed
end

text \<open>
  Projection of a run onto its components: we project the time structure onto the component
  and keep only the corresponding occurrences of ticks in the hamlet.
\<close>
definition fst\<^sub>r\<^sub>u\<^sub>n :: \<open>('a::orderedrank \<times> 'b::orderedrank) run \<Rightarrow> 'a run\<close>
where     \<open>fst\<^sub>r\<^sub>u\<^sub>n r = Abs_run ((\<lambda>n. fst (time r n)), (\<lambda>n. take (rank (fst (time r n))) (hamlet r n)))\<close>

definition snd\<^sub>r\<^sub>u\<^sub>n :: \<open>('a::orderedrank \<times> 'b::orderedrank) run \<Rightarrow> 'b run\<close>
where     \<open>snd\<^sub>r\<^sub>u\<^sub>n r = Abs_run ((\<lambda>n. snd (time r n)), (\<lambda>n. drop (rank (fst (time r n))) (hamlet r n)))\<close>

definition prod\<^sub>r\<^sub>u\<^sub>n :: \<open>('a::orderedrank) run \<Rightarrow> 'b::orderedrank run \<Rightarrow> ('a \<times> 'b) run\<close> (infix "\<times>\<^sub>r\<^sub>u\<^sub>n" 60)
where
  \<open>r\<^sub>1 \<times>\<^sub>r\<^sub>u\<^sub>n r\<^sub>2 \<equiv> Abs_run ((\<lambda>n. (time r\<^sub>1 n, time r\<^sub>2 n)), (\<lambda>n. (hamlet r\<^sub>1 n)@(hamlet r\<^sub>2 n)))\<close>

text \<open>
  The projections of a run and the product of two runs are runs.
\<close>
lemma fstrun_is_run:
  \<open>run_rep_prop (time (fst\<^sub>r\<^sub>u\<^sub>n r)) (hamlet (fst\<^sub>r\<^sub>u\<^sub>n r))\<close>
by (simp add: run_has_prop)

lemma sndrun_is_run:
  \<open>run_rep_prop (time (snd\<^sub>r\<^sub>u\<^sub>n r)) (hamlet (snd\<^sub>r\<^sub>u\<^sub>n r))\<close>
by (simp add: run_has_prop)

lemma prod_run_is_run:
  \<open>run_rep_prop (time (r\<^sub>1 \<times>\<^sub>r\<^sub>u\<^sub>n r\<^sub>2)) (hamlet (r\<^sub>1 \<times>\<^sub>r\<^sub>u\<^sub>n r\<^sub>2))\<close>
by (simp add: run_has_prop)

lemma take_as_long:
  assumes \<open>n \<le> length l\<close>
  shows   \<open>n = length (take n l)\<close>
using assms by (simp add: min.absorb2)

lemma drop_as_long:
  assumes \<open>n \<le> length l\<close>
  shows   \<open>(length l) - n = length (drop n l)\<close>
using assms by (simp add: min.absorb2)

lemma rank_fst_le: \<open>rank (fst x) \<le> rank x\<close>
by (simp add: rank_prod_def)

lemma rank_snd_le: \<open>rank (snd x) \<le> rank x\<close>
by (simp add: rank_prod_def)

lemma fst_run_rep:
  \<open>mono (\<lambda>n. fst (time r n))
  \<and> (\<forall>n. rank (fst (time r n)) = length (take (rank (fst (time r n))) (hamlet r n)))\<close>
proof
  have mtr:\<open>mono (time r)\<close> by (simp add: mono_time_run)
  thus \<open>mono (\<lambda>n. fst (time r n))\<close> by (simp add: run_has_prop less_eq_prod_def mono_def)
next
  have \<open>\<forall>n. rank (fst (time r n)) \<le> rank (time r n)\<close> using rank_fst_le ..
  hence \<open>\<forall>n. rank (fst (time r n)) \<le> length (hamlet r n)\<close> by (simp add: compat_time_hamlet)
  with take_as_long show
    \<open>\<forall>n. rank (fst (time r n)) = length (take (rank (fst (time r n))) (hamlet r n))\<close> by auto
qed

lemma snd_run_rep:
  \<open>mono (\<lambda>n. snd (time r n))
  \<and> (\<forall>n. rank (snd (time r n)) = length (drop (rank (fst (time r n))) (hamlet r n)))\<close>
proof
  have mtr:\<open>mono (time r)\<close> by (simp add: mono_time_run)
  thus \<open>mono (\<lambda>n. snd (time r n))\<close> by (simp add: less_eq_prod_def mono_def)
next
  { fix n
    from compat_time_hamlet[of \<open>r\<close> \<open>n\<close>] rank_prod_def[of \<open>time r n\<close>] have
      \<open>length (hamlet r n) = rank (fst (time r n)) + rank (snd (time r n))\<close> by simp
    with diff_add_inverse have
      \<open>rank (snd (time r n)) = length (hamlet r n) - rank (fst (time r n))\<close> by simp
    also have \<open>rank (fst (time r n)) \<le> rank (time r n)\<close> using rank_fst_le .
    hence \<open>rank (fst (time r n)) \<le> length (hamlet r n)\<close> by (simp add: compat_time_hamlet)
    from drop_as_long[OF this] have
      \<open>(length (hamlet r n)) - (rank (fst (time r n))) =
        length (drop (rank (fst (time r n))) (hamlet r n))\<close> .
    finally have \<open>rank (snd (time r n)) = length (drop (rank (fst (time r n))) (hamlet r n))\<close> .
  }
  thus \<open>\<forall>n. rank (snd (time r n)) = length (drop (rank (fst (time r n))) (hamlet r n))\<close> ..
qed

lemma prod_run_rep:
  \<open>mono (\<lambda>n. (time r\<^sub>1 n, time r\<^sub>2 n))
  \<and> (\<forall>n. rank (time r\<^sub>1 n, time r\<^sub>2 n) = length ((hamlet r\<^sub>1 n)@(hamlet r\<^sub>2 n)))\<close>
proof
  have \<open>mono (time r\<^sub>1)\<close> by (simp add: mono_time_run)
  moreover have \<open>mono (time r\<^sub>2)\<close> by (simp add: mono_time_run)
  ultimately show \<open>mono (\<lambda>n. (time r\<^sub>1 n, time r\<^sub>2 n))\<close> by (simp add: less_eq_prod_def mono_def)

  have \<open>\<forall>n. rank (time r\<^sub>1 n) = length (hamlet r\<^sub>1 n)\<close> by (simp add: compat_time_hamlet)
  moreover have \<open>\<forall>n. rank (time r\<^sub>2 n) = length (hamlet r\<^sub>2 n)\<close> by (simp add: compat_time_hamlet)
  ultimately show \<open>\<forall>n. rank (time r\<^sub>1 n, time r\<^sub>2 n) = length ((hamlet r\<^sub>1 n)@(hamlet r\<^sub>2 n))\<close>
    by (simp add: rank_prod_def)
qed

lemma fst_run_rep':\<open>((\<lambda>n. fst (time r n)), (\<lambda>n. take (rank (fst (time r n))) (hamlet r n)))
                     \<in> {(t, h). run_rep_prop t h}\<close>
using fst_run_rep by (simp add: run_rep_prop_def)

lemma snd_run_rep':\<open>((\<lambda>n. snd (time r n)), (\<lambda>n. drop (rank (fst (time r n))) (hamlet r n)))
                     \<in> {(t, h). run_rep_prop t h}\<close>
using snd_run_rep by (simp add: run_rep_prop_def)

lemma prod_run_rep':\<open>((\<lambda>n. (time r\<^sub>1 n, time r\<^sub>2 n)), (\<lambda>n. (hamlet r\<^sub>1 n)@(hamlet r\<^sub>2 n)))
                     \<in> {(t, h). run_rep_prop t h}\<close>
using prod_run_rep by (simp add: run_rep_prop_def)

lemma time_fst_time:
  \<open>time (fst\<^sub>r\<^sub>u\<^sub>n r) = (\<lambda>n. fst (time r n))\<close>
proof
  let ?REP = \<open>((\<lambda>n. fst (time r n)), (\<lambda>n. take (rank (fst (time r n))) (hamlet r n)))\<close>
  have \<open>Rep_run (Abs_run ?REP) = ?REP\<close> using Abs_run_inverse[OF fst_run_rep'] .
  hence \<open>time (fst\<^sub>r\<^sub>u\<^sub>n r) = fst ?REP\<close> unfolding fst\<^sub>r\<^sub>u\<^sub>n_def time_def by simp
  also have \<open>... = (\<lambda>n. fst (time r n))\<close> by simp
  finally show \<open>\<And>n. time (fst\<^sub>r\<^sub>u\<^sub>n r) n = fst (time r n)\<close> by simp
qed

lemma time_snd_time:
  \<open>time (snd\<^sub>r\<^sub>u\<^sub>n r) = (\<lambda>n. snd (time r n))\<close>
proof
  let ?REP = \<open>((\<lambda>n. snd (time r n)), (\<lambda>n. drop (rank (fst (time r n))) (hamlet r n)))\<close>
  have \<open>Rep_run (Abs_run ?REP) = ?REP\<close> using Abs_run_inverse[OF snd_run_rep'] .
  hence \<open>time (snd\<^sub>r\<^sub>u\<^sub>n r) = fst ?REP\<close> unfolding snd\<^sub>r\<^sub>u\<^sub>n_def time_def by simp
  also have \<open>... = (\<lambda>n. snd (time r n))\<close> by simp
  finally show \<open>\<And>n. time (snd\<^sub>r\<^sub>u\<^sub>n r) n = snd (time r n)\<close> by simp
qed

lemma time_prod_time: \<open>time (r\<^sub>1 \<times>\<^sub>r\<^sub>u\<^sub>n r\<^sub>2) = (\<lambda>n. (time r\<^sub>1 n, time r\<^sub>2 n))\<close>
proof
  let ?REP = \<open>((\<lambda>n. (time r\<^sub>1 n, time r\<^sub>2 n)), (\<lambda>n. (hamlet r\<^sub>1 n)@(hamlet r\<^sub>2 n)))\<close>
  have \<open>Rep_run (Abs_run ?REP) = ?REP\<close> using Abs_run_inverse[OF prod_run_rep'] .
  hence \<open>time (r\<^sub>1 \<times>\<^sub>r\<^sub>u\<^sub>n r\<^sub>2) = fst ?REP\<close> unfolding prod\<^sub>r\<^sub>u\<^sub>n_def time_def by simp
  also have \<open>... = (\<lambda>n. (time r\<^sub>1 n, time r\<^sub>2 n))\<close> by simp
  finally show \<open>\<And>n. time (r\<^sub>1 \<times>\<^sub>r\<^sub>u\<^sub>n r\<^sub>2) n = (time r\<^sub>1 n, time r\<^sub>2 n)\<close> by simp
qed

lemma hamlet_fst_hamlet:
  \<open>hamlet (fst\<^sub>r\<^sub>u\<^sub>n r) = (\<lambda>n. take (rank (fst (time r n))) (hamlet r n))\<close>
proof
  let ?REP = \<open>((\<lambda>n. fst (time r n)), (\<lambda>n. take (rank (fst (time r n))) (hamlet r n)))\<close>
  have \<open>Rep_run (Abs_run ?REP) = ?REP\<close> using Abs_run_inverse[OF fst_run_rep'] .
  hence \<open>hamlet (fst\<^sub>r\<^sub>u\<^sub>n r) = snd ?REP\<close> unfolding fst\<^sub>r\<^sub>u\<^sub>n_def hamlet_def by simp
  also have \<open>... = (\<lambda>n. take (rank (fst (time r n))) (hamlet r n))\<close> by simp
  finally show \<open>\<And>n. hamlet (fst\<^sub>r\<^sub>u\<^sub>n r) n = take (rank (fst (time r n))) (hamlet r n)\<close> by simp
qed

lemma hamlet_snd_hamlet:
  \<open>hamlet (snd\<^sub>r\<^sub>u\<^sub>n r) = (\<lambda>n. drop (rank (fst (time r n))) (hamlet r n))\<close>
proof
  let ?REP = \<open>((\<lambda>n. snd (time r n)), (\<lambda>n. drop (rank (fst (time r n))) (hamlet r n)))\<close>
  have \<open>Rep_run (Abs_run ?REP) = ?REP\<close> using Abs_run_inverse[OF snd_run_rep'] .
  hence \<open>hamlet (snd\<^sub>r\<^sub>u\<^sub>n r) = snd ?REP\<close> unfolding snd\<^sub>r\<^sub>u\<^sub>n_def hamlet_def by simp
  also have \<open>... = (\<lambda>n. drop (rank (fst (time r n))) (hamlet r n))\<close> by simp
  finally show \<open>\<And>n. hamlet (snd\<^sub>r\<^sub>u\<^sub>n r) n = drop (rank (fst (time r n))) (hamlet r n)\<close> by simp
qed

lemma hamlet_prod_hamlet:
  \<open>hamlet (r\<^sub>1 \<times>\<^sub>r\<^sub>u\<^sub>n r\<^sub>2) = (\<lambda>n. (hamlet r\<^sub>1 n)@(hamlet r\<^sub>2 n))\<close>
proof
  let ?REP = \<open>((\<lambda>n. (time r\<^sub>1 n, time r\<^sub>2 n)), (\<lambda>n. (hamlet r\<^sub>1 n)@(hamlet r\<^sub>2 n)))\<close>
  have \<open>Rep_run (Abs_run ?REP) = ?REP\<close> using Abs_run_inverse[OF prod_run_rep'] .
  hence \<open>hamlet (r\<^sub>1 \<times>\<^sub>r\<^sub>u\<^sub>n r\<^sub>2) = snd ?REP\<close> unfolding prod\<^sub>r\<^sub>u\<^sub>n_def hamlet_def by simp
  also have \<open>... = (\<lambda>n. (hamlet r\<^sub>1 n)@(hamlet r\<^sub>2 n))\<close> by simp
  finally show \<open>\<And>n. hamlet (r\<^sub>1 \<times>\<^sub>r\<^sub>u\<^sub>n r\<^sub>2) n = (hamlet r\<^sub>1 n)@(hamlet r\<^sub>2 n)\<close> by simp
qed

lemma rank_fst:
  \<open>rank (fst\<^sub>r\<^sub>u\<^sub>n r) = rank (fst (time r 0))\<close>
unfolding rank_run_def using time_fst_time[of \<open>r\<close>] by simp

lemma rank_snd:
  \<open>rank (snd\<^sub>r\<^sub>u\<^sub>n r) = rank (snd (time r 0))\<close>
unfolding rank_run_def using time_snd_time[of \<open>r\<close>] by simp

lemma rank_run_prod:
  \<open>rank (r::('a::{orderedrank} \<times> 'b::{orderedrank}) run)
   = rank (fst\<^sub>r\<^sub>u\<^sub>n r) + rank (snd\<^sub>r\<^sub>u\<^sub>n r)\<close>
using rank_fst[of \<open>r\<close>] rank_snd[of \<open>r\<close>] rank_prod_def[of \<open>time r 0\<close>] rank_run_def[of \<open>r\<close>] by simp

lemma rank_run_prod_any:
  \<open>rank (r::('a::{orderedrank} \<times> 'b::{orderedrank}) run)
 = rank (r\<^sub>1::'a run) + rank (r\<^sub>2::'b run)\<close>
proof -
  have \<open>rank r = rank (time r 0)\<close> by (simp add: rank_run_def)
  also have \<open>... = rank ((time r\<^sub>1 0), (time r\<^sub>2 0))\<close> using rank_class.const .
  also have \<open>... = rank (time r\<^sub>1 0) + rank (time r\<^sub>2 0)\<close> by (simp add: rank_prod_def)
  finally show \<open> rank r = rank r\<^sub>1 + rank r\<^sub>2\<close> by (simp add: rank_run_def)
qed

lemma run_prod_rank:\<open>rank (r\<^sub>1 \<times>\<^sub>r\<^sub>u\<^sub>n r\<^sub>2) = rank r\<^sub>1 + rank r\<^sub>2\<close>
using rank_run_prod_any .

lemma fst_run_proj:\<open>fst\<^sub>r\<^sub>u\<^sub>n (r\<^sub>1 \<times>\<^sub>r\<^sub>u\<^sub>n r\<^sub>2) = r\<^sub>1\<close>
proof -
  have lh:\<open>\<forall>n. length (hamlet r\<^sub>1 n) = rank (time r\<^sub>1 n)\<close> by (simp add: compat_time_hamlet)
  have \<open>fst\<^sub>r\<^sub>u\<^sub>n (r\<^sub>1 \<times>\<^sub>r\<^sub>u\<^sub>n r\<^sub>2) = Abs_run ((\<lambda>n. time r\<^sub>1 n),
                                     (\<lambda>n. (hamlet r\<^sub>1 n)))\<close>
    unfolding fst\<^sub>r\<^sub>u\<^sub>n_def
    using time_prod_time[of \<open>r\<^sub>1\<close> \<open>r\<^sub>2\<close>] hamlet_prod_hamlet[of \<open>r\<^sub>1\<close> \<open>r\<^sub>2\<close>] lh by simp
  thus ?thesis by (simp add: Rep_run_inverse hamlet_def time_def)
qed

lemma snd_run_proj:\<open>snd\<^sub>r\<^sub>u\<^sub>n (r\<^sub>1 \<times>\<^sub>r\<^sub>u\<^sub>n r\<^sub>2) = r\<^sub>2\<close>
proof -
  have lh:\<open>\<forall>n. length (hamlet r\<^sub>1 n) = rank (time r\<^sub>1 n)\<close> by (simp add: compat_time_hamlet)
  have \<open>snd\<^sub>r\<^sub>u\<^sub>n (r\<^sub>1 \<times>\<^sub>r\<^sub>u\<^sub>n r\<^sub>2) = Abs_run ((\<lambda>n. time r\<^sub>2 n),
                                     (\<lambda>n. (hamlet r\<^sub>2 n)))\<close>
    unfolding snd\<^sub>r\<^sub>u\<^sub>n_def
    using time_prod_time[of \<open>r\<^sub>1\<close> \<open>r\<^sub>2\<close>] hamlet_prod_hamlet[of \<open>r\<^sub>1\<close> \<open>r\<^sub>2\<close>] lh by simp
  thus ?thesis by (simp add: Rep_run_inverse hamlet_def time_def)
qed

type_synonym ('a) runs = \<open>('a) run set\<close>

section\<open> The semantic domain of Tesl is a lattice \<close>

text \<open>
  The most permissive TESL specification allows all well formed runs.
\<close>
definition TeslTop :: \<open>('a::orderedrank) runs\<close> ("\<top>")
where     \<open>\<top> \<equiv> {r. run_rep_prop (time r) (hamlet r)}\<close>

text \<open>
  The most restrictive TESL specification allows no run.
\<close>
definition TeslBot :: \<open>('a::order) runs\<close> ("\<bottom>")
where     \<open>\<bottom> \<equiv> {}\<close>

(* Runs that start after \<tau> *)
definition TeslTopFrom :: \<open>'a \<Rightarrow> ('a::orderedrank) runs\<close> ("\<top>\<^bsub>\<le>_\<^esub>")
where     \<open>\<top>\<^bsub>\<le>\<tau>\<^esub> \<equiv> {r. run_rep_prop (time r) (hamlet r) \<and> \<tau> \<le> (time r) 0}\<close>

lemma foundation1 [intro]:
  \<open>r \<in> \<top>\<^bsub>\<le>\<tau>\<^esub> \<Longrightarrow> run_rep_prop (time r) (hamlet r) \<and> \<tau> \<le> (time r) 0 \<close>
by (simp add: TeslTopFrom_def)

text \<open> Composition of TESL specs: the runs have to satisfy both specs. \<close>
definition TeslComp :: \<open>('a::order) runs \<Rightarrow> 'a runs \<Rightarrow> 'a runs\<close> (infixl  "\<otimes>" 55)
where     \<open>S \<otimes> T \<equiv> S \<inter> T\<close>

text \<open>
  If a run satisfies two specifications, it satisfies their composition.
\<close>
lemma teslcomp:
  assumes \<open>r \<in> S\<close>
  and     \<open>r \<in> T\<close>
  shows   \<open>r \<in> S \<otimes> T\<close>
using assms by (simp add: TeslComp_def)

text \<open> Composing a spec with itself yields the same spec \<close>
lemma idem : \<open>S \<otimes> S = S\<close>
unfolding TeslComp_def by simp

text \<open> The composition of specifications commutes \<close>
lemma commute : \<open>S \<otimes> T = T \<otimes> S\<close>
unfolding TeslComp_def
by (simp add: Int_commute)

text \<open> The composition of specifications is associative \<close>
lemma assoc : \<open>S \<otimes> (T \<otimes> U) = (S \<otimes> T) \<otimes> U\<close>
unfolding TeslComp_def
by blast

text \<open> The empty specification is neutral for composition \<close>
lemma all_runs_in_top:\<open>S \<subseteq> \<top>\<close>
using TeslTop_def by auto

lemma idem_top : \<open>\<top> \<otimes> S = S\<close>
unfolding TeslComp_def using all_runs_in_top by blast

text \<open> Composing with the unsatisfiable specification yields the unsatisfiable specification. \<close>
lemma bot_strict : \<open>\<bottom> \<otimes> S = \<bottom>\<close>
unfolding TeslComp_def TeslBot_def by simp

text \<open> The composition of two specifications is stricter than each specification. \<close>
lemma \<open>S \<otimes> S' \<subseteq> S\<close>
unfolding TeslComp_def by simp

section \<open> Tesl clocks \<close>

text \<open>
A clock has two facets :
\begin{itemize}
  \item it is a projection from the denotational universe @{typ '\<AA>}
        of a system run onto a particular time line
  \item it is a projection from the hamlet of the system run onto its own hamlet component
\<close>

type_synonym ('a,'b)\<H> = \<open>(('a \<Rightarrow> 'b) \<times> clockidx)\<close>

\<comment> \<open>A way to build only consistent clocks (an idea by Chantal Keller)\<close>
definition clock0::\<open>(('a\<times>'b),'a)\<H>\<close>
where \<open>clock0 \<equiv> (fst,0)\<close>

fun clock_suc::\<open>('a, 'b)\<H> \<Rightarrow> ('c \<times> 'a, 'b)\<H>\<close>
  where \<open>clock_suc (f, n) = ((f\<circ>snd), (Suc n))\<close>

text \<open> Projection of a clock onto its time component. \<close>
abbreviation \<open>timep \<equiv> fst\<close>
text \<open> Projection of a clock onto its hamlet index. \<close>
abbreviation \<open>index \<equiv> snd\<close>

lemma \<open>timep clock0 = fst\<close> by (simp add: clock0_def)
lemma \<open>index clock0 = 0\<close> by (simp add: clock0_def)
lemma \<open>timep (clock_suc clock0) = fst\<circ>snd\<close> by (simp add: clock0_def)
lemma \<open>index (clock_suc clock0) = 1\<close> by (simp add: clock0_def)
lemma \<open>timep (clock_suc (clock_suc clock0)) = fst\<circ>snd\<circ>snd\<close> by (simp add: clock0_def)
lemma \<open>index (clock_suc (clock_suc clock0)) = 2\<close> by (simp add: clock0_def)

value \<open>(timep clock0) (a, b, c, ())\<close>
value \<open>(timep (clock_suc clock0)) (a, b, c, ())\<close>
value \<open>(timep (clock_suc (clock_suc clock0))) (a, b, c, ())\<close>

value \<open>[a, b, c]!(index clock0)\<close>
value \<open>[a, b, c]!(index (clock_suc clock0))\<close>
value \<open>[a, b, c]!(index (clock_suc (clock_suc clock0)))\<close>

\<comment> \<open>****************************\<close>

abbreviation timeOfClockOnRun ::\<open>('a::orderedrank,'b)\<H> \<Rightarrow> 'a run \<Rightarrow> nat \<Rightarrow> 'b\<close>
             ("timeof _ in _ at _")
where \<open>timeof c in r at n \<equiv> ((timep c) (time r n))\<close>

end


(*<*)
theory Hilbert
  imports Main "HOL-Eisbach.Eisbach"

abbrevs
 not="\<^bold>\<not>" and disj="\<^bold>\<or>" and conj="\<^bold>\<and>" and impl="\<^bold>\<rightarrow>" and equiv="\<^bold>\<leftrightarrow>"
 and true="\<^bold>\<top>" and false="\<^bold>\<bottom>"
 and ob="\<^bold>\<circle>" and perm="\<^bold>P" and forb="\<^bold>F"

 and derivable="\<turnstile>"
begin
(*>*)

section \<open>Proving first theorems\<close>

subsection \<open>Hilbert Calculus for Classical Logic\<close>
text \<open>Technical remark at the beginning: In order to distinguish our connectives
from the usual logical connectives of the Isabelle/HOL system, we use @{text "\<^bold>b\<^bold>o\<^bold>l\<^bold>d"}-face written
versions of them. You may use the abbreviations at the top of the document (in the theory file)
to write things down, e.g. if you start writing "dis..." (the abbreviation is "disj"),
Isabelle should suggest the autocompletion for @{text "\<^bold>\<or>"}, etc.\<close>

typedecl \<sigma> \<comment> \<open>Introduce new type for syntactical formulae (propositions).\<close>

text \<open>
For our classical propositional language, we introduce two primitive symbols:
Implication and negation. The others can be defined in terms of these two.
\<close>
consts PLimpl :: "\<sigma> \<Rightarrow> \<sigma> \<Rightarrow> \<sigma>" (infixr "\<^bold>\<rightarrow>" 49)
       PLnot :: "\<sigma> \<Rightarrow> \<sigma>" ("\<^bold>\<not>_" [52]53)

consts PLatomicProp :: "\<sigma>"

definition PLdisj :: "\<sigma> \<Rightarrow> \<sigma> \<Rightarrow> \<sigma>" (infixr "\<^bold>\<or>" 50) where "a \<^bold>\<or> b \<equiv> \<^bold>\<not>a \<^bold>\<rightarrow> b"
definition PLconj :: "\<sigma> \<Rightarrow> \<sigma> \<Rightarrow> \<sigma>" (infixr "\<^bold>\<and>" 51) where "a \<^bold>\<and> b \<equiv> \<^bold>\<not>(\<^bold>\<not>a \<^bold>\<or> \<^bold>\<not>b)"
definition PLequi :: "\<sigma> \<Rightarrow> \<sigma> \<Rightarrow> \<sigma>" (infix "\<^bold>\<leftrightarrow>" 48) where "a \<^bold>\<leftrightarrow> b \<equiv> (a \<^bold>\<rightarrow> b) \<^bold>\<and> (b \<^bold>\<rightarrow> a)"
definition PLtop :: "\<sigma>" ("\<^bold>\<top>") where "\<^bold>\<top> \<equiv> PLatomicProp \<^bold>\<or> \<^bold>\<not>PLatomicProp"
definition PLbot :: "\<sigma>" ("\<^bold>\<bottom>") where "\<^bold>\<bottom> \<equiv> \<^bold>\<not>\<^bold>\<top>"

text \<open>Next we define the notion of syntactical derivability and consequence: \<close>

consts derivable :: "\<sigma> \<Rightarrow> bool" ("\<turnstile> _" 40)
definition consequence :: "\<sigma> \<Rightarrow> \<sigma> \<Rightarrow> bool" ("_ \<turnstile> _" 40) where
"A \<turnstile> B \<equiv> \<turnstile> (A \<^bold>\<rightarrow> B)"

text \<open>We can now axiomatize the derivability relation using a Hilbert-style system:\<close>

axiomatization where
  A2:  "\<turnstile> A \<^bold>\<rightarrow> (B \<^bold>\<rightarrow> A)" and (* Three Hilbert-style axioms *)
  A3:  "\<turnstile> (A \<^bold>\<rightarrow> (B \<^bold>\<rightarrow> C)) \<^bold>\<rightarrow> ((A \<^bold>\<rightarrow> B) \<^bold>\<rightarrow> (A \<^bold>\<rightarrow> C))" and
  A4:  "\<turnstile> (\<^bold>\<not>A \<^bold>\<rightarrow> \<^bold>\<not>B) \<^bold>\<rightarrow> (B \<^bold>\<rightarrow> A)" and
  MP:  "\<turnstile> (A \<^bold>\<rightarrow> B) \<Longrightarrow> \<turnstile> A \<Longrightarrow> \<turnstile> B" (* One inference rule: Modus ponens *)

paragraph \<open>Proof example.\<close>
text \<open>Now we are ready to proof first simple theorems:\<close>

lemma "\<turnstile> A \<^bold>\<rightarrow> A"
proof -
  have 1: "\<turnstile> (A \<^bold>\<rightarrow> ((B \<^bold>\<rightarrow> A) \<^bold>\<rightarrow> A)) \<^bold>\<rightarrow> ((A \<^bold>\<rightarrow> (B \<^bold>\<rightarrow> A)) \<^bold>\<rightarrow> (A \<^bold>\<rightarrow> A))" by (rule A3[of _ "B \<^bold>\<rightarrow> A" "A"])
  have 2: "\<turnstile> A \<^bold>\<rightarrow> ((B \<^bold>\<rightarrow> A) \<^bold>\<rightarrow> A)" by (rule A2[of _ "B \<^bold>\<rightarrow> A"])
  from 1 2 have 3: "\<turnstile> (A \<^bold>\<rightarrow> (B \<^bold>\<rightarrow> A)) \<^bold>\<rightarrow> (A \<^bold>\<rightarrow> A)" by (rule MP)
  have 4: "\<turnstile> A \<^bold>\<rightarrow> (B \<^bold>\<rightarrow> A)" by (rule A2[of _ _])
  from 3 4 have "\<turnstile> A \<^bold>\<rightarrow> A" by (rule MP)
  then show ?thesis .
qed

text \<open>The same proof a little bit nicer with syntactic sugar:\<close>
lemma "\<turnstile> A \<^bold>\<rightarrow> A"
proof -
  have "\<turnstile> (A \<^bold>\<rightarrow> ((B \<^bold>\<rightarrow> A) \<^bold>\<rightarrow> A)) \<^bold>\<rightarrow> ((A \<^bold>\<rightarrow> (B \<^bold>\<rightarrow> A)) \<^bold>\<rightarrow> (A \<^bold>\<rightarrow> A))" by (rule A3[of _ "B \<^bold>\<rightarrow> A" "A"])
  moreover have "\<turnstile> A \<^bold>\<rightarrow> ((B \<^bold>\<rightarrow> A) \<^bold>\<rightarrow> A)" by (rule A2[of _ "B \<^bold>\<rightarrow> A"])
  ultimately have "\<turnstile> (A \<^bold>\<rightarrow> (B \<^bold>\<rightarrow> A)) \<^bold>\<rightarrow> (A \<^bold>\<rightarrow> A)" by (rule MP)
  moreover have "\<turnstile> A \<^bold>\<rightarrow> (B \<^bold>\<rightarrow> A)" by (rule A2[of _ _])
  ultimately show "\<turnstile> A \<^bold>\<rightarrow> A" by (rule MP)
qed

subsection \<open>Exercises\<close>
paragraph \<open>Exercise 2.\<close>
text \<open>Prove one of the following statements by giving an explicit proof within
the given Hilbert calculus. Please make sure that every inference step in your
proof is fine-grained and annotated with the respective calculus rule name.

Hint: Find a proof first by pen-and-paper work and then formalize it within Isabelle.\<close>

text \<open>
  \<^item> @{prop "\<turnstile> \<^bold>\<not>(F \<^bold>\<rightarrow> F) \<^bold>\<rightarrow> G"}
  \<^item> @{prop "\<turnstile> \<^bold>\<not>\<^bold>\<not>F \<^bold>\<rightarrow> F"}
\<close>

text "We will later see that many proofs can in fact be done almost automatically by Isabelle,
see e.g. the example from further above:"

lemma PL1: "\<turnstile> A \<^bold>\<rightarrow> A" using A2 A3 MP by blast
lemma PL2: "\<turnstile> \<^bold>\<not>(F \<^bold>\<rightarrow> F) \<^bold>\<rightarrow> G" by (metis A2 A3 A4 MP)
lemma PL3: "\<turnstile> \<^bold>\<not>\<^bold>\<not>F \<^bold>\<rightarrow> F" by (metis A2 A3 A4 MP)

text \<open>Also, to make things look a bit nicer, we define a compound strategy @{text "PL"}
(for "Propositional Logic") that applies an internal automated theorem prover with the
respective axioms for propositional logic (A2, A3, A4 and MP)\<close>
(*<*)
named_theorems add \<comment> \<open>Needed for technical reasons\<close>
(*>*)
method PL declares add = (metis A2 A3 A4 MP add)

text \<open>In the following, we can simply use @{text "by PL"} for proving propositional
tautologies. However, as proofs can be arbitrarily complicated, this method may fail
for difficult formulas.\<close>

section \<open>Hilbert proofs for MDL\<close>

text "We augment the language PL with the new connectives of MDL:"

consts ob :: "\<sigma> \<Rightarrow> \<sigma>" ("\<^bold>\<circle>_" [52]53) \<comment> \<open>New atomic connective for obligation\<close>

text \<open>The other new deontic logic connective can be defined as usual:\<close>

definition perm :: "\<sigma> \<Rightarrow> \<sigma>" ("\<^bold>P_" [52]53) where "\<^bold>P a \<equiv> \<^bold>\<not>(\<^bold>\<circle>(\<^bold>\<not>a))"
definition forbidden :: "\<sigma> \<Rightarrow> \<sigma>" ("\<^bold>F_" [52]53) where "\<^bold>F a \<equiv> \<^bold>\<circle>(\<^bold>\<not>a)"

text \<open>Next, we additionally augment the axiomatization of our proof system for PL
with the rules of the system D for MDL:\<close>

axiomatization where
  K:   "\<turnstile> \<^bold>\<circle>(A \<^bold>\<rightarrow> B) \<^bold>\<rightarrow> (\<^bold>\<circle>A \<^bold>\<rightarrow> \<^bold>\<circle>B)" and
  D:   "\<turnstile> \<^bold>\<circle>A \<^bold>\<rightarrow> \<^bold>PA" and
  NEC: "\<turnstile> A \<Longrightarrow> \<turnstile> (\<^bold>\<circle>A)"

subsection \<open>MDL Proof Examples\<close>

lemma "\<turnstile> \<^bold>\<circle>(p \<^bold>\<and> q) \<^bold>\<rightarrow> \<^bold>\<circle>p"
proof -
  have 1: "\<turnstile> (p \<^bold>\<and> q) \<^bold>\<rightarrow> p" by (PL add: PLconj_def PLdisj_def)
  from 1 have 2: "\<turnstile> \<^bold>\<circle>((p \<^bold>\<and> q) \<^bold>\<rightarrow> p)" by (rule NEC)
  have 3: "\<turnstile> \<^bold>\<circle>((p \<^bold>\<and> q) \<^bold>\<rightarrow> p) \<^bold>\<rightarrow> \<^bold>\<circle>(p \<^bold>\<and> q) \<^bold>\<rightarrow> \<^bold>\<circle>p" by (rule K)
  from 3 2 show "\<turnstile> \<^bold>\<circle>(p \<^bold>\<and> q) \<^bold>\<rightarrow> \<^bold>\<circle>p" by (rule MP)
qed

text \<open>Note that, although we have the necessitation rule @{thm "NEC"} , the formula
@{term "A \<^bold>\<rightarrow> \<^bold>\<circle>A"} is not generally valid:\<close>

lemma "\<turnstile> a \<^bold>\<rightarrow> \<^bold>\<circle>a" nitpick[user_axioms,expect=genuine] oops

subsection \<open>Exercises\<close>
paragraph \<open>Exercise 2.\<close>
text \<open>Prove the following statement by giving an explicit proof within
the given Hilbert calculus. Please make sure that every inference step in your
proof is fine-grained and annotated with the respective calculus rule name. You may use
the general @{method "PL"} method for inferring propositional tautologies.

Hint: Reuse your proof from the previous exercise sheet and formalize it within Isabelle.\<close>

text \<open>
  \<^item> @{prop "\<turnstile> \<^bold>\<not>\<^bold>\<circle>\<^bold>\<bottom>"}
\<close>

(*<*)
end
(*>*)


(* This Isabelle theory is produced using the TIP tool offered at the following website:
     https://github.com/tip-org/tools
   This file was originally provided as part of TIP benchmark at the following website:
     https://github.com/tip-org/benchmarks
   Yutaka Nagashima at CIIRC, CTU changed the TIP output theory file slightly
   to make it compatible with Isabelle2017.*)
  theory TIP_relaxedprefix_is_prefix_3
imports "../../Test_Base"
begin

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

datatype It = A | B | C

fun x :: "'a list => 'a list => 'a list" where
"x (nil2) z = z"
| "x (cons2 z2 xs) z = cons2 z2 (x xs z)"

fun isPrefix :: "It list => It list => bool" where
"isPrefix (nil2) z = True"
| "isPrefix (cons2 z2 x2) (nil2) = False"
| "isPrefix (cons2 z2 x2) (cons2 x3 x4) =
     ((z2 = x3) & (isPrefix x2 x4))"

fun isRelaxedPrefix :: "It list => It list => bool" where
"isRelaxedPrefix (nil2) z = True"
| "isRelaxedPrefix (cons2 z2 (nil2)) z = True"
| "isRelaxedPrefix (cons2 z2 (cons2 x3 x4)) (nil2) = False"
| "isRelaxedPrefix (cons2 z2 (cons2 x3 x4)) (cons2 x5 x6) =
     (if (z2 = x5) then isRelaxedPrefix (cons2 x3 x4) x6 else
        isPrefix (cons2 x3 x4) (cons2 x5 x6))"

theorem property0 :
  "isRelaxedPrefix (x xs (cons2 y (nil2))) (x xs ys)"
  oops

end


header {* Miscellaneous Lemmas *}
theory Dijkstra_Misc
imports Main
begin
  inductive_set least_map for f S where
    "\<lbrakk> x\<in>S; \<forall>x'\<in>S. f x \<le> f x' \<rbrakk> \<Longrightarrow> x \<in> least_map f S"

  lemma least_map_subset: "least_map f S \<subseteq> S"
    by (auto elim: least_map.cases)

  lemmas least_map_elemD = set_mp[OF least_map_subset]

  lemma least_map_leD:
    assumes "x \<in> least_map f S"
    assumes "y\<in>S"
    shows "f x \<le> f y"
    using assms
    by (auto elim: least_map.cases)

  lemma least_map_empty[simp]: "least_map f {} = {}"
    by (auto elim: least_map.cases)

  lemma least_map_singleton[simp]: "least_map (f::'a\<Rightarrow>'b::order) {x} = {x}"
    by (auto elim: least_map.cases intro!: least_map.intros simp: refl)

  lemma least_map_insert_min:
    fixes f::"'a\<Rightarrow>'b::order"
    assumes "\<forall>y\<in>S. f x \<le> f y"
    shows "x \<in> least_map f (insert x S)"
    using assms by (auto intro: least_map.intros)

  lemma least_map_insert_nmin:
    "\<lbrakk> x\<in>least_map f S; f x \<le> f a \<rbrakk> \<Longrightarrow> x\<in>least_map f (insert a S)"
    by (auto elim: least_map.cases intro: least_map.intros)

context semilattice_inf
begin
  lemmas [simp] = inf_absorb1 inf_absorb2

  lemma inf_absorb_less[simp]:
    "a < b \<Longrightarrow> inf a b = a"
    "a < b \<Longrightarrow> inf b a = a"
    apply (metis le_iff_inf less_imp_le)
    by (metis inf_commute le_iff_inf less_imp_le)
end

end