section\<open>Finite Strings\<close>
text\<open>Finite-String.thy implements a type of strings whose lengths are bounded by a constant defined
    at "proof-time", by taking a sub-type of the built-in string type. A finite length bound is
    important for applications in real analysis, specifically the Differential-Dynamic-Logic (dL)
    entry, because finite-string identifiers are used as the index of a real vector, only forming a
    Euclidean space if identifiers are finite.

    We include finite strings in this AFP entry both to promote using it as the basis of future
    versions of the dL entry and simply in case the typeclass instances herein are useful. One could
    imagine using this type in file formats with fixed-length fields.\<close>
(*  Author:     Brandon Bohrer*)

theory "Finite_String"
  imports
    Main
    "HOL-Library.Code_Target_Int"
begin

text\<open>This theory uses induction on pairs of lists often: give names to the cases\<close>
lemmas list_induct2'[case_names BothNil LeftCons RightCons BothCons] = List.list_induct2'

text\<open>Set a hard-coded global maximum string length\<close>
definition max_str:"MAX_STR = 20"

text\<open>Finite strings are strings whose size is within the maximum\<close>
typedef fin_string = "{s::string. size s \<le> MAX_STR}"
  morphisms Rep_fin_string Abs_fin_string
  apply(auto)
  apply(rule exI[where x=Nil])
  by(auto simp add: max_str)

text\<open>Lift definition of string length\<close>
setup_lifting  Finite_String.fin_string.type_definition_fin_string
lift_definition ilength::"fin_string \<Rightarrow> nat" is length done

text\<open>Product of types never decreases cardinality\<close>
lemma card_prod_finite:
  fixes C:: "char set" and S::"string set"
  assumes C:"card C \<ge> 1" and S:"card S \<ge> 0"
  shows "card C * card S \<ge> card S"
  using C S by auto

fun cons :: "('a * 'a list) \<Rightarrow> 'a list"
  where "cons (x,y) = x # y"

text\<open>Finite strings are finite\<close>
instantiation fin_string :: finite begin
instance proof
  have any:"\<forall>i::nat. card {s::string. length s \<le> i} > 0"
    apply(auto)
    subgoal for i
  proof (induct i)
    case 0
    then show ?case by auto
  next
    case (Suc k)
    assume IH:"card {s::string. length s \<le> k} > 0"
    let ?c = "(UNIV::char set)"
    let ?ih = "{s::string. length s \<le> k}"
    let ?prod = "(?c \<times> ?ih)"
    let ?b = "(cons ` ?prod)"
    let ?A = "{s::string. length s \<le> Suc k}"
    let ?B = "insert [] ?b"
    have IHfin:"finite ?ih" using IH card_ge_0_finite by blast
    have finChar:"finite ?c" using card_ge_0_finite finite_code by blast
    have finiteProd:"finite ?prod"
      using Groups_Big.card_cartesian_product IHfin finChar by auto
    have cardCons:"card ?b = card ?prod"
      apply(rule Finite_Set.card_image)
      by(auto simp add: inj_on_def)
    have finiteCons:"finite ?b" using cardCons finiteProd card_ge_0_finite by blast
    have finiteB:"finite ?B" using finite_insert finiteCons by auto
    have lr:"\<And>x. x \<in> ?A \<Longrightarrow> x \<in> ?B" subgoal for x
      apply(auto) apply(cases x) apply auto
      by (metis UNIV_I cons.simps image_eqI mem_Collect_eq mem_Sigma_iff) done
    have rl:"\<And>x. x \<in> ?B \<Longrightarrow> x \<in> ?A" subgoal for x
      by(auto) done
    have isCons:"?A = ?B"
      using lr rl by auto
  show ?case
      using finiteB isCons IH by (simp add: card_insert)
  qed
  done
  note finMax = card_ge_0_finite[OF spec[OF any, of MAX_STR]]
  have fin:"finite {x | x y . x = Abs_fin_string y \<and> y \<in> {s. length s \<le> MAX_STR}}"
    using Abs_fin_string_cases finMax by auto
  have univEq:"UNIV = {x | x y . x = Abs_fin_string y \<and> y \<in> {s. length s \<le> MAX_STR}}"
    using Abs_fin_string_cases
    by (metis (mono_tags, lifting) Collect_cong UNIV_I top_empty_eq top_set_def)
  then have "finite (UNIV :: fin_string set)" using univEq fin by auto
  then show "finite (UNIV::fin_string set)" by auto
qed
end

text\<open>Characters are linearly ordered by their code value\<close>
instantiation char :: linorder begin
definition less_eq_char where
less_eq_char[code]:"less_eq_char x  y \<equiv> int_of_char x \<le> int_of_char y"
definition less_char where
less_char[code]:"less_char x y \<equiv> int_of_char x < int_of_char y"
instance
  by(standard, auto simp add: less_char less_eq_char int_of_char_def)+
end

text\<open>Finite strings are linearly ordered, lexicographically\<close>
instantiation fin_string :: linorder begin
fun lleq_charlist :: "char list \<Rightarrow> char list \<Rightarrow> bool"
  where
  "lleq_charlist Nil Nil = True"
| "lleq_charlist Nil _ = True"
| "lleq_charlist _ Nil = False"
| "lleq_charlist (x # xs)(y # ys) =
   (if x = y then lleq_charlist xs ys else x < y)"

fun less_charlist :: "char list \<Rightarrow> char list \<Rightarrow> bool"
  where
  "less_charlist Nil Nil = False"
| "less_charlist Nil _ = True"
| "less_charlist _ Nil = False"
| "less_charlist (x # xs)(y # ys) =
   (if x = y then less_charlist xs ys else x < y)"

lift_definition less_eq_fin_string::"fin_string \<Rightarrow> fin_string \<Rightarrow> bool" is lleq_charlist done
lift_definition less_fin_string::"fin_string \<Rightarrow> fin_string \<Rightarrow> bool" is less_charlist done

