(* Title:      Omega Algebras
   Author:     Walter Guttmann
   Maintainer: Walter Guttmann <walter.guttmann at canterbury.ac.nz>
*)

section \<open>Omega Algebras\<close>

theory Omega_Algebras

imports Stone_Kleene_Relation_Algebras.Kleene_Algebras

begin

nitpick_params [timeout = 600]

class omega =
  fixes omega :: "'a \<Rightarrow> 'a" ("_\<^sup>\<omega>" [100] 100)

class left_omega_algebra = left_kleene_algebra + omega +
  assumes omega_unfold: "y\<^sup>\<omega> = y * y\<^sup>\<omega>"
  assumes omega_induct: "x \<le> z \<squnion> y * x \<longrightarrow> x \<le> y\<^sup>\<omega> \<squnion> y\<^sup>\<star> * z"
begin

text \<open>Many lemmas in this class are taken from Georg Struth's Isabelle theories.\<close>

lemma star_bot_below_omega:
  "x\<^sup>\<star> * bot \<le> x\<^sup>\<omega>"
  using omega_unfold star_left_induct_equal by auto

lemma star_bot_below_omega_bot:
  "x\<^sup>\<star> * bot \<le> x\<^sup>\<omega> * bot"
  by (metis omega_unfold star_left_induct_equal sup_monoid.add_0_left mult_assoc)

lemma omega_induct_mult:
  "y \<le> x * y \<Longrightarrow> y \<le> x\<^sup>\<omega>"
  by (metis bot_least omega_induct sup.absorb1 sup.absorb2 star_bot_below_omega)

lemma omega_sub_dist:
  "x\<^sup>\<omega> \<le> (x \<squnion> y)\<^sup>\<omega>"
  by (metis eq_refl mult_isotone omega_unfold sup.cobounded1 omega_induct_mult)

lemma omega_isotone:
  "x \<le> y \<Longrightarrow> x\<^sup>\<omega> \<le> y\<^sup>\<omega>"
  using sup_left_divisibility omega_sub_dist by fastforce

lemma omega_induct_equal:
  "y = z \<squnion> x * y \<Longrightarrow> y \<le> x\<^sup>\<omega> \<squnion> x\<^sup>\<star> * z"
  by (simp add: omega_induct)

lemma omega_bot:
  "bot\<^sup>\<omega> = bot"
  by (metis mult_left_zero omega_unfold)

lemma omega_one_greatest:
  "x \<le> 1\<^sup>\<omega>"
  by (simp add: omega_induct_mult)

lemma star_mult_omega:
  "x\<^sup>\<star> * x\<^sup>\<omega> = x\<^sup>\<omega>"
  by (metis order.antisym omega_unfold star.circ_loop_fixpoint star_left_induct_mult_equal sup.cobounded2)

lemma omega_sub_vector:
  "x\<^sup>\<omega> * y \<le> x\<^sup>\<omega>"
  by (metis mult_semi_associative omega_unfold omega_induct_mult)

lemma omega_simulation:
  "z * x \<le> y * z \<Longrightarrow> z * x\<^sup>\<omega> \<le> y\<^sup>\<omega>"
  by (smt (verit, ccfv_threshold) mult_isotone omega_unfold order_lesseq_imp mult_assoc omega_induct_mult)

lemma omega_omega:
  "x\<^sup>\<omega>\<^sup>\<omega> \<le> x\<^sup>\<omega>"
  by (metis omega_unfold omega_sub_vector)

lemma left_plus_omega:
  "(x * x\<^sup>\<star>)\<^sup>\<omega> = x\<^sup>\<omega>"
  by (metis order.antisym mult_assoc omega_induct_mult omega_unfold order_refl star.left_plus_circ star_mult_omega)

lemma omega_slide:
  "x * (y * x)\<^sup>\<omega> = (x * y)\<^sup>\<omega>"
  by (metis order.antisym mult_assoc mult_right_isotone omega_simulation omega_unfold order_refl)

lemma omega_simulation_2:
  "y * x \<le> x * y \<Longrightarrow> (x * y)\<^sup>\<omega> \<le> x\<^sup>\<omega>"
  by (metis mult_right_isotone sup.absorb2 omega_induct_mult omega_slide omega_sub_dist)

lemma wagner:
  "(x \<squnion> y)\<^sup>\<omega> = x * (x \<squnion> y)\<^sup>\<omega> \<squnion> z \<Longrightarrow> (x \<squnion> y)\<^sup>\<omega> = x\<^sup>\<omega> \<squnion> x\<^sup>\<star> * z"
  by (smt (verit, ccfv_SIG) order.refl star_left_induct sup.absorb2 sup_assoc sup_commute omega_induct_equal omega_sub_dist)

lemma right_plus_omega:
  "(x\<^sup>\<star> * x)\<^sup>\<omega> = x\<^sup>\<omega>"
  by (metis left_plus_omega omega_slide star_mult_omega)

lemma omega_sub_dist_1:
  "(x * y\<^sup>\<star>)\<^sup>\<omega> \<le> (x \<squnion> y)\<^sup>\<omega>"
  by (metis left_plus_omega mult_isotone star.circ_sub_dist sup.cobounded1 sup_monoid.add_commute omega_isotone)

lemma omega_sub_dist_2:
  "(x\<^sup>\<star> * y)\<^sup>\<omega> \<le> (x \<squnion> y)\<^sup>\<omega>"
  by (metis mult_isotone star.circ_sub_dist sup.cobounded2 omega_isotone right_plus_omega)

lemma omega_mult_omega_star:
  "x\<^sup>\<omega> * x\<^sup>\<omega>\<^sup>\<star> = x\<^sup>\<omega>"
  by (simp add: order.antisym star.circ_mult_increasing omega_sub_vector)

lemma omega_sum_unfold_1:
  "(x \<squnion> y)\<^sup>\<omega> = x\<^sup>\<omega> \<squnion> x\<^sup>\<star> * y * (x \<squnion> y)\<^sup>\<omega>"
  by (metis mult_right_dist_sup omega_unfold mult_assoc wagner)

lemma omega_sum_unfold_2:
  "(x \<squnion> y)\<^sup>\<omega> \<le> (x\<^sup>\<star> * y)\<^sup>\<omega> \<squnion> (x\<^sup>\<star> * y)\<^sup>\<star> * x\<^sup>\<omega>"
  using omega_induct_equal omega_sum_unfold_1 by auto

lemma omega_sum_unfold_3:
  "(x\<^sup>\<star> * y)\<^sup>\<star> * x\<^sup>\<omega> \<le> (x \<squnion> y)\<^sup>\<omega>"
  using star_left_induct_equal omega_sum_unfold_1 by auto

lemma omega_decompose:
  "(x \<squnion> y)\<^sup>\<omega> = (x\<^sup>\<star> * y)\<^sup>\<omega> \<squnion> (x\<^sup>\<star> * y)\<^sup>\<star> * x\<^sup>\<omega>"
  by (metis sup.absorb1 sup_same_context omega_sub_dist_2 omega_sum_unfold_2 omega_sum_unfold_3)

lemma omega_loop_fixpoint:
  "y * (y\<^sup>\<omega> \<squnion> y\<^sup>\<star> * z) \<squnion> z = y\<^sup>\<omega> \<squnion> y\<^sup>\<star> * z"
  apply (rule order.antisym)
  apply (smt (verit, ccfv_threshold) eq_refl mult_isotone mult_left_sub_dist_sup omega_induct omega_unfold star.circ_loop_fixpoint sup_assoc sup_commute sup_right_isotone)
  by (smt (z3) mult_left_sub_dist_sup omega_unfold star.circ_loop_fixpoint sup.left_commute sup_commute sup_right_isotone)

lemma omega_loop_greatest_fixpoint:
  "y * x \<squnion> z = x \<Longrightarrow> x \<le> y\<^sup>\<omega> \<squnion> y\<^sup>\<star> * z"
  by (simp add: sup_commute omega_induct_equal)

lemma omega_square:
  "x\<^sup>\<omega> = (x * x)\<^sup>\<omega>"
  using order.antisym omega_unfold order_refl mult_assoc omega_induct_mult omega_simulation_2 by auto

lemma mult_bot_omega:
  "(x * bot)\<^sup>\<omega> = x * bot"
  by (metis mult_left_zero omega_slide)

lemma mult_bot_add_omega:
  "(x \<squnion> y * bot)\<^sup>\<omega> = x\<^sup>\<omega> \<squnion> x\<^sup>\<star> * y * bot"
  by (metis mult_left_zero sup_commute mult_assoc mult_bot_omega omega_decompose omega_loop_fixpoint)

lemma omega_mult_star:
  "x\<^sup>\<omega> * x\<^sup>\<star> = x\<^sup>\<omega>"
  by (meson antisym_conv star.circ_back_loop_prefixpoint sup.boundedE omega_sub_vector)

lemma omega_loop_is_greatest_fixpoint:
  "is_greatest_fixpoint (\<lambda>x . y * x \<squnion> z) (y\<^sup>\<omega> \<squnion> y\<^sup>\<star> * z)"
  by (simp add: is_greatest_fixpoint_def omega_loop_fixpoint omega_loop_greatest_fixpoint)

lemma omega_loop_nu:
  "\<nu> (\<lambda>x . y * x \<squnion> z) = y\<^sup>\<omega> \<squnion> y\<^sup>\<star> * z"
  by (metis greatest_fixpoint_same omega_loop_is_greatest_fixpoint)

lemma omega_loop_bot_is_greatest_fixpoint:
  "is_greatest_fixpoint (\<lambda>x . y * x) (y\<^sup>\<omega>)"
  using is_greatest_fixpoint_def omega_unfold omega_induct_mult by auto

lemma omega_loop_bot_nu:
  "\<nu> (\<lambda>x . y * x) = y\<^sup>\<omega>"
  by (metis greatest_fixpoint_same omega_loop_bot_is_greatest_fixpoint)

lemma affine_has_greatest_fixpoint:
  "has_greatest_fixpoint (\<lambda>x . y * x \<squnion> z)"
  using has_greatest_fixpoint_def omega_loop_is_greatest_fixpoint by blast

lemma omega_separate_unfold:
  "(x\<^sup>\<star> * y)\<^sup>\<omega> = y\<^sup>\<omega> \<squnion> y\<^sup>\<star> * x * (x\<^sup>\<star> * y)\<^sup>\<omega>"
  by (metis star.circ_loop_fixpoint sup_commute mult_assoc omega_slide omega_sum_unfold_1)

lemma omega_bot_left_slide:
  "(x * y)\<^sup>\<star> * ((x * y)\<^sup>\<omega> * bot \<squnion> 1) * x \<le> x * (y * x)\<^sup>\<star> * ((y * x)\<^sup>\<omega> * bot \<squnion> 1)"
proof -
  have "x \<squnion> x * (y * x) * (y * x)\<^sup>\<star> * ((y * x)\<^sup>\<omega> * bot \<squnion> 1) \<le> x * (y * x)\<^sup>\<star> * ((y * x)\<^sup>\<omega> * bot \<squnion> 1)"
    by (metis sup_commute mult_assoc mult_right_isotone star.circ_back_loop_prefixpoint star.mult_zero_sup_circ star.mult_zero_circ le_supE le_supI order.refl star.circ_increasing star.circ_mult_upper_bound)
  hence "((x * y)\<^sup>\<omega> * bot \<squnion> 1) * x \<squnion> x * y * (x * (y * x)\<^sup>\<star> * ((y * x)\<^sup>\<omega> * bot \<squnion> 1)) \<le> x * (y * x)\<^sup>\<star> * ((y * x)\<^sup>\<omega> * bot \<squnion> 1)"
    by (smt (z3) sup.absorb_iff2 sup_assoc mult_assoc mult_left_one mult_left_sub_dist_sup_left mult_left_zero mult_right_dist_sup omega_slide star_mult_omega)
  thus ?thesis
    by (simp add: star_left_induct mult_assoc)
qed

lemma omega_bot_add_1:
  "(x \<squnion> y)\<^sup>\<star> * ((x \<squnion> y)\<^sup>\<omega> * bot \<squnion> 1) = x\<^sup>\<star> * (x\<^sup>\<omega> * bot \<squnion> 1) * (y * x\<^sup>\<star> * (x\<^sup>\<omega> * bot \<squnion> 1))\<^sup>\<star> * ((y * x\<^sup>\<star> * (x\<^sup>\<omega> * bot \<squnion> 1))\<^sup>\<omega> * bot \<squnion> 1)"
proof (rule order.antisym)
  have 1: "(x \<squnion> y) * x\<^sup>\<star> * (x\<^sup>\<omega> * bot \<squnion> 1) * (y * x\<^sup>\<star> * (x\<^sup>\<omega> * bot \<squnion> 1))\<^sup>\<star> * ((y * x\<^sup>\<star> * (x\<^sup>\<omega> * bot \<squnion> 1))\<^sup>\<omega> * bot \<squnion> 1) \<le> x\<^sup>\<star> * (x\<^sup>\<omega> * bot \<squnion> 1) * (y * x\<^sup>\<star> * (x\<^sup>\<omega> * bot \<squnion> 1))\<^sup>\<star> * ((y * x\<^sup>\<star> * (x\<^sup>\<omega> * bot \<squnion> 1))\<^sup>\<omega> * bot \<squnion> 1)"
    by (smt (z3) eq_refl star.circ_mult_upper_bound star.circ_sub_dist_1 star.mult_zero_circ star.mult_zero_sup_circ star_sup_1 sup_assoc sup_commute mult_assoc)
  have 2: "1 \<le> x\<^sup>\<star> * (x\<^sup>\<omega> * bot \<squnion> 1) * (y * x\<^sup>\<star> * (x\<^sup>\<omega> * bot \<squnion> 1))\<^sup>\<star> * ((y * x\<^sup>\<star> * (x\<^sup>\<omega> * bot \<squnion> 1))\<^sup>\<omega> * bot \<squnion> 1)"
    using reflexive_mult_closed star.circ_reflexive sup_ge2 by auto
  have "(y * x\<^sup>\<star>)\<^sup>\<omega> * bot \<le> (y * x\<^sup>\<star> * (x\<^sup>\<omega> * bot \<squnion> 1))\<^sup>\<omega> * bot"
    by (metis mult_1_right mult_left_isotone mult_left_sub_dist_sup_right omega_isotone)
  also have 3: "... \<le> (x\<^sup>\<omega> * bot \<squnion> 1) * (y * x\<^sup>\<star> * (x\<^sup>\<omega> * bot \<squnion> 1))\<^sup>\<star> * ((y * x\<^sup>\<star> * (x\<^sup>\<omega> * bot \<squnion> 1))\<^sup>\<omega> * bot \<squnion> 1)"
    by (metis mult_isotone mult_left_one star.circ_reflexive sup_commute sup_ge2)
  finally have 4: "(x\<^sup>\<star> * y)\<^sup>\<omega> * bot \<le> x\<^sup>\<star> * (x\<^sup>\<omega> * bot \<squnion> 1) * (y * x\<^sup>\<star> * (x\<^sup>\<omega> * bot \<squnion> 1))\<^sup>\<star> * ((y * x\<^sup>\<star> * (x\<^sup>\<omega> * bot \<squnion> 1))\<^sup>\<omega> * bot \<squnion> 1)"
    by (smt mult_assoc mult_right_isotone omega_slide)
  have "y * (x\<^sup>\<star> * y)\<^sup>\<star> * x\<^sup>\<omega> * bot \<le> y * (x\<^sup>\<star> * (x\<^sup>\<omega> * bot \<squnion> y))\<^sup>\<star> * x\<^sup>\<star> * x\<^sup>\<omega> * bot * (y * x\<^sup>\<star> * (x\<^sup>\<omega> * bot \<squnion> 1))\<^sup>\<omega> * bot"
    using mult_isotone mult_left_sub_dist_sup_left mult_left_zero order.refl star_isotone sup_commute mult_assoc star_mult_omega by auto
  also have "... \<le> y * (x\<^sup>\<star> * (x\<^sup>\<omega> * bot \<squnion> y))\<^sup>\<star> * (x\<^sup>\<star> * (x\<^sup>\<omega> * bot \<squnion> 1) * y)\<^sup>\<omega> * bot"
    by (smt mult_assoc mult_left_isotone mult_left_sub_dist_sup_left omega_slide)
  also have "... = y * (x\<^sup>\<star> * (x\<^sup>\<omega> * bot \<squnion> 1) * y)\<^sup>\<omega> * bot"
    using mult_left_one mult_left_zero mult_right_dist_sup mult_assoc star_mult_omega by auto
  finally have "x\<^sup>\<star> * y * (x\<^sup>\<star> * y)\<^sup>\<star> * x\<^sup>\<omega> * bot \<le> x\<^sup>\<star> * (x\<^sup>\<omega> * bot \<squnion> 1) * (y * x\<^sup>\<star> * (x\<^sup>\<omega> * bot \<squnion> 1))\<^sup>\<star> * ((y * x\<^sup>\<star> * (x\<^sup>\<omega> * bot \<squnion> 1))\<^sup>\<omega> * bot \<squnion> 1)"
    using 3 by (smt mult_assoc mult_right_isotone omega_slide order_trans)
  hence "(x\<^sup>\<star> * y)\<^sup>\<star> * x\<^sup>\<omega> * bot \<le> x\<^sup>\<star> * (x\<^sup>\<omega> * bot \<squnion> 1) * (y * x\<^sup>\<star> * (x\<^sup>\<omega> * bot \<squnion> 1))\<^sup>\<star> * ((y * x\<^sup>\<star> * (x\<^sup>\<omega> * bot \<squnion> 1))\<^sup>\<omega> * bot \<squnion> 1)"
    by (smt (verit, ccfv_threshold) sup_assoc sup_commute le_iff_sup mult_assoc mult_isotone mult_left_one mult_1_right mult_right_sub_dist_sup_left order_trans star.circ_loop_fixpoint star.circ_reflexive star.mult_zero_circ)
  hence "(x \<squnion> y)\<^sup>\<omega> * bot \<le> x\<^sup>\<star> * (x\<^sup>\<omega> * bot \<squnion> 1) * (y * x\<^sup>\<star> * (x\<^sup>\<omega> * bot \<squnion> 1))\<^sup>\<star> * ((y * x\<^sup>\<star> * (x\<^sup>\<omega> * bot \<squnion> 1))\<^sup>\<omega> * bot \<squnion> 1)"
    using 4 by (smt (z3) mult_right_dist_sup sup.orderE sup_assoc sup_right_divisibility omega_decompose)
  thus "(x \<squnion> y)\<^sup>\<star> * ((x \<squnion> y)\<^sup>\<omega> * bot \<squnion> 1) \<le> x\<^sup>\<star> * (x\<^sup>\<omega> * bot \<squnion> 1) * (y * x\<^sup>\<star> * (x\<^sup>\<omega> * bot \<squnion> 1))\<^sup>\<star> * ((y * x\<^sup>\<star> * (x\<^sup>\<omega> * bot \<squnion> 1))\<^sup>\<omega> * bot \<squnion> 1)"
    using 1 2 star_left_induct mult_assoc by force
