(* Title:      Correctness of Path Algorithms
   Author:     Walter Guttmann, Peter Hoefner
   Maintainer: Walter Guttmann <walter.guttmann at canterbury.ac.nz>
               Peter Hoefner <peter at hoefner-online.de>
*)

section \<open>Correctness of Path Algorithms\<close>

text \<open>
To show that our theory of paths integrates with verification tasks, we verify the correctness of three basic path algorithms.
Algorithms at the presented level are executable and can serve prototyping purposes.
Data refinement can be carried out to move from such algorithms to more efficient programs.
The total-correctness proofs use a library developed in \cite{Guttmann2018c}.
\<close>

theory Path_Algorithms

imports "HOL-Hoare.Hoare_Logic" Rooted_Paths

begin

no_notation
  trancl ("(_\<^sup>+)" [1000] 999)

class choose_singleton_point_signature =
  fixes choose_singleton :: "'a \<Rightarrow> 'a"
  fixes choose_point :: "'a \<Rightarrow> 'a"

class relation_algebra_rtc_tarski_choose_point =
  relation_algebra_rtc_tarski + choose_singleton_point_signature +
  assumes choose_singleton_singleton: "x \<noteq> 0 \<Longrightarrow> singleton (choose_singleton x)"
  assumes choose_singleton_decreasing: "choose_singleton x \<le> x"
  assumes choose_point_point: "is_vector x \<Longrightarrow> x \<noteq> 0 \<Longrightarrow> point (choose_point x)"
  assumes choose_point_decreasing: "choose_point x \<le> x"
begin

no_notation
  composition (infixl ";" 75) and
  times (infixl "*" 70)

notation
  composition (infixl "*" 75)

subsection \<open>Construction of a path\<close>

text \<open>
Our first example is a basic greedy algorithm that constructs a path from a vertex $x$ to a different vertex $y$ of a directed acyclic graph $D$.
\<close>

abbreviation "construct_path_inv q x y D W \<equiv>
    is_acyclic D \<and> point x \<and> point y \<and> point q \<and>
    D\<^sup>\<star> * q \<le> D\<^sup>T\<^sup>\<star> * x \<and> W \<le> D \<and> terminating_path W \<and>
    (W = 0 \<longleftrightarrow> q=y) \<and> (W \<noteq> 0 \<longleftrightarrow> q = start_points W \<and> y = end_points W)"

abbreviation "construct_path_inv_simp q x y D W \<equiv>
    is_acyclic D \<and> point x \<and> point y \<and> point q \<and>
    D\<^sup>\<star> * q \<le> D\<^sup>T\<^sup>\<star> * x \<and> W \<le> D \<and> terminating_path W \<and>
    q = start_points W \<and> y = end_points W"

lemma construct_path_pre:
  assumes "is_acyclic D"
      and "point y"
      and "point x"
      and "D\<^sup>\<star> * y \<le> D\<^sup>T\<^sup>\<star> * x"
    shows "construct_path_inv y x y D 0"
  apply (intro conjI, simp_all add: assms is_inj_def is_p_fun_def path_def)
  using assms(2) cycle_iff by fastforce

text \<open>
The following three lemmas are auxiliary lemmas for \<open>construct_path_inv\<close>.
They are pulled out of the main proof to have more structure.
\<close>

lemma path_inv_points:
  assumes "construct_path_inv q x y D W \<and> q \<noteq> x"
  shows "point q"
    and "point (choose_point (D*q))"
 using assms apply blast
by (metis assms choose_point_point comp_assoc is_vector_def point_def reachable_implies_predecessor)

lemma path_inv_choose_point_decrease:
  assumes "construct_path_inv q x y D W \<and> q \<noteq> x"
    shows "W\<noteq>0 \<Longrightarrow> choose_point (D*q) \<le> -((W + choose_point (D*q) * q\<^sup>T)\<^sup>T*1)"
proof -
  let ?q = "choose_point (D*q)"
  let ?W = "W + ?q * q\<^sup>T"
  assume as: "W\<noteq>0"
  hence "q*W \<le> W\<^sup>+" (* "connected_root q W" *)
    by (metis assms conv_contrav conv_invol conv_iso conv_terminating_path
              forward_terminating_path_end_points_1 plus_conv point_def ss423bij
              terminating_path_iff)
  hence "?q \<cdot> W\<^sup>T*1 \<le> D*q \<cdot> W\<^sup>T\<^sup>+*q"
    using choose_point_decreasing meet_iso meet_isor inf_mono assms connected_root_iff2 by simp
  also have "... \<le> (D \<cdot> D\<^sup>T\<^sup>+)*q"
    by (metis assms inj_distr point_def conv_contrav conv_invol conv_iso meet_isor
              mult_isol_var mult_isor star_conv star_slide_var star_subdist sup.commute sup.orderE)
  also have "... \<le> 0"
    by (metis acyclic_trans assms conv_zero step_has_target order.eq_iff galois_aux ss_p18)
  finally have a: "?q \<le> -(W\<^sup>T*1)"
    using galois_aux le_bot by blast

  have "point ?q"
    using assms by(rule path_inv_points(2))
  hence "?q \<le> -(q*?q\<^sup>T*1)"
    by (metis assms acyclic_imp_one_step_different_points(2) point_is_point
            choose_point_decreasing edge_end end_point_char end_point_no_successor)
  with a show ?thesis
    by (simp add: inf.boundedI)
qed

lemma end_points:
  assumes "construct_path_inv q x y D W \<and> q \<noteq> x"
    shows "choose_point (D*q) = start_points (W + choose_point (D*q) * q\<^sup>T)"
      and "y = end_points (W + choose_point (D*q) * q\<^sup>T)"
proof -
  let ?q = "choose_point (D*q)"
  let ?W = "W + ?q * q\<^sup>T"
  show 1: "?q = start_points ?W"
  proof (rule order.antisym)
    show" start_points ?W \<le> ?q"
      by (metis assms(1) path_inv_points(2) acyclic_imp_one_step_different_points(2)
                choose_point_decreasing edge_end edge_start sup.commute
                path_concatenation_start_points_approx point_is_point order.eq_iff sup_bot_left)
    show "?q \<le> start_points ?W"
    proof -
      have a: "?q = ?q*q\<^sup>T*1"
        by (metis assms(1) comp_assoc point_equations(1) point_is_point aux4 conv_zero
                  choose_point_decreasing choose_point_point conv_contrav conv_one point_def
                  inf.orderE inf_compl_bot inf_compl_bot_right is_vector_def maddux_142
                  sup_bot_left sur_def_var1)
      hence "?q =(q \<cdot> -q) + (?q \<cdot> -q \<cdot> -(?W\<^sup>T*1))"
        by (metis assms path_inv_points(2) path_inv_choose_point_decrease
                  acyclic_imp_one_step_different_points(1) choose_point_decreasing inf.orderE
                  inf_compl_bot sup_inf_absorb edge_start point_is_point sup_bot_left)
      also have "... \<le> (W*1 \<cdot> -(?W\<^sup>T*1) \<cdot> -q) + (?q \<cdot> -q \<cdot> -(?W\<^sup>T*1))"
        by simp
      also have "... = (W*1 + ?q) \<cdot> -(q + ?W\<^sup>T*1)"
        by (metis compl_sup inf_sup_distrib2 meet_assoc sup.commute)
      also have "... \<le> ?W*1 \<cdot> -(?W\<^sup>T*1)"
        using a by (metis inf.left_commute distrib_right' compl_sup inf.cobounded2)
      finally show "?q \<le> start_points ?W" .
    qed
  qed
  show "y = end_points ?W"
  proof -
    have point_nq: "point ?q"
      using assms by(rule path_inv_points(2))
    hence yp: "y \<le> -?q"
      using 1 assms
      by (metis acyclic_imp_one_step_different_points(2) choose_point_decreasing cycle_no_points(1)
                finite_iff finite_iff_msc forward_finite_iff_msc path_aux1a path_edge_equals_cycle
                point_is_point point_not_equal(1) terminating_iff1)
    have "y = y + (W*1 \<cdot> -(W\<^sup>T*1) \<cdot> -(W*1))"
      by (simp add: inf.commute)
    also have "... = y + (q \<cdot> -(W*1))"
      using assms by fastforce
    also have "... = y + (q \<cdot> -(W*1) \<cdot> -?q)"
      by (metis calculation sup_assoc sup_inf_absorb)
    also have "... = (y \<cdot> -?q) + (q \<cdot> -(W*1) \<cdot> -?q)"
      using yp by (simp add: inf.absorb1)
    also have "... = (W\<^sup>T*1 \<cdot> -(W*1) \<cdot> -?q) + (q \<cdot> -(W*1) \<cdot> -?q)"
      using assms by fastforce
    also have "... = (W\<^sup>T*1 + q) \<cdot> -(W*1) \<cdot> -?q"
      by (simp add: inf_sup_distrib2)
    also have "... = (W\<^sup>T*1 + q) \<cdot> -(W*1 + ?q)"
      by (simp add: inf.assoc)
    also have "... = (W\<^sup>T*1 + q*?q\<^sup>T*1) \<cdot> -(W*1 + ?q*q\<^sup>T*1)"
      using point_nq
      by(metis assms(1) comp_assoc conv_contrav conv_one is_vector_def point_def sur_def_var1)
    also have "... = (?W\<^sup>T)*1 \<cdot> -(?W*1)"
      by simp
    finally show ?thesis .
  qed
qed

lemma construct_path_inv:
  assumes "construct_path_inv q x y D W \<and> q \<noteq> x"
  shows "construct_path_inv (choose_point (D*q)) x y D (W + choose_point (D*q)*q\<^sup>T)"
proof (intro conjI)
  let ?q = "choose_point (D*q)"
  let ?W = "W + ?q * q\<^sup>T"
  show "is_acyclic D"
    using assms by blast
  show point_y: "point y"
    using assms by blast
  show "point x"
    using assms by blast
  show "?W \<le> D"
    using assms choose_point_decreasing le_sup_iff point_def ss423bij inf.boundedE by blast
  show "D\<^sup>\<star>*?q \<le> D\<^sup>T\<^sup>\<star>*x"
  proof -
    have "D\<^sup>+*q \<le> D\<^sup>T\<^sup>\<star>*x"
      using assms conv_galois_2 order_trans star_1l by blast
    thus ?thesis
      by (metis choose_point_decreasing comp_assoc dual_order.trans mult_isol star_slide_var)
  qed
  show point_nq: "point ?q"
    using assms by(rule path_inv_points(2))
  show pathW: "path ?W"
    proof(cases "W=0")
      assume "W=0"
      thus ?thesis
        using assms edge_is_path point_is_point point_nq by simp
    next
      assume a: "W\<noteq>0"
      have b: "?q*q\<^sup>T \<le> 1*?q*q\<^sup>T*-(?q*q\<^sup>T*1)"
      proof -
        have "?q*q\<^sup>T \<le>1" by simp
        thus ?thesis
          using assms point_nq
          by(metis different_points_consequences(1) point_def sur_def_var1
               acyclic_imp_one_step_different_points(2) choose_point_decreasing comp_assoc
               is_vector_def point_def point_equations(3,4) point_is_point)
      qed
      have c: "W \<le> -(1*W)*W*1"
        using assms terminating_path_iff by blast
      have d: "(?q*q\<^sup>T)\<^sup>T*1 \<cdot> -((?q*q\<^sup>T)*1) = W*1 \<cdot> -(W\<^sup>T*1)"
        using a
        by (metis assms path_inv_points(2) acyclic_reachable_points choose_point_decreasing
                  edge_end point_is_point comp_assoc point_def sur_total total_one)
      have e: "?q*q\<^sup>T*1 \<cdot> W\<^sup>T*1 = 0"
      proof -
        have "?q*q\<^sup>T*1 \<cdot> W\<^sup>T*1 = ?q \<cdot> W\<^sup>T*1"
          using assms point_nq
          by (metis comp_assoc conv_contrav conv_one is_vector_def point_def sur_def_var1)
        also have "... \<le> -(?W\<^sup>T*1) \<cdot> ?W\<^sup>T*1"
          using assms path_inv_choose_point_decrease
          by (smt a conv_contrav conv_iso conv_one inf_mono less_eq_def subdistl_eq)
        also have "... \<le> 0"
          using compl_inf_bot eq_refl by blast
        finally show ?thesis
          using bot_unique by blast
      qed
      show ?thesis
      using b c d e by (metis assms comp_assoc edge_is_path path_concatenation_cycle_free
                                point_is_point sup.commute point_nq)
  qed
  show "?W = 0 \<longleftrightarrow> ?q = y"
    apply (rule iffI)
    apply (metis assms conv_zero dist_alt edge_start inf_compl_bot_right modular_1_aux' modular_2_aux'
              point_is_point sup.left_idem sup_bot_left point_nq)
    by (smt assms end_points(1) conv_contrav conv_invol cycle_no_points(1) end_point_iff2 has_start_end_points_iff path_aux1b path_edge_equals_cycle point_is_point start_point_iff2 sup_bot_left top_greatest pathW)
  show "?W\<noteq>0 \<longleftrightarrow> ?q = start_points ?W \<and> y = end_points ?W"
    apply (rule iffI)
    using assms end_points apply blast
    using assms by force
  show "terminating ?W"
    by (smt assms end_points end_point_iff2 has_start_end_points_iff point_is_point start_point_iff2
            terminating_iff1 pathW point_nq)
qed

theorem construct_path_partial: "VARS p q W
  { is_acyclic D \<and> point y \<and> point x \<and> D\<^sup>\<star>*y \<le> D\<^sup>T\<^sup>\<star>*x }
  W := 0;
  q := y;
  WHILE q \<noteq> x
    INV { construct_path_inv q x y D W }
     DO p := choose_point (D*q);
        W := W + p*q\<^sup>T;
        q := p
     OD
  { W \<le> D \<and> terminating_path W \<and> (W=0 \<longleftrightarrow> x=y) \<and> (W\<noteq>0 \<longleftrightarrow> x = start_points W \<and> y = end_points W) }"
  apply vcg
  using construct_path_pre apply blast
  using construct_path_inv apply blast
  by fastforce

end (* relation_algebra_rtc_tarski_choose_point *)

text \<open>For termination, we additionally need finiteness.\<close>

context finite
begin

lemma decrease_set:
  assumes "\<forall>x::'a . Q x \<longrightarrow> P x"
      and "P w"
      and "\<not> Q w"
    shows "card { x . Q x } < card { x . P x }"
by (metis Collect_mono assms card_seteq finite mem_Collect_eq not_le)

end

class relation_algebra_rtc_tarski_choose_point_finite =
      relation_algebra_rtc_tarski_choose_point + relation_algebra_rtc_tarski_point_finite
begin

lemma decrease_variant:
  assumes "y \<le> z"
      and "w \<le> z"
      and "\<not> w \<le> y"
    shows "card { x . x \<le> y } < card { x . x \<le> z }"
by (metis Collect_mono assms card_seteq linorder_not_le dual_order.trans finite_code mem_Collect_eq)

lemma construct_path_inv_termination:
  assumes "construct_path_inv q x y D W \<and> q \<noteq> x"
    shows "card { z . z \<le> -(W + choose_point (D*q)*q\<^sup>T) } < card { z . z \<le> -W }"
proof -
  let ?q = "choose_point (D*q)"
  let ?W = "W + ?q * q\<^sup>T"
  show ?thesis
  proof (rule decrease_variant)
    show "-?W \<le> -W"
      by simp
    show "?q * q\<^sup>T \<le> -W"
      by (metis assms galois_aux inf_compl_bot_right maddux_142 mult_isor order_trans top_greatest)
    show "\<not> (?q * q\<^sup>T \<le> -?W)"
      using assms end_points(1)
      by (smt acyclic_imp_one_step_different_points(2) choose_point_decreasing compl_sup inf.absorb1
              inf_compl_bot_right sup.commute sup_bot.left_neutral conv_zero end_points(2))
  qed
qed

theorem construct_path_total: "VARS p q W
  [ is_acyclic D \<and> point y \<and> point x \<and> D\<^sup>\<star>*y \<le> D\<^sup>T\<^sup>\<star>*x ]
  W := 0;
  q := y;
  WHILE q \<noteq> x
    INV { construct_path_inv q x y D W }
    VAR { card { z . z \<le> -W } }
     DO p := choose_point (D*q);
        W := W + p*q\<^sup>T;
        q := p
     OD
  [ W \<le> D \<and> terminating_path W \<and> (W=0 \<longleftrightarrow> x=y) \<and> (W\<noteq>0 \<longleftrightarrow> x = start_points W \<and> y = end_points W) ]"
  apply vcg_tc
  using construct_path_pre apply blast
  apply (rule CollectI, rule conjI)
  using construct_path_inv apply blast
  using construct_path_inv_termination apply clarsimp
  by fastforce

end (* relation_algebra_rtc_tarski_choose_point_finite *)

subsection \<open>Topological sorting\<close>

text \<open>
In our second example we look at topological sorting.
Given a directed acyclic graph, the problem is to construct a linear order of its vertices that contains $x$ before $y$ for each edge $(x,y)$ of the graph.
If the input graph models dependencies between tasks, the output is a linear schedule of the tasks that respects all dependencies.
\<close>

context relation_algebra_rtc_tarski_choose_point
begin

abbreviation topological_sort_inv
  where "topological_sort_inv q v R W \<equiv>
         regressively_finite R \<and> R \<cdot> v*v\<^sup>T \<le> W\<^sup>+ \<and> terminating_path W \<and> W*1 = v\<cdot>-q \<and>
         (W = 0 \<or> q = end_points W) \<and> point q \<and> R*v \<le> v \<and> q \<le> v \<and> is_vector v"

lemma topological_sort_pre:
  assumes "regressively_finite R"
  shows "topological_sort_inv (choose_point (minimum R 1)) (choose_point (minimum R 1)) R 0"
proof (intro conjI,simp_all add:assms)
  let ?q = "choose_point (- (R\<^sup>T * 1))"
  show point_q: "point ?q"
    using assms by (metis (full_types) annir choose_point_point galois_aux2 is_inj_def is_sur_def
                          is_vector_def one_idem_mult point_def ss_p18 inf_top_left one_compl)
  show "R \<cdot> ?q * ?q\<^sup>T \<le> 0"
    by (metis choose_point_decreasing conv_invol end_point_char order.eq_iff inf_bot_left schroeder_2)
  show "path 0"
    by (simp add: is_inj_def is_p_fun_def path_def)
  show "R*?q \<le> ?q"
    by (metis choose_point_decreasing compl_bot_eq conv_galois_1 inf_compl_bot_left2 le_inf_iff)
  show "is_vector ?q"
    using point_q point_def by blast
qed

lemma topological_sort_inv:
  assumes "v \<noteq> 1"
      and "topological_sort_inv q v R W"
    shows "topological_sort_inv (choose_point (minimum R (- v))) (v +
                      choose_point (minimum R (- v))) R (W + q * choose_point (minimum R (- v))\<^sup>T)"