lemma lleq_head:
  fixes L1 L2 x
  assumes a:
  "(\<And>z. lleq_charlist L2 z \<Longrightarrow> lleq_charlist L1 z)"
  "lleq_charlist L1 L2"
  "lleq_charlist (x # L2) w"
  shows "lleq_charlist (x # L1) w"
  using a by(induction arbitrary: x rule: List.list_induct2', auto)

lemma lleq_less:
  fixes x y
  shows "(less_charlist x y) = (lleq_charlist x y \<and> \<not> lleq_charlist y  x)"
  by(induction rule: List.list_induct2', auto)

lemma lleq_refl:
  fixes x
  shows "lleq_charlist x x"
  by(induction x, auto)

lemma lleq_trans:
  fixes x y z
  shows "lleq_charlist x y \<Longrightarrow> lleq_charlist y z \<Longrightarrow> lleq_charlist x z"
proof(induction arbitrary: z rule: list_induct2')
  case BothNil
  then show ?case  by auto
next
  case (LeftCons x xs)
  then show ?case
    apply(induction y)
    using lleq_charlist.elims(2) lleq_charlist.simps(2) by blast+
next
  case (RightCons y ys)
  then show ?case by auto
next
  case (BothCons x xs y ys z)
  then show ?case
    using lleq_head[of xs ys x z] apply(cases "x = y", auto)
    apply(cases z, auto)
    subgoal for a list
    by(cases "x = a", auto)
    done
qed

lemma lleq_antisym:
  fixes x y
  shows "lleq_charlist x y \<Longrightarrow> lleq_charlist y x \<Longrightarrow> x = y"
proof(induction rule: list_induct2')
     case (LeftCons x xs)      then show ?case by(cases "xs=y",auto)
next case (RightCons y ys)     then show ?case by(cases "x=ys",auto)
next case (BothCons x xs y ys) then show ?case by(cases "x=y", auto)
qed (auto)

lemma lleq_dichotomy:
  fixes x y
  shows "lleq_charlist x y \<or> lleq_charlist y x"
  by(induction rule: List.list_induct2',auto)

instance
  apply(standard)
      unfolding less_eq_fin_string_def less_fin_string_def
      apply (auto simp add: lleq_less lleq_refl lleq_trans lleq_dichotomy)
  using lleq_antisym less_eq_fin_string_def less_fin_string_def Rep_fin_string_inject by blast
end

fun string_expose::"string \<Rightarrow> (unit + (char * string))"
  where "string_expose Nil = Inl ()"
  | "string_expose (c#cs) = Inr(c,cs)"

fun string_cons::"char \<Rightarrow> string \<Rightarrow> string"
  where "string_cons c s = (if length s \<ge> MAX_STR then s else c # s)"

lift_definition fin_string_empty::fin_string is "''''" by(auto simp add: max_str)
lift_definition fin_string_cons::"char \<Rightarrow> fin_string \<Rightarrow> fin_string" is "string_cons" by auto
lift_definition fin_string_expose::"fin_string \<Rightarrow> (unit + (char*fin_string))" is string_expose
  apply(auto simp add: dual_order.trans less_imp_le pred_sum.simps string_expose.elims)
  by (metis dual_order.trans impossible_Cons le_cases string_expose.elims)

text\<open>Helper functions for enum typeclass instance\<close>
fun fin_string_upto :: "nat \<Rightarrow> fin_string list"
  where
  "fin_string_upto 0 = [fin_string_empty]"
| "fin_string_upto (Suc k) =
 (let r = fin_string_upto k in
  let ab =  (enum_class.enum::char list) in
  fin_string_empty # concat (map (\<lambda> c. map (\<lambda>s. fin_string_cons c  s) r) ab))"

lemma mem_appL:"List.member L1 x \<Longrightarrow> List.member (L1 @ L2) x"
  apply(induction L1 arbitrary: L2)
  by(auto simp add: member_rec)

lemma mem_appR:"List.member L2 x \<Longrightarrow> List.member (L1 @ L2) x"
  apply(induction L1 arbitrary: L2)
  by(auto simp add: member_rec)

lemma mem_app_or:"List.member (L1 @ L2) x = List.member L1 x \<or> List.member L2 x"
  unfolding member_def by auto

lemma fin_string_nil:
  fixes n
  shows "List.member (fin_string_upto n) fin_string_empty"
  by(induction n, auto simp add: member_rec Let_def fin_string_empty_def)

text\<open>List of every string. Not practical for code generation but used to show strings are an enum\<close>
definition vals_def[code]:"vals \<equiv> fin_string_upto MAX_STR"

definition fin_string_enum :: "fin_string list"
  where "fin_string_enum = vals"
definition fin_string_enum_all :: "(fin_string \<Rightarrow> bool) \<Rightarrow> bool"
  where "fin_string_enum_all = (\<lambda> f. list_all f vals)"
definition fin_string_enum_ex :: "(fin_string \<Rightarrow> bool) \<Rightarrow> bool"
  where "fin_string_enum_ex = (\<lambda> f. list_ex f vals)"

text\<open>Induct on the length of a bounded list, with access to index of element\<close>
lemma length_induct:
  fixes P
  assumes len:"length L \<le> MAX_STR"
  assumes BC:"P [] 0"
  assumes IS:"(\<And>k x xs.  P xs k \<Longrightarrow> P ((x # xs)) (Suc k))"
  shows "P L (length L)"
  proof -
    have "\<And>k.  length L = k \<Longrightarrow> k \<le> MAX_STR \<Longrightarrow> P L (length L)"
    proof (induction L)
      case Nil then show ?case using BC by auto
    next
      case (Cons a L)
      then have it:"P (L) (length L)" using less_imp_le by fastforce
      then show ?case  using IS[OF it, of a] by (auto)
    qed
  then show ?thesis using BC IS len by auto
  qed

text\<open>Induct on length of fin-string\<close>
lemma ilength_induct:
  fixes P
  assumes BC:"P fin_string_empty 0"
  assumes IS:"(\<And>k x xs.  P xs k \<Longrightarrow> P (Abs_fin_string (x # Rep_fin_string xs)) (Suc k))"
  shows  "P L (ilength L)"
  apply(cases L)
  apply(unfold ilength_def)
  apply(auto simp add: Abs_fin_string_inverse)
  subgoal for y
  proof -
    assume a1:"L = Abs_fin_string y"
    assume a2:" length y \<le> MAX_STR "
    have main:"\<And>k. L = Abs_fin_string y \<Longrightarrow> length y = k \<Longrightarrow> k \<le> MAX_STR
        \<Longrightarrow> P (Abs_fin_string y) (length y)"
      subgoal for k
        apply(induction y arbitrary: k L)
        subgoal for k using BC unfolding fin_string_empty_def by auto
        subgoal for a y k L
        proof -
          assume IH:"(\<And>k L. L = Abs_fin_string y \<Longrightarrow> length y = k \<Longrightarrow> k \<le> MAX_STR
            \<Longrightarrow> P (Abs_fin_string y) (length y))"
          assume L:"L = Abs_fin_string (a # y)"
          assume l:"length (a # y) = k"
          assume str:"k \<le> MAX_STR"
          have yLen:"length y < MAX_STR" using l str by auto
          have it:"P (Abs_fin_string y) (length y)"
            using IH[of "Abs_fin_string y" "k-1", OF refl] using L l str by auto
          show  "P (Abs_fin_string (a # y)) (length (a # y))"
            using IS[OF it, of a] apply (auto simp add: fin_string_cons_def Abs_fin_string_inverse)
            apply(cases "MAX_STR \<le> length (Rep_fin_string (Abs_fin_string y))")
            using yLen by(auto simp add: l yLen Abs_fin_string_inverse)
        qed
        done
      done
    show ?thesis
      apply(rule main)
      using BC IS a1 a2 by auto
  qed
  done

lemma enum_chars:"set (enum_class.enum::char list)= UNIV"
  using Enum.enum_class.enum_UNIV by auto

lemma member_concat:"List.member (concat LL) x = (\<exists>L. List.member LL L \<and> List.member L x)"
  by(auto simp add: member_def)

text\<open>fin-string-upto k enumerates all strings up to length $min(k,MAX\_STR)$\<close>
lemma fin_string_length:
  fixes L::string
  assumes len:"length L \<le> k"
  assumes Len:"length L \<le> MAX_STR"
  shows "List.member (fin_string_upto k) (Abs_fin_string L)"
proof -
  have BC:"\<forall>j\<ge>0. 0 \<le> MAX_STR \<longrightarrow> length [] = 0 \<longrightarrow>
    List.member (fin_string_upto j) (Abs_fin_string [])"
    apply(auto)
    subgoal for j
      apply(cases j)
      by (auto simp add: fin_string_empty_def member_rec)
    done
  have IS:"(\<And>k x xs.
      \<forall>j\<ge>k. k\<le>MAX_STR \<longrightarrow> length xs=k \<longrightarrow> List.member (fin_string_upto j) (Abs_fin_string xs)\<Longrightarrow>
      \<forall>j\<ge>Suc k. Suc k \<le> MAX_STR \<longrightarrow> length (x # xs) = Suc k
        \<longrightarrow> List.member (fin_string_upto j) (Abs_fin_string (x # xs)))"
    subgoal for k x xs
    proof -
      assume "\<forall>j\<ge>k. k \<le> MAX_STR \<longrightarrow> length xs = k
        \<longrightarrow> List.member (fin_string_upto j) (Abs_fin_string xs)"
      then have IH:"\<And>j. j\<ge> k \<Longrightarrow> k \<le> MAX_STR \<Longrightarrow> length xs = k
        \<Longrightarrow> List.member (fin_string_upto j) (Abs_fin_string xs)"
        by auto
      show ?thesis
        apply(auto)
        subgoal for j
        proof -
          assume kj:"Suc (length xs) \<le> j"
          assume sucMax:"Suc (length xs) \<le> MAX_STR"
          assume ilen:" k = length xs"
          obtain jj where jj[simp]:"j = Suc jj" using kj Suc_le_D by auto
          then have kMax:"k < MAX_STR" using jj kj Suc_le_D ilen
            by (simp add: less_eq_Suc_le sucMax)
           have res:"List.member (fin_string_upto (jj)) (Abs_fin_string xs)"
            using IH[of "jj"] kj jj ilen  Suc_leD sucMax by blast
          have neq:"Abs_fin_string [] \<noteq> Abs_fin_string (x # xs)"
            using Abs_fin_string_inverse fin_string_empty.abs_eq fin_string_empty.rep_eq
              len length_Cons list.distinct(1) mem_Collect_eq
            by (metis ilen sucMax)
          have univ:" set enum_class.enum  = (UNIV::char set)" using enum_chars by auto
          have "List.member (fin_string_upto j) (Abs_fin_string (x # xs))"
            apply(auto simp add: member_rec(2) fin_string_empty_def)
            using len sucMax
            apply(auto simp add: member_rec fin_string_empty_def fin_string_cons_def
                Abs_fin_string_inverse Rep_fin_string_inverse neq)
          proof -
            let ?witLL = "(\<lambda> x. map (map_fun Rep_fin_string Abs_fin_string (string_cons x))
                            (fin_string_upto jj))"
            have f1: "Abs_fin_string xs \<in> set (fin_string_upto jj)"
                by (metis member_def res)
            have f2:"Abs_fin_string (x # xs) = Abs_fin_string
                      (if MAX_STR \<le> length (Rep_fin_string (Abs_fin_string xs))
                       then Rep_fin_string (Abs_fin_string xs)
                       else x # Rep_fin_string (Abs_fin_string xs))"
                using Abs_fin_string_inverse ilen kMax by auto
            have ex:"\<exists> LL. (List.member (map ?witLL enum_class.enum) LL)
                          \<and> List.member LL (Abs_fin_string (x # xs))"
              apply(rule exI[where x="?witLL x"])
              apply(auto simp add: member_def univ)
              using f1 f2 by blast
            show "List.member (concat (map ?witLL enum_class.enum))
                    (Abs_fin_string (x # xs))"
              using member_concat ex by fastforce
          qed
          then show "List.member (fin_string_upto j) (Abs_fin_string (x # xs))"  by auto
        qed
        done
    qed
    done
  have impl:"length L \<le> k \<Longrightarrow> List.member (fin_string_upto k) (Abs_fin_string L)"
    using len Len
    length_induct[where P = "(\<lambda> L k. \<forall> j \<ge> k. k \<le> MAX_STR \<longrightarrow> length L = k
        \<longrightarrow> List.member (fin_string_upto j) (Abs_fin_string L))"
      , OF Len BC IS]
      by auto
    show ?thesis
    using impl len by auto
qed

lemma fin_string_upto_length:
  shows "List.member (fin_string_upto n) L \<Longrightarrow> ilength L \<le> n"
  apply(induction n arbitrary: L)
   apply(auto simp add: fin_string_empty_def Let_def ilength_def fin_string_cons_def
     Rep_fin_string_inverse Abs_fin_string_inverse member_rec)
proof -
  fix n L
  let ?witLL = "(\<lambda>x. map(map_fun Rep_fin_string Abs_fin_string(string_cons x))(fin_string_upto n))"
  assume len:"(\<And>L. List.member (fin_string_upto n) L \<Longrightarrow> length (Rep_fin_string L) \<le> n)"
  assume mem:"List.member (concat (map ?witLL enum_class.enum)) L"
  have L:"List.member (fin_string_upto n) L \<Longrightarrow> length (Rep_fin_string L) \<le> Suc n"
    using len[of L] by auto
  assume a:"List.member (concat (map ?witLL enum_class.enum)) L"
  obtain LL where conc:"List.member (map ?witLL enum_class.enum) LL"
    and concmem:"List.member LL L"
    using member_concat a by metis
  obtain c cs where c:"L = fin_string_cons c cs" and cs:"List.member (fin_string_upto n) cs"
    using a conc unfolding member_def apply(auto)
    subgoal for c d cs
      apply(cases "MAX_STR \<le> length (Rep_fin_string cs)")
      apply(auto simp add: Rep_fin_string_inverse)
      by (metis (full_types) Rep_fin_string_inverse fin_string_cons.rep_eq string_cons.simps)+
    done
  then have "ilength (fin_string_cons c cs) \<le> (Suc n)"
    using len[of cs] unfolding ilength_def fin_string_cons_def
    apply (auto simp add: Rep_fin_string_inverse)
    using c fin_string_cons.rep_eq by force
  then show "length (Rep_fin_string L) \<le> Suc n"
    using c ilength.rep_eq by auto
qed

text\<open>fin-string-upto produces no duplicate identifiers\<close>
lemma distinct_upto:
  shows "i \<le> MAX_STR \<Longrightarrow> distinct (fin_string_upto i)"
proof (induction i)
  case 0
  then show ?case by(auto)
next
  case (Suc j) then
  have jLen:"Suc j \<le> MAX_STR"
    and IH:"distinct (fin_string_upto j)" by auto
  have distinct_char:"distinct (enum_class.enum:: char list)"
    by (auto simp add: distinct_map enum_char_unfold)
  have diseq:"\<And> x y. y \<in> set (fin_string_upto j) \<Longrightarrow>  fin_string_empty \<noteq> fin_string_cons x y"
    using Rep_fin_string_inverse jLen apply(auto simp add: fin_string_empty_def fin_string_cons_def)
    using fin_string_empty.rep_eq le_zero_eq list.size not_less_eq_eq zero_le Abs_fin_string_inject
    by (metis,auto)
  show ?case
    apply(auto simp add: Let_def)
    subgoal for x xa using diseq by auto
    apply(rule distinct_concat)
    subgoal
      apply(auto simp add: distinct_map)
       apply(rule distinct_char)
      apply(rule subset_inj_on[where B=UNIV])
       apply(rule injI)
       apply(auto simp add: fin_string_cons_def)
    proof -
      fix x y
      let ?l = "(\<lambda>xa x. Abs_fin_string
        (if MAX_STR \<le> length (Rep_fin_string xa)
         then Rep_fin_string xa
         else x # Rep_fin_string xa))"
      assume a1:"\<forall>xa\<in>set (fin_string_upto j). ?l xa x = ?l xa y"
      then have a2:"\<And>xa. (List.member (fin_string_upto j) xa) \<Longrightarrow> ?l xa x = ?l xa y"
        using  member_def by force
      then have "Abs_fin_string [x] = Abs_fin_string [y] \<or> (MAX_STR::nat) = 0"
        using a2 fin_string_empty.rep_eq fin_string_nil by force
      then show "x = y"
        by (metis Abs_fin_string_inverse jLen le_zero_eq length_Cons list.inject list.size(3)
            mem_Collect_eq nat.distinct(1) not_less_eq_eq)
    qed
    subgoal for ys
      apply(auto simp add: fin_string_cons_def)
    proof -
      fix c :: char
      assume c:"c \<in> set enum_class.enum"
      assume ys:"ys=map(map_fun Rep_fin_string Abs_fin_string (string_cons c)) (fin_string_upto j)"
      show"distinct(map(map_fun Rep_fin_string Abs_fin_string (string_cons c)) (fin_string_upto j))"
        unfolding distinct_map apply(rule conjI)
         apply(rule IH)
        apply(rule inj_onI)
        apply(auto)
        subgoal for x y
          using jLen fin_string_upto_length[of j x] fin_string_upto_length[of j y]
          unfolding List.member_def ilength_def apply auto
          by (metis (mono_tags, hide_lams) Rep_fin_string_inverse fin_string_cons.rep_eq le_trans
              list.inject not_less_eq_eq string_cons.simps)
          done
      qed
      apply(auto simp add: fin_string_cons_def)
      subgoal for c ca xa xb xc
        apply(cases "MAX_STR \<le> length (Rep_fin_string xa)")
         apply (metis fin_string_upto_length jLen ilength.rep_eq le_trans member_def not_less_eq_eq)
        apply(cases "MAX_STR \<le> length (Rep_fin_string xb)")
         apply(metis fin_string_upto_length jLen ilength.rep_eq le_trans member_def not_less_eq_eq)
        apply(cases "MAX_STR \<le> length (Rep_fin_string xc)")
         by(auto,metis Rep_fin_string_inverse fin_string_cons.rep_eq list.inject string_cons.simps)
      done
  qed

text\<open>Finite strings are an enumeration type\<close>
instantiation fin_string :: enum begin
definition enum_fin_string
  where enum_fin_string_def[code]:"enum_fin_string \<equiv> fin_string_enum"
definition enum_all_fin_string
  where enum_all_fin_string[code]:"enum_all_fin_string \<equiv> fin_string_enum_all"
definition enum_ex_fin_string
  where enum_ex_fin_string[code]:"enum_ex_fin_string \<equiv> fin_string_enum_ex"
lemma enum_ALL:"(UNIV::fin_string set) = set enum_class.enum"
  apply(auto simp add:enum_fin_string_def fin_string_enum_def vals_def)
  by(metis fin_string_length List.member_def mem_Collect_eq Abs_fin_string_cases)

lemma vals_ALL:"set (vals::fin_string list) = UNIV"
  using enum_ALL vals_def Rep_fin_string fin_string_length ilength.rep_eq member_def
  by(metis (mono_tags) Rep_fin_string_inverse UNIV_eq_I mem_Collect_eq)

lemma setA:
  assumes set:"\<And>y. y \<in> set L \<Longrightarrow> P y"
  shows "list_all P L"
  using set  by (simp add: list.pred_set)

lemma setE:
  assumes set:" y \<in> set L"
  assumes P:"P y"
  shows "list_ex P L"
  using set P  list_ex_iff by auto

instance
  apply(standard)
  apply(rule enum_ALL)
  by (auto simp add: fin_string_enum_all_def list_all_iff vals_ALL setA setE enum_all_fin_string
      enum_ALL fin_string_enum_def vals_def enum_fin_string_def distinct_upto list_ex_iff
      enum_ex_fin_string fin_string_enum_ex_def)
end

instantiation fin_string :: equal begin
definition equal_fin_string :: "fin_string \<Rightarrow> fin_string \<Rightarrow> bool"
  where [code]:"equal_fin_string X Y = (X \<le> Y \<and> Y \<le> X)"
instance
  apply(standard)
  by(auto simp add: equal_fin_string_def)
end
end


theory sort_MSortBU2Permutes
imports Main
        "$HIPSTER_HOME/IsaHipster"
begin

datatype 'a list = Nil2 | Cons2 "'a" "'a list"

datatype Nat = Z | S "Nat"

fun risers :: "int list => (int list) list" where
"risers (Nil2) = Nil2"
| "risers (Cons2 y (Nil2)) = Cons2 (Cons2 y (Nil2)) (Nil2)"
| "risers (Cons2 y (Cons2 y2 xs)) =
     (if y <= y2 then
        case risers (Cons2 y2 xs) of
          | Nil2 => risers (Cons2 y2 xs)
          | Cons2 ys yss => Cons2 (Cons2 y ys) yss
        end
        else
        Cons2 (Cons2 y (Nil2)) (risers (Cons2 y2 xs)))"

fun lmerge :: "int list => int list => int list" where
"lmerge (Nil2) y = y"
| "lmerge (Cons2 z x2) (Nil2) = Cons2 z x2"
| "lmerge (Cons2 z x2) (Cons2 x3 x4) =
     (if z <= x3 then Cons2 z (lmerge x2 (Cons2 x3 x4)) else
        Cons2 x3 (lmerge (Cons2 z x2) x4))"

fun pairwise :: "(int list) list => (int list) list" where
"pairwise (Nil2) = Nil2"
| "pairwise (Cons2 xs (Nil2)) = Cons2 xs (Nil2)"
| "pairwise (Cons2 xs (Cons2 ys xss)) =
     Cons2 (lmerge xs ys) (pairwise xss)"

fun mergingbu2 :: "(int list) list => int list" where
"mergingbu2 (Nil2) = Nil2"
| "mergingbu2 (Cons2 xs (Nil2)) = xs"
| "mergingbu2 (Cons2 xs (Cons2 z x2)) =
     mergingbu2 (pairwise (Cons2 xs (Cons2 z x2)))"

fun dot :: "('b => 'c) => ('a => 'b) => 'a => 'c" where
"dot x y z = x (y z)"

fun msortbu2 :: "int list => int list" where
"msortbu2 x =
   dot
     (% (y :: (int list) list) => mergingbu2 y)
     (% (z :: int list) => risers z) x"

fun count :: "int => int list => Nat" where
"count x (Nil2) = Z"
| "count x (Cons2 z xs) =
     (if x = z then S (count x xs) else count x xs)"

(*hipster risers lmerge pairwise mergingbu2 dot msortbu2 count *)

theorem x0 :
  "!! (x :: int) (y :: int list) .
     (count x (msortbu2 y)) = (count x y)"
  by (tactic \<open>Subgoal.FOCUS_PARAMS (K (Tactic_Data.hard_tac @{context})) @{context} 1\<close>)

end


(*
 * Copyright 2020, Data61, CSIRO (ABN 41 687 119 230)
 *
 * SPDX-License-Identifier: BSD-2-Clause
 *)

theory BenchBasics
  imports Benchmark
begin

lemma five_less_than_ten: "(5 :: nat) < 10"
  by simp

lemma p_or_not_p: "p \<or> \<not> p"
  by blast

lemma twelve_equals_six_plus_six: "(12 = (6 + 6 :: nat))"
  by simp

lemma twelve_equals_six_plus_six': "(12 = (6 + 6 :: nat)) \<equiv> True"
  by simp

lemma true_conj1: "True \<and> P \<equiv> P"
  by simp

lemma disj_flip: "(a \<or> b) = (b \<or> a)"
  by (rule disj_commute)

lemma disj_flip': "a \<or> b \<equiv> b \<or> a"
  apply (rule eq_reflection)
  apply (rule disj_commute)
  done

ML_file "bench_basics.ML"

end


(*
  File: GCD_Impl.thy
  Author: Bohua Zhan
*)

theory GCD_Impl
  imports SepAuto
begin

text \<open>A tutorial example for computation of GCD.\<close>

text \<open>Turn on auto2's trace\<close>
declare [[print_trace]]

text \<open>Property of gcd that justifies the recursive computation. Add as a
  right-to-left rewrite rule.\<close>
setup \<open>add_rewrite_rule_back @{thm gcd_red_nat}\<close>

text \<open>Functional version of gcd.\<close>
fun gcd_fun :: "nat \<Rightarrow> nat \<Rightarrow> nat" where
  "gcd_fun a b = (if b = 0 then a else gcd_fun b (a mod b))"

text \<open>The fun package automatically generates induction rule upon showing
  termination. This adds the induction rule for the @fun\_induct command.\<close>
setup \<open>add_fun_induct_rule (@{term gcd_fun}, @{thm gcd_fun.induct})\<close>

lemma gcd_fun_correct:
  "gcd_fun a b = gcd a b"
@proof
  @fun_induct "gcd_fun a b"
  @unfold "gcd_fun a b"
@qed

text \<open>Imperative version of gcd.\<close>
partial_function (heap) gcd_impl :: "nat \<Rightarrow> nat \<Rightarrow> nat Heap" where
  "gcd_impl a b = (
    if b = 0 then return a
    else do {
      c \<leftarrow> return (a mod b);
      r \<leftarrow> gcd_impl b c;
      return r
    })"

text \<open>The program is sufficiently simple that we can prove the Hoare triple
  directly (without going through the functional program).\<close>
theorem gcd_impl_correct:
  "<emp> gcd_impl a b <\<lambda>r. \<up>(r = gcd a b)>"
@proof
  @fun_induct "gcd_fun a b"
@qed

text \<open>Turn off trace.\<close>
declare [[print_trace = false]]

end


(*  Title:      ZF/Constructible/Wellorderings.thy
    Author:     Lawrence C Paulson, Cambridge University Computer Laboratory
*)

section \<open>Relativized Wellorderings\<close>

theory Wellorderings imports Relative begin

text\<open>We define functions analogous to @{term ordermap} @{term ordertype}
      but without using recursion.  Instead, there is a direct appeal
      to Replacement.  This will be the basis for a version relativized
      to some class \<open>M\<close>.  The main result is Theorem I 7.6 in Kunen,
      page 17.\<close>

subsection\<open>Wellorderings\<close>

definition
  irreflexive :: "[i=>o,i,i]=>o" where
    "irreflexive(M,A,r) == \<forall>x[M]. x\<in>A \<longrightarrow> <x,x> \<notin> r"

definition
  transitive_rel :: "[i=>o,i,i]=>o" where
    "transitive_rel(M,A,r) ==
        \<forall>x[M]. x\<in>A \<longrightarrow> (\<forall>y[M]. y\<in>A \<longrightarrow> (\<forall>z[M]. z\<in>A \<longrightarrow>
                          <x,y>\<in>r \<longrightarrow> <y,z>\<in>r \<longrightarrow> <x,z>\<in>r))"

definition
  linear_rel :: "[i=>o,i,i]=>o" where
    "linear_rel(M,A,r) ==
        \<forall>x[M]. x\<in>A \<longrightarrow> (\<forall>y[M]. y\<in>A \<longrightarrow> <x,y>\<in>r | x=y | <y,x>\<in>r)"

definition
  wellfounded :: "[i=>o,i]=>o" where
    \<comment>\<open>EVERY non-empty set has an \<open>r\<close>-minimal element\<close>
    "wellfounded(M,r) ==
        \<forall>x[M]. x\<noteq>0 \<longrightarrow> (\<exists>y[M]. y\<in>x & ~(\<exists>z[M]. z\<in>x & <z,y> \<in> r))"
definition
  wellfounded_on :: "[i=>o,i,i]=>o" where
    \<comment>\<open>every non-empty SUBSET OF \<open>A\<close> has an \<open>r\<close>-minimal element\<close>
    "wellfounded_on(M,A,r) ==
        \<forall>x[M]. x\<noteq>0 \<longrightarrow> x\<subseteq>A \<longrightarrow> (\<exists>y[M]. y\<in>x & ~(\<exists>z[M]. z\<in>x & <z,y> \<in> r))"

definition
  wellordered :: "[i=>o,i,i]=>o" where
    \<comment>\<open>linear and wellfounded on \<open>A\<close>\<close>
    "wellordered(M,A,r) ==
        transitive_rel(M,A,r) & linear_rel(M,A,r) & wellfounded_on(M,A,r)"

subsubsection \<open>Trivial absoluteness proofs\<close>

lemma (in M_basic) irreflexive_abs [simp]:
     "M(A) ==> irreflexive(M,A,r) \<longleftrightarrow> irrefl(A,r)"
by (simp add: irreflexive_def irrefl_def)

lemma (in M_basic) transitive_rel_abs [simp]:
     "M(A) ==> transitive_rel(M,A,r) \<longleftrightarrow> trans[A](r)"
by (simp add: transitive_rel_def trans_on_def)

lemma (in M_basic) linear_rel_abs [simp]:
     "M(A) ==> linear_rel(M,A,r) \<longleftrightarrow> linear(A,r)"
by (simp add: linear_rel_def linear_def)

lemma (in M_basic) wellordered_is_trans_on:
    "[| wellordered(M,A,r); M(A) |] ==> trans[A](r)"
by (auto simp add: wellordered_def)

lemma (in M_basic) wellordered_is_linear:
    "[| wellordered(M,A,r); M(A) |] ==> linear(A,r)"
by (auto simp add: wellordered_def)

lemma (in M_basic) wellordered_is_wellfounded_on:
    "[| wellordered(M,A,r); M(A) |] ==> wellfounded_on(M,A,r)"
by (auto simp add: wellordered_def)

lemma (in M_basic) wellfounded_imp_wellfounded_on:
    "[| wellfounded(M,r); M(A) |] ==> wellfounded_on(M,A,r)"
by (auto simp add: wellfounded_def wellfounded_on_def)

lemma (in M_basic) wellfounded_on_subset_A:
     "[| wellfounded_on(M,A,r);  B<=A |] ==> wellfounded_on(M,B,r)"
by (simp add: wellfounded_on_def, blast)

subsubsection \<open>Well-founded relations\<close>

lemma  (in M_basic) wellfounded_on_iff_wellfounded:
     "wellfounded_on(M,A,r) \<longleftrightarrow> wellfounded(M, r \<inter> A*A)"
apply (simp add: wellfounded_on_def wellfounded_def, safe)
 apply force
apply (drule_tac x=x in rspec, assumption, blast)
done

lemma (in M_basic) wellfounded_on_imp_wellfounded:
     "[|wellfounded_on(M,A,r); r \<subseteq> A*A|] ==> wellfounded(M,r)"
by (simp add: wellfounded_on_iff_wellfounded subset_Int_iff)

lemma (in M_basic) wellfounded_on_field_imp_wellfounded:
     "wellfounded_on(M, field(r), r) ==> wellfounded(M,r)"
by (simp add: wellfounded_def wellfounded_on_iff_wellfounded, fast)

lemma (in M_basic) wellfounded_iff_wellfounded_on_field:
     "M(r) ==> wellfounded(M,r) \<longleftrightarrow> wellfounded_on(M, field(r), r)"
by (blast intro: wellfounded_imp_wellfounded_on
                 wellfounded_on_field_imp_wellfounded)

(*Consider the least z in domain(r) such that P(z) does not hold...*)
lemma (in M_basic) wellfounded_induct:
     "[| wellfounded(M,r); M(a); M(r); separation(M, \<lambda>x. ~P(x));
         \<forall>x. M(x) & (\<forall>y. <y,x> \<in> r \<longrightarrow> P(y)) \<longrightarrow> P(x) |]
      ==> P(a)"
apply (simp (no_asm_use) add: wellfounded_def)
apply (drule_tac x="{z \<in> domain(r). ~P(z)}" in rspec)
apply (blast dest: transM)+
done

lemma (in M_basic) wellfounded_on_induct:
     "[| a\<in>A;  wellfounded_on(M,A,r);  M(A);
       separation(M, \<lambda>x. x\<in>A \<longrightarrow> ~P(x));
       \<forall>x\<in>A. M(x) & (\<forall>y\<in>A. <y,x> \<in> r \<longrightarrow> P(y)) \<longrightarrow> P(x) |]
      ==> P(a)"
apply (simp (no_asm_use) add: wellfounded_on_def)
apply (drule_tac x="{z\<in>A. z\<in>A \<longrightarrow> ~P(z)}" in rspec)
apply (blast intro: transM)+
done

subsubsection \<open>Kunen's lemma IV 3.14, page 123\<close>

lemma (in M_basic) linear_imp_relativized:
     "linear(A,r) ==> linear_rel(M,A,r)"
by (simp add: linear_def linear_rel_def)

lemma (in M_basic) trans_on_imp_relativized:
     "trans[A](r) ==> transitive_rel(M,A,r)"
by (unfold transitive_rel_def trans_on_def, blast)

lemma (in M_basic) wf_on_imp_relativized:
     "wf[A](r) ==> wellfounded_on(M,A,r)"
apply (simp add: wellfounded_on_def wf_def wf_on_def, clarify)
apply (drule_tac x=x in spec, blast)
done

lemma (in M_basic) wf_imp_relativized:
     "wf(r) ==> wellfounded(M,r)"
apply (simp add: wellfounded_def wf_def, clarify)
apply (drule_tac x=x in spec, blast)
done

lemma (in M_basic) well_ord_imp_relativized:
     "well_ord(A,r) ==> wellordered(M,A,r)"
by (simp add: wellordered_def well_ord_def tot_ord_def part_ord_def
       linear_imp_relativized trans_on_imp_relativized wf_on_imp_relativized)

text\<open>The property being well founded (and hence of being well ordered) is not absolute:
the set that doesn't contain a minimal element may not exist in the class M.
However, every set that is well founded in a transitive model M is well founded (page 124).\<close>

subsection\<open>Relativized versions of order-isomorphisms and order types\<close>

lemma (in M_basic) order_isomorphism_abs [simp]:
     "[| M(A); M(B); M(f) |]
      ==> order_isomorphism(M,A,r,B,s,f) \<longleftrightarrow> f \<in> ord_iso(A,r,B,s)"
by (simp add: apply_closed order_isomorphism_def ord_iso_def)

lemma (in M_basic) pred_set_abs [simp]:
     "[| M(r); M(B) |] ==> pred_set(M,A,x,r,B) \<longleftrightarrow> B = Order.pred(A,x,r)"
apply (simp add: pred_set_def Order.pred_def)
apply (blast dest: transM)
done

lemma (in M_basic) pred_closed [intro,simp]:
     "[| M(A); M(r); M(x) |] ==> M(Order.pred(A,x,r))"
apply (simp add: Order.pred_def)
apply (insert pred_separation [of r x], simp)
done

lemma (in M_basic) membership_abs [simp]:
     "[| M(r); M(A) |] ==> membership(M,A,r) \<longleftrightarrow> r = Memrel(A)"
apply (simp add: membership_def Memrel_def, safe)
  apply (rule equalityI)
   apply clarify
   apply (frule transM, assumption)
   apply blast
  apply clarify
  apply (subgoal_tac "M(<xb,ya>)", blast)
  apply (blast dest: transM)
 apply auto
done

lemma (in M_basic) M_Memrel_iff:
     "M(A) ==>
      Memrel(A) = {z \<in> A*A. \<exists>x[M]. \<exists>y[M]. z = \<langle>x,y\<rangle> & x \<in> y}"
apply (simp add: Memrel_def)
apply (blast dest: transM)
done

lemma (in M_basic) Memrel_closed [intro,simp]:
     "M(A) ==> M(Memrel(A))"
apply (simp add: M_Memrel_iff)
apply (insert Memrel_separation, simp)
done

subsection \<open>Main results of Kunen, Chapter 1 section 6\<close>

text\<open>Subset properties-- proved outside the locale\<close>

lemma linear_rel_subset:
    "[| linear_rel(M,A,r);  B<=A |] ==> linear_rel(M,B,r)"
by (unfold linear_rel_def, blast)

lemma transitive_rel_subset:
    "[| transitive_rel(M,A,r);  B<=A |] ==> transitive_rel(M,B,r)"
by (unfold transitive_rel_def, blast)

lemma wellfounded_on_subset:
    "[| wellfounded_on(M,A,r);  B<=A |] ==> wellfounded_on(M,B,r)"
by (unfold wellfounded_on_def subset_def, blast)

lemma wellordered_subset:
    "[| wellordered(M,A,r);  B<=A |] ==> wellordered(M,B,r)"
apply (unfold wellordered_def)
apply (blast intro: linear_rel_subset transitive_rel_subset
                    wellfounded_on_subset)
done

lemma (in M_basic) wellfounded_on_asym:
     "[| wellfounded_on(M,A,r);  <a,x>\<in>r;  a\<in>A; x\<in>A;  M(A) |] ==> <x,a>\<notin>r"
apply (simp add: wellfounded_on_def)
apply (drule_tac x="{x,a}" in rspec)
apply (blast dest: transM)+
done

lemma (in M_basic) wellordered_asym:
     "[| wellordered(M,A,r);  <a,x>\<in>r;  a\<in>A; x\<in>A;  M(A) |] ==> <x,a>\<notin>r"
by (simp add: wellordered_def, blast dest: wellfounded_on_asym)

end


(*  Author:     Tobias Nipkow
    Copyright   1998 TUM

To generate a regular expression, the alphabet must be finite.
regexp needs to be supplied with an 'a list for a unique order

add_Atom d i j r a = (if d a i = j then Union r (Atom a) else r)
atoms d i j as = foldl (add_Atom d i j) Empty as

regexp as d i j 0 = (if i=j then Union (Star Empty) (atoms d i j as)
                        else atoms d i j as
*)

header "From deterministic automata to regular sets"

theory RegSet_of_nat_DA
imports "../Regular-Sets/Regular_Set" DA
begin

type_synonym 'a nat_next = "'a => nat => nat"

abbreviation
  deltas :: "'a nat_next => 'a list => nat => nat" where
  "deltas == foldl2"

primrec trace :: "'a nat_next => nat => 'a list => nat list"  where
"trace d i [] = []" |
"trace d i (x#xs) = d x i # trace d (d x i) xs"

(* conversion a la Warshall *)

primrec regset :: "'a nat_next => nat => nat => nat => 'a list set" where
"regset d i j 0 = (if i=j then insert [] {[a] | a. d a i = j}
                          else {[a] | a. d a i = j})" |
"regset d i j (Suc k) =
  regset d i j k Un
  (regset d i k k) @@ (star(regset d k k k)) @@ (regset d k j k)"

definition
 regset_of_DA :: "('a,nat)da => nat => 'a list set" where
"regset_of_DA A k = (UN j:{j. j<k & fin A j}. regset (next A) (start A) j k)"

definition
 bounded :: "'a nat_next => nat => bool" where
"bounded d k = (!n. n < k --> (!x. d x n < k))"

declare
  in_set_butlast_appendI[simp,intro] less_SucI[simp] image_eqI[simp]

(* Lists *)

lemma butlast_empty[iff]:
  "(butlast xs = []) = (case xs of [] => True | y#ys => ys=[])"
by (cases xs) simp_all

lemma in_set_butlast_concatI:
 "x:set(butlast xs) ==> xs:set xss ==> x:set(butlast(concat xss))"
apply (induct "xss")
 apply simp
apply (simp add: butlast_append del: ball_simps)
apply (rule conjI)
 apply (clarify)
 apply (erule disjE)
  apply (blast)
 apply (subgoal_tac "xs=[]")
  apply simp
 apply (blast)
apply (blast dest: in_set_butlastD)
done

(* Regular sets *)

(* The main lemma:
   how to decompose a trace into a prefix, a list of loops and a suffix.
*)
lemma decompose[rule_format]:
 "!i. k : set(trace d i xs) --> (EX pref mids suf.
  xs = pref @ concat mids @ suf &
  deltas d pref i = k & (!n:set(butlast(trace d i pref)). n ~= k) &
  (!mid:set mids. (deltas d mid k = k) &
                  (!n:set(butlast(trace d k mid)). n ~= k)) &
  (!n:set(butlast(trace d k suf)). n ~= k))"
apply (induct "xs")
 apply (simp)
apply (rename_tac a as)
apply (intro strip)
apply (case_tac "d a i = k")
 apply (rule_tac x = "[a]" in exI)
 apply simp
 apply (case_tac "k : set(trace d (d a i) as)")
  apply (erule allE)
  apply (erule impE)
   apply (assumption)
  apply (erule exE)+
  apply (rule_tac x = "pref#mids" in exI)
  apply (rule_tac x = "suf" in exI)
  apply simp
 apply (rule_tac x = "[]" in exI)
 apply (rule_tac x = "as" in exI)
 apply simp
 apply (blast dest: in_set_butlastD)
apply simp
apply (erule allE)
apply (erule impE)
 apply (assumption)
apply (erule exE)+
apply (rule_tac x = "a#pref" in exI)
apply (rule_tac x = "mids" in exI)
apply (rule_tac x = "suf" in exI)
apply simp
done

lemma length_trace[simp]: "!!i. length(trace d i xs) = length xs"
by (induct "xs") simp_all

lemma deltas_append[simp]:
  "!!i. deltas d (xs@ys) i = deltas d ys (deltas d xs i)"
by (induct "xs") simp_all

lemma trace_append[simp]:
  "!!i. trace d i (xs@ys) = trace d i xs @ trace d (deltas d xs i) ys"
by (induct "xs") simp_all

lemma trace_concat[simp]:
 "(!xs: set xss. deltas d xs i = i) ==>
  trace d i (concat xss) = concat (map (trace d i) xss)"
by (induct "xss") simp_all

lemma trace_is_Nil[simp]: "!!i. (trace d i xs = []) = (xs = [])"
by (case_tac "xs") simp_all

lemma trace_is_Cons_conv[simp]:
 "(trace d i xs = n#ns) =
  (case xs of [] => False | y#ys => n = d y i & ns = trace d n ys)"
apply (case_tac "xs")
apply simp_all
apply (blast)
done

lemma set_trace_conv:
 "!!i. set(trace d i xs) =
  (if xs=[] then {} else insert(deltas d xs i)(set(butlast(trace d i xs))))"
apply (induct "xs")
 apply (simp)
apply (simp add: insert_commute)
done

lemma deltas_concat[simp]:
 "(!mid:set mids. deltas d mid k = k) ==> deltas d (concat mids) k = k"
by (induct mids) simp_all

lemma lem: "[| n < Suc k; n ~= k |] ==> n < k"
by arith

lemma regset_spec:
 "!!i j xs. xs : regset d i j k =
        ((!n:set(butlast(trace d i xs)). n < k) & deltas d xs i = j)"
apply (induct k)
 apply(simp split: list.split)
 apply(fastforce)
apply (simp add: conc_def)
apply (rule iffI)
 apply (erule disjE)
  apply simp
 apply (erule exE conjE)+
 apply simp
 apply (subgoal_tac
      "(!m:set(butlast(trace d k xsb)). m < Suc k) & deltas d xsb k = k")
  apply (simp add: set_trace_conv butlast_append ball_Un)
 apply (erule star_induct)
  apply (simp)
 apply (simp add: set_trace_conv butlast_append ball_Un)
apply (case_tac "k : set(butlast(trace d i xs))")
 prefer 2 apply (rule disjI1)
 apply (blast intro:lem)
apply (rule disjI2)
apply (drule in_set_butlastD[THEN decompose])
apply (clarify)
apply (rule_tac x = "pref" in exI)
apply simp
apply (rule conjI)
 apply (rule ballI)
 apply (rule lem)
  prefer 2 apply simp
 apply (drule bspec) prefer 2 apply assumption
 apply simp
apply (rule_tac x = "concat mids" in exI)
apply (simp)
apply (rule conjI)
 apply (rule concat_in_star)
 apply (clarsimp simp: subset_iff)
 apply (rule lem)
  prefer 2 apply simp
 apply (drule bspec) prefer 2 apply assumption
 apply (simp add: image_eqI in_set_butlast_concatI)
apply (rule ballI)
apply (rule lem)
 apply auto
done

lemma trace_below:
 "bounded d k ==> !i. i < k --> (!n:set(trace d i xs). n < k)"
apply (unfold bounded_def)
apply (induct "xs")
 apply simp
apply (simp (no_asm))
apply (blast)
done

lemma regset_below:
 "[| bounded d k; i < k; j < k |] ==>
  regset d i j k = {xs. deltas d xs i = j}"
apply (rule set_eqI)
apply (simp add: regset_spec)
apply (blast dest: trace_below in_set_butlastD)
done

lemma deltas_below:
 "!!i. bounded d k ==> i < k ==> deltas d w i < k"
apply (unfold bounded_def)
apply (induct "w")
 apply simp_all
done

lemma regset_DA_equiv:
 "[| bounded (next A) k; start A < k; j < k |] ==>
  w : regset_of_DA A k = accepts A w"
apply(unfold regset_of_DA_def)
apply (simp cong: conj_cong
            add: regset_below deltas_below accepts_def delta_def)
done

end


subsection \<open>Weak Simulation\<close>

theory Weak_Relations
imports
  Weak_Transition_Systems
  Strong_Relations
begin

context lts_tau
begin

definition weak_simulation ::
  \<open>('s \<Rightarrow> 's \<Rightarrow> bool) \<Rightarrow> bool\<close>
where
  \<open>weak_simulation R \<equiv> \<forall> p q. R p q \<longrightarrow>
    (\<forall> p' a. p \<longmapsto>a p' \<longrightarrow> (\<exists> q'. R p' q'
      \<and> (q \<Rightarrow>^a q')))\<close>

text \<open>Note: Isabelle won't finish the proofs needed for the introduction of the following
  coinductive predicate if it unfolds the abbreviation of @{text \<open>\<Rightarrow>^\<close>}. Therefore we use
  @{text \<open>\<Rightarrow>^^\<close>} as a barrier. There is no mathematical purpose in this.\<close>

definition weak_step_tau2 :: \<open>'s \<Rightarrow> 'a \<Rightarrow> 's \<Rightarrow> bool\<close>
    ("_ \<Rightarrow>^^ _  _" [70, 70, 70] 80)
where [simp]:
  \<open>(p \<Rightarrow>^^ a q) \<equiv> p \<Rightarrow>^a q\<close>

coinductive greatest_weak_simulation ::
  \<open>'s \<Rightarrow> 's \<Rightarrow> bool\<close>
where
  \<open>(\<forall> p' a. p \<longmapsto>a p' \<longrightarrow> (\<exists> q'. greatest_weak_simulation p' q' \<and> (q \<Rightarrow>^^ a q')))
  \<Longrightarrow> greatest_weak_simulation p q\<close>

lemma weak_sim_ruleformat:
assumes \<open>weak_simulation R\<close>
  and \<open>R p q\<close>
shows
  \<open>p \<longmapsto>a p' \<Longrightarrow> \<not>tau a \<Longrightarrow> (\<exists> q'. R p' q' \<and> (q \<Rightarrow>a q'))\<close>
  \<open>p \<longmapsto>a p' \<Longrightarrow>  tau a \<Longrightarrow> (\<exists> q'. R p' q' \<and> (q \<longmapsto>* tau q'))\<close>
  using assms unfolding weak_simulation_def by (blast+)

abbreviation weakly_simulated_by :: \<open>'s \<Rightarrow> 's \<Rightarrow> bool\<close> ("_ \<sqsubseteq>ws  _" [60, 60] 65)
  where \<open>weakly_simulated_by p q \<equiv> \<exists> R . weak_simulation R \<and> R p q\<close>

lemma weaksim_greatest:
  shows \<open>weak_simulation (\<lambda> p q . p \<sqsubseteq>ws q)\<close>
  unfolding weak_simulation_def
  by (metis (no_types, lifting))

lemma gws_is_weak_simulation:
  shows \<open>weak_simulation greatest_weak_simulation\<close>
  unfolding weak_simulation_def
proof safe
  fix p q p' a
  assume ih:
    \<open>greatest_weak_simulation p q\<close>
    \<open>p \<longmapsto>a  p'\<close>
  hence \<open>(\<forall>x xa. p \<longmapsto>x xa \<longrightarrow> (\<exists>q'. q \<Rightarrow>^^ x  q' \<and> greatest_weak_simulation xa q'))\<close>
    by (meson greatest_weak_simulation.simps)
  then obtain q' where \<open>q \<Rightarrow>^^ a  q' \<and> greatest_weak_simulation p' q'\<close> using ih by blast
  thus \<open>\<exists>q'. greatest_weak_simulation p' q' \<and> q \<Rightarrow>^a  q'\<close>
    unfolding weak_step_tau2_def by blast
qed

lemma weakly_sim_by_implies_gws:
  assumes \<open>p \<sqsubseteq>ws q\<close>
  shows \<open>greatest_weak_simulation p q\<close>
  using assms
proof (coinduct, simp del: weak_step_tau2_def, safe)
  fix x1 x2 R a xa
  assume ih: \<open>weak_simulation R\<close> \<open>R x1 x2\<close> \<open>x1 \<longmapsto>a  xa\<close>
  then obtain q' where \<open>x2 \<Rightarrow>^^ a  q'\<close> \<open>R xa q'\<close>
    unfolding weak_simulation_def weak_step_tau2_def by blast
  thus \<open>\<exists>q'. (xa \<sqsubseteq>ws  q' \<or> greatest_weak_simulation xa q') \<and> x2 \<Rightarrow>^^ a  q'\<close>
    using ih by blast
qed

lemma gws_eq_weakly_sim_by:
  shows \<open>p \<sqsubseteq>ws q = greatest_weak_simulation p q\<close>
  using weakly_sim_by_implies_gws gws_is_weak_simulation by blast

lemma steps_retain_weak_sim:
assumes
  \<open>weak_simulation R\<close>
  \<open>R p q\<close>
  \<open>p \<longmapsto>*A  p'\<close>
  \<open>\<And> a . tau a \<Longrightarrow> A a\<close>
shows \<open>\<exists>q'. R p' q' \<and> q \<longmapsto>*A  q'\<close>
  using assms(3,2,4) proof (induct)
  case (refl p' A)
  hence \<open>R p' q  \<and> q \<longmapsto>* A  q\<close> using assms(2) by (simp add: steps.refl)
  then show ?case by blast
next
  case (step p A p' a p'')
  then obtain q' where q': \<open>R p' q'\<close> \<open>q \<longmapsto>* A  q'\<close> by blast
  obtain q'' where q'':
    \<open>R p'' q''\<close> \<open>(\<not> tau a \<longrightarrow> q' \<Rightarrow>a  q'') \<and> (tau a \<longrightarrow> q' \<longmapsto>* tau  q'')\<close>
    using `weak_simulation R` q'(1) step(3) unfolding weak_simulation_def by blast
  have \<open>q' \<longmapsto>* A  q''\<close>
    using q''(2) steps_spec[of q'] step(4) step(6) weak_steps[of q' a q''] by blast
  hence \<open>q \<longmapsto>* A  q''\<close> using steps_concat[OF _ q'(2)] by blast
  thus ?case using q''(1) by blast
qed

lemma weak_sim_weak_premise:
  \<open>weak_simulation R =
    (\<forall> p q . R p q \<longrightarrow>
      (\<forall> p' a. p \<Rightarrow>^a p' \<longrightarrow> (\<exists> q'. R p' q' \<and> q \<Rightarrow>^a q')))\<close>
proof
  assume \<open>\<forall> p q . R p q \<longrightarrow> (\<forall>p' a. p \<Rightarrow>^a  p' \<longrightarrow> (\<exists>q'. R p' q' \<and> q \<Rightarrow>^a  q'))\<close>
  thus \<open>weak_simulation R\<close>
    unfolding weak_simulation_def using step_weak_step_tau by simp
next
  assume ws: \<open>weak_simulation R\<close>
  show \<open>\<forall>p q. R p q \<longrightarrow> (\<forall>p' a. p \<Rightarrow>^a  p' \<longrightarrow> (\<exists>q'. R p' q' \<and> q \<Rightarrow>^a  q'))\<close>
  proof safe
    fix p q p' a pq1 pq2
    assume case_assms:
      \<open>R p q\<close>
      \<open>p \<longmapsto>* tau  pq1\<close>
      \<open>pq1 \<longmapsto>a  pq2\<close>
      \<open>pq2 \<longmapsto>* tau  p'\<close>
    then obtain q' where q'_def: \<open>q \<longmapsto>* tau  q'\<close> \<open>R pq1 q'\<close>
      using steps_retain_weak_sim[OF ws] by blast
    then moreover obtain q'' where q''_def: \<open>R pq2 q''\<close> \<open>q' \<Rightarrow>^a  q''\<close>
      using ws case_assms(3) unfolding weak_simulation_def by blast
    then moreover obtain q''' where q''_def: \<open>R p' q'''\<close> \<open>q'' \<longmapsto>* tau  q'''\<close>
      using case_assms(4) steps_retain_weak_sim[OF ws] by blast
    ultimately show \<open>\<exists> q'''. R p' q''' \<and> q \<Rightarrow>^a  q'''\<close> using weak_step_extend by blast
  next
    fix p q p' a
    assume
      \<open>R p q\<close>
      \<open>p \<longmapsto>* tau  p'\<close>
      \<open>\<nexists>q'. R p' q' \<and> q \<Rightarrow>^a  q'\<close>
      \<open>tau a\<close>
    thus \<open>False\<close>
      using steps_retain_weak_sim[OF ws] by blast
  next
    \<comment>\<open>case identical to first case\<close>
    fix p q p' a pq1 pq2
    assume case_assms:
      \<open>R p q\<close>
      \<open>p \<longmapsto>* tau  pq1\<close>
      \<open>pq1 \<longmapsto>a  pq2\<close>
      \<open>pq2 \<longmapsto>* tau  p'\<close>
    then obtain q' where q'_def: \<open>q \<longmapsto>* tau  q'\<close> \<open>R pq1 q'\<close>
      using steps_retain_weak_sim[OF ws] by blast
    then moreover obtain q'' where q''_def: \<open>R pq2 q''\<close> \<open>q' \<Rightarrow>^a  q''\<close>
      using ws case_assms(3) unfolding weak_simulation_def by blast
    then moreover obtain q''' where q''_def: \<open>R p' q'''\<close> \<open>q'' \<longmapsto>* tau  q'''\<close>
      using case_assms(4) steps_retain_weak_sim[OF ws] by blast
    ultimately show \<open>\<exists> q'''. R p' q''' \<and> q \<Rightarrow>^a  q'''\<close> using weak_step_extend by blast
  qed
qed

lemma weak_sim_enabled_subs:
  assumes
    \<open>p \<sqsubseteq>ws q\<close>
    \<open>weak_enabled p a\<close>
    \<open>\<not> tau a\<close>
  shows \<open>weak_enabled q a\<close>
proof-
  obtain p' where p'_spec: \<open>p \<Rightarrow>a p'\<close>
    using \<open>weak_enabled p a\<close> weak_enabled_step by blast
  obtain R where \<open>R p q\<close> \<open>weak_simulation R\<close> using assms(1) by blast
  then obtain q' where \<open>q \<Rightarrow>^a q'\<close>
    unfolding weak_sim_weak_premise using weak_step_impl_weak_tau[OF p'_spec] by blast
  thus ?thesis using weak_enabled_step assms(3) by blast
qed

lemma weak_sim_union_cl:
  assumes
    \<open>weak_simulation RA\<close>
    \<open>weak_simulation RB\<close>
  shows
    \<open>weak_simulation (\<lambda> p q. RA p q \<or> RB p q)\<close>
  using assms unfolding weak_simulation_def by blast

lemma weak_sim_remove_dead_state:
  assumes
    \<open>weak_simulation R\<close>
    \<open>\<And> a p . \<not> step d a p \<and> \<not> step p a d\<close>
  shows
    \<open>weak_simulation (\<lambda> p q . R p q \<and> q \<noteq> d)\<close>
  unfolding weak_simulation_def
proof safe
  fix p q p' a
  assume
    \<open>R p q\<close>
    \<open>q \<noteq> d\<close>
    \<open>p \<longmapsto>a  p'\<close>
  then obtain q' where \<open>R p' q'\<close> \<open>q \<Rightarrow>^a  q'\<close>
    using assms(1) unfolding weak_simulation_def by blast
  moreover hence \<open>q' \<noteq> d\<close>
    using assms(2) `q \<noteq> d` by (metis steps.cases)
  ultimately show \<open>\<exists>q'. (R p' q' \<and> q' \<noteq> d) \<and> q \<Rightarrow>^a  q'\<close> by blast
qed

lemma weak_sim_tau_step:
  \<open>weak_simulation (\<lambda> p1 q1 . q1 \<longmapsto>* tau p1)\<close>
  unfolding weak_simulation_def
  using lts.steps.simps by metis

lemma weak_sim_trans_constructive:
  fixes R1 R2
  defines
    \<open>R \<equiv> \<lambda> p q . \<exists> pq . (R1 p pq \<and> R2 pq q) \<or> (R2 p pq \<and> R1 pq q)\<close>
  assumes
    R1_def: \<open>weak_simulation R1\<close> \<open>R1 p pq\<close> and
    R2_def: \<open>weak_simulation R2\<close> \<open>R2 pq q\<close>
  shows
    \<open>R p q\<close> \<open>weak_simulation R\<close>
proof-
  show \<open>R p q\<close> unfolding R_def using R1_def(2) R2_def(2) by blast
next
  show \<open>weak_simulation R\<close>
    unfolding weak_sim_weak_premise R_def
  proof (safe)
    fix p q pq p' a pq1 pq2
    assume
      \<open>R1 p pq\<close>
      \<open>R2 pq q\<close>
      \<open>\<not> tau a\<close>
      \<open>p \<longmapsto>* tau  pq1\<close>
      \<open>pq1 \<longmapsto>a  pq2\<close>
      \<open>pq2 \<longmapsto>* tau  p'\<close>
    thus \<open>\<exists>q'. (\<exists>pq. R1 p' pq \<and> R2 pq q' \<or> R2 p' pq \<and> R1 pq q') \<and> q \<Rightarrow>^a  q'\<close>
      using R1_def(1) R2_def(1) unfolding weak_sim_weak_premise by blast
  next
    fix p q pq p' a
    assume
      \<open>R1 p pq\<close>
      \<open>R2 pq q\<close>
      \<open>p \<longmapsto>* tau  p'\<close>
      \<open>\<nexists>q'.(\<exists>pq. R1 p' pq \<and> R2 pq q' \<or> R2 p' pq \<and> R1 pq q')\<and> q \<Rightarrow>^a  q'\<close>
      \<open>tau a\<close>
    thus \<open>False\<close>
      using R1_def(1) R2_def(1) unfolding weak_sim_weak_premise by blast
  next
    fix p q pq p' a pq1 pq2
    assume
      \<open>R1 p pq\<close>
      \<open>R2 pq q\<close>
      \<open>p \<longmapsto>* tau  p'\<close>
      \<open>p \<longmapsto>* tau  pq1\<close>
      \<open>pq1 \<longmapsto>a  pq2\<close>
      \<open>pq2 \<longmapsto>* tau  p'\<close>
    then obtain pq' q' where \<open>R1 p' pq'\<close> \<open>pq \<Rightarrow>^a  pq'\<close> \<open>R2 pq' q'\<close> \<open>q \<Rightarrow>^a  q'\<close>
      using R1_def(1) R2_def(1) assms(3) unfolding weak_sim_weak_premise by blast
    thus \<open>\<exists>q'. (\<exists>pq. R1 p' pq \<and> R2 pq q' \<or> R2 p' pq \<and> R1 pq q') \<and> q \<Rightarrow>^a  q'\<close>
      by blast
  next
    fix p q pq p' a pq1 pq2
    assume sa:
      \<open>R2 p pq\<close>
      \<open>R1 pq q\<close>
      \<open>\<not> tau a\<close>
      \<open>p \<longmapsto>* tau  pq1\<close>
      \<open>pq1 \<longmapsto>a  pq2\<close>
      \<open>pq2 \<longmapsto>* tau  p'\<close>
    then obtain pq' q'  where \<open>R2 p' pq'\<close> \<open>pq \<Rightarrow>^a  pq'\<close> \<open>R1 pq' q'\<close> \<open>q \<Rightarrow>^a  q'\<close>
      using R2_def(1) R1_def(1) unfolding weak_sim_weak_premise by blast
    thus \<open>\<exists>q'. (\<exists>pq. R1 p' pq \<and> R2 pq q' \<or> R2 p' pq \<and> R1 pq q') \<and> q \<Rightarrow>^a  q'\<close>
      by blast
  next
    fix p q pq p' a
    assume
      \<open>R2 p pq\<close>
      \<open>R1 pq q\<close>
      \<open>p \<longmapsto>* tau  p'\<close>
      \<open>\<nexists>q'.(\<exists>pq. R1 p' pq \<and> R2 pq q' \<or> R2 p' pq \<and> R1 pq q')\<and> q \<Rightarrow>^a  q'\<close>
      \<open>tau a\<close>
    thus \<open>False\<close>
      using R1_def(1) R2_def(1) weak_step_tau_tau[OF `p \<longmapsto>* tau  p'` tau_tau]
      unfolding weak_sim_weak_premise by (metis (no_types, lifting))
  next
    fix p q pq p' a pq1 pq2
    assume sa:
      \<open>R2 p pq\<close>
      \<open>R1 pq q\<close>
      \<open>p \<longmapsto>* tau  p'\<close>
      \<open>p \<longmapsto>* tau  pq1\<close>
      \<open>pq1 \<longmapsto>a  pq2\<close>
      \<open>pq2 \<longmapsto>* tau  p'\<close>
    then obtain pq'  where \<open>R2 p' pq'\<close> \<open>pq \<Rightarrow>^a  pq'\<close>
      using R1_def(1) R2_def(1) weak_step_impl_weak_tau[of p a p']
      unfolding weak_sim_weak_premise by blast
    moreover then obtain q' where \<open>R1 pq' q'\<close> \<open>q \<Rightarrow>^a  q'\<close>
      using R1_def(1) sa(2) unfolding weak_sim_weak_premise by blast
    ultimately show \<open>\<exists>q'. (\<exists>pq. R1 p' pq \<and> R2 pq q' \<or> R2 p' pq \<and> R1 pq q') \<and> q \<Rightarrow>^a  q'\<close>
      by blast
  qed
qed

lemma weak_sim_trans:
  assumes
    \<open>p \<sqsubseteq>ws pq\<close>
    \<open>pq \<sqsubseteq>ws q\<close>
  shows
    \<open>p \<sqsubseteq>ws q\<close>
  using assms(1,2)
proof -
  obtain R1 R2  where  \<open>weak_simulation R1\<close> \<open>R1 p pq\<close> \<open>weak_simulation R2\<close> \<open>R2 pq q\<close>
    using assms(1,2) by blast
  thus ?thesis
    using weak_sim_trans_constructive tau_tau
    by blast
qed

lemma weak_sim_word_impl:
  fixes
    p q p' A
  assumes
    \<open>weak_simulation R\<close> \<open>R p q\<close> \<open>p \<Rightarrow>$ A  p'\<close>
  shows
    \<open>\<exists>q'. R p' q' \<and> q \<Rightarrow>$ A  q'\<close>
using assms(2,3) proof (induct A arbitrary: p q)
  case Nil
  then show ?case
    using assms(1) steps_retain_weak_sim by auto
next
  case (Cons a A)
  then obtain p'' where p''_spec: \<open>p \<Rightarrow>^a p''\<close> \<open>p'' \<Rightarrow>$ A p'\<close> by auto
  with Cons(2) assms(1) obtain q'' where q''_spec: \<open>q \<Rightarrow>^a q''\<close> \<open>R p'' q''\<close>
    unfolding weak_sim_weak_premise by blast
  then show ?case using Cons(1) p''_spec(2)
    using weak_step_seq.simps(2) by blast
qed

lemma weak_sim_word_impl_contra:
  assumes
    \<open>\<forall> p q . R p q \<longrightarrow>
      (\<forall> p' A. p \<Rightarrow>$A p' \<longrightarrow> (\<exists> q'. R p' q' \<and> q \<Rightarrow>$A q'))\<close>
  shows
    \<open>weak_simulation R\<close>
proof -
  from assms have
    \<open>\<forall> p q p' A . R p q \<longrightarrow> p \<Rightarrow>$A p' \<longrightarrow> (\<exists> q'. R p' q' \<and> q \<Rightarrow>$A q')\<close> by blast
  hence \<open>\<forall> p q p' a . R p q \<longrightarrow> p \<Rightarrow>$[a] p' \<longrightarrow> (\<exists> q'. R p' q' \<and> q \<Rightarrow>$[a] q')\<close> by blast
  thus ?thesis unfolding weak_single_step weak_sim_weak_premise by blast
qed

lemma weak_sim_word:
  \<open>weak_simulation R =
    (\<forall> p q . R p q \<longrightarrow>
      (\<forall> p' A. p \<Rightarrow>$A p' \<longrightarrow> (\<exists> q'. R p' q' \<and> q \<Rightarrow>$A q')))\<close>
  using weak_sim_word_impl weak_sim_word_impl_contra by blast

subsection \<open>Weak Bisimulation\<close>

definition weak_bisimulation ::
  \<open>('s \<Rightarrow> 's \<Rightarrow> bool) \<Rightarrow> bool\<close>
where
  \<open>weak_bisimulation R \<equiv> \<forall> p q. R p q \<longrightarrow>
    (\<forall> p' a. p \<longmapsto>a p' \<longrightarrow> (\<exists> q'. R p' q'
      \<and> (q \<Rightarrow>^a q'))) \<and>
    (\<forall> q' a. q \<longmapsto>a q' \<longrightarrow> (\<exists> p'. R p' q'
      \<and> ( p \<Rightarrow>^a p')))\<close>

lemma weak_bisim_ruleformat:
assumes \<open>weak_bisimulation R\<close>
  and \<open>R p q\<close>
shows
  \<open>p \<longmapsto>a p' \<Longrightarrow> \<not>tau a \<Longrightarrow> (\<exists> q'. R p' q' \<and> (q \<Rightarrow>a q'))\<close>
  \<open>p \<longmapsto>a p' \<Longrightarrow>  tau a \<Longrightarrow> (\<exists> q'. R p' q' \<and> (q \<longmapsto>* tau q'))\<close>
  \<open>q \<longmapsto>a q' \<Longrightarrow> \<not>tau a \<Longrightarrow> (\<exists> p'. R p' q' \<and> (p \<Rightarrow>a p'))\<close>
  \<open>q \<longmapsto>a q' \<Longrightarrow>  tau a \<Longrightarrow> (\<exists> p'. R p' q' \<and> (p \<longmapsto>* tau p'))\<close>
  using assms unfolding weak_bisimulation_def by (blast+)

definition tau_weak_bisimulation ::
  \<open>('s \<Rightarrow> 's \<Rightarrow>  bool) \<Rightarrow>  bool\<close>
where
  \<open>tau_weak_bisimulation R \<equiv> \<forall> p q. R p q \<longrightarrow>
    (\<forall> p' a. p \<longmapsto>a p' \<longrightarrow>
      (\<exists> q'. R p' q' \<and> (q \<Rightarrow>a q'))) \<and>
    (\<forall> q' a. q \<longmapsto>a q' \<longrightarrow>
      (\<exists> p'. R p' q' \<and> (p \<Rightarrow>a p')))\<close>

lemma weak_bisim_implies_tau_weak_bisim:
  assumes
    \<open>tau_weak_bisimulation R\<close>
  shows
    \<open>weak_bisimulation R\<close>
unfolding weak_bisimulation_def proof (safe)
  fix p q p' a
  assume \<open>R p q\<close> \<open>p \<longmapsto>a  p'\<close>
  thus \<open>\<exists>q'. R p' q' \<and> (q \<Rightarrow>^a  q')\<close>
    using assms weak_steps[of q a _ tau] unfolding tau_weak_bisimulation_def by blast
next
  fix p q q' a
  assume \<open>R p q\<close> \<open>q \<longmapsto>a  q'\<close>
  thus \<open>\<exists>p'. R p' q' \<and> (p \<Rightarrow>^a  p')\<close>
    using assms weak_steps[of p a _ tau] unfolding tau_weak_bisimulation_def by blast
qed

lemma weak_bisim_invert:
  assumes
    \<open>weak_bisimulation R\<close>
  shows
    \<open>weak_bisimulation (\<lambda> p q. R q p)\<close>
using assms unfolding weak_bisimulation_def by auto

lemma bisim_weak_bisim:
  assumes \<open>bisimulation R\<close>
  shows \<open>weak_bisimulation R\<close>
  unfolding weak_bisimulation_def
proof (clarify, rule)
  fix p q
  assume R: \<open>R p q\<close>
  show \<open>\<forall>p' a. p \<longmapsto>a  p' \<longrightarrow> (\<exists>q'. R p' q' \<and> (q \<Rightarrow>^a  q'))\<close>
  proof (clarify)
    fix p' a
    assume p'a: \<open>p \<longmapsto>a  p'\<close>
    have
      \<open>\<not> tau a \<longrightarrow> (\<exists>q'. R p' q' \<and> q \<Rightarrow>a  q')\<close>
      \<open>(tau a \<longrightarrow> (\<exists>q'. R p' q' \<and> q \<longmapsto>* tau  q'))\<close>
      using bisim_ruleformat(1)[OF assms R p'a] step_weak_step step_weak_step_tau by auto
    thus \<open>\<exists>q'. R p' q' \<and> (q \<Rightarrow>^a  q')\<close> by blast
  qed
next
  fix p q
  assume R: \<open>R p q\<close>
  have \<open>\<forall>q' a. q \<longmapsto>a  q' \<longrightarrow> (\<not> tau a \<longrightarrow> (\<exists>p'. R p' q' \<and> p \<Rightarrow>a  p'))
     \<and> (tau a \<longrightarrow> (\<exists>p'. R p' q' \<and> p \<longmapsto>* tau  p'))\<close>
  proof (clarify)
    fix q' a
    assume q'a: \<open>q \<longmapsto>a  q'\<close>
    show
      \<open>(\<not> tau a \<longrightarrow> (\<exists>p'. R p' q' \<and> p \<Rightarrow>a  p')) \<and>
      (tau a \<longrightarrow> (\<exists>p'. R p' q' \<and> p \<longmapsto>* tau  p'))\<close>
      using bisim_ruleformat(2)[OF assms R q'a] step_weak_step
        step_weak_step_tau steps_one_step by auto
  qed
  thus \<open>\<forall>q' a. q \<longmapsto>a  q' \<longrightarrow> (\<exists>p'. R p' q' \<and> (p \<Rightarrow>^a  p'))\<close> by blast
qed

lemma weak_bisim_weak_sim:
shows
  \<open>weak_bisimulation R = (weak_simulation R \<and> weak_simulation (\<lambda> p q . R q p))\<close>
unfolding weak_bisimulation_def weak_simulation_def by auto

lemma steps_retain_weak_bisim:
  assumes
    \<open>weak_bisimulation R\<close>
    \<open>R p q\<close>
    \<open>p \<longmapsto>*A  p'\<close>
    \<open>\<And> a . tau a \<Longrightarrow> A a\<close>
  shows \<open>\<exists>q'. R p' q' \<and> q \<longmapsto>*A  q'\<close>
    using assms weak_bisim_weak_sim steps_retain_weak_sim
    by auto

lemma weak_bisim_union:
  assumes
    \<open>weak_bisimulation R1\<close>
    \<open>weak_bisimulation R2\<close>
  shows
    \<open>weak_bisimulation (\<lambda> p q . R1 p q \<or> R2 p q)\<close>
  using assms unfolding weak_bisimulation_def by blast

lemma weak_bisim_taufree_strong:
  assumes
    \<open>weak_bisimulation R\<close>
    \<open>\<And> p q a. p \<longmapsto> a q \<Longrightarrow> \<not> tau a\<close>
  shows
    \<open>bisimulation R\<close>
  using assms strong_weak_transition_system
  unfolding weak_bisimulation_def bisimulation_def
  by auto

subsection \<open>Trace Inclusion\<close>

definition trace_inclusion ::
  \<open>('s \<Rightarrow> 's \<Rightarrow> bool) \<Rightarrow> bool\<close>
where
  \<open>trace_inclusion R  \<equiv> \<forall> p q p' A . (\<forall> a \<in> set(A). a \<noteq> \<tau>)
  \<and> R p q \<and> p \<Rightarrow>$ A p' \<longrightarrow> (\<exists> q'. q \<Rightarrow>$ A q')\<close>

abbreviation weakly_trace_included_by :: \<open>'s \<Rightarrow> 's \<Rightarrow> bool\<close> ("_ \<sqsubseteq>T  _" [60, 60] 65)
  where \<open>weakly_trace_included_by p q \<equiv> \<exists> R . trace_inclusion R \<and> R p q\<close>

subsection \<open>Delay Simulation\<close>

definition delay_simulation ::
  \<open>('s \<Rightarrow> 's \<Rightarrow> bool) \<Rightarrow> bool\<close>
where
  \<open>delay_simulation R \<equiv> \<forall> p q. R p q \<longrightarrow>
    (\<forall> p' a. p \<longmapsto>a p' \<longrightarrow>
      (tau a \<longrightarrow> R p' q) \<and>
      (\<not>tau a \<longrightarrow> (\<exists> q'. R p' q'\<and> (q =\<rhd>a q'))))\<close>

lemma delay_simulation_implies_weak_simulation:
  assumes
    \<open>delay_simulation R\<close>
  shows
    \<open>weak_simulation R\<close>
  using assms weak_step_delay_implies_weak_tau steps.refl
  unfolding delay_simulation_def weak_simulation_def by blast

subsection \<open>Coupled Equivalences\<close>

abbreviation coupling ::
  \<open>('s \<Rightarrow> 's \<Rightarrow> bool) \<Rightarrow> bool\<close>
  where \<open>coupling R \<equiv> \<forall> p q . R p q \<longrightarrow> (\<exists> q'. q \<longmapsto>*tau q' \<and> R q' p)\<close>

lemma coupling_tau_max_symm:
  assumes
    \<open>R p q \<longrightarrow> (\<exists> q'. q \<longmapsto>*tau q' \<and> R q' p)\<close>
    \<open>tau_max q\<close>
    \<open>R p q\<close>
  shows
    \<open>R q p\<close>
  using assms steps_no_step_pos[of q tau] by blast

corollary coupling_stability_symm:
  assumes
    \<open>R p q \<longrightarrow> (\<exists> q'. q \<longmapsto>*tau q' \<and> R q' p)\<close>
    \<open>stable_state q\<close>
    \<open>R p q\<close>
  shows
    \<open>R q p\<close>
  using coupling_tau_max_symm stable_tauclosure_only_loop assms by metis

end \<comment>\<open>context @{locale lts_tau}\<close>
end