next
  have 5: "x\<^sup>\<omega> * bot \<le> (x \<squnion> y)\<^sup>\<star> * ((x \<squnion> y)\<^sup>\<omega> * bot \<squnion> 1)"
    by (metis bot_least le_supI1 le_supI2 mult_isotone star.circ_loop_fixpoint sup.cobounded1 omega_isotone)
  have 6: "(y * x\<^sup>\<star>)\<^sup>\<omega> * bot \<le> (x \<squnion> y)\<^sup>\<star> * ((x \<squnion> y)\<^sup>\<omega> * bot \<squnion> 1)"
    by (metis sup_commute mult_left_isotone omega_sub_dist_1 mult_assoc mult_left_sub_dist_sup_left order_trans star_mult_omega)
  have 7: "(y * x\<^sup>\<star>)\<^sup>\<star> \<le> (x \<squnion> y)\<^sup>\<star>"
    by (metis mult_left_one mult_right_sub_dist_sup_left star.circ_sup_1 star.circ_plus_one)
  hence "(y * x\<^sup>\<star>)\<^sup>\<star> * x\<^sup>\<omega> * bot \<le> (x \<squnion> y)\<^sup>\<star> * ((x \<squnion> y)\<^sup>\<omega> * bot \<squnion> 1)"
    by (smt sup_assoc le_iff_sup mult_assoc mult_isotone mult_right_dist_sup omega_sub_dist)
  hence "(x\<^sup>\<omega> * bot \<squnion> y * x\<^sup>\<star>)\<^sup>\<omega> * bot \<le> (x \<squnion> y)\<^sup>\<star> * ((x \<squnion> y)\<^sup>\<omega> * bot \<squnion> 1)"
    using 6 by (smt sup_commute sup.bounded_iff mult_assoc mult_right_dist_sup mult_bot_add_omega omega_unfold omega_bot)
  hence "(y * x\<^sup>\<star> * (x\<^sup>\<omega> * bot \<squnion> 1))\<^sup>\<omega> * bot \<le> y * x\<^sup>\<star> * (x \<squnion> y)\<^sup>\<star> * ((x \<squnion> y)\<^sup>\<omega> * bot \<squnion> 1)"
    by (smt mult_assoc mult_left_one mult_left_zero mult_right_dist_sup mult_right_isotone omega_slide)
  also have "... \<le> (x \<squnion> y)\<^sup>\<star> * ((x \<squnion> y)\<^sup>\<omega> * bot \<squnion> 1)"
    using 7 by (metis mult_left_isotone order_refl star.circ_mult_upper_bound star_left_induct_mult_iff)
  finally have "(y * x\<^sup>\<star> * (x\<^sup>\<omega> * bot \<squnion> 1))\<^sup>\<star> * ((y * x\<^sup>\<star> * (x\<^sup>\<omega> * bot \<squnion> 1))\<^sup>\<omega> * bot \<squnion> 1) \<le> (x \<squnion> y)\<^sup>\<star> * ((x \<squnion> y)\<^sup>\<omega> * bot \<squnion> 1)"
    using 5 by (smt (z3) le_supE star.circ_mult_upper_bound star.circ_sub_dist_1 star.mult_zero_circ star.mult_zero_sup_circ star_involutive star_isotone sup_commute)
  hence "(x\<^sup>\<omega> * bot \<squnion> 1) * (y * x\<^sup>\<star> * (x\<^sup>\<omega> * bot \<squnion> 1))\<^sup>\<star> * ((y * x\<^sup>\<star> * (x\<^sup>\<omega> * bot \<squnion> 1))\<^sup>\<omega> * bot \<squnion> 1) \<le> (x \<squnion> y)\<^sup>\<star> * ((x \<squnion> y)\<^sup>\<omega> * bot \<squnion> 1)"
    using 5 by (metis sup_commute mult_assoc star.circ_isotone star.circ_mult_upper_bound star.mult_zero_sup_circ star.mult_zero_circ star_involutive)
  thus "x\<^sup>\<star> * (x\<^sup>\<omega> * bot \<squnion> 1) * (y * x\<^sup>\<star> * (x\<^sup>\<omega> * bot \<squnion> 1))\<^sup>\<star> * ((y * x\<^sup>\<star> * (x\<^sup>\<omega> * bot \<squnion> 1))\<^sup>\<omega> * bot \<squnion> 1) \<le> (x \<squnion> y)\<^sup>\<star> * ((x \<squnion> y)\<^sup>\<omega> * bot \<squnion> 1)"
    by (smt sup_assoc sup_commute mult_assoc star.circ_mult_upper_bound star.circ_sub_dist star.mult_zero_sup_circ star.mult_zero_circ)
qed

lemma star_omega_greatest:
  "x\<^sup>\<star>\<^sup>\<omega> = 1\<^sup>\<omega>"
  by (metis sup_commute le_iff_sup omega_one_greatest omega_sub_dist star.circ_plus_one)

lemma omega_vector_greatest:
  "x\<^sup>\<omega> * 1\<^sup>\<omega> = x\<^sup>\<omega>"
  by (metis order.antisym mult_isotone omega_mult_omega_star omega_one_greatest omega_sub_vector)

lemma mult_greatest_omega:
  "(x * 1\<^sup>\<omega>)\<^sup>\<omega> \<le> x * 1\<^sup>\<omega>"
  by (metis mult_right_isotone omega_slide omega_sub_vector)

lemma omega_mult_star_2:
  "x\<^sup>\<omega> * y\<^sup>\<star> = x\<^sup>\<omega>"
  by (meson order.antisym le_supE star.circ_back_loop_prefixpoint omega_sub_vector)

lemma omega_import:
  assumes "p \<le> p * p"
      and "p * x \<le> x * p"
    shows "p * x\<^sup>\<omega> = p * (p * x)\<^sup>\<omega>"
proof -
  have "p * x\<^sup>\<omega> \<le> p * (p * x) * x\<^sup>\<omega>"
    by (metis assms(1) mult_assoc mult_left_isotone omega_unfold)
  also have "... \<le> p * x * p * x\<^sup>\<omega>"
    by (metis assms(2) mult_assoc mult_left_isotone mult_right_isotone)
  finally have "p * x\<^sup>\<omega> \<le> (p * x)\<^sup>\<omega>"
    by (simp add: mult_assoc omega_induct_mult)
  hence "p * x\<^sup>\<omega> \<le> p * (p * x)\<^sup>\<omega>"
    by (metis assms(1) mult_assoc mult_left_isotone mult_right_isotone order_trans)
  thus "p * x\<^sup>\<omega> = p * (p * x)\<^sup>\<omega>"
    by (metis assms(2) sup_left_divisibility order.antisym mult_right_isotone omega_induct_mult omega_slide omega_sub_dist)
qed

proposition omega_circ_simulate_right_plus: "z * x \<le> y * (y\<^sup>\<omega> * bot \<squnion> y\<^sup>\<star>) * z \<squnion> w \<longrightarrow> z * (x\<^sup>\<omega> * bot \<squnion> x\<^sup>\<star>) \<le> (y\<^sup>\<omega> * bot \<squnion> y\<^sup>\<star>) * (z \<squnion> w * (x\<^sup>\<omega> * bot \<squnion> x\<^sup>\<star>))" nitpick [expect=genuine,card=4] oops
proposition omega_circ_simulate_left_plus: "x * z \<le> z * (y\<^sup>\<omega> * bot \<squnion> y\<^sup>\<star>) \<squnion> w \<longrightarrow> (x\<^sup>\<omega> * bot \<squnion> x\<^sup>\<star>) * z \<le> (z \<squnion> (x\<^sup>\<omega> * bot \<squnion> x\<^sup>\<star>) * w) * (y\<^sup>\<omega> * bot \<squnion> y\<^sup>\<star>)" nitpick [expect=genuine,card=5] oops

end

text \<open>Theorem 50.2\<close>

sublocale left_omega_algebra < comb0: left_conway_semiring where circ = "(\<lambda>x . x\<^sup>\<star> * (x\<^sup>\<omega> * bot \<squnion> 1))"
  apply unfold_locales
  apply (smt sup_assoc sup_commute le_iff_sup mult_assoc mult_left_sub_dist_sup_left omega_unfold star.circ_loop_fixpoint star_mult_omega)
  using omega_bot_left_slide mult_assoc apply fastforce
  using omega_bot_add_1 mult_assoc by simp

class left_zero_omega_algebra = left_zero_kleene_algebra + left_omega_algebra
begin

lemma star_omega_absorb:
  "y\<^sup>\<star> * (y\<^sup>\<star> * x)\<^sup>\<star> * y\<^sup>\<omega> = (y\<^sup>\<star> * x)\<^sup>\<star> * y\<^sup>\<omega>"
proof -
  have "y\<^sup>\<star> * (y\<^sup>\<star> * x)\<^sup>\<star> * y\<^sup>\<omega> = y\<^sup>\<star> * y\<^sup>\<star> * x * (y\<^sup>\<star> * x)\<^sup>\<star> * y\<^sup>\<omega> \<squnion> y\<^sup>\<star> * y\<^sup>\<omega>"
    by (metis sup_commute mult_assoc mult_right_dist_sup star.circ_back_loop_fixpoint star.circ_plus_same)
  thus ?thesis
    by (metis mult_assoc star.circ_loop_fixpoint star.circ_transitive_equal star_mult_omega)
qed

lemma omega_circ_simulate_right_plus:
  assumes "z * x \<le> y * (y\<^sup>\<omega> * bot \<squnion> y\<^sup>\<star>) * z \<squnion> w"
    shows "z * (x\<^sup>\<omega> * bot \<squnion> x\<^sup>\<star>) \<le> (y\<^sup>\<omega> * bot \<squnion> y\<^sup>\<star>) * (z \<squnion> w * (x\<^sup>\<omega> * bot \<squnion> x\<^sup>\<star>))"
proof -
  have 1: "z * x \<le> y\<^sup>\<omega> * bot \<squnion> y * y\<^sup>\<star> * z \<squnion> w"
    by (metis assms mult_assoc mult_left_dist_sup mult_left_zero mult_right_dist_sup omega_unfold)
  hence "(y\<^sup>\<omega> * bot \<squnion> y\<^sup>\<star> * z \<squnion> y\<^sup>\<star> * w * x\<^sup>\<omega> * bot \<squnion> y\<^sup>\<star> * w * x\<^sup>\<star>) * x \<le> y\<^sup>\<omega> * bot \<squnion> y\<^sup>\<star> * (y\<^sup>\<omega> * bot \<squnion> y * y\<^sup>\<star> * z \<squnion> w) \<squnion> y\<^sup>\<star> * w * x\<^sup>\<omega> * bot \<squnion> y\<^sup>\<star> * w * x\<^sup>\<star>"
    by (smt sup_assoc sup_ge1 sup_ge2 le_iff_sup mult_assoc mult_left_dist_sup mult_left_zero mult_right_dist_sup star.circ_back_loop_fixpoint)
  also have "... = y\<^sup>\<omega> * bot \<squnion> y\<^sup>\<star> * y * y\<^sup>\<star> * z \<squnion> y\<^sup>\<star> * w * x\<^sup>\<omega> * bot \<squnion> y\<^sup>\<star> * w * x\<^sup>\<star>"
    by (smt sup_assoc sup_ge2 le_iff_sup mult_assoc mult_left_dist_sup star.circ_back_loop_fixpoint star_mult_omega)
  also have "... \<le> y\<^sup>\<omega> * bot \<squnion> y\<^sup>\<star> * z \<squnion> y\<^sup>\<star> * w * x\<^sup>\<omega> * bot \<squnion> y\<^sup>\<star> * w * x\<^sup>\<star>"
    by (smt sup_commute sup_left_isotone mult_left_isotone star.circ_increasing star.circ_plus_same star.circ_transitive_equal)
  finally have "z \<squnion> (y\<^sup>\<omega> * bot \<squnion> y\<^sup>\<star> * z \<squnion> y\<^sup>\<star> * w * x\<^sup>\<omega> * bot \<squnion> y\<^sup>\<star> * w * x\<^sup>\<star>) * x \<le> y\<^sup>\<omega> * bot \<squnion> y\<^sup>\<star> * z \<squnion> y\<^sup>\<star> * w * x\<^sup>\<omega> * bot \<squnion> y\<^sup>\<star> * w * x\<^sup>\<star>"
    by (metis (no_types, lifting) le_supE le_supI star.circ_loop_fixpoint sup.cobounded1)
  hence 2: "z * x\<^sup>\<star> \<le> y\<^sup>\<omega> * bot \<squnion> y\<^sup>\<star> * z \<squnion> y\<^sup>\<star> * w * x\<^sup>\<omega> * bot \<squnion> y\<^sup>\<star> * w * x\<^sup>\<star>"
    by (simp add: star_right_induct)
  have "z * x\<^sup>\<omega> * bot \<le> (y\<^sup>\<omega> * bot \<squnion> y * y\<^sup>\<star> * z \<squnion> w) * x\<^sup>\<omega> * bot"
    using 1 by (smt sup_left_divisibility mult_assoc mult_right_sub_dist_sup_left omega_unfold)
  hence "z * x\<^sup>\<omega> * bot \<le> y\<^sup>\<omega> \<squnion> y\<^sup>\<star> * (y\<^sup>\<omega> * bot \<squnion> w * x\<^sup>\<omega> * bot)"
    by (smt sup_assoc sup_commute left_plus_omega mult_assoc mult_left_zero mult_right_dist_sup omega_induct star.left_plus_circ)
  thus "z * (x\<^sup>\<omega> * bot \<squnion> x\<^sup>\<star>) \<le> (y\<^sup>\<omega> * bot \<squnion> y\<^sup>\<star>) * (z \<squnion> w * (x\<^sup>\<omega> * bot \<squnion> x\<^sup>\<star>))"
    using 2 by (smt sup_assoc sup_commute le_iff_sup mult_assoc mult_left_dist_sup mult_left_zero mult_right_dist_sup omega_unfold omega_bot star_mult_omega zero_right_mult_decreasing)