proof (intro conjI)
  let ?p = "choose_point (minimum R (-v))"
  let ?W = "W + q*?p\<^sup>T"
  let ?v = "v + ?p"
  show point_p: "point ?p"
    using assms
    by (metis choose_point_point compl_bot_eq double_compl galois_aux2 comp_assoc is_vector_def
              vector_compl vector_mult)
  hence ep_np: "end_points (q*?p\<^sup>T) = ?p"
    using assms(2)
    by (metis aux4 choose_point_decreasing edge_end le_supI1 point_in_vector_or_complement_iff
              point_is_point)
  hence sp_q: "start_points (q*?p\<^sup>T) = q"
    using assms(2) point_p
    by (metis (no_types, lifting) conv_contrav conv_invol edge_start point_is_point)
  hence ep_sp: "W \<noteq> 0 \<Longrightarrow> end_points W = start_points (q*?p\<^sup>T)"
    using assms(2) by force
  have "W*1 \<cdot> (q*?p\<^sup>T)\<^sup>T*1 = v\<cdot>-q\<cdot>?p"
    using assms(2) point_p is_vector_def mult_assoc point_def point_equations(3) point_is_point
    by auto
  hence 1: "W*1 \<cdot> (q*?p\<^sup>T)\<^sup>T*1 = 0"
    by (metis choose_point_decreasing dual_order.trans galois_aux inf.cobounded2 inf.commute)

  show "regressively_finite R"
    using assms(2) by blast
  show "R \<cdot> ?v*?v\<^sup>T \<le> ?W\<^sup>+"
  proof -
    have a: "R \<cdot> v*v\<^sup>T \<le> ?W\<^sup>+"
      using assms(2) by (meson mult_isol_var order.trans order_prop star_subdist)
    have b: "R \<cdot> v*?p\<^sup>T \<le> ?W\<^sup>+"
    proof -
      have "R \<cdot> v*?p\<^sup>T \<le> W*1*?p\<^sup>T + q*?p\<^sup>T"
        by (metis inf_le2 assms(2) aux4 double_compl inf_absorb2 distrib_right)
      also have "... = W*?p\<^sup>T + q*?p\<^sup>T"
        using point_p by (metis conv_contrav conv_one is_vector_def mult_assoc point_def)
      also have "... \<le> W\<^sup>+*end_points W*?p\<^sup>T + q*?p\<^sup>T"
        using assms(2)
        by (meson forward_terminating_path_end_points_1 join_iso mult_isor terminating_path_iff)
      also have "... \<le> W\<^sup>+*q*?p\<^sup>T + q*?p\<^sup>T"
        using assms(2) by (metis annil eq_refl)
      also have "... = W\<^sup>\<star>*q*?p\<^sup>T"
        using conway.dagger_unfoldl_distr mult_assoc sup_commute by fastforce
      also have "... \<le> ?W\<^sup>+"
        by (metis mult_assoc mult_isol_var star_slide_var star_subdist sup_ge2)
      finally show ?thesis .
    qed
    have c: "R \<cdot> ?p*v\<^sup>T \<le> ?W\<^sup>+"
    proof -
      have "v \<le> -?p"
        using choose_point_decreasing compl_le_swap1 inf_le1 order_trans by blast
      hence "R*v \<le> -?p"
        using assms(2) order.trans by blast
      thus ?thesis
        by (metis galois_aux inf_le2 schroeder_2)
    qed
    have d: "R \<cdot> ?p*?p\<^sup>T \<le> ?W\<^sup>+"
    proof -
      have "R \<cdot> ?p*?p\<^sup>T \<le> R \<cdot> 1'"
        using point_p is_inj_def meet_isor point_def by blast
      also have "... = 0"
        using assms(2) regressively_finite_irreflexive galois_aux by blast
      finally show ?thesis
        using bot_least inf.absorb_iff2 by simp
    qed
    have "R \<cdot> ?v*?v\<^sup>T = (R \<cdot> v*v\<^sup>T) + (R \<cdot> v*?p\<^sup>T) + (R \<cdot> ?p*v\<^sup>T) + (R \<cdot> ?p*?p\<^sup>T)"
      by (metis conv_add distrib_left distrib_right inf_sup_distrib1 sup.commute sup.left_commute)
    also have "... \<le> ?W\<^sup>+"
      using a b c d by (simp add: le_sup_iff)
    finally show ?thesis .
  qed
  show pathW: "path ?W"
  proof (cases "W = 0")
    assume "W = 0"
    thus ?thesis
      using assms(2) point_p edge_is_path point_is_point sup_bot_left by auto
  next
    assume a1: "W \<noteq> 0"
    have fw_path: "forward_terminating_path W"
      using assms(2) terminating_iff by blast
    have bw_path: "backward_terminating_path (q*?p\<^sup>T)"
      using assms point_p sp_q
      by (metis conv_backward_terminating conv_has_start_points conv_path edge_is_path
                forward_terminating_iff1 point_is_point start_point_iff2)
    show ?thesis
      using fw_path bw_path ep_sp 1 a1 path_concatenation_cycle_free by blast
  qed
  show "terminating ?W"
  proof (rule start_end_implies_terminating)
    show "has_start_points ?W"
      apply (cases "W = 0")
      using assms(2) sp_q pathW
      apply (metis (no_types, lifting) point_is_point start_point_iff2 sup_bot.left_neutral)
      using assms(2) ep_sp 1 pathW
      by (metis has_start_end_points_iff path_concatenation_start_points start_point_iff2
                terminating_iff1)
    show "has_end_points ?W"
      apply (cases "W = 0")
      using point_p ep_np ep_sp pathW end_point_iff2 point_is_point apply force
      using point_p ep_np ep_sp 1 pathW
      by (metis end_point_iff2 path_concatenation_end_points point_is_point)
  qed
  show "?W*1 = ?v\<cdot>-?p"
  proof -
    have "?W*1 = v"
      by (metis assms(2) point_p is_vector_def mult_assoc point_def point_equations(3)
                point_is_point aux4 distrib_right' inf_absorb2 sup.commute)
    also have "... = v\<cdot>-?p"
      by (metis choose_point_decreasing compl_le_swap1 inf.cobounded1 inf.orderE order_trans)
    finally show ?thesis
      by (simp add: inf_sup_distrib2)
  qed
  show "?W = 0 \<or> ?p = end_points ?W"
    using ep_np ep_sp 1 by (metis path_concatenation_end_points sup_bot_left)
  show "R*?v \<le> ?v"
    using assms(2)
    by (meson choose_point_decreasing conv_galois_1 inf.cobounded2 order.trans sup.coboundedI1
              sup_least)
  show "?p \<le> ?v"
    by simp
  show "is_vector ?v"
    using assms(2) point_p point_def vector_add by blast
qed

lemma topological_sort_post:
 assumes "\<not> v \<noteq> 1"
     and "topological_sort_inv q v R W"
   shows "R \<le> W\<^sup>+ \<and> terminating_path W \<and> (W + W\<^sup>T)*1 = -1'*1"
proof (intro conjI,simp_all add:assms)
  show "R \<le> W\<^sup>+"
    using assms by force
  show " backward_terminating W \<and> W \<le> 1 * W * (- v + q)"
    using assms by force
  show "v \<cdot> - q + W\<^sup>T * 1 = - 1' * 1"
    proof (cases "W = 0")
      assume "W = 0"
      thus ?thesis
        using assms
        by (metis compl_bot_eq conv_one conv_zero double_compl inf_top.left_neutral is_inj_def
                  le_bot mult_1_right one_idem_mult point_def ss_p18 star_zero sup.absorb2 top_le)
    next
      assume a1: "W \<noteq> 0"
      hence "-1' \<noteq> 0"
        using assms backward_terminating_path_irreflexive le_bot by fastforce
      hence "1 = 1*-1'*1"
        by (simp add: tarski)
      also have "... = -1'*1"
        by (metis comp_assoc distrib_left mult_1_left sup_top_left distrib_right sup_compl_top)
      finally have a: "1 = -1'*1" .
      have "W*1 + W\<^sup>T*1 = 1"
        using assms a1 by (metis double_compl galois_aux4 inf.absorb_iff2 inf_top.left_neutral)
      thus ?thesis
        using a by (simp add: assms(2))
    qed
qed

theorem topological_sort_partial: "VARS p q v W
  { regressively_finite R }
  W := 0;
  q := choose_point (minimum R 1);
  v := q;
  WHILE v \<noteq> 1
    INV { topological_sort_inv q v R W }
     DO p := choose_point (minimum R (-v));
        W := W + q*p\<^sup>T;
        q := p;
        v := v + p
     OD
  { R \<le> W\<^sup>+ \<and> terminating_path W \<and> (W + W\<^sup>T)*1 = -1'*1 }"
  apply vcg
  using topological_sort_pre apply blast
  using topological_sort_inv apply blast
  using topological_sort_post by blast

end (* relation_algebra_rtc_tarski_choose_point *)

context relation_algebra_rtc_tarski_choose_point_finite
begin

lemma topological_sort_inv_termination:
  assumes "v \<noteq> 1"
      and "topological_sort_inv q v R W"
    shows "card {z . z \<le> -(v + choose_point (minimum R (-v)))} < card { z . z \<le> -v }"
proof (rule decrease_variant)
  let ?p = "choose_point (minimum R (-v))"
  let ?v = "v + ?p"
  show "-?v \<le> -v"
    by simp
  show "?p \<le> -v"
    using choose_point_decreasing inf.boundedE by blast
  have "point ?p"
    using assms
    by (metis choose_point_point compl_bot_eq double_compl galois_aux2 comp_assoc is_vector_def
              vector_compl vector_mult)
  thus "\<not> (?p \<le> -?v)"
    by (metis annir compl_sup inf.absorb1 inf_compl_bot_right maddux_20 no_end_point_char)
qed

text \<open>
Use precondition \<open>is_acyclic\<close> instead of \<open>regressively_finite\<close>.
They are equivalent for finite graphs.
\<close>

theorem topological_sort_total: "VARS p q v W
  [ is_acyclic R ]
  W := 0;
  q := choose_point (minimum R 1);
  v := q;
  WHILE v \<noteq> 1
    INV { topological_sort_inv q v R W }
    VAR { card { z . z \<le> -v } }
      DO p := choose_point (minimum R (-v));
         W := W + q*p\<^sup>T;
         q := p;
         v := v + p
      OD
   [ R \<le> W\<^sup>+ \<and> terminating_path W \<and> (W + W\<^sup>T)*1 = -1'*1 ]"
  apply vcg_tc
  apply (drule acyclic_regressively_finite)
  using topological_sort_pre apply blast
  apply (rule CollectI, rule conjI)
  using topological_sort_inv apply blast
  using topological_sort_inv_termination apply auto[1]
  using topological_sort_post by blast

end (* relation_algebra_rtc_tarski_choose_point_finite *)

subsection \<open>Construction of a tree\<close>

text \<open>
Our last application is a correctness proof of an algorithm that constructs a non-empty cycle for a given directed graph.
This works in two steps.
The first step is to construct a directed tree from a given root along the edges of the graph.
\<close>

context relation_algebra_rtc_tarski_choose_point
begin

abbreviation construct_tree_pre
  where "construct_tree_pre x y R \<equiv> y \<le> R\<^sup>T\<^sup>\<star>*x \<and> point x"
abbreviation construct_tree_inv
  where "construct_tree_inv v x y D R \<equiv> construct_tree_pre x y R \<and> is_acyclic D \<and> is_inj D \<and>
                                         D \<le> R \<and> D*x = 0 \<and> v = x + D\<^sup>T*1 \<and> x*v\<^sup>T \<le> D\<^sup>\<star> \<and> D \<le> v*v\<^sup>T \<and>
                                         is_vector v"
abbreviation construct_tree_post
  where "construct_tree_post x y D R \<equiv> is_acyclic D \<and> is_inj D \<and> D \<le> R \<and> D*x = 0 \<and> D\<^sup>T*1 \<le> D\<^sup>T\<^sup>\<star>*x \<and>
                                        D\<^sup>\<star>*y \<le> D\<^sup>T\<^sup>\<star>*x"

lemma construct_tree_pre:
  assumes "construct_tree_pre x y R"
    shows "construct_tree_inv x x y 0 R"
using assms by (simp add: is_inj_def point_def)

lemma construct_tree_inv_aux:
  assumes "\<not> y \<le> v"
      and "construct_tree_inv v x y D R"
    shows "singleton (choose_singleton (v*-v\<^sup>T \<cdot> R))"
proof (rule choose_singleton_singleton, rule notI)
  assume "v*-v\<^sup>T \<cdot> R = 0"
  hence "R\<^sup>T\<^sup>\<star>*v \<le> v"
    by (metis galois_aux conv_compl conv_galois_1 conv_galois_2 conv_invol double_compl
              star_inductl_var)
  hence "y = 0"
    using assms by (meson mult_isol order_trans sup.cobounded1)
  thus False
   using assms point_is_point by auto
qed

lemma construct_tree_inv:
  assumes "\<not> y \<le> v"
      and "construct_tree_inv v x y D R"
    shows "construct_tree_inv (v + choose_singleton (v*-v\<^sup>T \<cdot> R)\<^sup>T*1) x y (D +
                               choose_singleton (v*-v\<^sup>T \<cdot> R)) R"
proof (intro conjI)
  let ?e = "choose_singleton (v*-v\<^sup>T \<cdot> R)"
  let ?D = "D + ?e"
  let ?v = "v + ?e\<^sup>T*1"
  have 1: "?e \<le> v*-v\<^sup>T"
    using choose_singleton_decreasing inf.boundedE by blast
  show "point x"
    by (simp add: assms)
  show "y \<le> R\<^sup>T\<^sup>\<star>*x"
    by (simp add: assms)
  show "is_acyclic ?D"
    using 1 assms acyclic_inv by fastforce
  show "is_inj ?D"
    using 1 construct_tree_inv_aux assms injective_inv by blast
  show "?D \<le> R"
    apply (rule sup.boundedI)
    using assms apply blast
    using choose_singleton_decreasing inf.boundedE by blast
  show "?D*x = 0"
  proof -
    have "?D*x = ?e*x"
      by (simp add: assms)
    also have "... \<le> ?e*v"
      by (simp add: assms mult_isol)
    also have "... \<le> v*-v\<^sup>T*v"
      using 1 mult_isor by blast
    also have "... = 0"
      by (metis assms(2) annir comp_assoc vector_prop1)
    finally show ?thesis
      using le_bot by blast
  qed
  show "?v = x + ?D\<^sup>T*1"
    by (simp add: assms sup_assoc)
  show "x*?v\<^sup>T \<le> ?D\<^sup>\<star>"
  proof -
    have "x*?v\<^sup>T = x*v\<^sup>T + x*1*?e"
      by (simp add: distrib_left mult_assoc)
    also have "... \<le> D\<^sup>\<star> + x*1*(?e \<cdot> v*-v\<^sup>T)"
      using 1 by (metis assms(2) inf.absorb1 join_iso)
    also have "... = D\<^sup>\<star> + x*1*(?e \<cdot> v \<cdot> -v\<^sup>T)"
      by (metis assms(2) comp_assoc conv_compl inf.assoc vector_compl vector_meet_comp)
    also have "... \<le> D\<^sup>\<star> + x*1*(?e \<cdot> v)"
      using join_isol mult_subdistl by fastforce
    also have "... = D\<^sup>\<star> + x*(1 \<cdot> v\<^sup>T)*?e"
      by (metis assms(2) inf.commute mult_assoc vector_2)
    also have "... = D\<^sup>\<star> + x*v\<^sup>T*?e"
      by simp
    also have "... \<le> D\<^sup>\<star> + D\<^sup>\<star>*?e"
      using assms join_isol mult_isor by blast
    also have "... \<le> ?D\<^sup>\<star>"
      by (meson le_sup_iff prod_star_closure star_ext star_subdist)
    finally show ?thesis .
  qed
  show "?D \<le> ?v*?v\<^sup>T"
  proof (rule sup.boundedI)
    show "D \<le> ?v*?v\<^sup>T"
      using assms
      by (meson conv_add distrib_left le_supI1 conv_iso dual_order.trans mult_isol_var order_prop)
    have "?e \<le> v*(-v\<^sup>T \<cdot> v\<^sup>T*?e)"
      using 1 inf.absorb_iff2 modular_1' by fastforce
    also have "... \<le> v*1*?e"
      by (simp add: comp_assoc le_infI2 mult_isol_var)
    also have "... \<le> ?v*?v\<^sup>T"
      by (metis conv_contrav conv_invol conv_iso conv_one mult_assoc mult_isol_var sup.cobounded1
                sup_ge2)
    finally show "?e \<le> ?v*?v\<^sup>T"
      by simp
  qed
  show "is_vector ?v"
    using assms comp_assoc is_vector_def by fastforce
qed

lemma construct_tree_post:
  assumes "y \<le> v"
      and "construct_tree_inv v x y D R"
    shows "construct_tree_post x y D R"
proof -
  have "v*x\<^sup>T \<le> D\<^sup>T\<^sup>\<star>"
    by (metis (no_types, lifting) assms(2) conv_contrav conv_invol conv_iso star_conv)
  hence 1: "v \<le> D\<^sup>T\<^sup>\<star>*x"
    using assms point_def ss423bij by blast
  hence 2: "D\<^sup>T*1 \<le> D\<^sup>T\<^sup>\<star>*x"
    using assms le_supE by blast
  have "D\<^sup>\<star>*y \<le> D\<^sup>T\<^sup>\<star>*x"
  proof (rule star_inductl, rule sup.boundedI)
    show "y \<le> D\<^sup>T\<^sup>\<star>*x"
      using 1 assms order.trans by blast
  next
    have "D*(D\<^sup>T\<^sup>\<star>*x) = D*x + D*D\<^sup>T\<^sup>+*x"
      by (metis conway.dagger_unfoldl_distr distrib_left mult_assoc)
    also have "... = D*D\<^sup>T\<^sup>+*x"
      using assms by simp
    also have "... \<le> 1'*D\<^sup>T\<^sup>\<star>*x"
      by (metis assms(2) is_inj_def mult_assoc mult_isor)
    finally show "D*(D\<^sup>T\<^sup>\<star>*x) \<le> D\<^sup>T\<^sup>\<star>*x"
      by simp
  qed
  thus "construct_tree_post x y D R"
    using 2 assms by simp
qed

theorem construct_tree_partial: "VARS e v D
  { construct_tree_pre x y R }
  D := 0;
  v := x;
  WHILE \<not> y \<le> v
    INV { construct_tree_inv v x y D R }
     DO e := choose_singleton (v*-v\<^sup>T \<cdot> R);
        D := D + e;
        v := v + e\<^sup>T*1
     OD
  { construct_tree_post x y D R }"
 apply vcg
 using construct_tree_pre apply blast
 using construct_tree_inv apply blast
 using construct_tree_post by blast

end (* relation_algebra_rtc_tarski_choose_point *)

context relation_algebra_rtc_tarski_choose_point_finite
begin

lemma construct_tree_inv_termination:
 assumes " \<not> y \<le> v"
     and "construct_tree_inv v x y D R"
   shows "card { z . z \<le> -(v + choose_singleton (v*-v\<^sup>T \<cdot> R)\<^sup>T*1) } < card { z . z \<le> -v }"
proof (rule decrease_variant)
  let ?e = "choose_singleton (v*-v\<^sup>T \<cdot> R)"
  let ?v = "v + ?e\<^sup>T*1"
  have 1: "?e \<le> v*-v\<^sup>T"
    using choose_singleton_decreasing inf.boundedE by blast
  have 2: "singleton ?e"
    using construct_tree_inv_aux assms by auto
  show "-?v \<le> -v"
    by simp
  have "?e\<^sup>T \<le> -v*v\<^sup>T"
    using 1 conv_compl conv_iso by force
  also have "... \<le> -v*1"
    by (simp add: mult_isol)
  finally show "?e\<^sup>T*1 \<le> -v"
    using assms by (metis is_vector_def mult_isor one_compl)
  thus "\<not> (?e\<^sup>T*1 \<le> -?v)"
    using 2 by (metis annir compl_sup inf.absorb1 inf_compl_bot_right surj_one tarski)
qed

theorem construct_tree_total: "VARS e v D
 [ construct_tree_pre x y R ]
 D := 0;
 v := x;
 WHILE \<not> y \<le> v
   INV { construct_tree_inv v x y D R }
   VAR { card { z . z \<le> -v } }
    DO e := choose_singleton (v*-v\<^sup>T \<cdot> R);
       D := D + e;
       v := v + e\<^sup>T*1
    OD
 [ construct_tree_post x y D R ]"
  apply vcg_tc
  using construct_tree_pre apply blast
  apply (rule CollectI, rule conjI)
  using construct_tree_inv apply blast
  using construct_tree_inv_termination apply force
  using construct_tree_post by blast

end (* relation_algebra_rtc_tarski_choose_point_finite *)

subsection \<open>Construction of a non-empty cycle\<close>

text \<open>
The second step is to construct a path from the root to a given vertex in the tree.
Adding an edge back to the root gives the cycle.
\<close>

context relation_algebra_rtc_tarski_choose_point
begin

abbreviation comment
  where "comment _ \<equiv> SKIP" (* instead of inner comments *)
abbreviation construct_cycle_inv
  where "construct_cycle_inv v x y D R \<equiv> construct_tree_inv v x y D R \<and> point y \<and> y*x\<^sup>T \<le> R"

lemma construct_cycle_pre:
 assumes " \<not> is_acyclic R"
     and "y = choose_point ((R\<^sup>+ \<cdot> 1')*1)"
     and "x = choose_point (R\<^sup>\<star>*y \<cdot> R\<^sup>T*y)"
   shows "construct_cycle_inv x x y 0 R"
proof(rule conjI, rule_tac [2] conjI)
  show point_y: "point y"
    using assms by (simp add: choose_point_point is_vector_def mult_assoc galois_aux ss_p18)
  have "R\<^sup>\<star>*y \<cdot> R\<^sup>T*y \<noteq> 0"
  proof
    have "R\<^sup>+ \<cdot> 1' = (R\<^sup>+)\<^sup>T \<cdot> 1'"
      by (metis (mono_tags, hide_lams) conv_e conv_times inf.cobounded1 inf.commute
                many_strongly_connected_iff_6_eq mult_oner star_subid)
    also have "... = R\<^sup>T\<^sup>+ \<cdot> 1'"
      using plus_conv by fastforce
    also have "... \<le> (R\<^sup>T\<^sup>\<star> \<cdot> R)*R\<^sup>T"
      by (metis conv_contrav conv_e conv_invol modular_2_var mult_oner star_slide_var)
    also have "... \<le> (R\<^sup>T\<^sup>\<star> \<cdot> R)*1"
      by (simp add: mult_isol)
    finally have a: "(R\<^sup>+ \<cdot> 1')*1 \<le> (R\<^sup>T\<^sup>\<star> \<cdot> R)*1"
      by (metis mult_assoc mult_isor one_idem_mult)
    assume "R\<^sup>\<star>*y \<cdot> R\<^sup>T*y = 0"
    hence "(R\<^sup>\<star> \<cdot> R\<^sup>T)*y = 0"
      using point_y inj_distr point_def by blast
    hence "(R\<^sup>\<star> \<cdot> R\<^sup>T)\<^sup>T*1 \<le> -y"
      by (simp add: conv_galois_1)
    hence "y \<le> -((R\<^sup>\<star> \<cdot> R\<^sup>T)\<^sup>T*1)"
      using compl_le_swap1 by blast
    also have "... = -((R\<^sup>T\<^sup>\<star> \<cdot> R)*1)"
      by (simp add: star_conv)
    also have "... \<le> -((R\<^sup>+ \<cdot> 1')*1)"
      using a comp_anti by blast
    also have "... \<le> -y"
      by (simp add: assms galois_aux ss_p18 choose_point_decreasing)
    finally have "y = 0"
      using inf.absorb2 by fastforce
    thus False
      using point_y annir point_equations(2) point_is_point tarski by force
  qed
  hence point_x: "point x"
    by (metis point_y assms(3) inj_distr is_vector_def mult_assoc point_def choose_point_point)
  hence "y \<le> R\<^sup>T\<^sup>\<star> * x"
    by (metis assms(3) point_y choose_point_decreasing inf_le1 order.trans point_swap star_conv)
  thus tree_inv: "construct_tree_inv x x y 0 R"
    using point_x construct_tree_pre by blast
  show "y * x\<^sup>T \<le> R"
  proof -
    have "x \<le> R\<^sup>\<star>*y \<cdot> R\<^sup>T*y"
      using assms(3) choose_point_decreasing by blast
    also have "... = (R\<^sup>\<star> \<cdot> R\<^sup>T)*y"
      using point_y inj_distr point_def by fastforce
    finally have "x*y\<^sup>T \<le> R\<^sup>\<star> \<cdot> R\<^sup>T"
      using point_y point_def ss423bij by blast
    also have "... \<le> R\<^sup>T"
      by simp
    finally show ?thesis
      using conv_iso by force
  qed
qed

lemma construct_cycle_pre2:
 assumes "y \<le> v"
     and "construct_cycle_inv v x y D R"
   shows "construct_path_inv y x y D 0 \<and> D \<le> R \<and> D * x = 0 \<and> y * x\<^sup>T \<le> R"
proof(intro conjI, simp_all add: assms)
  show "D\<^sup>\<star> * y \<le> D\<^sup>T\<^sup>\<star> * x"
    using assms construct_tree_post by blast
  show "path 0"
    by (simp add: is_inj_def is_p_fun_def path_def)
  show "y \<noteq> 0"
    using assms(2) is_point_def point_is_point by blast
qed

lemma construct_cycle_post:
  assumes "\<not> q \<noteq> x"
      and "(construct_path_inv q x y D W \<and> D \<le> R \<and> D * x = 0 \<and> y * x\<^sup>T \<le> R)"
    shows "W + y * x\<^sup>T \<noteq> 0 \<and> W + y * x\<^sup>T \<le> R \<and> cycle (W + y * x\<^sup>T)"
proof(intro conjI)
  let ?C = "W + y*x\<^sup>T"
  show "?C \<noteq> 0"
    by (metis assms acyclic_imp_one_step_different_points(2) no_trivial_inverse point_def ss423bij
              sup_bot.monoid_axioms monoid.left_neutral)
  show "?C \<le> R"
    using assms(2) order_trans sup.boundedI by blast
  show "path (W + y * x\<^sup>T)"
    by (metis assms construct_tree_pre edge_is_path less_eq_def path_edge_equals_cycle
              point_is_point terminating_iff1)
  show "many_strongly_connected (W + y * x\<^sup>T)"
    by (metis assms construct_tree_pre bot_least conv_zero less_eq_def
              path_edge_equals_cycle star_conv star_subid terminating_iff1)
  qed

theorem construct_cycle_partial: "VARS e p q v x y C D W
  { \<not> is_acyclic R }
  y := choose_point ((R\<^sup>+ \<cdot> 1')*1);
  x := choose_point (R\<^sup>\<star>*y \<cdot> R\<^sup>T*y);
  D := 0;
  v := x;
  WHILE \<not> y \<le> v
    INV { construct_cycle_inv v x y D R }
     DO e := choose_singleton (v*-v\<^sup>T \<cdot> R);
        D := D + e;
        v := v + e\<^sup>T*1
     OD;
  comment { is_acyclic D \<and> point y \<and> point x \<and> D\<^sup>\<star>*y \<le> D\<^sup>T\<^sup>\<star>*x };
  W := 0;
  q := y;
  WHILE q \<noteq> x
    INV { construct_path_inv q x y D W \<and> D \<le> R \<and> D*x = 0 \<and> y*x\<^sup>T \<le> R }
     DO p := choose_point (D*q);
        W := W + p*q\<^sup>T;
        q := p
     OD;
  comment { W \<le> D \<and> terminating_path W \<and> (W = 0 \<longleftrightarrow> q=y) \<and> (W \<noteq> 0 \<longleftrightarrow> q = start_points W \<and> y = end_points W) };
  C := W + y*x\<^sup>T
  { C \<noteq> 0 \<and> C \<le> R \<and> cycle C }"
  apply vcg
  using construct_cycle_pre apply blast
  using construct_tree_inv apply blast
  using construct_cycle_pre2 apply blast
  using construct_path_inv apply blast
  using construct_cycle_post by blast

end (* relation_algebra_rtc_tarski_choose_point *)

context relation_algebra_rtc_tarski_choose_point_finite
begin

theorem construct_cycle_total: "VARS e p q v x y C D W
  [ \<not> is_acyclic R ]
  y := choose_point ((R\<^sup>+ \<cdot> 1')*1);
  x := choose_point (R\<^sup>\<star>*y \<cdot> R\<^sup>T*y);
  D := 0;
  v := x;
  WHILE \<not> y \<le> v
    INV { construct_cycle_inv v x y D R }
    VAR { card { z . z \<le> -v } }
     DO e := choose_singleton (v*-v\<^sup>T \<cdot> R);
        D := D + e;
        v := v + e\<^sup>T*1
     OD;
  comment { is_acyclic D \<and> point y \<and> point x \<and> D\<^sup>\<star>*y \<le> D\<^sup>T\<^sup>\<star>*x };
  W := 0;
  q := y;
  WHILE q \<noteq> x
    INV { construct_path_inv q x y D W \<and> D \<le> R \<and> D*x = 0 \<and> y*x\<^sup>T \<le> R }
    VAR { card { z . z \<le> -W } }
     DO p := choose_point (D*q);
        W := W + p*q\<^sup>T;
        q := p
     OD;
  comment { W \<le> D \<and> terminating_path W \<and> (W = 0 \<longleftrightarrow> q=y) \<and> (W \<noteq> 0 \<longleftrightarrow> q = start_points W \<and> y = end_points W)};
  C := W + y*x\<^sup>T
 [ C \<noteq> 0 \<and> C \<le> R \<and> cycle C ]"
  apply vcg_tc
  using construct_cycle_pre apply blast
  apply (rule CollectI, rule conjI)
  using construct_tree_inv apply blast
  using construct_tree_inv_termination apply force
  using construct_cycle_pre2 apply blast
  apply (rule CollectI, rule conjI)
  using construct_path_inv apply blast
  using construct_path_inv_termination apply clarsimp
  using construct_cycle_post by blast

end (* relation_algebra_rtc_tarski_choose_point_finite *)

end


(*  Title:      JinjaThreads/Compiler/ListIndex.thy
    Author:     Tobias Nipkow, Andreas Lochbihler
*)

section \<open>Indexing variables in variable lists\<close>

theory ListIndex imports Main begin

text\<open>In order to support local variables and arbitrarily nested
blocks, the local variables are arranged as an indexed list. The
outermost local variable (``this'') is the first element in the list,
the most recently created local variable the last element. When
descending into a block structure, a corresponding list @{term Vs} of
variable names is maintained. To find the index of some variable
@{term V}, we have to find the index of the \emph{last} occurrence of
@{term V} in @{term Vs}. This is what @{term index} does:\<close>

primrec index :: "'a list \<Rightarrow> 'a \<Rightarrow> nat"
where
  "index [] y = 0"
| "index (x#xs) y =
  (if x=y then if x \<in> set xs then index xs y + 1 else 0 else index xs y + 1)"

definition hidden :: "'a list \<Rightarrow> nat \<Rightarrow> bool"
where "hidden xs i  \<equiv>  i < size xs \<and> xs!i \<in> set(drop (i+1) xs)"

subsection \<open>@{term index}\<close>

lemma [simp]: "(index (xs @ [x]) y = size xs) = (x = y)"
(*<*)by(induct xs) auto(*>*)

lemma [simp]: "x \<in> set xs \<Longrightarrow> xs ! index xs x = x"
(*<*)by(induct xs) auto(*>*)

lemma [simp]: "x \<notin> set xs \<Longrightarrow> index xs x = size xs"
(*<*)by(induct xs) auto(*>*)

lemma size_index_conv[simp]: "(size xs = index xs x) = (x \<notin> set xs)"
(*<*)by(induct xs) auto(*>*)

lemma "(index xs x < size xs) = (x \<in> set xs)"
(*<*)by(induct xs) auto(*>*)

lemma [simp]: "\<lbrakk> y \<in> set xs; x \<noteq> y \<rbrakk> \<Longrightarrow> index (xs @ [x]) y = index xs y"
(*<*)by(induct xs) auto(*>*)

lemma index_less_size[simp]: "x \<in> set xs \<Longrightarrow> index xs x < size xs"
(*<*)
apply(induct xs)
 apply simp
apply(fastforce)
done
(*>*)

lemma index_less_aux: "\<lbrakk>x \<in> set xs; size xs \<le> n\<rbrakk> \<Longrightarrow> index xs x < n"
(*<*)
apply(subgoal_tac "index xs x < size xs")
apply(simp (no_asm_simp))
apply simp
done
(*>*)

lemma [simp]: "x \<in> set xs \<or> y \<in> set xs \<Longrightarrow> (index xs x = index xs y) = (x = y)"
(*<*)by (induct xs) auto(*>*)

lemma inj_on_index: "inj_on (index xs) (set xs)"
(*<*)by(simp add:inj_on_def)(*>*)

lemma index_drop: "\<And>x i. \<lbrakk> x \<in> set xs; index xs x < i \<rbrakk> \<Longrightarrow> x \<notin> set(drop i xs)"
(*<*)
apply(induct xs)
apply (auto simp:drop_Cons split:if_split_asm nat.splits dest:in_set_dropD)
done
(*>*)

subsection \<open>@{term hidden}\<close>

lemma hidden_index: "x \<in> set xs \<Longrightarrow> hidden (xs @ [x]) (index xs x)"
(*<*)
apply(auto simp add:hidden_def index_less_aux nth_append)
 apply(drule index_less_size)
 apply(simp del:index_less_size)
done
(*>*)

lemma hidden_inacc: "hidden xs i \<Longrightarrow> index xs x \<noteq> i"
(*<*)
apply(case_tac "x \<in> set xs")
apply(auto simp add:hidden_def index_less_aux nth_append index_drop)
done
(*>*)

lemma [simp]: "hidden xs i \<Longrightarrow> hidden (xs@[x]) i"
(*<*)by(auto simp add:hidden_def nth_append)(*>*)

lemma fun_upds_apply: "\<And>m ys.
  (m(xs[\<mapsto>]ys)) x =
  (let xs' = take (size ys) xs
   in if x \<in> set xs' then Some(ys ! index xs' x) else m x)"
(*<*)
apply(induct xs)
 apply (simp add:Let_def)
apply(case_tac ys)
 apply (simp add:Let_def)
apply (simp add:Let_def)
done
(*>*)

lemma map_upds_apply_eq_Some:
  "((m(xs[\<mapsto>]ys)) x = Some y) =
  (let xs' = take (size ys) xs
   in if x \<in> set xs' then ys ! index xs' x = y else m x = Some y)"
(*<*)by(simp add:fun_upds_apply Let_def)(*>*)

lemma map_upds_upd_conv_index:
  "\<lbrakk>x \<in> set xs; size xs \<le> size ys \<rbrakk>
  \<Longrightarrow> m(xs[\<mapsto>]ys)(x\<mapsto>y) = m(xs[\<mapsto>]ys[index xs x := y])"
(*<*)
apply(rule ext)
apply(simp add:fun_upds_apply index_less_aux eq_sym_conv Let_def)
done
(*>*)

lemma image_index:
  "A \<subseteq> set(xs@[x]) \<Longrightarrow> index (xs @ [x]) ` A =
  (if x \<in> A then insert (size xs) (index xs ` (A-{x})) else index xs ` A)"
(*<*)
apply(auto simp:image_def)
   apply(rule bexI)
    prefer 2 apply blast
   apply simp
  apply(rule ccontr)
  apply(erule_tac x=xa in ballE)
   prefer 2 apply blast
  apply(fastforce simp add:neq_commute)
 apply(subgoal_tac "x \<noteq> xa")
  prefer 2 apply blast
 apply(fastforce simp add:neq_commute)
apply(subgoal_tac "x \<noteq> xa")
 prefer 2 apply blast
apply(force)
done
(*>*)

lemma index_le_lengthD: "index xs x < length xs \<Longrightarrow> x \<in> set xs"
by(erule contrapos_pp)(simp)

lemma not_hidden_index_nth: "\<lbrakk> i < length Vs; \<not> hidden Vs i \<rbrakk> \<Longrightarrow> index Vs (Vs ! i) = i"
by(induct Vs arbitrary: i)(auto split: if_split_asm nat.split_asm simp add: nth_Cons hidden_def)

lemma hidden_snoc_nth:
  assumes len: "i < length Vs"
  shows "hidden (Vs @ [Vs ! i]) i"
proof(cases "hidden Vs i")
  case True thus ?thesis by simp
next
  case False
  with len have "index Vs (Vs ! i) = i" by(rule not_hidden_index_nth)
  moreover from len have "hidden (Vs @ [Vs ! i]) (index Vs (Vs ! i))"
    by(auto intro: hidden_index)
  ultimately show ?thesis by simp
qed

lemma map_upds_Some_eq_nth_index:
  assumes "[Vs [\<mapsto>] vs] V = Some v" "length Vs \<le> length vs"
  shows "vs ! index Vs V = v"
proof -
  from \<open>[Vs [\<mapsto>] vs] V = Some v\<close> have "V \<in> set Vs"
    by -(rule classical, auto)
  with \<open>[Vs [\<mapsto>] vs] V = Some v\<close> \<open>length Vs \<le> length vs\<close> show ?thesis
  proof(induct Vs arbitrary: vs)
    case Nil thus ?case by simp
  next
    case (Cons x xs ys)
    note IH = \<open>\<And>vs. \<lbrakk> [xs [\<mapsto>] vs] V = Some v; length xs \<le> length vs; V \<in> set xs \<rbrakk> \<Longrightarrow> vs ! index xs V = v\<close>
    from \<open>[x # xs [\<mapsto>] ys] V = Some v\<close> obtain y Ys where "ys = y # Ys" by(cases ys, auto)
    with \<open>length (x # xs) \<le> length ys\<close> have "length xs \<le> length Ys" by simp
    show ?case
    proof(cases "V \<in> set xs")
      case True
      with \<open>[x # xs [\<mapsto>] ys] V = Some v\<close> \<open>length xs \<le> length Ys\<close> \<open>ys = y # Ys\<close>
      have "[xs [\<mapsto>] Ys] V = Some v"
        apply(auto simp add: map_upds_def map_of_eq_None_iff set_zip image_Collect split: if_split_asm)
        apply(clarsimp simp add: in_set_conv_decomp)
        apply(hypsubst_thin)
        apply(erule_tac x="length ys" in allE)
        by(simp)
      with IH[OF this \<open>length xs \<le> length Ys\<close> True] \<open>ys = y # Ys\<close> True
      show ?thesis by(simp)
    next
      case False with \<open>V \<in> set (x # xs)\<close> have "x = V" by auto
      with False \<open>[x # xs [\<mapsto>] ys] V = Some v\<close> \<open>ys = y # Ys\<close> have "y = v"
        by(auto)
      with False \<open>x = V\<close> \<open>ys = y # Ys\<close>
      show ?thesis by(simp)
    qed
  qed
qed

end


theory Chapter16_3_Typechecking
imports Chapter16_2_Expression
begin

inductive typecheck :: "type env => expr => type => bool"
where tc_var [simp]: "lookup gam x = Some t ==> typecheck gam (Var x) t"
    | tc_lam [simp]: "typecheck (extend gam t1) e t2 ==> typecheck gam (Lam t1 e) (Arrow t1 t2)"
    | tc_appl [simp]: "typecheck gam e1 (Arrow t2 t) ==> typecheck gam e2 t2 ==>
                typecheck gam (Appl e1 e2) t"
    | tc_triv [simp]: "typecheck gam Triv Unit"
    | tc_pair [simp]: "typecheck gam e1 t1 ==> typecheck gam e2 t2 ==>
                typecheck gam (Pair e1 e2) (Prod t1 t2)"
    | tc_projl [simp]: "typecheck gam e (Prod t1 t2) ==> typecheck gam (ProjL e) t1"
    | tc_projr [simp]: "typecheck gam e (Prod t1 t2) ==> typecheck gam (ProjR e) t2"
    | tc_abort [simp]: "typecheck gam e Void ==> typecheck gam (Abort t e) t"
    | tc_case [simp]: "typecheck gam et (Sum t1 t2) ==> typecheck (extend gam t1) el t ==>
                typecheck (extend gam t2) er t ==> typecheck gam (Case et el er) t"
    | tc_inl [simp]: "typecheck gam e t1 ==> typecheck gam (InL t1 t2 e) (Sum t1 t2)"
    | tc_inr [simp]: "typecheck gam e t2 ==> typecheck gam (InR t1 t2 e) (Sum t1 t2)"
    | tc_fix [simp]: "typecheck (extend gam t) e t ==> typecheck gam (Fix t e) t"
    | tc_fold [simp]: "typecheck gam e (type_subst (Rec t) first t) ==> typecheck gam (Fold t e) (Rec t)"
    | tc_unfold [simp]: "typecheck gam e (Rec t) ==>
                typecheck gam (Unfold e) (type_subst (Rec t) first t)"

inductive_cases [elim!]: "typecheck gam (Var x) t"
inductive_cases [elim!]: "typecheck gam (Lam t1 e) t"
inductive_cases [elim!]: "typecheck gam (Appl e1 e2) t"
inductive_cases [elim!]: "typecheck gam Triv t"
inductive_cases [elim!]: "typecheck gam (Pair e1 e2) t"
inductive_cases [elim!]: "typecheck gam (ProjL e) t"
inductive_cases [elim!]: "typecheck gam (ProjR e) t"
inductive_cases [elim!]: "typecheck gam (Abort t1 e) t"
inductive_cases [elim!]: "typecheck gam (Case et el er) t"
inductive_cases [elim!]: "typecheck gam (InL t1 t2 e) t"
inductive_cases [elim!]: "typecheck gam (InR t1 t2 e) t"
inductive_cases [elim!]: "typecheck gam (Fix t1 e) t"
inductive_cases [elim!]: "typecheck gam (Fold t1 e) t"
inductive_cases [elim!]: "typecheck gam (Unfold e) t"

lemma [simp]: "typecheck (extend_at n gam t') e t ==> n in gam ==> typecheck gam e' t' ==>
                  typecheck gam (subst e' n e) t"
by (induction "extend_at n gam t'" e t arbitrary: n gam t' e' rule: typecheck.induct, fastforce+)

end


header {* Abstract syntax for Hybrid CSP. *}

theory HHL_SL
  imports  op_SL
begin

type_synonym now_dash = real
type_synonym dform = "history => now \<Rightarrow> now_dash \<Rightarrow> bool"

definition semd :: "history \<Rightarrow> now \<Rightarrow> now_dash  \<Rightarrow> dform \<Rightarrow> bool" ("_, [_, _] |= _"  50) where
"h, [n, m] |= H == (H h n m)"

(* One axiom stating that the dform formula is only decided by the interval between now and now_dash*)
axiomatization where
DC : "now \<le> now' \<Longrightarrow>(\<forall> t. t> now & t< now'\<longrightarrow> h t = h' t) \<Longrightarrow> (df :: dform) h now now' = df h' now now'"

section
{*Duration Calculus operators and lemmas proved.*}
(*Special assertions \<and> lemmas proved*)

(*almost P, P holds almost everywhere over the interval.*)
definition almost :: "fform \<Rightarrow> dform" where
(*"almost P \<equiv> % h n nd. (nd-n>0) & (\<not>(\<exists> a b.(n\<le>a & a<b & b\<le>nd) & (\<forall> t. t>a & t<b \<longrightarrow> \<not>P(h(t)))))"*)
(*An alternative definition of almost*)
"almost P \<equiv> % h n nd. (nd-n>0) &  (\<forall>a\<ge>n. \<forall>b\<le>nd. a < b \<longrightarrow> (\<exists>t. t>a \<and> t<b \<and> P(h(t))))"
definition chop :: "dform \<Rightarrow> dform \<Rightarrow> dform"  ("_[^]_" 80)
where
"chop H M \<equiv> % h n nd. (\<exists> nm. (nm \<ge> n \<and> nm \<le> nd \<and> (H h n nm) \<and> (M h nm nd)))"

(*The length of the interval l is equal to, greater than, less than T.*)
definition elE :: "real \<Rightarrow> dform" where
"elE T \<equiv> % h n nd. (nd-n) = T"
definition elG :: "real \<Rightarrow> dform" where
"elG T \<equiv> % h n nd. (nd-n) > T"
definition elL :: "real \<Rightarrow> dform" where
"elL T \<equiv> % h n nd. (nd-n) < T"

definition dAnd :: "dform \<Rightarrow> dform \<Rightarrow> dform"  (infixl "[[&]]"  79) where
"P [[&]] Q == % h n m. P h n m \<and> Q h n m"
definition dOr :: "dform \<Rightarrow> dform \<Rightarrow> dform"  (infixl "[[|]]" 79) where
"P [[|]] Q == % h n m. P h n m \<or> Q h n m"
definition dNot :: "dform \<Rightarrow> dform"  ("[[\<not>]]_" 79) where
"[[\<not>]]P == % h n m. \<not> P h n m"
definition dImp :: "dform \<Rightarrow> dform \<Rightarrow> dform"  (infixl "[[\<longrightarrow>]]" 79) where
"P [[\<longrightarrow>]] Q == % h n m. P h n m \<longrightarrow> Q h n m"

declare almost_def [simp]
declare chop_def [simp]
declare elE_def [simp]
declare elG_def [simp]
declare elL_def [simp]

(*True holds almost everywhere.*)
lemma almostf : "\<forall> h n nd. nd-n\<le>0 \<or> almost fTrue h n nd"
apply (simp)
 by (metis dense le_iff_diff_le_0 not_le)

(*almost P \<Leftrightarrow> chop almost P almost P*)
lemma chopfb : "((chop (almost P) (almost P)) h n nd \<Longrightarrow> (almost P) h n nd)"
apply (simp)
apply (rule conjI, auto)
by (metis (poly_guards_query) less_eq_real_def less_trans not_less)

lemma chopfor : "((chop (elE 0 [[|]]almost P) (elE 0 [[|]]almost P)) h n nd \<Longrightarrow> (elE 0 [[|]]almost P) h n nd)"
apply (simp add:dOr_def)
apply (rule disjCI, auto)
by (metis dual_order.refl le_cases less_eq_real_def less_imp_not_less less_trans linear neq_iff not_less)

lemma chopf : "((almost P) h n nd \<Longrightarrow> (chop (almost P) (almost P)) h n nd)"
apply (simp)
apply (rule_tac x = "(n+nd)/2" in exI, auto)
apply (metis (poly_guards_query) le_iff_diff_le_0 not_le real_less_half_sum)
by (metis less_diff_eq monoid_add_class.add.left_neutral real_gt_half_sum)

lemma chop0L : "chop (almost P) (elE 0) h n nd \<Longrightarrow> almost P h n nd"
by auto
lemma chop0R : " almost P h n nd \<longrightarrow> chop (almost P) (elE 0) h n nd"
by auto
(*Monotonicity: s \<Rightarrow> t \<Longrightarrow> almost s \<Rightarrow> almost t*)
lemma almostmono: "(\<forall> s. P s \<longrightarrow> Q s) \<Longrightarrow> (\<forall> h n nd. almost P h n nd \<longrightarrow> almost Q h n nd)"
apply (auto)
by (metis (full_types))

lemma almostint: "now<nowf \<Longrightarrow> \<forall> t. (t>now \<and> t<nowf) \<longrightarrow> P (f t) \<Longrightarrow> almost P f now nowf"
apply (auto)
by (metis le_less_trans less_le_trans of_rat_dense)

section{*Inference rules for hybird CSP: Hybrid Hoare Logic rules*}

(*Specification*)
definition Valid :: "fform => proc => fform \<Rightarrow> dform => bool" ("{_}_{_; _}" 80)
where "Valid p c q H == (\<forall> now h now' h' . semB c now h now' h' \<longrightarrow> p (h(now)) \<longrightarrow> (q (h'(now'))
\<and> H h' now now'))"
definition ValidP :: "fform \<Rightarrow>fform \<Rightarrow> procP => fform \<Rightarrow> fform \<Rightarrow> dform \<Rightarrow> dform \<Rightarrow> bool"
("{_, _}_{_, _; _, _}" 80)
where "ValidP pa pb c qa qb Ha Hb == (\<forall> nowp nowq fp fq nowp' nowq' fp' fq'.
semBP c nowp fp nowq fq nowp' fp' nowq' fq'  \<longrightarrow>
(pa) (fp(nowp)) \<longrightarrow>pb (fq(nowq)) \<longrightarrow>
(qa (fp'(nowp'))\<and> qb (fq'(nowq'))\<and> (Ha fp' nowp nowp') \<and> (Hb fq' nowq nowq')))"

subsection{*Inference rules proved sound*}

(*Skip rule*)
lemma SkipRule : "\<forall> s h now now'. (p s \<longrightarrow> q s) \<and> ((elE 0) h now now'\<longrightarrow> H h now now')
         \<Longrightarrow> {p} Skip {q; H}"
by (auto simp add:Valid_def)

(*Assignment rule*)
lemma AssignRRule  :" (\<forall> s. p s \<longrightarrow> (q (%(y, i). if (y=x\<and>i=R) then (evalE f s) else s(y, i))))
                   \<and> (\<forall> h now now'. ((elE 0) h now now'\<longrightarrow> H h now now')) ==>
       {p} ((RVar x) := f) {q; H}"
apply (simp add:Valid_def, auto)
done

(*Sequential rule*)
(*The proof is complicated because of the existence of chop operator.*)
lemma SequentialRule_aux : " {p} P {m; H} \<Longrightarrow> {m} Q {q; G} ==>
             {p} P;  Q {q; H [^] G}"
apply  (simp add:Valid_def, auto)
apply (subgoal_tac "now \<le> now'a \<and> now'a \<le> now'\<and> H h' now now'a = H f' now now'a")
apply metis
apply (rule conjI)
apply (cut_tac P = "P" and now = now and  now'=now'a and f = "h" and f' = "f'" in sem1, simp)
apply metis
apply (rule conjI)
apply (cut_tac P = "Q" and now = now'a and  now'=now' and f = "f'" and f' = "h'" in sem1, simp)
apply metis
apply (rule DC)
apply (cut_tac P = "P" and now = now and  now'=now'a and f = "h" and f' = "f'" in sem1, simp)
apply metis
apply (subgoal_tac "\<forall>t. t < now'a \<or> t>now' \<longrightarrow> f' t = h' t")
apply metis
apply (cut_tac P = Q in  sem2, auto)
done

lemma SequentialRule : " {p} P {m; H} \<Longrightarrow> {m} Q {q; G} ==> (\<forall> h m n. (H [^] G) h m n \<longrightarrow> M h m n) \<Longrightarrow>
             {p} P;  Q {q; M}"
apply (cut_tac P = P and  Q = Q  and  p = p and  q =q and m = m and H = H  and  G = G in  SequentialRule_aux, auto)
apply (simp add:Valid_def)
done

(*Conditional rule*)
lemma ConditionTRule : " ((\<forall> s. p s \<longrightarrow> ( b s)) \<and> {p} P {q; H})
             ==> {p} IF b P {q; H}"
apply (simp add:Valid_def, auto)
done

lemma ConditionFRule : " ((\<forall> s. p s \<longrightarrow> (q s \<and> (\<not>   b s))) \<and> (\<forall> h now now'. ((elE 0) h now now'\<longrightarrow> H h now now')))
                          ==> {p} IF b P {q; H}"
apply (simp add:Valid_def, auto)
done

lemma ConditionGRule : " {p [&] b} P {q; H} \<and> {p [&] ([\<not>]b)} Q {q; H}
             ==> {p} IFELSE b P Q{q; H}"
apply (simp add:Valid_def fAnd_def fNot_def, auto)
done

declare almost_def [simp del]
declare chop_def [simp del]
(*Assume v'=E is the differential equation for the continuous evolution.*)
(*This proof takes most effort for solving the invariant-related constraints, which will be passed to an
external oracle for invariant generation in fact. So don't worry.*)
lemma ContinuousRule :
"\<forall> s u. ( ( \<forall> y i.(y, i) \<noteq> (fst (v), snd (v)) \<longrightarrow> s (y, i) = u (y, i)) \<longrightarrow> (p s) \<longrightarrow> (p u)) \<and>
 ( \<forall> s.  Init s \<longrightarrow>  Inv s)
 \<and> (\<forall> s.  (p [&] (Inv) [&] ([\<not>]b)) s \<longrightarrow> q s)
 \<and> (\<forall> s. (exeFlow (<[v]:E&&Inv&b>) (Inv)) s \<longrightarrow> Inv s)
 \<and>  (\<forall> h now now'. ((elE 0) h now now' \<or> (almost (Inv [&] p  [&] b)) h now now') \<longrightarrow>
                  H h now now')
 ==> {Init [&] (p::fform)} <[v]:E&&Inv&(b)> {q; H}"
apply (simp add:Valid_def) apply clarify
apply (subgoal_tac "\<forall> t. t\<ge>now & t\<le>now' \<longrightarrow> exeFlow (<[v]:E&&Inv&b>) (Inv) (h'(t))")
prefer 2
apply (simp add:exeFlow_def)
apply (metis fAnd_def)
apply auto
apply (metis fAnd_def)
apply (subgoal_tac "(p [&] Inv) (\<lambda>(y, i). if y = fst v \<and> i = snd v
 then Solution (<[v]:E&&Inv&b>) (h now) (now + d - now) else h now (y, i))")
apply (simp add:fAnd_def)+
apply (rule conjI, auto)
apply (subgoal_tac "\<forall> y i. (y, i) \<noteq> v \<longrightarrow> (h(now)) (y, i) = ((\<lambda>(y, i). if y = fst v \<and> i = snd v
   then Solution (<[v]:E&&Inv&b>) (h now) (now + d - now) else h now (y, i))) (y, i)")
apply smt2
apply auto
apply (subgoal_tac "exeFlow (<[v]:E&&Inv&b>) (Inv)
                    (\<lambda>(y, i). if y = fst v \<and> i = snd v
        then Solution (<[v]:E&&Inv&b>) (h now) (now+d - now) else h now (y, i))")
apply (metis (no_types, lifting))
apply (drule_tac x = "now +d" in spec, auto)
apply (subgoal_tac "almost (Inv [&] p [&] b)
(\<lambda>t. if t \<le> now + d \<and> now < t then \<lambda>(y, i). if y = fst v \<and> i = snd v
then Solution (<[v]:E&&Inv&b>) (h now) (t - now) else h now (y, i) else h t) now (now+d)", auto)
apply (rule almostint, auto)
apply (simp add:fAnd_def)
apply (rule conjI)
apply (subgoal_tac "exeFlow (<[v]:E&&Inv&b>) (Inv)
                    (\<lambda>(y, i). if y = fst v \<and> i = snd v
        then Solution (<[v]:E&&Inv&b>) (h now) (t - now) else h now (y, i))")
apply (metis (no_types, lifting))
apply (drule_tac x = "t" in spec, auto)
apply (subgoal_tac "\<forall> y i. (y, i) \<noteq> v \<longrightarrow> (h(now)) (y, i) = ((\<lambda>(y, i). if y = fst v \<and> i = snd v
   then Solution (<[v]:E&&Inv&b>) (h now) (t - now) else h now (y, i))) (y, i)")
apply smt2
apply auto
done

(*We simple extend the above rule to the general case where the continuous are a list of variables not just one.
The proof can be given in the same way.*)
primrec notcontain :: "(string * typeid) \<Rightarrow> (string * typeid) list \<Rightarrow> bool"
where
"notcontain a ([]) = True" |
"notcontain a (e # Elist) = (if a = e then False else (notcontain a Elist))"

axiomatization where ContinuousRuleGT:
" (\<forall> s. (p) s --> b s)
\<and> ( \<forall> s.  p s \<longrightarrow>  Inv s)
 \<and> (\<forall> s.  ((Inv) [&] (close (b)) [&] (close([\<not>]b))) s \<longrightarrow> q s)
 \<and> (\<forall> s. (exeFlow (<V:E&&Inv&b>) (Inv)) s \<longrightarrow> Inv s)
 \<and>  (\<forall> h now now'. ((elE 0) h now now' \<or> (almost (Inv [&]  close(b))) h now now') \<longrightarrow>
                  H h now now')
 ==> {p} <V:E&&Inv&(b)> {q; H}"

axiomatization where ContinuousRuleGF:
" \<forall> s. p s \<longrightarrow> (([\<not>] b) [&]q) s
 ==> {p} <V:E&&Inv&(b)> {q; elE 0}"

(*There are three rules for parallel  composition, which covers all the cases.*)
(*Parallel rule for the case without communication*)
lemma Parallel_aux :
"  semBP (P || Q) nowp fp nowq fq nowp' fp' nowq' fq' \<Longrightarrow>
       \<forall>now h now' h'. semB P now h now' h' \<longrightarrow> pp (h now) \<longrightarrow> qp (h' now') \<and> Hp h' now now' \<Longrightarrow>
       \<forall>now h now' h'. semB Q now h now' h' \<longrightarrow> pq (h now) \<longrightarrow> qq (h' now') \<and> Hq h' now now' \<Longrightarrow>
       chanset P = {} \<Longrightarrow> chanset Q = {} \<Longrightarrow>
       pp (fp nowp) \<Longrightarrow> pq (fq nowq) \<Longrightarrow> qp (fp' nowp') \<and> qq (fq' nowq') \<and> Hp fp' nowp nowp' \<and> Hq fq' nowq nowq'"
apply (ind_cases " semBP (P || Q) nowp fp nowq fq nowp' fp' nowq' fq'")
apply metis
apply (simp add:chanset_def)+
done

lemma Parallel1Rule : "chanset P = {} \<and> chanset Q = {} \<Longrightarrow> {pp} P {qp; Hp} \<Longrightarrow> {pq} Q {qq; Hq}
                       \<Longrightarrow> {pp, pq} P||Q {qp, qq; Hp, Hq}"
apply (clarsimp simp:Valid_def ValidP_def)
apply (rule Parallel_aux)
apply simp+
done

(*Parallel rule for the case with communication at the end.*)
lemma Communication_aux:
"  semBP (P; Cm (ch??(RVar x)) || Q; Cm (ch!!e)) nowp fp nowq fq nowp' fp' nowq' fq' \<Longrightarrow>
    \<forall> nowp nowq fp fq nowp' nowq' fp' fq'.
          semBP (P || Q) nowp fp nowq fq nowp' fp' nowq' fq' \<longrightarrow>
          px (fp nowp) \<longrightarrow> py (fq nowq) \<longrightarrow> qx (fp' nowp') \<and> qy (fq' nowq') \<and> Hx fp' nowp nowp' \<and> Hy fq' nowq nowq' \<Longrightarrow>
       \<forall>s. qx s \<longrightarrow> rx (\<lambda>(y, i). if y = x \<and> i = R then evalE e s else s (y, i)) \<Longrightarrow>
       \<forall>s. qy s \<longrightarrow> ry s \<Longrightarrow>
       \<forall>h n m. (Hx[^](elE 0 [[|]]almost qx)) h n m \<longrightarrow> Gx h n m \<Longrightarrow>
       \<forall>h n m. (Hy[^](elE 0 [[|]]almost qy)) h n m \<longrightarrow> Gy h n m \<Longrightarrow>
       px (fp nowp) \<Longrightarrow> py (fq nowq) \<Longrightarrow> rx (fp' nowp') \<and> ry (fq' nowq') \<and> Gx fp' nowp nowp' \<and> Gy fq' nowq nowq'"
apply (ind_cases "semBP (P; Cm (ch??(RVar x)) || Q; Cm (ch!!e)) nowp fp nowq fq nowp' fp' nowq' fq'")
apply (simp add:chanset_def)
apply (simp add:chanset_def)
apply (subgoal_tac " qx (fp'a nowp'a) \<and> qy (fq'a nowq'a) \<and> Hx fp'a nowp nowp'a \<and> Hy fq'a nowq nowq'a")
prefer 2
apply metis
apply (rule conjI)
apply (subgoal_tac "fp' nowp' = (\<lambda>(y, i). if y = x \<and> i = R then evalE e (fp'a nowp'a) else (fp'a nowp'a) (y, i))", simp)
apply (metis less_irrefl)
apply (rule conjI)
apply (metis max.cobounded1 max_def_raw not_less)
apply (rule conjI)
(*to prove GX*)
apply (subgoal_tac "(Hx[^](elE 0 [[|]] almost qx)) fp' nowp nowp'", simp)
apply (subgoal_tac "Hx fp' nowp nowp'a",simp)
prefer 2
apply (subgoal_tac "Hx fp'a nowp nowp'a = Hx fp' nowp nowp'a", simp)
apply (rule DC)
apply (metis semB1)
apply (metis less_max_iff_disj less_not_sym)
apply (simp add:chop_def)
apply (rule_tac x = "nowp'a" in exI, simp)
apply (rule conjI)
apply (metis semB1)
apply (simp add:dOr_def)
apply (case_tac "max nowp'a nowq'a > nowp'a")
prefer 2 apply (rule disjI1)
apply (metis less_eq_real_def max.cobounded1)
apply (rule disjI2)
apply (rule almostint, simp)
apply (metis (no_types, lifting))
(*to prove Gy, just copy the proof for Gx with a little adaption*)
apply (subgoal_tac "(Hy[^](elE 0 [[|]] almost qy)) fq' nowq nowq'", simp)
apply (subgoal_tac "Hy fq' nowq nowq'a",simp)
prefer 2
apply (subgoal_tac "Hy fq'a nowq nowq'a = Hy fq' nowq nowq'a", simp)
apply (rule DC)
apply (metis semB1)
apply (metis less_max_iff_disj less_not_sym)
apply (simp add:chop_def)
apply (rule_tac x = "nowq'a" in exI, simp)
apply (rule conjI)
apply (metis semB1)
apply (simp add:dOr_def)
apply (case_tac "max nowp'a nowq'a > nowq'a")
prefer 2
apply (rule disjI1)
apply (metis less_eq_real_def max.cobounded2)
apply (rule disjI2)
apply (rule almostint, simp)
apply (subgoal_tac "qy (fq'a nowq'a)")
apply smt2
by metis

lemma CommunicationRule :
  " ({px, py} (P || Q) {qx, qy; Hx, Hy}) \<Longrightarrow>
   (\<forall> s. qx s \<longrightarrow> (rx (%(y, i). if (y=x\<and>i=R) then (evalE e s) else s(y, i))))
 \<and> (\<forall> s. qy s \<longrightarrow> ry s)
 \<and> (\<forall> h n m. (Hx[^](elE 0 [[|]]almost qx)) h n m \<longrightarrow> Gx h n m) \<and>
   (\<forall> h n m. (Hy[^](elE 0 [[|]]almost qy)) h n m \<longrightarrow> Gy h n m)
  ==>
{px, py} (P;Cm (ch??(RVar (x))))||(Q; (Cm (ch!!e))) {rx, ry; Gx, Gy}"
apply (clarsimp simp:ValidP_def)
apply (rule Communication_aux)
apply simp+
done

(*Parallel rule for the case with non-communication process at the end.*)
lemma Parallel2_aux : "semBP (P; U || Q; V) nowp fp nowq fq nowp' fp' nowq' fq' \<Longrightarrow>
        \<forall>nowp nowq fp fq nowp' nowq' fp' fq'.
          semBP (P || Q) nowp fp nowq fq nowp' fp' nowq' fq' \<longrightarrow>
          pp (fp nowp) \<longrightarrow> pq (fq nowq) \<longrightarrow> qp (fp' nowp') \<and> qq (fq' nowq') \<and>
        Hp fp' nowp nowp' \<and> Hq fq' nowq nowq' \<Longrightarrow>
       \<forall>now h now' h'. semB U now h now' h' \<longrightarrow> qp (h now) \<longrightarrow> qu (h' now') \<and> Hu h' now now' \<Longrightarrow>
       \<forall>now h now' h'. semB V now h now' h' \<longrightarrow> qq (h now) \<longrightarrow> qv (h' now') \<and> Hv h' now now' \<Longrightarrow>
       chanset P \<noteq> {} \<Longrightarrow> chanset Q \<noteq> {} \<Longrightarrow> chanset U = {} \<Longrightarrow> chanset V = {} \<Longrightarrow>
       pp (fp nowp) \<Longrightarrow> pq (fq nowq) \<Longrightarrow> qu (fp' nowp') \<and> qv (fq' nowq') \<and>
             (Hp[^]Hu) fp' nowp nowp' \<and> (Hq[^]Hv) fq' nowq nowq'"
apply (ind_cases "semBP (P; U || Q; V) nowp fp nowq fq nowp' fp' nowq' fq'")
apply (simp add:chanset_def)
prefer 2 apply (simp add:chanset_def)
prefer 2 apply (simp add:chanset_def)
apply (subgoal_tac "qp (fp'a nowp'a) \<and> qq (fq'a nowq'a) \<and> Hp fp'a nowp nowp'a \<and> Hq fq'a nowq nowq'a")
prefer 2
apply metis
apply (rule conjI) apply metis
apply (rule conjI) apply metis
apply (subgoal_tac "(Hu) fp' nowp'a nowp' ")
apply (subgoal_tac "(Hv) fq' nowq'a nowq'")
prefer 2 apply metis prefer 2 apply metis
apply (subgoal_tac " Hq fq' nowq nowq'a")
apply (subgoal_tac " Hp fp' nowp nowp'a ")
apply (rule conjI)
apply (unfold chop_def)
apply (metis sem1 semB1)
apply (metis sem1 semB1)
apply (subgoal_tac "Hp fp'a nowp nowp'a = Hp fp' nowp nowp'a", simp)
apply (rule DC)
apply (metis semB1)
apply (metis sem2)
apply (subgoal_tac " Hq fq'a nowq nowq'a =  Hq fq' nowq nowq'a", simp)
apply (rule DC)
apply (metis semB1)
apply (metis sem2)
done

lemma Parallel2Rule : "{pp, pq} P||Q {qp, qq; Hp, Hq}  \<Longrightarrow> chanset P \<noteq> {} \<and> chanset Q \<noteq> {} \<Longrightarrow>
                          {qp} U {qu; Hu} \<Longrightarrow> {qq} V {qv; Hv} \<Longrightarrow> chanset U = {} \<and> chanset V = {}
                       \<Longrightarrow> {pp, pq} P; U||Q; V {qu, qv; Hp [^] Hu, Hq [^] Hv}"
apply (clarsimp simp:Valid_def ValidP_def)
apply (rule Parallel2_aux)
apply simp+
done

(*Repetition rule*)

lemma Repetition_aux_1: " semB (P* NUM 0) now h now' h' ⟹
       ∀h n m. (H[^]H) h n m ⟶ H h n m ⟹
       ∀now h now' h'. semB P now h now' h' ⟶ Inv (h now) ⟶ Inv (h' now') ∧ H h' now now' ⟹
       Inv (h now) ⟹ Inv (h' now') ∧ (H h' now now' ∨ now' = now)"
  apply (ind_cases "semB (P* NUM 0) now h now' h'", auto)
  done

lemma Repetition_aux_2: " (⋀now h now' h'. semB (P* NUM N) now h now' h' ⟹ Inv (h now) ⟹ Inv (h' now') ∧ (H h' now now' ∨ now' = now)) ⟹
       semB (P* NUM Suc N) now h now' h' ⟹
       ∀h n m. (H[^]H) h n m ⟶ H h n m ⟹
       ∀now h now' h'. semB P now h now' h' ⟶ Inv (h now) ⟶ Inv (h' now') ∧ H h' now now' ⟹
       Inv (h now) ⟹ Inv (h' now') ∧ (H h' now now' ∨ now' = now)"
  apply (ind_cases "semB (P* NUM Suc N) now h now' h'")
  apply simp
  by (smt DC chop_def sem1 sem2)

lemma Repetition_aux: "semB (P* NUM N) now h now' h' ⟹
                     ∀h n m. (H[^]H) h n m ⟶ H h n m ⟹
                     ∀now h now' h'. semB P now h now' h' ⟶ Inv (h now) ⟶ Inv (h' now') ∧ H h' now now' ⟹
                     Inv (h now) ⟹ Inv (h' now') ∧ (H [[|]] (λh n nd. nd = n)) h' now now'"
apply (simp add:dOr_def)
apply (induction N arbitrary: now h now' h')
   apply (rule Repetition_aux_1) apply simp+
  apply (cut_tac P = P and N = N and now = now and h = h and h' = h' and Inv = Inv in Repetition_aux_2, auto)
    done

lemma RepetitionRule: "∀h n m. (H[^]H) h n m ⟶ H h n m ⟹ {Inv} P {Inv; H}
                      ==>  {Inv} P*&&Inv {Inv; (H [[|]] (elE 0))} "
  apply (simp add:Valid_def) apply clarify
  apply (rule Repetition_aux)
   apply simp+
  done

(*Join Rule*)
lemma JoinRule : "{p} P {m; H} ⟹ {p} Q {q; G} ==>
             {p} P [[ Q {m [|] q; H [[|]] G}"
  apply (simp add:Valid_def fOr_def dOr_def, auto)
    done

(*Consequence rule*)
lemma ConsequenceRule : "{px} P {qx; Hx}
                  \<and> (\<forall> s. p s \<longrightarrow> px s) \<and> (\<forall> s. qx s \<longrightarrow> q s)
                  \<and> (\<forall> h n m. Hx h n m \<longrightarrow> H h n m)
            ==> {p} P {q; H}"
apply (simp add:Valid_def)
done

(*Case analysis rule*)
lemma CaseRule : "{p [&] pb} P {q; H} \<and> {(p [&] ([\<not>]pb))} P {q; H}
   ==> {p} P {q; H}"
apply (simp add:Valid_def fAnd_def fNot_def, auto)
apply metis+
done

end


(******************************************************************************)
(* Project: Isabelle/UTP Toolkit                                              *)
(* File: Sequence.thy                                                         *)
(* Authors: Simon Foster and Frank Zeyda                                      *)
(* Emails: simon.foster@york.ac.uk and frank.zeyda@york.ac.uk                 *)
(******************************************************************************)

section \<open> Infinite Sequences \<close>

theory Infinite_Sequence
imports
  HOL.Real
  List_Extra
  "HOL-Library.Sublist"
  "HOL-Library.Nat_Bijection"
begin

typedef 'a infseq = "UNIV :: (nat \<Rightarrow> 'a) set"
  by (auto)

setup_lifting type_definition_infseq

definition ssubstr :: "nat \<Rightarrow> nat \<Rightarrow> 'a infseq \<Rightarrow> 'a list" where
"ssubstr i j xs = map (Rep_infseq xs) [i ..< j]"

lift_definition nth_infseq :: "'a infseq \<Rightarrow> nat \<Rightarrow> 'a" (infixl "!\<^sub>s" 100)
is "\<lambda> f i. f i" .

abbreviation sinit :: "nat \<Rightarrow> 'a infseq \<Rightarrow> 'a list" where
"sinit i xs \<equiv> ssubstr 0 i xs"

lemma sinit_len [simp]:
  "length (sinit i xs) = i"
  by (simp add: ssubstr_def)

lemma sinit_0 [simp]: "sinit 0 xs = []"
  by (simp add: ssubstr_def)

lemma prefix_upt_0 [intro]:
  "i \<le> j \<Longrightarrow> prefix [0..<i] [0..<j]"
  by (induct i, auto, metis append_prefixD le0 prefix_order.lift_Suc_mono_le prefix_order.order_refl upt_Suc)

lemma sinit_prefix:
  "i \<le> j \<Longrightarrow> prefix (sinit i xs) (sinit j xs)"
  by (simp add: map_mono_prefix prefix_upt_0 ssubstr_def)

lemma sinit_strict_prefix:
  "i < j \<Longrightarrow> strict_prefix (sinit i xs) (sinit j xs)"
  by (metis sinit_len sinit_prefix le_less nat_neq_iff prefix_order.dual_order.strict_iff_order)

lemma nth_sinit:
  "i < n \<Longrightarrow> sinit n xs ! i = xs !\<^sub>s i"
  apply (auto simp add: ssubstr_def)
  apply (transfer, auto)
  done

lemma sinit_append_split:
  assumes "i < j"
  shows "sinit j xs = sinit i xs @ ssubstr i j xs"
proof -
  have "[0..<i] @ [i..<j] = [0..<j]"
    by (metis assms le0 le_add_diff_inverse le_less upt_add_eq_append)
  thus ?thesis
    by (auto simp add: ssubstr_def, transfer, simp add: map_append[THEN sym])
qed

lemma sinit_linear_asym_lemma1:
  assumes "asym R" "i < j" "(sinit i xs, sinit i ys) \<in> lexord R" "(sinit j ys, sinit j xs) \<in> lexord R"
  shows False
proof -
  have sinit_xs: "sinit j xs = sinit i xs @ ssubstr i j xs"
    by (metis assms(2) sinit_append_split)
  have sinit_ys: "sinit j ys = sinit i ys @ ssubstr i j ys"
    by (metis assms(2) sinit_append_split)
  from sinit_xs sinit_ys assms(4)
  have "(sinit i ys, sinit i xs) \<in> lexord R \<or> (sinit i ys = sinit i xs \<and> (ssubstr i j ys, ssubstr i j xs) \<in> lexord R)"
    by (auto dest: lexord_append)
  with assms lexord_asymmetric show False
    by (force)
qed

lemma sinit_linear_asym_lemma2:
  assumes "asym R" "(sinit i xs, sinit i ys) \<in> lexord R" "(sinit j ys, sinit j xs) \<in> lexord R"
  shows False
proof (cases i j rule: linorder_cases)
  case less with assms show ?thesis
    by (auto dest: sinit_linear_asym_lemma1)
next
  case equal with assms show ?thesis
    by (simp add: lexord_asymmetric)
next
  case greater with assms show ?thesis
    by (auto dest: sinit_linear_asym_lemma1)
qed

lemma range_ext:
  assumes "\<forall>i :: nat. \<forall>x\<in>{0..<i}. f(x) = g(x)"
  shows "f = g"
proof (rule ext)
  fix x :: nat
  obtain i :: nat where "i > x"
    by (metis lessI)
  with assms show "f(x) = g(x)"
    by (auto)
qed

lemma sinit_ext:
  "(\<forall> i. sinit i xs = sinit i ys) \<Longrightarrow> xs = ys"
  by (simp add: ssubstr_def, transfer, auto intro: range_ext)

definition infseq_lexord :: "'a rel \<Rightarrow> ('a infseq) rel" where
"infseq_lexord R = {(xs, ys). (\<exists> i. (sinit i xs, sinit i ys) \<in> lexord R)}"

lemma infseq_lexord_irreflexive:
  "\<forall>x. (x, x) \<notin> R \<Longrightarrow> (xs, xs) \<notin> infseq_lexord R"
  by (auto dest: lexord_irreflexive simp add: irrefl_def infseq_lexord_def)

lemma infseq_lexord_irrefl:
  "irrefl R \<Longrightarrow> irrefl (infseq_lexord R)"
  by (simp add: irrefl_def infseq_lexord_irreflexive)

lemma infseq_lexord_transitive:
  assumes "trans R"
  shows "trans (infseq_lexord R)"
unfolding infseq_lexord_def
proof (rule transI, clarify)
  fix xs ys zs :: "'a infseq" and m n :: nat
  assume las: "(sinit m xs, sinit m ys) \<in> lexord R" "(sinit n ys, sinit n zs) \<in> lexord R"
  hence inz: "m > 0"
    using gr0I by force
  from las(1) obtain i where sinitm: "(sinit m xs!i, sinit m ys!i) \<in> R" "i < m" "\<forall> j<i. sinit m xs!j = sinit m ys!j"
    using lexord_eq_length by force
  from las(2) obtain j where sinitn: "(sinit n ys!j, sinit n zs!j) \<in> R" "j < n" "\<forall> k<j. sinit n ys!k = sinit n zs!k"
    using lexord_eq_length by force
  show "\<exists>i. (sinit i xs, sinit i zs) \<in> lexord R"
  proof (cases "i \<le> j")
    case True note lt = this
    with sinitm sinitn have "(sinit n xs!i, sinit n zs!i) \<in> R"
      by (metis assms le_eq_less_or_eq le_less_trans nth_sinit transD)
    moreover from lt sinitm sinitn have "\<forall> j<i. sinit m xs!j = sinit m zs!j"
      by (metis less_le_trans less_trans nth_sinit)
    ultimately have "(sinit n xs, sinit n zs) \<in> lexord R" using sinitm(2) sinitn(2) lt
      apply (rule_tac lexord_intro_elems)
         apply (auto)
      apply (metis less_le_trans less_trans nth_sinit)
      done
    thus ?thesis by auto
  next
    case False
    then have ge: "i > j" by auto
    with assms sinitm sinitn have "(sinit n xs!j, sinit n zs!j) \<in> R"
      by (metis less_trans nth_sinit)
    moreover from ge sinitm sinitn have "\<forall> k<j. sinit m xs!k = sinit m zs!k"
      by (metis dual_order.strict_trans nth_sinit)
    ultimately have "(sinit n xs, sinit n zs) \<in> lexord R" using sinitm(2) sinitn(2) ge
      apply (rule_tac lexord_intro_elems)
         apply (auto)
      apply (metis less_trans nth_sinit)
      done
    thus ?thesis by auto
  qed
qed

lemma infseq_lexord_trans:
  "\<lbrakk> (xs, ys) \<in> infseq_lexord R; (ys, zs) \<in> infseq_lexord R; trans R \<rbrakk> \<Longrightarrow> (xs, zs) \<in> infseq_lexord R"
  by (meson infseq_lexord_transitive transE)

lemma infseq_lexord_antisym:
  "\<lbrakk> asym R; (a, b) \<in> infseq_lexord R \<rbrakk> \<Longrightarrow> (b, a) \<notin> infseq_lexord R"
  by (auto dest: sinit_linear_asym_lemma2 simp add: infseq_lexord_def)

lemma infseq_lexord_asym:
  assumes "asym R"
  shows "asym (infseq_lexord R)"
  by (meson assms asym.simps infseq_lexord_antisym infseq_lexord_irrefl)

lemma infseq_lexord_total:
  assumes "total R"
  shows "total (infseq_lexord R)"
  using assms by (auto simp add: total_on_def infseq_lexord_def, meson lexord_linear sinit_ext)

lemma infseq_lexord_strict_linear_order:
  assumes "strict_linear_order R"
  shows "strict_linear_order (infseq_lexord R)"
  using assms
  by (auto simp add: strict_linear_order_on_def partial_order_on_def preorder_on_def
           intro: infseq_lexord_transitive infseq_lexord_irrefl infseq_lexord_total)

lemma infseq_lexord_linear:
  assumes "(\<forall> a b. (a,b)\<in> R \<or> a = b \<or> (b,a) \<in> R)"
  shows "(x,y) \<in> infseq_lexord R \<or> x = y \<or> (y,x) \<in> infseq_lexord R"
proof -
  have "total R"
    using assms total_on_def by blast
  hence "total (infseq_lexord R)"
    using infseq_lexord_total by blast
  thus ?thesis
    by (auto simp add: total_on_def)
qed

instantiation infseq :: (ord) ord
begin

definition less_infseq :: "'a infseq \<Rightarrow> 'a infseq \<Rightarrow> bool" where
"less_infseq xs ys \<longleftrightarrow> (xs, ys) \<in> infseq_lexord {(xs, ys). xs < ys}"

definition less_eq_infseq :: "'a infseq \<Rightarrow> 'a infseq \<Rightarrow> bool" where
"less_eq_infseq xs ys = (xs = ys \<or> xs < ys)"

instance ..

end

instance infseq :: (order) order
proof
  fix xs :: "'a infseq"
  show "xs \<le> xs" by (simp add: less_eq_infseq_def)
next
  fix xs ys zs :: "'a infseq"
  assume "xs \<le> ys" and "ys \<le> zs"
  then show "xs \<le> zs"
    by (force dest: infseq_lexord_trans simp add: less_eq_infseq_def less_infseq_def trans_def)
next
  fix xs ys :: "'a infseq"
  assume "xs \<le> ys" and "ys \<le> xs"
  then show "xs = ys"
    apply (auto simp add: less_eq_infseq_def less_infseq_def)
    apply (rule infseq_lexord_irreflexive [THEN notE])
     defer
     apply (rule infseq_lexord_trans)
       apply (auto intro: transI)
    done
next
  fix xs ys :: "'a infseq"
  show "xs < ys \<longleftrightarrow> xs \<le> ys \<and> \<not> ys \<le> xs"
    apply (auto simp add: less_infseq_def less_eq_infseq_def)
     defer
     apply (rule infseq_lexord_irreflexive [THEN notE])
      apply auto
     apply (rule infseq_lexord_irreflexive [THEN notE])
      defer
      apply (rule infseq_lexord_trans)
        apply (auto intro: transI)
    apply (simp add: infseq_lexord_irreflexive)
    done
qed

instance infseq :: (linorder) linorder
proof
  fix xs ys :: "'a infseq"
  have "(xs, ys) \<in> infseq_lexord {(u, v). u < v} \<or> xs = ys \<or> (ys, xs) \<in> infseq_lexord {(u, v). u < v}"
    by (rule infseq_lexord_linear) auto
  then show "xs \<le> ys \<or> ys \<le> xs"
    by (auto simp add: less_eq_infseq_def less_infseq_def)
qed

lemma infseq_lexord_mono [mono]:
  "(\<And> x y. f x y \<longrightarrow> g x y) \<Longrightarrow> (xs, ys) \<in> infseq_lexord {(x, y). f x y} \<longrightarrow> (xs, ys) \<in> infseq_lexord {(x, y). g x y}"
  apply (auto simp add: infseq_lexord_def)
  apply (metis case_prodD case_prodI lexord_take_index_conv mem_Collect_eq)
done

fun insort_rel :: "'a rel \<Rightarrow> 'a \<Rightarrow> 'a list \<Rightarrow> 'a list" where
"insort_rel R x [] = [x]" |
"insort_rel R x (y # ys) = (if (x = y \<or> (x,y) \<in> R) then x # y # ys else y # insort_rel R x ys)"

inductive sorted_rel :: "'a rel \<Rightarrow> 'a list \<Rightarrow> bool" where
Nil_rel [iff]: "sorted_rel R []" |
Cons_rel: "\<forall> y \<in> set xs. (x = y \<or> (x, y) \<in> R) \<Longrightarrow> sorted_rel R xs \<Longrightarrow> sorted_rel R (x # xs)"

definition list_of_set :: "'a rel \<Rightarrow> 'a set \<Rightarrow> 'a list" where
"list_of_set R = folding_on.F (insort_rel R) []"

lift_definition infseq_inj :: "'a infseq infseq \<Rightarrow> 'a infseq" is
"\<lambda> f i. f (fst (prod_decode i)) (snd (prod_decode i))" .

lift_definition infseq_proj :: "'a infseq \<Rightarrow> 'a infseq infseq" is
"\<lambda> f i j. f (prod_encode (i, j))" .

lemma infseq_inj_inverse: "infseq_proj (infseq_inj x) = x"
  by (transfer, simp)

lemma infseq_proj_inverse: "infseq_inj (infseq_proj x) = x"
  by (transfer, simp)

lemma infseq_inj: "inj infseq_inj"
  by (metis injI infseq_inj_inverse)

lemma infseq_inj_surj: "bij infseq_inj"
  apply (rule bijI)
   apply (auto simp add: infseq_inj)
  apply (metis rangeI infseq_proj_inverse)
  done
end