qed

lemma omega_circ_simulate_left_plus:
  assumes "x * z \<le> z * (y\<^sup>\<omega> * bot \<squnion> y\<^sup>\<star>) \<squnion> w"
    shows "(x\<^sup>\<omega> * bot \<squnion> x\<^sup>\<star>) * z \<le> (z \<squnion> (x\<^sup>\<omega> * bot \<squnion> x\<^sup>\<star>) * w) * (y\<^sup>\<omega> * bot \<squnion> y\<^sup>\<star>)"
proof -
  have "x * (z * y\<^sup>\<omega> * bot \<squnion> z * y\<^sup>\<star> \<squnion> x\<^sup>\<omega> * bot \<squnion> x\<^sup>\<star> * w * y\<^sup>\<omega> * bot \<squnion> x\<^sup>\<star> * w * y\<^sup>\<star>) = x * z * y\<^sup>\<omega> * bot \<squnion> x * z * y\<^sup>\<star> \<squnion> x\<^sup>\<omega> * bot \<squnion> x * x\<^sup>\<star> * w * y\<^sup>\<omega> * bot \<squnion> x * x\<^sup>\<star> * w * y\<^sup>\<star>"
    by (smt mult_assoc mult_left_dist_sup omega_unfold)
  also have "... \<le> x * z * y\<^sup>\<omega> * bot \<squnion> x * z * y\<^sup>\<star> \<squnion> x\<^sup>\<omega> * bot \<squnion> x\<^sup>\<star> * w * y\<^sup>\<omega> * bot \<squnion> x\<^sup>\<star> * w * y\<^sup>\<star>"
    by (metis sup_mono sup_right_isotone mult_left_isotone star.left_plus_below_circ)
  also have "... \<le> (z * y\<^sup>\<omega> * bot \<squnion> z * y\<^sup>\<star> \<squnion> w) * y\<^sup>\<omega> * bot \<squnion> (z * y\<^sup>\<omega> * bot \<squnion> z * y\<^sup>\<star> \<squnion> w) * y\<^sup>\<star> \<squnion> x\<^sup>\<omega> * bot \<squnion> x\<^sup>\<star> * w * y\<^sup>\<omega> * bot \<squnion> x\<^sup>\<star> * w * y\<^sup>\<star>"
    by (metis assms sup_left_isotone mult_assoc mult_left_dist_sup mult_left_isotone)
  also have "... = z * y\<^sup>\<omega> * bot \<squnion> z * y\<^sup>\<star> * y\<^sup>\<omega> * bot \<squnion> w * y\<^sup>\<omega> * bot \<squnion> z * y\<^sup>\<omega> * bot \<squnion> z * y\<^sup>\<star> * y\<^sup>\<star> \<squnion> w * y\<^sup>\<star> \<squnion> x\<^sup>\<omega> * bot \<squnion> x\<^sup>\<star> * w * y\<^sup>\<omega> * bot \<squnion> x\<^sup>\<star> * w * y\<^sup>\<star>"
    by (smt sup_assoc mult_assoc mult_left_zero mult_right_dist_sup)
  also have "... = z * y\<^sup>\<omega> * bot \<squnion> z * y\<^sup>\<star> \<squnion> x\<^sup>\<omega> * bot \<squnion> x\<^sup>\<star> * w * y\<^sup>\<omega> * bot \<squnion> x\<^sup>\<star> * w * y\<^sup>\<star>"
    by (smt (verit, ccfv_threshold) sup_assoc sup_commute sup_idem mult_assoc mult_right_dist_sup star.circ_loop_fixpoint star.circ_transitive_equal star_mult_omega)
  finally have "x\<^sup>\<star> * z \<le> z * y\<^sup>\<omega> * bot \<squnion> z * y\<^sup>\<star> \<squnion> x\<^sup>\<omega> * bot \<squnion> x\<^sup>\<star> * w * y\<^sup>\<omega> * bot \<squnion> x\<^sup>\<star> * w * y\<^sup>\<star>"
    by (smt (z3) le_supE sup_least sup_ge1 star.circ_back_loop_fixpoint star_left_induct)
  hence "(x\<^sup>\<omega> * bot \<squnion> x\<^sup>\<star>) * z \<le> z * y\<^sup>\<omega> * bot \<squnion> z * y\<^sup>\<star> \<squnion> x\<^sup>\<omega> * bot \<squnion> x\<^sup>\<star> * w * y\<^sup>\<omega> * bot \<squnion> x\<^sup>\<star> * w * y\<^sup>\<star>"
    by (smt (z3) sup.left_commute sup_commute sup_least sup_ge1 mult_assoc mult_left_zero mult_right_dist_sup)
  thus "(x\<^sup>\<omega> * bot \<squnion> x\<^sup>\<star>) * z \<le> (z \<squnion> (x\<^sup>\<omega> * bot \<squnion> x\<^sup>\<star>) * w) * (y\<^sup>\<omega> * bot \<squnion> y\<^sup>\<star>)"
    by (smt sup_assoc mult_assoc mult_left_dist_sup mult_left_zero mult_right_dist_sup)
qed

lemma omega_translate:
  "x\<^sup>\<star> * (x\<^sup>\<omega> * bot \<squnion> 1) = x\<^sup>\<omega> * bot \<squnion> x\<^sup>\<star>"
  by (metis mult_assoc mult_left_dist_sup mult_1_right star_mult_omega)

lemma omega_circ_simulate_right:
  assumes "z * x \<le> y * z \<squnion> w"
    shows "z * (x\<^sup>\<omega> * bot \<squnion> x\<^sup>\<star>) \<le> (y\<^sup>\<omega> * bot \<squnion> y\<^sup>\<star>) * (z \<squnion> w * (x\<^sup>\<omega> * bot \<squnion> x\<^sup>\<star>))"
proof -
  have "... \<le> y * (y\<^sup>\<omega> * bot \<squnion> y\<^sup>\<star>) * z \<squnion> w"
    using comb0.circ_mult_increasing mult_isotone sup_left_isotone omega_translate by auto
  thus "z * (x\<^sup>\<omega> * bot \<squnion> x\<^sup>\<star>) \<le> (y\<^sup>\<omega> * bot \<squnion> y\<^sup>\<star>) * (z \<squnion> w * (x\<^sup>\<omega> * bot \<squnion> x\<^sup>\<star>))"
    using assms order_trans omega_circ_simulate_right_plus by blast
qed

end

sublocale left_zero_omega_algebra < comb1: left_conway_semiring_1 where circ = "(\<lambda>x . x\<^sup>\<star> * (x\<^sup>\<omega> * bot \<squnion> 1))"
  apply unfold_locales
  by (smt order.eq_iff mult_assoc mult_left_dist_sup mult_left_zero mult_right_dist_sup mult_1_right omega_slide star_slide)

sublocale left_zero_omega_algebra < comb0: itering where circ = "(\<lambda>x . x\<^sup>\<star> * (x\<^sup>\<omega> * bot \<squnion> 1))"
  apply unfold_locales
  using comb1.circ_sup_9 apply blast
  using comb1.circ_mult_1 apply blast
  apply (metis omega_circ_simulate_right_plus omega_translate)
  using omega_circ_simulate_left_plus omega_translate by auto

text \<open>Theorem 2.2\<close>

sublocale left_zero_omega_algebra < comb2: itering where circ = "(\<lambda>x . x\<^sup>\<omega> * bot \<squnion> x\<^sup>\<star>)"
  apply unfold_locales
  using comb1.circ_sup_9 omega_translate apply force
  apply (metis comb1.circ_mult_1 omega_translate)
  using omega_circ_simulate_right_plus apply blast
  by (simp add: omega_circ_simulate_left_plus)

class omega_algebra = kleene_algebra + left_zero_omega_algebra

class left_omega_conway_semiring = left_omega_algebra + left_conway_semiring
begin

subclass left_kleene_conway_semiring ..

lemma circ_below_omega_star:
  "x\<^sup>\<circ> \<le> x\<^sup>\<omega> \<squnion> x\<^sup>\<star>"
  by (metis circ_left_unfold mult_1_right omega_induct order_refl)

lemma omega_mult_circ:
  "x\<^sup>\<omega> * x\<^sup>\<circ> = x\<^sup>\<omega>"
  by (metis circ_star omega_mult_star_2)

lemma circ_mult_omega:
  "x\<^sup>\<circ> * x\<^sup>\<omega> = x\<^sup>\<omega>"
  by (metis order.antisym sup_right_divisibility circ_loop_fixpoint circ_plus_sub omega_simulation)

lemma circ_omega_greatest:
  "x\<^sup>\<circ>\<^sup>\<omega> = 1\<^sup>\<omega>"
  by (metis circ_star star_omega_greatest)

lemma omega_circ:
  "x\<^sup>\<omega>\<^sup>\<circ> = 1 \<squnion> x\<^sup>\<omega>"
  by (metis order.antisym circ_left_unfold mult_left_sub_dist_sup_left mult_1_right omega_sub_vector)

end

class bounded_left_omega_algebra = bounded_left_kleene_algebra + left_omega_algebra
begin

lemma omega_one:
  "1\<^sup>\<omega> = top"
  by (simp add: order.antisym omega_one_greatest)

lemma star_omega_top:
  "x\<^sup>\<star>\<^sup>\<omega> = top"
  by (simp add: star_omega_greatest omega_one)

lemma omega_vector:
  "x\<^sup>\<omega> * top = x\<^sup>\<omega>"
  by (simp add: order.antisym omega_sub_vector top_right_mult_increasing)

lemma mult_top_omega:
  "(x * top)\<^sup>\<omega> \<le> x * top"
  using mult_greatest_omega omega_one by auto

end

sublocale bounded_left_omega_algebra < comb0: bounded_left_conway_semiring where circ = "(\<lambda>x . x\<^sup>\<star> * (x\<^sup>\<omega> * bot \<squnion> 1))" ..

class bounded_left_zero_omega_algebra = bounded_left_zero_kleene_algebra + left_zero_omega_algebra
begin

subclass bounded_left_omega_algebra ..

end

sublocale bounded_left_zero_omega_algebra < comb0: bounded_itering where circ = "(\<lambda>x . x\<^sup>\<star> * (x\<^sup>\<omega> * bot \<squnion> 1))" ..

class bounded_omega_algebra = bounded_kleene_algebra + omega_algebra
begin

subclass bounded_left_zero_omega_algebra ..

end

class bounded_left_omega_conway_semiring = bounded_left_omega_algebra + left_omega_conway_semiring
begin

subclass left_kleene_conway_semiring ..

subclass bounded_left_conway_semiring ..

lemma circ_omega:
  "x\<^sup>\<circ>\<^sup>\<omega> = top"
  by (simp add: circ_omega_greatest omega_one)

end

class top_left_omega_algebra = bounded_left_omega_algebra +
  assumes top_left_bot: "top * x = top"
begin

lemma omega_translate_3:
  "x\<^sup>\<star> * (x\<^sup>\<omega> * bot \<squnion> 1) = x\<^sup>\<star> * (x\<^sup>\<omega> \<squnion> 1)"
  by (metis omega_one omega_vector_greatest top_left_bot mult_assoc)

end

text \<open>Theorem 50.2\<close>

sublocale top_left_omega_algebra < comb4: left_conway_semiring where circ = "(\<lambda>x . x\<^sup>\<star> * (x\<^sup>\<omega> \<squnion> 1))"
  apply unfold_locales
  using comb0.circ_left_unfold omega_translate_3 apply force
  using omega_bot_left_slide omega_translate_3 mult_assoc apply force
  using comb0.circ_sup_1 omega_translate_3 by auto

class top_left_bot_omega_algebra = bounded_left_zero_omega_algebra +
  assumes top_left_bot: "top * x = top"
begin

lemma omega_translate_2:
  "x\<^sup>\<omega> * bot \<squnion> x\<^sup>\<star> = x\<^sup>\<omega> \<squnion> x\<^sup>\<star>"
  by (metis mult_assoc omega_mult_star_2 star.circ_top top_left_bot)

end

text \<open>Theorem 2.3\<close>

sublocale top_left_bot_omega_algebra < comb3: itering where circ = "(\<lambda>x . x\<^sup>\<omega> \<squnion> x\<^sup>\<star>)"
  apply unfold_locales
  using comb2.circ_slide_1 comb2.circ_sup_1 omega_translate_2 apply force
  apply (metis comb2.circ_mult_1 omega_translate_2)
  using omega_circ_simulate_right_plus omega_translate_2 apply force
  using omega_circ_simulate_left_plus omega_translate_2 by auto

class Omega =
  fixes Omega :: "'a \<Rightarrow> 'a" ("_\<^sup>\<Omega>" [100] 100)

end


theory Transition_System
imports
  Residual
begin

section \<open>Nominal Transition Systems and Bisimulations\<close>

subsection \<open>Basic Lemmas\<close>

lemma symp_eqvt [eqvt]:
  assumes "symp R" shows "symp (p \<bullet> R)"
using assms unfolding symp_def by (subst permute_fun_def)+ (simp add: permute_pure)

subsection \<open>Nominal transition systems\<close>

locale nominal_ts =
  fixes satisfies :: "'state::fs \<Rightarrow> 'pred::fs \<Rightarrow> bool"                (infix "\<turnstile>" 70)
    and transition :: "'state \<Rightarrow> ('act::bn,'state) residual \<Rightarrow> bool"  (infix "\<rightarrow>" 70)
  assumes satisfies_eqvt [eqvt]: "P \<turnstile> \<phi> \<Longrightarrow> p \<bullet> P \<turnstile> p \<bullet> \<phi>"
      and transition_eqvt [eqvt]: "P \<rightarrow> \<alpha>Q \<Longrightarrow> p \<bullet> P \<rightarrow> p \<bullet> \<alpha>Q"
begin

  lemma transition_eqvt':
    assumes "P \<rightarrow> \<langle>\<alpha>,Q\<rangle>" shows "p \<bullet> P \<rightarrow> \<langle>p \<bullet> \<alpha>, p \<bullet> Q\<rangle>"
  using assms by (metis abs_residual_pair_eqvt transition_eqvt)

end

subsection \<open>Bisimulations\<close>

context nominal_ts
begin

  definition is_bisimulation :: "('state \<Rightarrow> 'state \<Rightarrow> bool) \<Rightarrow> bool" where
    "is_bisimulation R \<equiv>
      symp R \<and>
      (\<forall>P Q. R P Q \<longrightarrow> (\<forall>\<phi>. P \<turnstile> \<phi> \<longrightarrow> Q \<turnstile> \<phi>)) \<and>
      (\<forall>P Q. R P Q \<longrightarrow> (\<forall>\<alpha> P'. bn \<alpha> \<sharp>* Q \<longrightarrow> P \<rightarrow> \<langle>\<alpha>,P'\<rangle> \<longrightarrow> (\<exists>Q'. Q \<rightarrow> \<langle>\<alpha>,Q'\<rangle> \<and> R P' Q')))"

  definition bisimilar :: "'state \<Rightarrow> 'state \<Rightarrow> bool"  (infix "\<sim>\<cdot>" 100) where
    "P \<sim>\<cdot> Q \<equiv> \<exists>R. is_bisimulation R \<and> R P Q"

  text \<open>@{const bisimilar} is an equivariant equivalence relation.\<close>

  lemma is_bisimulation_eqvt (*[eqvt]*):
    assumes "is_bisimulation R" shows "is_bisimulation (p \<bullet> R)"
  using assms unfolding is_bisimulation_def
  proof (clarify)
    assume 1: "symp R"
    assume 2: "\<forall>P Q. R P Q \<longrightarrow> (\<forall>\<phi>. P \<turnstile> \<phi> \<longrightarrow> Q \<turnstile> \<phi>)"
    assume 3: "\<forall>P Q. R P Q \<longrightarrow> (\<forall>\<alpha> P'. bn \<alpha> \<sharp>* Q \<longrightarrow> P \<rightarrow> \<langle>\<alpha>,P'\<rangle> \<longrightarrow> (\<exists>Q'. Q \<rightarrow> \<langle>\<alpha>,Q'\<rangle> \<and> R P' Q'))"
    have "symp (p \<bullet> R)" (is ?S)
      using 1 by (simp add: symp_eqvt)
    moreover have "\<forall>P Q. (p \<bullet> R) P Q \<longrightarrow> (\<forall>\<phi>. P \<turnstile> \<phi> \<longrightarrow> Q \<turnstile> \<phi>)" (is ?T)
      proof (clarify)
        fix P Q \<phi>
        assume *: "(p \<bullet> R) P Q" and **: "P \<turnstile> \<phi>"
        from * have "R (-p \<bullet> P) (-p \<bullet> Q)"
          by (simp add: eqvt_lambda permute_bool_def unpermute_def)
        then show "Q \<turnstile> \<phi>"
          using 2 ** by (metis permute_minus_cancel(1) satisfies_eqvt)
      qed
    moreover have "\<forall>P Q. (p \<bullet> R) P Q \<longrightarrow> (\<forall>\<alpha> P'. bn \<alpha> \<sharp>* Q \<longrightarrow> P \<rightarrow> \<langle>\<alpha>,P'\<rangle> \<longrightarrow> (\<exists>Q'. Q \<rightarrow> \<langle>\<alpha>,Q'\<rangle> \<and> (p \<bullet> R) P' Q'))" (is ?U)
      proof (clarify)
        fix P Q \<alpha> P'
        assume *: "(p \<bullet> R) P Q" and **: "bn \<alpha> \<sharp>* Q" and ***: "P \<rightarrow> \<langle>\<alpha>,P'\<rangle>"
        from * have "R (-p \<bullet> P) (-p \<bullet> Q)"
          by (simp add: eqvt_lambda permute_bool_def unpermute_def)
        moreover have "bn (-p \<bullet> \<alpha>) \<sharp>* (-p \<bullet> Q)"
          using ** by (metis bn_eqvt fresh_star_permute_iff)
        moreover have "-p \<bullet> P \<rightarrow> \<langle>-p \<bullet> \<alpha>, -p \<bullet> P'\<rangle>"
          using *** by (metis transition_eqvt')
        ultimately obtain Q' where T: "-p \<bullet> Q \<rightarrow> \<langle>-p \<bullet> \<alpha>,Q'\<rangle>" and R: "R (-p \<bullet> P') Q'"
          using 3 by metis
        from T have "Q \<rightarrow> \<langle>\<alpha>, p \<bullet> Q'\<rangle>"
          by (metis permute_minus_cancel(1) transition_eqvt')
        moreover from R have "(p \<bullet> R) P' (p \<bullet> Q')"
          by (metis eqvt_apply eqvt_lambda permute_bool_def unpermute_def)
        ultimately show "\<exists>Q'. Q \<rightarrow> \<langle>\<alpha>,Q'\<rangle> \<and> (p \<bullet> R) P' Q'"
          by metis
      qed
    ultimately show "?S \<and> ?T \<and> ?U" by simp
  qed

  lemma bisimilar_eqvt (*[eqvt]*):
    assumes "P \<sim>\<cdot> Q" shows "(p \<bullet> P) \<sim>\<cdot> (p \<bullet> Q)"
  proof -
    from assms obtain R where *: "is_bisimulation R \<and> R P Q"
      unfolding bisimilar_def ..
    then have "is_bisimulation (p \<bullet> R)"
      by (simp add: is_bisimulation_eqvt)
    moreover from "*" have "(p \<bullet> R) (p \<bullet> P) (p \<bullet> Q)"
      by (metis eqvt_apply permute_boolI)
    ultimately show "(p \<bullet> P) \<sim>\<cdot> (p \<bullet> Q)"
      unfolding bisimilar_def by auto
  qed

  lemma bisimilar_reflp: "reflp bisimilar"
  proof (rule reflpI)
    fix x
    have "is_bisimulation (=)"
      unfolding is_bisimulation_def by (simp add: symp_def)
    then show "x \<sim>\<cdot> x"
      unfolding bisimilar_def by auto
  qed

  lemma bisimilar_symp: "symp bisimilar"
  proof (rule sympI)
    fix P Q
    assume "P \<sim>\<cdot> Q"
    then obtain R where *: "is_bisimulation R \<and> R P Q"
      unfolding bisimilar_def ..
    then have "R Q P"
      unfolding is_bisimulation_def by (simp add: symp_def)
    with "*" show "Q \<sim>\<cdot> P"
      unfolding bisimilar_def by auto
  qed

  lemma bisimilar_is_bisimulation: "is_bisimulation bisimilar"
  unfolding is_bisimulation_def proof
    show "symp (\<sim>\<cdot>)"
      by (fact bisimilar_symp)
  next
    show "(\<forall>P Q. P \<sim>\<cdot> Q \<longrightarrow> (\<forall>\<phi>. P \<turnstile> \<phi> \<longrightarrow> Q \<turnstile> \<phi>)) \<and>
      (\<forall>P Q. P \<sim>\<cdot> Q \<longrightarrow> (\<forall>\<alpha> P'. bn \<alpha> \<sharp>* Q \<longrightarrow> P \<rightarrow> \<langle>\<alpha>,P'\<rangle> \<longrightarrow> (\<exists>Q'. Q \<rightarrow> \<langle>\<alpha>,Q'\<rangle> \<and> P' \<sim>\<cdot> Q')))"
      by (auto simp add: is_bisimulation_def bisimilar_def) blast
  qed

  lemma bisimilar_transp: "transp bisimilar"
  proof (rule transpI)
    fix P Q R
    assume PQ: "P \<sim>\<cdot> Q" and QR: "Q \<sim>\<cdot> R"
    let ?bisim = "bisimilar OO bisimilar"
    have "symp ?bisim"
      proof (rule sympI)
        fix P R
        assume "?bisim P R"
        then obtain Q where "P \<sim>\<cdot> Q" and "Q \<sim>\<cdot> R"
          by blast
        then have "R \<sim>\<cdot> Q" and "Q \<sim>\<cdot> P"
          by (metis bisimilar_symp sympE)+
        then show "?bisim R P"
          by blast
      qed
    moreover have "\<forall>P Q. ?bisim P Q \<longrightarrow> (\<forall>\<phi>. P \<turnstile> \<phi> \<longrightarrow> Q \<turnstile> \<phi>)"
      using bisimilar_is_bisimulation is_bisimulation_def by auto
    moreover have "\<forall>P Q. ?bisim P Q \<longrightarrow>
           (\<forall>\<alpha> P'. bn \<alpha> \<sharp>* Q \<longrightarrow> P \<rightarrow> \<langle>\<alpha>,P'\<rangle> \<longrightarrow> (\<exists>Q'. Q \<rightarrow> \<langle>\<alpha>,Q'\<rangle> \<and> ?bisim P' Q'))"
      proof (clarify)
        fix P R Q \<alpha> P'
        assume PR: "P \<sim>\<cdot> R" and RQ: "R \<sim>\<cdot> Q" and fresh: "bn \<alpha> \<sharp>* Q" and trans: "P \<rightarrow> \<langle>\<alpha>,P'\<rangle>"
        \<comment> \<open>rename~@{term "\<langle>\<alpha>,P'\<rangle>"} to avoid~@{term R}, without touching~@{term Q}\<close>
        obtain p where 1: "(p \<bullet> bn \<alpha>) \<sharp>* R" and 2: "supp (\<langle>\<alpha>,P'\<rangle>, Q) \<sharp>* p"
          proof (rule at_set_avoiding2[of "bn \<alpha>" R "(\<langle>\<alpha>,P'\<rangle>, Q)", THEN exE])
            show "finite (bn \<alpha>)" by (fact bn_finite)
          next
            show "finite (supp R)" by (fact finite_supp)
          next
            show "finite (supp (\<langle>\<alpha>,P'\<rangle>, Q))" by (simp add: finite_supp supp_Pair)
          next
            show "bn \<alpha> \<sharp>* (\<langle>\<alpha>,P'\<rangle>, Q)" by (simp add: fresh fresh_star_Pair)
          qed metis
        from 2 have 3: "supp \<langle>\<alpha>,P'\<rangle> \<sharp>* p" and 4: "supp Q \<sharp>* p"
          by (simp add: fresh_star_Un supp_Pair)+
        from 3 have "\<langle>p \<bullet> \<alpha>, p \<bullet> P'\<rangle> = \<langle>\<alpha>,P'\<rangle>"
          using supp_perm_eq by fastforce
        then obtain pR' where 5: "R \<rightarrow> \<langle>p \<bullet> \<alpha>, pR'\<rangle>" and 6: "(p \<bullet> P') \<sim>\<cdot> pR'"
          using PR trans 1 by (metis (mono_tags, lifting) bisimilar_is_bisimulation bn_eqvt is_bisimulation_def)
        from fresh and 4 have "bn (p \<bullet> \<alpha>) \<sharp>* Q"
          by (metis bn_eqvt fresh_star_permute_iff supp_perm_eq)
        then obtain pQ' where 7: "Q \<rightarrow> \<langle>p \<bullet> \<alpha>, pQ'\<rangle>" and 8: "pR' \<sim>\<cdot> pQ'"
          using RQ 5 by (metis (full_types) bisimilar_is_bisimulation is_bisimulation_def)
        from 7 have "Q \<rightarrow> \<langle>\<alpha>, -p \<bullet> pQ'\<rangle>"
          using 4 by (metis permute_minus_cancel(2) supp_perm_eq transition_eqvt')
        moreover from 6 and 8 have "?bisim P' (-p \<bullet> pQ')"
          by (metis (no_types, hide_lams) bisimilar_eqvt permute_minus_cancel(2) relcompp.simps)
        ultimately show "\<exists>Q'. Q \<rightarrow> \<langle>\<alpha>,Q'\<rangle> \<and> ?bisim P' Q'"
          by metis
      qed
    ultimately have "is_bisimulation ?bisim"
      unfolding is_bisimulation_def by metis
    moreover have "?bisim P R"
      using PQ QR by blast
    ultimately show "P \<sim>\<cdot> R"
      unfolding bisimilar_def by meson
  qed

  lemma bisimilar_equivp: "equivp bisimilar"
  by (metis bisimilar_reflp bisimilar_symp bisimilar_transp equivp_reflp_symp_transp)

  lemma bisimilar_simulation_step:
    assumes "P \<sim>\<cdot> Q" and "bn \<alpha> \<sharp>* Q" and "P \<rightarrow> \<langle>\<alpha>,P'\<rangle>"
    obtains Q' where "Q \<rightarrow> \<langle>\<alpha>,Q'\<rangle>" and "P' \<sim>\<cdot> Q'"
  using assms by (metis (poly_guards_query) bisimilar_is_bisimulation is_bisimulation_def)

end

end


(*<*)
theory case_exprs imports Main begin
(*>*)

text\<open>
\subsection{Case Expressions}
\label{sec:case-expressions}\index{*case expressions}%
HOL also features \isa{case}-expressions for analyzing
elements of a datatype. For example,
@{term[display]"case xs of [] => [] | y#ys => y"}
evaluates to \<^term>\<open>[]\<close> if \<^term>\<open>xs\<close> is \<^term>\<open>[]\<close> and to \<^term>\<open>y\<close> if
\<^term>\<open>xs\<close> is \<^term>\<open>y#ys\<close>. (Since the result in both branches must be of
the same type, it follows that \<^term>\<open>y\<close> is of type \<^typ>\<open>'a list\<close> and hence
that \<^term>\<open>xs\<close> is of type \<^typ>\<open>'a list list\<close>.)

In general, case expressions are of the form
\[
\begin{array}{c}
\<open>case\<close>~e~\<open>of\<close>\ pattern@1~\<open>\<Rightarrow>\<close>~e@1\ \<open>|\<close>\ \dots\
 \<open>|\<close>~pattern@m~\<open>\<Rightarrow>\<close>~e@m
\end{array}
\]
Like in functional programming, patterns are expressions consisting of
datatype constructors (e.g. \<^term>\<open>[]\<close> and \<open>#\<close>)
and variables, including the wildcard ``\verb$_$''.
Not all cases need to be covered and the order of cases matters.
However, one is well-advised not to wallow in complex patterns because
complex case distinctions tend to induce complex proofs.

\begin{warn}
Internally Isabelle only knows about exhaustive case expressions with
non-nested patterns: $pattern@i$ must be of the form
$C@i~x@ {i1}~\dots~x@ {ik@i}$ and $C@1, \dots, C@m$ must be exactly the
constructors of the type of $e$.
%
More complex case expressions are automatically
translated into the simpler form upon parsing but are not translated
back for printing. This may lead to surprising output.
\end{warn}

\begin{warn}
Like \<open>if\<close>, \<open>case\<close>-expressions may need to be enclosed in
parentheses to indicate their scope.
\end{warn}

\subsection{Structural Induction and Case Distinction}
\label{sec:struct-ind-case}
\index{case distinctions}\index{induction!structural}%
Induction is invoked by \methdx{induct_tac}, as we have seen above;
it works for any datatype.  In some cases, induction is overkill and a case
distinction over all constructors of the datatype suffices.  This is performed
by \methdx{case_tac}.  Here is a trivial example:
\<close>

lemma "(case xs of [] \<Rightarrow> [] | y#ys \<Rightarrow> xs) = xs"
apply(case_tac xs)

txt\<open>\noindent
results in the proof state
@{subgoals[display,indent=0,margin=65]}
which is solved automatically:
\<close>

apply(auto)
(*<*)done(*>*)
text\<open>
Note that we do not need to give a lemma a name if we do not intend to refer
to it explicitly in the future.
Other basic laws about a datatype are applied automatically during
simplification, so no special methods are provided for them.

\begin{warn}
  Induction is only allowed on free (or \isasymAnd-bound) variables that
  should not occur among the assumptions of the subgoal; see
  \S\ref{sec:ind-var-in-prems} for details. Case distinction
  (\<open>case_tac\<close>) works for arbitrary terms, which need to be
  quoted if they are non-atomic. However, apart from \<open>\<And>\<close>-bound
  variables, the terms must not contain variables that are bound outside.
  For example, given the goal \<^prop>\<open>\<forall>xs. xs = [] \<or> (\<exists>y ys. xs = y#ys)\<close>,
  \<open>case_tac xs\<close> will not work as expected because Isabelle interprets
  the \<^term>\<open>xs\<close> as a new free variable distinct from the bound
  \<^term>\<open>xs\<close> in the goal.
\end{warn}
\<close>

(*<*)
end
(*>*)


section \<open> Calculations \<close>

theory tcircus_calc
  imports tcircus_idle
begin

abbreviation tsyme :: "('e tev list, 's) uexpr \<Rightarrow> ('s, 'e) taction" where
"tsyme t \<equiv> U(\<exists> t\<^sub>0. $tr\<acute> = $tr @ \<guillemotleft>t\<^sub>0\<guillemotright> \<and> t\<^sub>0 \<subseteq>\<^sub>t \<lceil>t\<rceil>\<^sub>S\<^sub><)"

utp_const tsyme

lemma foldr_concat_eval [uexpr_transfer_extra]: "\<lbrakk>foldr (bop (@)) xs t\<rbrakk>\<^sub>e s = concat (map (\<lambda> e. \<lbrakk>e\<rbrakk>\<^sub>e s) xs) @ \<lbrakk>t\<rbrakk>\<^sub>e s"
  by (induct xs, rel_auto+)

definition [upred_defs]: "tc_time' X t = U(replicate t (Tock (-X)))"

utp_const tc_time'

text \<open> We introduce a small algebra for peri- and postconditions to capture timed behaviours. The
  first operator captures stable intermediate (i.e. quiescent) behaviours. Here, @{term s} is a
  predicate on the state (a condition), @{term t} is a trace over non-tock events, and @{term E}
  is the set of events being accepted at this point. FIXME: Should stable observations
  also update the state? \<close>

definition tc_stable :: "'s upred \<Rightarrow> ('e tev list, 's) uexpr \<Rightarrow> ('e set, 's) uexpr \<Rightarrow> 's upred \<Rightarrow> ('s, 'e) taction" ("\<E>'(_, _, _, _')") where
[upred_defs]: "\<E>(s,t,E,p) = U(\<lceil>s\<rceil>\<^sub>S\<^sub>< \<and> tsyme t \<and> (\<forall> e\<in>\<lceil>E\<rceil>\<^sub>S\<^sub><. \<guillemotleft>e\<guillemotright> \<notin>\<^sub>\<R> $ref\<acute>) \<and> ($pat\<acute> \<Rightarrow> \<lceil>p\<rceil>\<^sub>S\<^sub><))"

text \<open> We also need unstable intermediate observations, which the following relation provides. It
  has no set associated, since no refusal set is observed. \<close>

definition tc_unstable :: "'s upred \<Rightarrow> ('e tev list, 's) uexpr \<Rightarrow> ('s, 'e) taction" ("\<U>'(_, _')") where
[upred_defs]: "\<U>(s,t) = U(\<lceil>s\<rceil>\<^sub>S\<^sub>< \<and> tsyme t \<and> $ref\<acute> = \<^bold>\<bullet> \<and> $pat\<acute> = false)"

text \<open> A final observation is similar to a stable observation, except it can update the state
  variables and does not characterise a refusal set. \<close>

definition tc_final :: "'s upred \<Rightarrow>('e tev list, 's) uexpr \<Rightarrow> 's usubst \<Rightarrow> ('s, 'e) taction" ("\<F>'(_, _, _')") where
[upred_defs]: "\<F>(s,t,\<sigma>) = U(\<lceil>s\<rceil>\<^sub>S\<^sub>< \<and> tsyme t \<and> \<lceil>\<langle>\<sigma>\<rangle>\<^sub>a\<rceil>\<^sub>S)"

text \<open> A timed observation represents a period of delay. The set @{term X} characterises the set of
  events that are accepted during this period. The set @{term A} characterises the possible delay
  periods, for example @{term "{0..n}"} means a delay of between $0$ and $n$ units. \<close>

definition tc_time :: "('e set, 's) uexpr \<Rightarrow> (nat set, 's) uexpr \<Rightarrow> ('s, 'e) taction" ("\<T>'(_, _')") where
[upred_defs]: "\<T>(X, A) = U(\<exists> t \<in> tocks \<lceil>- X\<rceil>\<^sub>S\<^sub><. $tr\<acute> = $tr @ \<guillemotleft>t\<guillemotright> \<and> length(\<guillemotleft>t\<guillemotright>) \<in> \<lceil>A\<rceil>\<^sub>S\<^sub>< \<and> $st\<acute> = $st)"

utp_lift_notation tc_stable
utp_lift_notation tc_unstable
utp_lift_notation tc_final (2)
utp_lift_notation tc_time

lemma [closure]: "\<E>(s, t, E, p) is TRR"
  by (rel_auto)

lemma [closure]: "\<E>(s, t, E, p) is TDC"
  by (rel_auto, (meson refusal_mp)+)

lemma [closure]: "\<U>(s, t) is TRR"
  by (rel_auto)

lemma [closure]: "\<F>(s, t, \<sigma>) is TRR"
  by (rel_auto)

lemma [closure]: "\<T>(X, A) is TRR"
  by (rel_auto)

lemma [closure]: "\<T>(X, A) is TIP"
  by (rel_auto)

lemma [unrest]: "$st\<acute> \<sharp> \<E>(s, t, E, p)"
  by (rel_auto)

lemma [unrest]: "$st\<acute> \<sharp> \<U>(s, t)"
  by (rel_auto)

text \<open> Unstable observations are subsumed by stable ones \<close>

lemma instability_subsumed: "\<E>(s, t, E, p) \<sqsubseteq> \<U>(s, t)"
  by (rel_auto)

lemma "(\<E>(s\<^sub>1, t, E\<^sub>1, p\<^sub>1) \<and> \<E>(s\<^sub>2, t, E\<^sub>2, p\<^sub>2)) = \<E>(s\<^sub>1 \<and> s\<^sub>2, t, E\<^sub>1 \<union> E\<^sub>2, p\<^sub>1 \<and> p\<^sub>2)"
  by (rel_auto)

lemma stability_modulo_ref: "(\<exists> $pat\<acute> \<bullet> \<exists> $ref\<acute> \<bullet> \<E>(s, t, E, p)) = (\<exists> $pat\<acute> \<bullet> \<exists> $ref\<acute> \<bullet> \<U>(s, t))"
  by (rel_auto)

lemma tc_final_compose [rpred]: "\<F>(s\<^sub>1, t\<^sub>1, \<sigma>\<^sub>1) ;; \<F>(s\<^sub>2, t\<^sub>2, \<sigma>\<^sub>2) = \<F>(s\<^sub>1 \<and> \<sigma>\<^sub>1 \<dagger> s\<^sub>2, t\<^sub>1 @ \<sigma>\<^sub>1 \<dagger> t\<^sub>2, \<sigma>\<^sub>2 \<circ>\<^sub>s \<sigma>\<^sub>1)"
  apply (trr_auto)
  using tock_ord_append apply blast
  apply (metis append_take_drop_id tock_ord_decompose)
  done

utp_const UINFIMUM (1) USUPREMUM (1)

lemma time_stable_compose:
  "\<T>(X, A) ;; \<E>(s, t, E, p) = (\<Sqinter> n \<bullet> \<E>(n \<in> A \<and> s, bop (^) [Tock (-X)] n @ t, E, p))"
  apply (trr_auto)
  apply (metis lit.rep_eq tock_ord_append tocks_order_power)
  apply (metis lit.rep_eq tock_ord_append tocks_order_power)
  apply (metis (mono_tags, opaque_lifting) append_take_drop_id length_replicate power_replicate tock_ord_decompose(1) tock_ord_decompose(2) tock_ord_def tock_power_in_tocks tocks_ord_closed)
  apply (metis (mono_tags, opaque_lifting) append_take_drop_id length_replicate power_replicate tock_ord_decompose(1) tock_ord_decompose(2) tock_ord_def tock_power_in_tocks tocks_ord_closed)
  done

lemma time_unstable_compose:
  "\<T>(X, A) ;; \<U>(s, t) = (\<Sqinter> n \<bullet> \<U>(\<guillemotleft>n\<guillemotright> \<in> A \<and> s, bop (^) [Tock (-X)] \<guillemotleft>n\<guillemotright> @ t))"
  apply (trr_auto)
  apply (metis tock_ord_append tocks_order_power)
  apply (metis (mono_tags, opaque_lifting) append_take_drop_id length_replicate power_replicate tock_ord_decompose(1) tock_ord_decompose(2) tock_ord_def tock_power_in_tocks tocks_ord_closed)
  done

lemma time_final_compose:
  "\<T>(X, A) ;; \<F>(s, t, \<sigma>) = (\<Sqinter> n \<bullet> \<F>(\<guillemotleft>n\<guillemotright> \<in> A \<and> s, bop (^) [Tock (-X)] \<guillemotleft>n\<guillemotright> @ t, \<sigma>))"
  apply (trr_auto)
  apply (metis tock_ord_append tocks_order_power)
  apply (metis (mono_tags, opaque_lifting) append_take_drop_id length_replicate power_replicate tock_ord_decompose(1) tock_ord_decompose(2) tock_ord_def tock_power_in_tocks tocks_ord_closed)
  done

lemma [rpred]: "\<F>(s\<^sub>1, t\<^sub>1, \<sigma>) ;; \<E>(s\<^sub>2, t\<^sub>2, E, p) = \<E>(s\<^sub>1 \<and> \<sigma> \<dagger> s\<^sub>2, t\<^sub>1 @ \<sigma> \<dagger> t\<^sub>2, \<sigma> \<dagger> E, \<sigma> \<dagger> p)"
  apply (trr_auto)
  apply (metis tock_ord_append)
  using tock_ord_append apply blast
  apply (metis append_take_drop_id tock_ord_decompose(1) tock_ord_decompose(2))
  apply (metis append_take_drop_id tock_ord_decompose(1) tock_ord_decompose(2))
  done

lemma [rpred]: "\<F>(s\<^sub>1, t\<^sub>1, \<sigma>) ;; \<U>(s\<^sub>2, t\<^sub>2) = \<U>(s\<^sub>1 \<and> \<sigma> \<dagger> s\<^sub>2, t\<^sub>1 @ \<sigma> \<dagger> t\<^sub>2)"
  apply (trr_auto)
  apply (metis tock_ord_append)
  apply (metis append_take_drop_id tock_ord_decompose(1) tock_ord_decompose(2))
  done

lemma [rpred]: "\<T>(X, {}) = false"
  by (rel_auto)

lemma [rpred]: "\<T>(X, {0}) = II\<^sub>t"
  by (rel_auto)

lemma [rpred]: "\<F>(true, [], id\<^sub>s) = II\<^sub>t"
  by (rel_simp)

lemma time_single_single [rpred]: "\<T>(X, {m}) ;; \<T>(X, {n}) = \<T>(X, {m+n})"
  by (trr_auto)
     (metis (mono_tags, opaque_lifting) add_right_cancel append_take_drop_id length_append length_drop plus_list_def tocks_append trace_class.add_diff_cancel_left)

lemma time_single_lessthan [rpred]: "\<T>(X, {m}) ;; \<T>(X, {0..<n}) = \<T>(X, {m..<m+n})"
  by trr_auto
     (metis (no_types, lifting) add_left_strict_mono add_right_cancel append_take_drop_id diff_add_cancel_left' length_append length_drop tocks_append)

lemma time_single_atMost [rpred]: "\<T>(X, {m}) ;; \<T>(X, {0..n}) = \<T>(X, {m..m+n})"
  by trr_auto
     (metis (no_types, opaque_lifting) add_le_cancel_left add_right_cancel append_take_drop_id diff_add_cancel_left' length_append length_drop tocks_append)

lemma time_single_atLeast [rpred]: "\<T>(X, {m}) ;; \<T>(X, {n..}) = \<T>(X, {m+n..})"
  apply trr_auto
  apply (rename_tac t s)
  apply (rule_tac x="take (\<lbrakk>m\<rbrakk>\<^sub>e s) t" in exI)
  apply (auto)
  apply (rule_tac x="drop (\<lbrakk>m\<rbrakk>\<^sub>e s) t" in bexI)
   apply (auto)
  done

lemma split_time_dom:
  fixes l :: nat
  assumes "m\<^sub>1 + m\<^sub>2 \<le> l" "l \<le> m\<^sub>1 + m\<^sub>2 + (n\<^sub>1 + n\<^sub>2)"
  shows "(\<exists> n. n \<le> l \<and> m\<^sub>1 \<le> n \<and> m\<^sub>2 + n \<le> l \<and> n \<le> m\<^sub>1+n\<^sub>1 \<and> l \<le> m\<^sub>2+n\<^sub>2+n)"
  using assms
  by presburger

lemma [rpred]: "\<T>(X, {m\<^sub>1..m\<^sub>1+n\<^sub>1}) ;; \<T>(X, {m\<^sub>2..m\<^sub>2+n\<^sub>2}) = \<T>(X, {m\<^sub>1 + m\<^sub>2..m\<^sub>1 + m\<^sub>2+(n\<^sub>1 + n\<^sub>2)})"
proof (trr_auto)
  fix t s

  assume a: "t \<in> tocks (- \<lbrakk>X\<rbrakk>\<^sub>e s)" "\<lbrakk>m\<^sub>1\<rbrakk>\<^sub>e s + \<lbrakk>m\<^sub>2\<rbrakk>\<^sub>e s \<le> length t" "length t \<le> \<lbrakk>m\<^sub>1\<rbrakk>\<^sub>e s + \<lbrakk>m\<^sub>2\<rbrakk>\<^sub>e s + (\<lbrakk>n\<^sub>1\<rbrakk>\<^sub>e s + \<lbrakk>n\<^sub>2\<rbrakk>\<^sub>e s)"
  then obtain n where n: "n \<le> length t" "\<lbrakk>m\<^sub>1\<rbrakk>\<^sub>e s \<le> n" "\<lbrakk>m\<^sub>2\<rbrakk>\<^sub>e s + n \<le> length t" "n \<le> \<lbrakk>m\<^sub>1\<rbrakk>\<^sub>e s+\<lbrakk>n\<^sub>1\<rbrakk>\<^sub>e s" "length t \<le> \<lbrakk>m\<^sub>2\<rbrakk>\<^sub>e s+\<lbrakk>n\<^sub>2\<rbrakk>\<^sub>e s+n"
    using split_time_dom by blast

  with a show "\<exists>tr. tr \<in> tocks (- \<lbrakk>X\<rbrakk>\<^sub>e s) \<and>
                \<lbrakk>m\<^sub>1\<rbrakk>\<^sub>e s \<le> length tr \<and>
                length tr \<le> \<lbrakk>m\<^sub>1\<rbrakk>\<^sub>e s + \<lbrakk>n\<^sub>1\<rbrakk>\<^sub>e s \<and> (\<exists>x\<in>tocks (- \<lbrakk>X\<rbrakk>\<^sub>e s). t = tr @ x \<and> \<lbrakk>m\<^sub>2\<rbrakk>\<^sub>e s \<le> length x \<and> length x \<le> \<lbrakk>m\<^sub>2\<rbrakk>\<^sub>e s + \<lbrakk>n\<^sub>2\<rbrakk>\<^sub>e s)"
    apply (rule_tac x="take n t" in exI)
    apply (auto)
    apply (rule_tac x="drop n t" in bexI)
     apply (auto)
    done
qed

lemma idle_true [rpred]: "idle(true) = \<T>({}, {0..}) ;; \<E>(true, [], {}, true)"
  by rel_auto

lemma [rpred]: "idle(\<T>(X, A)) = \<T>(X, A)"
  by (rel_auto, simp add: tocks_subset)

lemma time_tocks_stable [rpred]: "idle(\<T>(X, A) ;; \<E>(s, [], E, p)) = \<T>(X, A) ;; \<E>(s, [], E, p)"
  by (rel_auto; simp add: tocks_subset)

lemma [rpred]: "idle(\<T>(X, A) ;; \<U>(s, [])) = \<T>(X, A) ;; \<U>(s, [])"
  by (rel_auto, simp add: tocks_subset)

lemma [rpred]: "idle(\<E>(s, [], E, p)) = \<E>(s, [], E, p)"
  by (rel_auto)

lemma [rpred]: "idle(\<E>(s, Evt t # ts, E, p)) = false"
  by (rel_simp)

lemma [rpred]: "idle(\<U>(s, Evt t # ts)) = false"
  by (rel_simp)

lemma [rpred]: "(\<T>(X\<^sub>1, A\<^sub>1) \<and> \<T>(X\<^sub>2, A\<^sub>2)) = \<T>(X\<^sub>1 \<union> X\<^sub>2, A\<^sub>1 \<inter> A\<^sub>2)"
  by (rel_auto)

lemma [rpred]: "(\<T>(A, T\<^sub>1) ;; \<E>(s\<^sub>1, [], {}, true) \<and> \<T>(B, T\<^sub>2) ;; \<E>(s\<^sub>2, [], {}, true))
       = \<T>(A \<union> B, T\<^sub>1 \<inter> T\<^sub>2) ;; \<E>(s\<^sub>1 \<and> s\<^sub>2, [], {}, true)"
  by (rel_auto)

lemma [rpred]: "(\<T>(X, A) ;; \<E>(true, [], E\<^sub>1, p\<^sub>1) \<and> \<T>(Y, B) ;; \<E>(true, [], E\<^sub>2, p\<^sub>2)) = \<T>(X \<union> Y, A \<inter> B) ;; \<E>(true, [], E\<^sub>1 \<union> E\<^sub>2, p\<^sub>1 \<and> p\<^sub>2)"
  by (rel_auto)

lemma nat_set_simps [simp]:
  fixes m::"(nat, _) uexpr"
  shows "U({0..<m} \<inter> {m}) = U({})" "U(A \<inter> A) = U(A)"
  by (rel_simp+)

lemma [rpred]: "active(\<U>(s, [])) = false"
  by (rel_auto)

lemma [rpred]: "idle(\<U>(s, [])) = \<U>(s, [])"
  by (rel_auto)

lemma [rpred]:
  assumes "P is TRR"
  shows "time(P ;; \<U>(true, [])) = time(P)"
proof -
  have "time(TRR(P) ;; \<U>(true, [])) = time(TRR P)"
    by (rel_blast)
  thus ?thesis
    by (simp add: Healthy_if assms)
qed

lemma [rpred]: "idle(\<T>(X, T) ;; \<U>(true, [Evt a])) = false"
  by (rel_simp)

lemma [rpred]: "active(\<T>(X, {0..})) = false"
  by (rel_auto)

lemma [rpred]: "active(\<T>(X, T) ;; \<U>(s, [])) = false"
  by (trr_auto)

lemma [rpred]: "(\<T>({}, {0..}) ;; \<E>(true, [], {}, true) \<and> idle(P)) = idle(P)"
  by (rel_auto)

lemma unstable_TRF:
  assumes "P is TRF"
  shows "P ;; \<U>(true, []) = U((\<exists> $st\<acute> \<bullet> P) \<and> $ref\<acute> = \<^bold>\<bullet> \<and> $pat\<acute> = false)"
proof -
  have "TRF P ;; \<U>(true, []) = U((\<exists> $st\<acute> \<bullet> TRF P) \<and> $ref\<acute> = \<^bold>\<bullet> \<and> $pat\<acute> = false)"
    by (rel_blast)
  thus ?thesis
    by (simp add: Healthy_if assms)
qed

text \<open> If a pericondition @{term P} contains an unstable version of each postcondition observation
  in @{term Q}, then every time trace of the @{term P} has an extension in @{term Q}. \<close>

lemma time_peri_in_post:
  assumes "P is TRR" "P is TIP" "Q is TRF" "P \<sqsubseteq> Q ;; \<U>(true, [])"
  shows "time(P) \<sqsubseteq> Q"
proof -
  have "Q ;; \<U>(true, []) ;; II\<^sub>t \<sqsubseteq> Q"
    by (trr_auto cls: assms, blast)
  also have "P ;; II\<^sub>t \<sqsubseteq> ..."
    by (simp add: RA1 assms(4) urel_dioid.mult_isor)
  also have "time(P) ;; II\<^sub>t \<sqsubseteq> ..."
    by (simp add: TIP_has_time assms(1) assms(2) urel_dioid.mult_isor utp_pred_laws.inf.orderI)
  also have "... = time(P)"
    by (simp add: TRF_right_unit TRF_time assms(1))
  finally show ?thesis .
qed

lemma TRR_conj_time [rpred]:
  assumes "P is TRR"
  shows "(time(\<T>({}, {0..}) ;; \<E>(true, [], {}, true)) \<and> P) = P"
proof -
  have "(time(\<T>({}, {0..}) ;; \<E>(true, [], {}, true)) \<and> TRR(P)) = TRR(P)"
    by (rel_blast)
  thus ?thesis
    by (simp add: Healthy_if assms)
qed

end


theory weird_nat_add3acc_assoc1
imports Main
        "$HIPSTER_HOME/IsaHipster"
begin

datatype Nat = Z | S "Nat"

fun add3acc :: "Nat => Nat => Nat => Nat" where
"add3acc (Z) (Z) z = z"
| "add3acc (Z) (S y2) z = add3acc Z y2 (S z)"
| "add3acc (S x2) y z = add3acc x2 (S y) z"

(*hipster add3acc *)

theorem x0 :
  "!! (x1 :: Nat) (x2 :: Nat) (x3 :: Nat) (x4 :: Nat) (x5 :: Nat) .
     (add3acc (add3acc x1 x2 x3) x4 x5) =
       (add3acc x1 x2 (add3acc x3 x4 x5))"
  by (tactic \<open>Subgoal.FOCUS_PARAMS (K (Tactic_Data.hard_tac @{context})) @{context} 1\<close>)

end


theory Transducer
  imports Main State_Machine
begin

type_synonym ('q, 'a, 'b) "out" =
  "'q \<times> 'a \<Rightarrow> 'b list"

record ('q, 'a, 'b) transducer = "('q, 'a) state_machine" +
  eta :: "('q, 'a, 'b) out"
  final :: "'q \<Rightarrow> bool"

fun hat2 :: "('q, 'a) trans \<Rightarrow> ('q, 'a, 'b) out \<Rightarrow> ('q, 'a list, 'b) out" where
  "hat2 t outf (q, [])   = []" |
  "hat2 t outf (q, a#as) = outf (q, a) @ hat2 t outf (t (q, a), as)"

(* \<eta>^(q, w) *)
abbreviation eta_hat :: "('q, 'a, 'b, 'e) transducer_scheme \<Rightarrow> ('q, 'a list, 'b) out" where
  "eta_hat sst \<equiv> hat2 (delta sst) (eta sst)"

definition run :: "('q, 'a, 'b, 'e) transducer_scheme \<Rightarrow> 'a list \<Rightarrow> ('b list) option" where
  "run T as = (if final T (hat1 (delta T) (initial T, as))
               then Some (hat2 (delta T) (eta T) (initial T, as))
               else None)"

definition compose_delta ::
  "('q1, 'a, 'b) transducer => ('q2, 'b, 'c) transducer => ('q1 \<times> 'q2, 'a) trans" where
  "compose_delta T1 T2 = (\<lambda>((q1, q2), a). (delta T1 (q1, a), hat1 (delta T2) (q2, eta T1 (q1, a))))"

definition compose_eta ::
  "('q1, 'a, 'b) transducer => ('q2, 'b, 'c) transducer => ('q1 \<times> 'q2, 'a, 'c) out" where
  "compose_eta T1 T2 = (\<lambda>((q1, q2), a). hat2 (delta T2) (eta T2) (q2, (eta T1 (q1, a))))"

definition compose :: "('q1, 'a, 'b) transducer => ('q2, 'b, 'c) transducer =>
                ('q1 \<times> 'q2, 'a, 'c) transducer" where
  "compose T1 T2 = (|
    initial = (initial T1, initial T2),
    delta = compose_delta T1 T2,
    eta = compose_eta T1 T2,
    final = \<lambda>(q1, q2). final T1 q1 \<and> final T2 q2
 |)"

lemma compose_delta_hat: "hat1 (compose_delta T1 T2) ((q1, q2), w) =
      (hat1 (delta T1) (q1, w), hat1 (delta T2) (q2, hat2 (delta T1) (eta T1) (q1, w)))"
  by (induction w arbitrary: q1 q2, auto simp add: compose_delta_def)

lemma eta_append: "hat2 t f (q, as @ bs) = hat2 t f (q, as) @ hat2 t f (hat1 t (q, as), bs)"
  by (induction as arbitrary: q, auto)

lemma compose_eta_hat: "hat2 (compose_delta T1 T2) (compose_eta T1 T2) ((q1, q2), w) =
       hat2 (delta T2) (eta T2) (q2, hat2 (delta T1) (eta T1) (q1, w))"
  by (induction w arbitrary: q1 q2,
      auto simp add: compose_delta_def compose_eta_def eta_append)

theorem compose_Transducer_Transducer:
  "run (compose T1 T2) w = (case run T1 w of Some u => run T2 u | None => None)"
  by (auto simp add: run_def compose_def compose_delta_hat compose_eta_hat)

end


theory Undirected_Incidence_Structure
  imports
    Incidence_Structure
    "../Undirected_Graph/Undirected_Graph"
begin

locale undirected_incidence_structure =
  fixes incidence :: "'b \<Rightarrow> 'g \<Rightarrow> ('a, 'b) edge list"
  assumes mem_incidence_imp_endpoint: "e \<in> set (incidence v G) \<Longrightarrow> v \<in> endpoints e"

definition (in undirected_incidence_structure) E :: "'g \<Rightarrow> ('a, 'b) multigraph" where
  "E G \<equiv> \<Union>v. set (incidence v G)"

lemma (in undirected_incidence_structure) endpoints_non_empty:
  assumes "e \<in> set (incidence v G)"
  shows "endpoints e \<noteq> {}"
  using assms
  by (auto dest: mem_incidence_imp_endpoint)

context Incidence_Structure
begin
sublocale undirected_incidence_structure "\<lambda>u G. map (\<lambda>(\<epsilon>, v). (\<epsilon>, {u, v})) (incidence u G)"
proof (standard, goal_cases)
  case (1 e v G)
  thus ?case
    by fastforce
qed
end

locale undirected_incidence_structure_2 =
  undirected_incidence_structure
  where incidence = incidence +
    other
  where other = other
  for incidence :: "'b \<Rightarrow> 'g \<Rightarrow> ('a, 'b) edge list"
    and other :: "('a, 'b) edge \<Rightarrow> 'b \<Rightarrow> 'b"

locale undirected_incidence_structure_2' = undirected_incidence_structure_2
  where incidence = incidence
  for incidence :: "'b \<Rightarrow> 'g \<Rightarrow> ('a, 'b) edge list" +
  fixes G :: 'g
begin
sublocale multigraph other "E G"
proof (standard, goal_cases)
  case (1 e)
  thm E_def
  then show ?case sorry
qed
end

end


theory Bounds
  imports Bit_Length  Abstractions "IMP_Minus.Big_StepT"  "Poly_Reductions_Lib.Polynomial_Growth_Functions"
begin
paragraph \<open>Bounding functions\<close>
text \<open> We restrict/over-approximate the behaviour of our programs by defining
 an upper bound to the execution time/result etc. depending on the input size.
The upper bound function is hence nothing but a function over natural numbers (input size)
to natural numbers (time steps/result size/ certificate size)\<close>

type_synonym bound_fun = "nat \<Rightarrow> nat"
paragraph \<open>Bit size of register set\<close>
text \<open> used to refer to input size / result size.\<close>
fun bit_size :: "val list \<Rightarrow> nat" where
"bit_size [] = 0"|
"bit_size (l#ls) = bit_length l + bit_size ls"

lemma bit_size_concat : "bit_size (xs@ys) = bit_size xs + bit_size ys"
  by (induction xs) auto

subsection \<open>Time bounded programs\<close>
paragraph \<open>Definition\<close>
text \<open>We are only interested in programs that always terminate.
A program c is bounded by a function p, if it does always terminate AND the termination time t is
always less than p(l). l being the input size.\<close>
definition time_bounded :: "com \<Rightarrow> vname list \<Rightarrow> bound_fun \<Rightarrow> bool" where
"time_bounded c l p \<equiv> (\<forall>s. \<exists>t s'. ((c,s) \<Rightarrow>\<^bsup>t\<^esup> s') \<and> t \<le> p (bit_size (map s l)))"

lemma time_boundedI:
  assumes "\<And>s. \<exists>t s'. ((c,s) \<Rightarrow>\<^bsup>t\<^esup> s') \<and> t \<le> p (bit_size (map s l))"
  shows "time_bounded c l p"
  using assms unfolding time_bounded_def by auto

definition poly_time_bounded :: "com \<Rightarrow> vname list \<Rightarrow> bool" where
"poly_time_bounded c l \<equiv> \<exists>p. poly p \<and> time_bounded c l p"

lemma poly_time_boundedD:
  assumes "poly_time_bounded c l"
  obtains p where "poly p" "time_bounded c l p"
  using assms unfolding poly_time_bounded_def by auto

lemma poly_time_boundedI:
  assumes "poly p" "time_bounded c l p"
  shows "poly_time_bounded c l"
  using assms unfolding poly_time_bounded_def by auto

subsection \<open>Result bounded programs \<close>
paragraph \<open>Definition\<close>
text \<open>Given the result's registers depend only on the input register.
That output/result is bounded by p(l) , l being the bit-size of the input.\<close>
definition result_bounded :: "com \<Rightarrow> vname list \<Rightarrow> vname list \<Rightarrow> bound_fun \<Rightarrow> bool" where
"result_bounded c input output p \<equiv> \<forall>x. length x = length input \<longrightarrow>
                                      (\<exists>r. length r = length output \<and>
                                               comp c (zip input x) (zip output r) \<and>
                                               bit_size r  \<le> p (bit_size x))"
definition poly_result_bounded :: "com \<Rightarrow> vname list \<Rightarrow> vname list \<Rightarrow> bool" where
"poly_result_bounded c input output \<equiv> \<exists>p. poly p \<and> result_bounded c input output p"

subsection \<open>Sequencing two polynomially bounded programs \<close>
lemma reduction_poly:
  assumes "poly_time_bounded f nxs" "poly_time_bounded g nys"  "poly_result_bounded f nxs nys"
  shows "poly_time_bounded (f;;g) nxs"
proof -
  from assms(1) obtain pf where pf_props: "poly pf" "time_bounded f nxs pf"
    apply(rule poly_time_boundedD) ..
  from assms(2) obtain pg where pg_props: "poly pg" "time_bounded g nys pg"
    apply(rule poly_time_boundedD) ..
  from assms(3) obtain pd  where "poly pd" and pd_fact: "\<forall>x. length x = length nxs
    \<longrightarrow> (\<exists>r. length r = length nys \<and> comp f (zip nxs x) (zip nys r) \<and>
                                                     bit_size r \<le> pd (bit_size x)) "
    using poly_result_bounded_def result_bounded_def by auto
  let ?p = "\<lambda>x. pf x + (make_mono pg o pd) x"
  have "poly ?p"
    using poly_add pf_props(1) pg_props(1) poly_compose `poly pd` poly_make_mono_iff by metis
  moreover have "time_bounded (f;; g) nxs ?p"
  proof (intro time_boundedI)
    fix s
    obtain x::"val list" where x_def: "x = map s nxs"  "length x = length nxs"  by simp
    then obtain sf tf where stepf:"(f,s) \<Rightarrow>\<^bsup> tf \<^esup> sf" "tf \<le> pf (bit_size x)"
      using pf_props(2)  by (simp add: time_bounded_def) blast
    obtain y where stepd: "comp f (zip nxs x) (zip nys y)"
      "bit_size y \<le> pd (bit_size x)" "length y = length nys" using pd_fact x_def(2)
      by auto
    then obtain s1 t1 where step':"(f,s) \<Rightarrow>\<^bsup> t1 \<^esup> s1" "map s1 nys = y" using comp_def x_def
        stepd(2) zip_eq_conv  by (smt list.map_comp)
    hence "s1 = sf" using big_step_t_determ2 stepf(1) by simp
    then obtain  sg tg where g_def: "(g,sf)\<Rightarrow>\<^bsup> tg \<^esup> sg" "tg \<le> pg(bit_size y)"
      using pg_props(2) time_bounded_def step'(2) by blast
    hence "tg \<le> make_mono pg (bit_size y)" using le_trans by blast
    moreover have "make_mono pg (bit_size y) \<le> make_mono pg (pd (bit_size x))"
      using stepd(2) mono_make_mono[of pg] incseq_def  by blast
    ultimately have t2_ineq: "tg \<le> (make_mono pg o pd)(bit_size x)" by fastforce
    hence "(f;;g,s) \<Rightarrow>\<^bsup> tf+tg \<^esup> sg"
      "tf+tg \<le> pf (bit_size x) + (make_mono pg o pd) (bit_size x)"
      using stepf(1) g_def (1) apply blast
      using add_mono stepf(2) t2_ineq by blast
    thus "\<exists>t s'. ((f;; g, s) \<Rightarrow>\<^bsup> t \<^esup> s') \<and>
             t \<le> pf (bit_size (map s nxs)) + (make_mono pg \<circ> pd) (bit_size (map s nxs)) "
      using x_def by blast
  qed
  ultimately show ?thesis
    by (rule poly_time_boundedI)
qed

subsection \<open>Valid certificate bounds\<close>
paragraph \<open>Definition\<close>
text \<open>
Given a program c AND an input x, a valid certificate z is a certificate for which the verifier c,
will return 0.
p is valid-certificate-bounded iff for every input x that has a corresponding valid certificate,
there EXISTS a valid certificate limited by p(l), l being the input size (''input'' register)
\<close>

definition certif_bounded_to_goal :: "com \<Rightarrow> bound_fun \<Rightarrow> lang \<Rightarrow> bool" where
"certif_bounded_to_goal c p L \<equiv>  \<forall>x. (\<exists>z r. verif c x z r \<and> r \<in> L)
                             \<longrightarrow> (\<exists>z r. verif c x z r \<and> bit_length z \<le> p (bit_length x) \<and> r \<in> L)"

definition certif_bounded :: "com \<Rightarrow> bound_fun \<Rightarrow> bool" where
"certif_bounded c p \<equiv> certif_bounded_to_goal c p {0} "

definition poly_certif_bounded :: "com \<Rightarrow> bool" where
"poly_certif_bounded c \<equiv> \<exists>p. poly p \<and> certif_bounded c p "

lemma summing: "bit_length x = bit_size [x]" by auto

lemma cons_certif_effect :
  assumes "comp f [(''input'',x)] [(''input'',y)]" "cons_certif f"
  shows   "comp f [(''input'',x),(''certificate'',z)] [(''input'',y),(''certificate'',z)]"
proof (auto simp add: comp_def)
  fix s
  assume " x = s ''input'' " "z = s ''certificate''"
  then obtain t s' where "(f, s) \<Rightarrow>\<^bsup> t \<^esup> s'" "s' ''input''= y" using assms(1) comp_def by auto
  then show "\<exists>t s'. (f, s) \<Rightarrow>\<^bsup> t \<^esup> s' \<and> s' ''input'' = y \<and> s' ''certificate'' = s ''certificate''"
    using assms(2) cons_certif_def by metis
qed

lemma extend_time_bounded :
  assumes "time_bounded f xs p"
  shows "time_bounded f (xs@ys) (make_mono p)"
proof (auto simp add: time_bounded_def)
  fix s
  from assms obtain t s' where def:"(f, s) \<Rightarrow>\<^bsup> t \<^esup> s'" "t \<le> p (bit_size (map s xs))"
    apply (auto simp add: time_bounded_def) by blast
  from def(2) have "t \<le> make_mono p (bit_size (map s xs))"
    using le_trans by blast
  hence " t \<le> make_mono p (bit_size (map s xs) + bit_size (map s ys))"
    by (meson incseq_def le_add1 le_trans mono_make_mono)
  thus " \<exists>t. (\<exists>s'. (f, s) \<Rightarrow>\<^bsup> t \<^esup> s') \<and>
             t \<le> make_mono p (bit_size(map s xs @ map s ys))"
    using def(1) bit_size_concat by auto
qed

lemma extend_poly_time_bounded:
  assumes "poly_time_bounded f xs "
  shows "poly_time_bounded f (xs@ys)"
proof -
  from assms obtain p where "poly p" "time_bounded f xs p" by (auto simp add: poly_time_bounded_def)
  hence "time_bounded f (xs@ys) (make_mono p) "  "poly (make_mono p)"
    by(auto simp add: extend_time_bounded  poly_make_mono_iff)
  thus ?thesis by (auto simp add:poly_time_bounded_def)
qed

lemma cons_certif_result_bounded:
  assumes "result_bounded f [''input''] [''input''] p" "cons_certif f"
  shows "result_bounded f [''input'',''certificate''] [''input'',''certificate'']
                                                                           (\<lambda>x. make_mono p x + x) "
proof (auto simp add:result_bounded_def)
  fix xs::"val list"
  assume "length xs = Suc (Suc 0)"
  then obtain x z where xs_def: "xs = [x,z]"
    by (metis (no_types, lifting) Suc_length_conv length_0_conv)
  have "length [x] = length [''input'']" by auto
  then obtain ys where ys_def: "comp f [(''input'',x)] (zip [''input''] ys)"
                        "length ys = length [''input'']"
                        "bit_size ys \<le> p (bit_length x)"
    using assms(1) result_bounded_def
    by (smt summing zip.simps(1) zip_Cons_Cons)
  from ys_def(2) obtain y where y_def: "ys = [y]"
    by (metis Suc_length_conv length_0_conv length_Cons)
  hence "comp f [(''input'',x)] [(''input'',y)]" using ys_def(1) by auto
  hence whole:"comp f [(''input'',x),(''certificate'',z)] [(''input'',y),(''certificate'',z)]"
    using assms(2) cons_certif_effect by fast
  obtain r where r_def: "r = [y,z]" by simp
  hence "length r = Suc (Suc 0)" by auto
  moreover have "comp f (zip [''input'', ''certificate''] xs)
              (zip [''input'', ''certificate''] r)" using r_def whole xs_def by auto
  moreover have "bit_length y \<le> p(bit_length x)" using y_def ys_def(3) by auto
  hence "bit_length y + bit_length z \<le> p (bit_length x) + bit_length x + bit_length z"
    by auto
  hence "bit_length y + bit_length z \<le> make_mono p (bit_length x)
                                               + bit_length x + bit_length z"
    by (simp add: le_make_mono order_trans)
  hence "bit_length y + bit_length z \<le> make_mono p (bit_length x + bit_length z)
                                               + bit_length x + bit_length z"
    by (meson add_right_mono incseq_def le_add1 le_trans mono_make_mono)
  hence "bit_size r \<le> make_mono p (bit_size xs) + bit_size xs"  using xs_def r_def by force
  ultimately show " \<exists>r. length r = Suc (Suc 0) \<and>
             comp f (zip [''input'', ''certificate''] xs)
              (zip [''input'', ''certificate''] r) \<and>
             bit_size r \<le> make_mono p (bit_size xs) + bit_size xs" by blast
qed
lemma cons_certif_poly_result_bounded:
  assumes "poly_result_bounded f [''input''] [''input'']" "cons_certif f"
  shows "poly_result_bounded f [''input'',''certificate''] [''input'',''certificate'']"
proof -
  from assms(1) obtain p where p_def: "poly p" "result_bounded f [''input''] [''input''] p"
    by (auto simp add:poly_result_bounded_def)
  hence "result_bounded f [''input'',''certificate''] [''input'',''certificate'']
                                                                       (\<lambda>x. make_mono p x +x)"
    using assms(2) cons_certif_result_bounded by fast
  moreover have "poly (\<lambda>x. make_mono p x + x)" using p_def(1)
    by (simp add: poly_add poly_linear poly_make_mono_iff)
  ultimately show ?thesis by (auto simp add:poly_result_bounded_def)
qed
lemma result_bounded_certif_bounded :
  assumes "result_bounded f [''input''] [''input''] q"
          "cons_certif f" "certif_bounded g p" "\<forall>y z. \<exists>r. verif g y z r "
        shows "certif_bounded (f;;g) (make_mono p o q)"
proof (auto simp add: certif_bounded_def certif_bounded_to_goal_def)
  fix x z
  assume local_asm:"verif (f;; g) x z 0"
  have "length [''input''] = length [x]" "[(''input'',x)] = zip [''input''] [x]"
    by auto
  then obtain ys where ys_def: "comp f ( zip [''input''] [x]) (zip [''input''] ys)"
              "bit_size ys \<le> q (bit_size [x])" "length ys = length [''input''] "
                      using assms(1) result_bounded_def summing
                      by metis

 from ys_def(3) obtain y where y_def: "ys = [y]"
   by (metis length_0_conv length_Suc_conv)
  have  red_part: "comp f  [(''input'',x),(''certificate'',z)] [(''input'',y),(''certificate'',z)]"
    using assms(2) cons_certif_effect y_def ys_def(1) by auto
  from assms(4) obtain r where r'_def: "verif g y z r"  using certif_bounded_def by presburger
  moreover from red_part y_def ys_def(1) r'_def assms(1) have "verif (f;; g) x z r"
    using comp_comp by (auto simp add:verif_def)
  hence  "r = 0" using local_asm comp_det apply(auto simp add:verif_def) by fastforce
  ultimately obtain z'  where  z'r'_def: " verif g y z' 0" "bit_length z' \<le> p (bit_length y)"
    using assms(3) certif_bounded_def certif_bounded_to_goal_def by auto
  from z'r'_def(2) have "bit_length z' \<le> make_mono p (bit_length y)"
    using le_trans less_imp_le_nat by blast
  moreover have "make_mono p (bit_length y) \<le> make_mono p (q (bit_length x))"
    using ys_def(2) mono_make_mono y_def by (simp add: incseqD)
  ultimately have "bit_length z' \<le>  make_mono p (q (bit_length x)) " by simp
  moreover  have  red_part':
    "comp f  [(''input'',x),(''certificate'',z')] [(''input'',y),(''certificate'',z')]"
    using assms(2) cons_certif_effect y_def ys_def(1) by auto
  hence "verif (f;;g) x z' 0"  using z'r'_def(1) comp_comp by (auto simp add:verif_def)
  ultimately show "\<exists>z. verif (f;; g) x z 0 \<and> bit_length z \<le> make_mono p (q (bit_length x))"
    using z'r'_def(2) by blast
qed

lemma poly_result_bounded_poly_certif_bounded:
  assumes "poly_result_bounded f [''input''] [''input'']"
                  "cons_certif f" "poly_certif_bounded g"
                          "\<forall>y z. \<exists>r. verif g y z r "
  shows "poly_certif_bounded (f;;g)"
proof (auto simp add: poly_certif_bounded_def)

  show "\<exists>p. poly p \<and> certif_bounded (f;; g) p "
  proof -
    from assms(1) obtain q where q_def: "poly q" "result_bounded f  [''input''] [''input''] q"
      using poly_result_bounded_def by blast
    from  assms(3) obtain p where p_def: "poly p" "certif_bounded g p" using poly_certif_bounded_def
      by meson
    let ?p = "make_mono p o q"
    from q_def(1) p_def(1) have "poly ?p"
      by (simp add: poly_compose poly_make_mono_iff)
    moreover have "certif_bounded (f;;g) ?p" using q_def(2) p_def(2) assms(2) assms(4)
     result_bounded_certif_bounded by simp
    ultimately show ?thesis by blast
  qed
qed

lemma result_bounded_compose:
  assumes "result_bounded f xs ys pf" "result_bounded g ys zs pg"
  shows "result_bounded (f;;g) xs zs (make_mono pg o pf)"
  apply(auto simp add:result_bounded_def)
proof -
  fix x::"val list"
  assume "length x = length xs"
  then obtain y z
    where yz_def:"comp f (zip xs x) (zip ys y)" "comp g (zip ys y) (zip zs z)"
                "bit_size y \<le> pf (bit_size x)" "bit_size z \<le> pg(bit_size y)"
                "length z = length zs" "length y = length ys"
   using assms result_bounded_def by blast
  hence  "comp (f;;g) (zip xs x) (zip zs z)" using comp_comp by simp
  moreover have  "bit_size z \<le> make_mono pg (bit_size y)" using yz_def(4) le_trans by blast
  hence  " bit_size z \<le> make_mono pg (pf (bit_size x))"
    using yz_def mono_make_mono  le_trans monoD by blast
  ultimately show "\<exists>r. length r = length zs \<and>comp (f;; g) (zip xs x) (zip zs r)
                      \<and> bit_size r \<le> make_mono pg (pf (bit_size x))" using yz_def(5) by auto
qed

lemma poly_result_compose :
  assumes "poly_result_bounded f xs ys" "poly_result_bounded g ys zs"
  shows "poly_result_bounded (f;;g) xs zs"
   proof -
     obtain pf pg where pf_pg_def: "poly pf" "poly pg" "result_bounded f xs ys pf"
                                    "result_bounded g ys zs pg"
      using assms poly_result_bounded_def by auto
    have "poly (make_mono pg o pf)"
      by (simp add: pf_pg_def(1) pf_pg_def(2) poly_compose poly_make_mono_iff)
    moreover have "result_bounded (f;;g) xs zs (make_mono pg o pf)"
      using result_bounded_compose pf_pg_def by auto
    ultimately show ?thesis by (auto simp add:poly_result_bounded_def)
  qed

end


(*  Title:      HOL/MicroJava/BV/Kildall.thy
    Author:     Tobias Nipkow, Gerwin Klein
    Copyright   2000 TUM

Kildall's algorithm.
*)

header {* \isaheader{Kildall's Algorithm}\label{sec:Kildall} *}

theory Kildall
imports SemilatAlg
begin

primrec propa :: "'s binop \<Rightarrow> (nat \<times> 's) list \<Rightarrow> 's list \<Rightarrow> nat set \<Rightarrow> 's list * nat set"
where
  "propa f []      \<tau>s w = (\<tau>s,w)"
| "propa f (q'#qs) \<tau>s w = (let (q,\<tau>) = q';
                             u = \<tau> \<squnion>\<^bsub>f\<^esub> \<tau>s!q;
                             w' = (if u = \<tau>s!q then w else insert q w)
                         in propa f qs (\<tau>s[q := u]) w')"

definition iter :: "'s binop \<Rightarrow> 's step_type \<Rightarrow>
          's list \<Rightarrow> nat set \<Rightarrow> 's list \<times> nat set"
where
  "iter f step \<tau>s w =
   while (\<lambda>(\<tau>s,w). w \<noteq> {})
         (\<lambda>(\<tau>s,w). let p = SOME p. p \<in> w
                   in propa f (step p (\<tau>s!p)) \<tau>s (w-{p}))
         (\<tau>s,w)"

definition unstables :: "'s ord \<Rightarrow> 's step_type \<Rightarrow> 's list \<Rightarrow> nat set"
where
  "unstables r step \<tau>s = {p. p < size \<tau>s \<and> \<not>stable r step \<tau>s p}"

definition kildall :: "'s ord \<Rightarrow> 's binop \<Rightarrow> 's step_type \<Rightarrow> 's list \<Rightarrow> 's list"
where
  "kildall r f step \<tau>s = fst(iter f step \<tau>s (unstables r step \<tau>s))"

primrec merges :: "'s binop \<Rightarrow> (nat \<times> 's) list \<Rightarrow> 's list \<Rightarrow> 's list"
where
  "merges f []      \<tau>s = \<tau>s"
| "merges f (p'#ps) \<tau>s = (let (p,\<tau>) = p' in merges f ps (\<tau>s[p := \<tau> \<squnion>\<^bsub>f\<^esub> \<tau>s!p]))"

lemmas [simp] = Let_def Semilat.le_iff_plus_unchanged [OF Semilat.intro, symmetric]

lemma (in Semilat) nth_merges:
 "\<And>ss. \<lbrakk>p < length ss; ss \<in> list n A; \<forall>(p,t)\<in>set ps. p<n \<and> t\<in>A \<rbrakk> \<Longrightarrow>
  (merges f ps ss)!p = map snd [(p',t') \<leftarrow> ps. p'=p] \<Squnion>\<^bsub>f\<^esub> ss!p"
  (is "\<And>ss. \<lbrakk>_; _; ?steptype ps\<rbrakk> \<Longrightarrow> ?P ss ps")
(*<*)
proof (induct ps)
  show "\<And>ss. ?P ss []" by simp

  fix ss p' ps'
  assume ss: "ss \<in> list n A"
  assume l:  "p < length ss"
  assume "?steptype (p'#ps')"
  then obtain a b where
    p': "p'=(a,b)" and ab: "a<n" "b\<in>A" and ps': "?steptype ps'"
    by (cases p') auto
  assume "\<And>ss. p< length ss \<Longrightarrow> ss \<in> list n A \<Longrightarrow> ?steptype ps' \<Longrightarrow> ?P ss ps'"
  hence IH: "\<And>ss. ss \<in> list n A \<Longrightarrow> p < length ss \<Longrightarrow> ?P ss ps'" using ps' by iprover

  from ss ab
  have "ss[a := b \<squnion>\<^bsub>f\<^esub> ss!a] \<in> list n A" by (simp add: closedD)
  moreover
  with l have "p < length (ss[a := b \<squnion>\<^bsub>f\<^esub> ss!a])" by simp
  ultimately
  have "?P (ss[a := b \<squnion>\<^bsub>f\<^esub> ss!a]) ps'" by (rule IH)
  with p' l
  show "?P ss (p'#ps')" by simp
qed
(*>*)

(** merges **)

lemma length_merges [simp]:
  "\<And>ss. size(merges f ps ss) = size ss"
(*<*) by (induct ps, auto) (*>*)

lemma (in Semilat) merges_preserves_type_lemma:
shows "\<forall>xs. xs \<in> list n A \<longrightarrow> (\<forall>(p,x) \<in> set ps. p<n \<and> x\<in>A)
         \<longrightarrow> merges f ps xs \<in> list n A"
(*<*)
apply (insert closedI)
apply (unfold closed_def)
apply (induct ps)
 apply simp
apply clarsimp
done
(*>*)

lemma (in Semilat) merges_preserves_type [simp]:
 "\<lbrakk> xs \<in> list n A; \<forall>(p,x) \<in> set ps. p<n \<and> x\<in>A \<rbrakk>
  \<Longrightarrow> merges f ps xs \<in> list n A"
by (simp add: merges_preserves_type_lemma)

lemma (in Semilat) merges_incr_lemma:
 "\<forall>xs. xs \<in> list n A \<longrightarrow> (\<forall>(p,x)\<in>set ps. p<size xs \<and> x \<in> A) \<longrightarrow> xs [\<sqsubseteq>\<^bsub>r\<^esub>] merges f ps xs"
(*<*)
apply (induct ps)
 apply simp
apply simp
apply clarify
apply (rule order_trans)
  apply simp
 apply (erule list_update_incr)
  apply simp
 apply simp
apply (blast intro!: listE_set intro: closedD listE_length [THEN nth_in])
done
(*>*)

lemma (in Semilat) merges_incr:
 "\<lbrakk> xs \<in> list n A; \<forall>(p,x)\<in>set ps. p<size xs \<and> x \<in> A \<rbrakk>
  \<Longrightarrow> xs [\<sqsubseteq>\<^bsub>r\<^esub>] merges f ps xs"
  by (simp add: merges_incr_lemma)

lemma (in Semilat) merges_same_conv [rule_format]:
 "(\<forall>xs. xs \<in> list n A \<longrightarrow> (\<forall>(p,x)\<in>set ps. p<size xs \<and> x\<in>A) \<longrightarrow>
     (merges f ps xs = xs) = (\<forall>(p,x)\<in>set ps. x \<sqsubseteq>\<^bsub>r\<^esub> xs!p))"
(*<*)
  apply (induct_tac ps)
   apply simp
  apply clarsimp
  apply (rename_tac p x ps xs)
  apply (rule iffI)
   apply (rule context_conjI)
    apply (subgoal_tac "xs[p := x \<squnion>\<^bsub>f\<^esub> xs!p] [\<sqsubseteq>\<^bsub>r\<^esub>] xs")
     apply (force dest!: le_listD simp add: nth_list_update)
    apply (erule subst, rule merges_incr)
       apply (blast intro!: listE_set intro: closedD listE_length [THEN nth_in])
      apply clarify
      apply (rule conjI)
       apply simp
       apply (blast dest: boundedD)
      apply blast
   apply clarify
   apply (erule allE)
   apply (erule impE)
    apply assumption
   apply (drule bspec)
    apply assumption
   apply (simp add: le_iff_plus_unchanged [THEN iffD1] list_update_same_conv [THEN iffD2])
   apply blast
  apply clarify
  apply (simp add: le_iff_plus_unchanged [THEN iffD1] list_update_same_conv [THEN iffD2])
  done
(*>*)

lemma (in Semilat) list_update_le_listI [rule_format]:
  "set xs \<subseteq> A \<longrightarrow> set ys \<subseteq> A \<longrightarrow> xs [\<sqsubseteq>\<^bsub>r\<^esub>] ys \<longrightarrow> p < size xs \<longrightarrow>
   x \<sqsubseteq>\<^bsub>r\<^esub> ys!p \<longrightarrow> x\<in>A \<longrightarrow> xs[p := x \<squnion>\<^bsub>f\<^esub> xs!p] [\<sqsubseteq>\<^bsub>r\<^esub>] ys"
(*<*)
  apply (insert semilat)
  apply (unfold Listn.le_def lesub_def semilat_def)
  apply (simp add: list_all2_conv_all_nth nth_list_update)
  apply (simp add: lesub_def)
  done
(*>*)

lemma (in Semilat) merges_pres_le_ub:
  assumes "set ts \<subseteq> A"  "set ss \<subseteq> A"
    "\<forall>(p,t)\<in>set ps. t \<sqsubseteq>\<^bsub>r\<^esub> ts!p \<and> t \<in> A \<and> p < size ts"  "ss [\<sqsubseteq>\<^bsub>r\<^esub>] ts"
  shows "merges f ps ss [\<sqsubseteq>\<^bsub>r\<^esub>] ts"
(*<*)
proof -
  { fix t ts ps
    have
    "\<And>qs. \<lbrakk>set ts \<subseteq> A; \<forall>(p,t)\<in>set ps. t \<sqsubseteq>\<^bsub>r\<^esub> ts!p \<and> t \<in> A \<and> p< size ts \<rbrakk> \<Longrightarrow>
    set qs \<subseteq> set ps  \<longrightarrow>
    (\<forall>ss. set ss \<subseteq> A \<longrightarrow> ss [\<sqsubseteq>\<^bsub>r\<^esub>] ts \<longrightarrow> merges f qs ss [\<sqsubseteq>\<^bsub>r\<^esub>] ts)"
    apply (induct_tac qs)
     apply simp
    apply (simp (no_asm_simp))
    apply clarify
    apply simp
    apply (erule allE, erule impE, erule_tac [2] mp)
     apply (drule bspec, assumption)
     apply (simp add: closedD)
    apply (drule bspec, assumption)
    apply (simp add: list_update_le_listI)
    done
  } note this [dest]
  from assms show ?thesis by blast
qed
(*>*)

(** propa **)

lemma decomp_propa:
  "\<And>ss w. (\<forall>(q,t)\<in>set qs. q < size ss) \<Longrightarrow>
   propa f qs ss w =
   (merges f qs ss, {q. \<exists>t.(q,t)\<in>set qs \<and> t \<squnion>\<^bsub>f\<^esub> ss!q \<noteq> ss!q} \<union> w)"
(*<*)
  apply (induct qs)
   apply simp
  apply (simp (no_asm))
  apply clarify
  apply simp
  apply (rule conjI)
   apply blast
  apply (simp add: nth_list_update)
  apply blast
  done
(*>*)

(** iter **)

lemma (in Semilat) stable_pres_lemma:
shows "\<lbrakk>pres_type step n A; bounded step n;
     ss \<in> list n A; p \<in> w; \<forall>q\<in>w. q < n;
     \<forall>q. q < n \<longrightarrow> q \<notin> w \<longrightarrow> stable r step ss q; q < n;
     \<forall>s'. (q,s') \<in> set (step p (ss!p)) \<longrightarrow> s' \<squnion>\<^bsub>f\<^esub> ss!q = ss!q;
     q \<notin> w \<or> q = p \<rbrakk>
  \<Longrightarrow> stable r step (merges f (step p (ss!p)) ss) q"
(*<*)
  apply (unfold stable_def)
  apply (subgoal_tac "\<forall>s'. (q,s') \<in> set (step p (ss!p)) \<longrightarrow> s' : A")
   prefer 2
   apply clarify
   apply (erule pres_typeD)
    prefer 3 apply assumption
    apply (rule listE_nth_in)
     apply assumption
    apply simp
   apply simp
  apply simp
  apply clarify
  apply (subst nth_merges)
       apply simp
       apply (blast dest: boundedD)
      apply assumption
     apply clarify
     apply (rule conjI)
      apply (blast dest: boundedD)
     apply (erule pres_typeD)
       prefer 3 apply assumption
      apply simp
     apply simp
apply(subgoal_tac "q < length ss")
prefer 2 apply simp
  apply (frule nth_merges [of q _ _ "step p (ss!p)"]) (* fixme: why does method subst not work?? *)
apply assumption
  apply clarify
  apply (rule conjI)
   apply (blast dest: boundedD)
  apply (erule pres_typeD)
     prefer 3 apply assumption
    apply simp
   apply simp
  apply (drule_tac P = "\<lambda>x. (a, b) \<in> set (step q x)" in subst)
   apply assumption

 apply (simp add: plusplus_empty)
 apply (cases "q \<in> w")
  apply simp
  apply (rule ub1')
     apply (rule Semilat.intro)
     apply (rule semilat)
    apply clarify
    apply (rule pres_typeD)
       apply assumption
      prefer 3 apply assumption
     apply (blast intro: listE_nth_in dest: boundedD)
    apply (blast intro: pres_typeD dest: boundedD)
   apply (blast intro: listE_nth_in dest: boundedD)
  apply assumption

 apply simp
 apply (erule allE, erule impE, assumption, erule impE, assumption)
 apply (rule order_trans)
   apply simp
  defer
 apply (rule pp_ub2)(*
    apply assumption*)
   apply simp
   apply clarify
   apply simp
   apply (rule pres_typeD)
      apply assumption
     prefer 3 apply assumption
    apply (blast intro: listE_nth_in dest: boundedD)
   apply (blast intro: pres_typeD dest: boundedD)
  apply (blast intro: listE_nth_in dest: boundedD)
 apply blast
 done
(*>*)

lemma (in Semilat) merges_bounded_lemma:
 "\<lbrakk> mono r step n A; bounded step n;
    \<forall>(p',s') \<in> set (step p (ss!p)). s' \<in> A; ss \<in> list n A; ts \<in> list n A; p < n;
    ss [\<sqsubseteq>\<^sub>r] ts; \<forall>p. p < n \<longrightarrow> stable r step ts p \<rbrakk>
  \<Longrightarrow> merges f (step p (ss!p)) ss [\<sqsubseteq>\<^sub>r] ts"
(*<*)
  apply (unfold stable_def)
  apply (rule merges_pres_le_ub)
     apply simp
    apply simp
   prefer 2 apply assumption

  apply clarsimp
  apply (drule boundedD, assumption+)
  apply (erule allE, erule impE, assumption)
  apply (drule bspec, assumption)
  apply simp

  apply (drule monoD [of _ _ _ _ p "ss!p"  "ts!p"])
     apply assumption
    apply simp
   apply (simp add: le_listD)

  apply (drule lesub_step_typeD, assumption)
  apply clarify
  apply (drule bspec, assumption)
  apply simp
  apply (blast intro: order_trans)
  done
(*>*)

lemma termination_lemma: assumes "Semilat A r f"
shows "\<lbrakk> ss \<in> list n A; \<forall>(q,t)\<in>set qs. q<n \<and> t\<in>A; p\<in>w \<rbrakk> \<Longrightarrow>
      ss [\<sqsubset>\<^sub>r] merges f qs ss \<or>
  merges f qs ss = ss \<and> {q. \<exists>t. (q,t)\<in>set qs \<and> t \<squnion>\<^bsub>f\<^esub> ss!q \<noteq> ss!q} \<union> (w-{p}) \<subset> w"
(*<*) (is "PROP ?P")
proof -
  interpret Semilat A r f by fact
  show "PROP ?P"
  apply(insert semilat)
    apply (unfold lesssub_def)
    apply (simp (no_asm_simp) add: merges_incr)
    apply (rule impI)
    apply (rule merges_same_conv [THEN iffD1, elim_format])
    apply assumption+
      defer
      apply (rule sym, assumption)
     defer apply simp
     apply (subgoal_tac "\<forall>q t. \<not>((q, t) \<in> set qs \<and> t \<squnion>\<^bsub>f\<^esub> ss ! q \<noteq> ss ! q)")
     apply (blast intro!: psubsetI elim: equalityE)
     apply clarsimp
     apply (drule bspec, assumption)
     apply (drule bspec, assumption)
     apply clarsimp
    done
qed
(*>*)

lemma iter_properties[rule_format]: assumes "Semilat A r f"
shows "\<lbrakk> acc r; pres_type step n A; mono r step n A;
     bounded step n; \<forall>p\<in>w0. p < n; ss0 \<in> list n A;
     \<forall>p<n. p \<notin> w0 \<longrightarrow> stable r step ss0 p \<rbrakk> \<Longrightarrow>
   iter f step ss0 w0 = (ss',w')
   \<longrightarrow>
   ss' \<in> list n A \<and> stables r step ss' \<and> ss0 [\<sqsubseteq>\<^sub>r] ss' \<and>
   (\<forall>ts\<in>list n A. ss0 [\<sqsubseteq>\<^sub>r] ts \<and> stables r step ts \<longrightarrow> ss' [\<sqsubseteq>\<^sub>r] ts)"
(*<*) (is "PROP ?P")
proof -
  interpret Semilat A r f by fact
  show "PROP ?P"
  apply(insert semilat)
  apply (unfold iter_def stables_def)
  apply (rule_tac P = "\<lambda>(ss,w).
   ss \<in> list n A \<and> (\<forall>p<n. p \<notin> w \<longrightarrow> stable r step ss p) \<and> ss0 [\<sqsubseteq>\<^sub>r] ss \<and>
   (\<forall>ts\<in>list n A. ss0 [\<sqsubseteq>\<^sub>r] ts \<and> stables r step ts \<longrightarrow> ss [\<sqsubseteq>\<^sub>r] ts) \<and>
   (\<forall>p\<in>w. p < n)" and
   r = "{(ss',ss) . ss [\<sqsubset>\<^sub>r] ss'} <*lex*> finite_psubset"
         in while_rule)

  -- "Invariant holds initially:"
  apply (simp add:stables_def)

  -- "Invariant is preserved:"
  apply(simp add: stables_def split_paired_all)
  apply(rename_tac ss w)
  apply(subgoal_tac "(SOME p. p \<in> w) \<in> w")
   prefer 2 apply (fast intro: someI)
  apply(subgoal_tac "\<forall>(q,t) \<in> set (step (SOME p. p \<in> w) (ss ! (SOME p. p \<in> w))). q < length ss \<and> t \<in> A")
   prefer 2
   apply clarify
   apply (rule conjI)
    apply(clarsimp, blast dest!: boundedD)
   apply (erule pres_typeD)
    prefer 3
    apply assumption
    apply (erule listE_nth_in)
    apply blast
   apply blast
  apply (subst decomp_propa)
   apply blast
  apply simp
  apply (rule conjI)
   apply (rule merges_preserves_type)
   apply blast
   apply clarify
   apply (rule conjI)
    apply(clarsimp, blast dest!: boundedD)
   apply (erule pres_typeD)
    prefer 3
    apply assumption
    apply (erule listE_nth_in)
    apply blast
   apply blast
  apply (rule conjI)
   apply clarify
   apply (blast intro!: stable_pres_lemma)
  apply (rule conjI)
   apply (blast intro!: merges_incr intro: le_list_trans)
  apply (rule conjI)
   apply clarsimp
   apply (blast intro!: merges_bounded_lemma)
  apply (blast dest!: boundedD)

  -- "Postcondition holds upon termination:"
  apply(clarsimp simp add: stables_def split_paired_all)

  -- "Well-foundedness of the termination relation:"
  apply (rule wf_lex_prod)
   apply (insert orderI [THEN acc_le_listI])
   apply (simp only: acc_def lesssub_def)
  apply (rule wf_finite_psubset)

  -- "Loop decreases along termination relation:"
  apply(simp add: stables_def split_paired_all)
  apply(rename_tac ss w)
  apply(subgoal_tac "(SOME p. p \<in> w) \<in> w")
   prefer 2 apply (fast intro: someI)
  apply(subgoal_tac "\<forall>(q,t) \<in> set (step (SOME p. p \<in> w) (ss ! (SOME p. p \<in> w))). q < length ss \<and> t \<in> A")
   prefer 2
   apply clarify
   apply (rule conjI)
    apply(clarsimp, blast dest!: boundedD)
   apply (erule pres_typeD)
    prefer 3
    apply assumption
    apply (erule listE_nth_in)
    apply blast
   apply blast
  apply (subst decomp_propa)
   apply blast
  apply clarify
  apply (simp del: listE_length
      add: lex_prod_def finite_psubset_def
           bounded_nat_set_is_finite)
  apply (rule termination_lemma)
  apply (rule assms)
  apply assumption+
  defer
  apply assumption
  apply clarsimp
  done
qed
(*>*)

lemma kildall_properties: assumes "Semilat A r f"
shows "\<lbrakk> acc r; pres_type step n A; mono r step n A;
     bounded step n; ss0 \<in> list n A \<rbrakk> \<Longrightarrow>
  kildall r f step ss0 \<in> list n A \<and>
  stables r step (kildall r f step ss0) \<and>
  ss0 [\<sqsubseteq>\<^sub>r] kildall r f step ss0 \<and>
  (\<forall>ts\<in>list n A. ss0 [\<sqsubseteq>\<^sub>r] ts \<and> stables r step ts \<longrightarrow>
                 kildall r f step ss0 [\<sqsubseteq>\<^sub>r] ts)"
(*<*) (is "PROP ?P")
proof -
  interpret Semilat A r f by fact
  show "PROP ?P"
  apply (unfold kildall_def)
  apply(case_tac "iter f step ss0 (unstables r step ss0)")
  apply(simp)
  apply (rule iter_properties)
  apply (simp_all add: unstables_def stable_def)
  apply (rule Semilat.intro)
  apply (rule semilat)
  done
qed

lemma is_bcv_kildall: assumes "Semilat A r f"
shows "\<lbrakk> acc r; top r T; pres_type step n A; bounded step n; mono r step n A \<rbrakk>
  \<Longrightarrow> is_bcv r T step n A (kildall r f step)" (is "PROP ?P")
proof -
  interpret Semilat A r f by fact
  show "PROP ?P"
  apply(unfold is_bcv_def wt_step_def)
  apply(insert `Semilat A r f` semilat kildall_properties[of A])
  apply(simp add:stables_def)
  apply clarify
  apply(subgoal_tac "kildall r f step \<tau>s\<^sub>0 \<in> list n A")
   prefer 2 apply (simp(no_asm_simp))
  apply (rule iffI)
   apply (rule_tac x = "kildall r f step \<tau>s\<^sub>0" in bexI)
    apply (rule conjI)
     apply (blast)
    apply (simp  (no_asm_simp))
   apply(assumption)
  apply clarify
  apply(subgoal_tac "kildall r f step \<tau>s\<^sub>0!p <=_r \<tau>s!p")
   apply simp
  apply (blast intro!: le_listD less_lengthI)
  done
qed
(*>*)

end