section \<open>Lambda Cube Examples\<close>

theory Example
imports Cube
begin

text \<open>Examples taken from:

  H. Barendregt. Introduction to Generalised Type Systems.
  J. Functional Programming.\<close>

method_setup depth_solve =
  \<open>Attrib.thms >> (fn thms => K (METHOD (fn facts =>
    (DEPTH_SOLVE (HEADGOAL (ares_tac (facts @ thms)))))))\<close>

method_setup depth_solve1 =
  \<open>Attrib.thms >> (fn thms => K (METHOD (fn facts =>
    (DEPTH_SOLVE_1 (HEADGOAL (ares_tac (facts @ thms)))))))\<close>

method_setup strip_asms =
  \<open>Attrib.thms >> (fn thms => K (METHOD (fn facts =>
    REPEAT (resolve_tac [@{thm strip_b}, @{thm strip_s}] 1 THEN
    DEPTH_SOLVE_1 (ares_tac (facts @ thms) 1)))))\<close>

subsection \<open>Simple types\<close>

schematic_lemma "A:* \<turnstile> A\<rightarrow>A : ?T"
  by (depth_solve rules)

schematic_lemma "A:* \<turnstile> \<Lambda> a:A. a : ?T"
  by (depth_solve rules)

schematic_lemma "A:* B:* b:B \<turnstile> \<Lambda> x:A. b : ?T"
  by (depth_solve rules)

schematic_lemma "A:* b:A \<turnstile> (\<Lambda> a:A. a)^b: ?T"
  by (depth_solve rules)

schematic_lemma "A:* B:* c:A b:B \<turnstile> (\<Lambda> x:A. b)^ c: ?T"
  by (depth_solve rules)

schematic_lemma "A:* B:* \<turnstile> \<Lambda> a:A. \<Lambda> b:B. a : ?T"
  by (depth_solve rules)

subsection \<open>Second-order types\<close>

schematic_lemma (in L2) "\<turnstile> \<Lambda> A:*. \<Lambda> a:A. a : ?T"
  by (depth_solve rules)

schematic_lemma (in L2) "A:* \<turnstile> (\<Lambda> B:*.\<Lambda> b:B. b)^A : ?T"
  by (depth_solve rules)

schematic_lemma (in L2) "A:* b:A \<turnstile> (\<Lambda> B:*.\<Lambda> b:B. b) ^ A ^ b: ?T"
  by (depth_solve rules)

schematic_lemma (in L2) "\<turnstile> \<Lambda> B:*.\<Lambda> a:(\<Pi> A:*.A).a ^ ((\<Pi> A:*.A)\<rightarrow>B) ^ a: ?T"
  by (depth_solve rules)

subsection \<open>Weakly higher-order propositional logic\<close>

schematic_lemma (in Lomega) "\<turnstile> \<Lambda> A:*.A\<rightarrow>A : ?T"
  by (depth_solve rules)

schematic_lemma (in Lomega) "B:* \<turnstile> (\<Lambda> A:*.A\<rightarrow>A) ^ B : ?T"
  by (depth_solve rules)

schematic_lemma (in Lomega) "B:* b:B \<turnstile> (\<Lambda> y:B. b): ?T"
  by (depth_solve rules)

schematic_lemma (in Lomega) "A:* F:*\<rightarrow>* \<turnstile> F^(F^A): ?T"
  by (depth_solve rules)

schematic_lemma (in Lomega) "A:* \<turnstile> \<Lambda> F:*\<rightarrow>*.F^(F^A): ?T"
  by (depth_solve rules)

subsection \<open>LP\<close>

schematic_lemma (in LP) "A:* \<turnstile> A \<rightarrow> * : ?T"
  by (depth_solve rules)

schematic_lemma (in LP) "A:* P:A\<rightarrow>* a:A \<turnstile> P^a: ?T"
  by (depth_solve rules)

schematic_lemma (in LP) "A:* P:A\<rightarrow>A\<rightarrow>* a:A \<turnstile> \<Pi> a:A. P^a^a: ?T"
  by (depth_solve rules)

schematic_lemma (in LP) "A:* P:A\<rightarrow>* Q:A\<rightarrow>* \<turnstile> \<Pi> a:A. P^a \<rightarrow> Q^a: ?T"
  by (depth_solve rules)

schematic_lemma (in LP) "A:* P:A\<rightarrow>* \<turnstile> \<Pi> a:A. P^a \<rightarrow> P^a: ?T"
  by (depth_solve rules)

schematic_lemma (in LP) "A:* P:A\<rightarrow>* \<turnstile> \<Lambda> a:A. \<Lambda> x:P^a. x: ?T"
  by (depth_solve rules)

schematic_lemma (in LP) "A:* P:A\<rightarrow>* Q:* \<turnstile> (\<Pi> a:A. P^a\<rightarrow>Q) \<rightarrow> (\<Pi> a:A. P^a) \<rightarrow> Q : ?T"
  by (depth_solve rules)

schematic_lemma (in LP) "A:* P:A\<rightarrow>* Q:* a0:A \<turnstile>
        \<Lambda> x:\<Pi> a:A. P^a\<rightarrow>Q. \<Lambda> y:\<Pi> a:A. P^a. x^a0^(y^a0): ?T"
  by (depth_solve rules)

subsection \<open>Omega-order types\<close>

schematic_lemma (in L2) "A:* B:* \<turnstile> \<Pi> C:*.(A\<rightarrow>B\<rightarrow>C)\<rightarrow>C : ?T"
  by (depth_solve rules)

schematic_lemma (in Lomega2) "\<turnstile> \<Lambda> A:*.\<Lambda> B:*.\<Pi> C:*.(A\<rightarrow>B\<rightarrow>C)\<rightarrow>C : ?T"
  by (depth_solve rules)

schematic_lemma (in Lomega2) "\<turnstile> \<Lambda> A:*.\<Lambda> B:*.\<Lambda> x:A. \<Lambda> y:B. x : ?T"
  by (depth_solve rules)

schematic_lemma (in Lomega2) "A:* B:* \<turnstile> ?p : (A\<rightarrow>B) \<rightarrow> ((B\<rightarrow>\<Pi> P:*.P)\<rightarrow>(A\<rightarrow>\<Pi> P:*.P))"
  apply (strip_asms rules)
  apply (rule lam_ss)
    apply (depth_solve1 rules)
   prefer 2
   apply (depth_solve1 rules)
  apply (rule lam_ss)
    apply (depth_solve1 rules)
   prefer 2
   apply (depth_solve1 rules)
  apply (rule lam_ss)
    apply assumption
   prefer 2
   apply (depth_solve1 rules)
  apply (erule pi_elim)
   apply assumption
  apply (erule pi_elim)
   apply assumption
  apply assumption
  done

subsection \<open>Second-order Predicate Logic\<close>

schematic_lemma (in LP2) "A:* P:A\<rightarrow>* \<turnstile> \<Lambda> a:A. P^a\<rightarrow>(\<Pi> A:*.A) : ?T"
  by (depth_solve rules)

schematic_lemma (in LP2) "A:* P:A\<rightarrow>A\<rightarrow>* \<turnstile>
    (\<Pi> a:A. \<Pi> b:A. P^a^b\<rightarrow>P^b^a\<rightarrow>\<Pi> P:*.P) \<rightarrow> \<Pi> a:A. P^a^a\<rightarrow>\<Pi> P:*.P : ?T"
  by (depth_solve rules)

schematic_lemma (in LP2) "A:* P:A\<rightarrow>A\<rightarrow>* \<turnstile>
    ?p: (\<Pi> a:A. \<Pi> b:A. P^a^b\<rightarrow>P^b^a\<rightarrow>\<Pi> P:*.P) \<rightarrow> \<Pi> a:A. P^a^a\<rightarrow>\<Pi> P:*.P"
  -- \<open>Antisymmetry implies irreflexivity:\<close>
  apply (strip_asms rules)
  apply (rule lam_ss)
    apply (depth_solve1 rules)
   prefer 2
   apply (depth_solve1 rules)
  apply (rule lam_ss)
    apply assumption
   prefer 2
   apply (depth_solve1 rules)
  apply (rule lam_ss)
    apply (depth_solve1 rules)
   prefer 2
   apply (depth_solve1 rules)
  apply (erule pi_elim, assumption, assumption?)+
  done

subsection \<open>LPomega\<close>

schematic_lemma (in LPomega) "A:* \<turnstile> \<Lambda> P:A\<rightarrow>A\<rightarrow>*.\<Lambda> a:A. P^a^a : ?T"
  by (depth_solve rules)

schematic_lemma (in LPomega) "\<turnstile> \<Lambda> A:*.\<Lambda> P:A\<rightarrow>A\<rightarrow>*.\<Lambda> a:A. P^a^a : ?T"
  by (depth_solve rules)

subsection \<open>Constructions\<close>

schematic_lemma (in CC) "\<turnstile> \<Lambda> A:*.\<Lambda> P:A\<rightarrow>*.\<Lambda> a:A. P^a\<rightarrow>\<Pi> P:*.P: ?T"
  by (depth_solve rules)

schematic_lemma (in CC) "\<turnstile> \<Lambda> A:*.\<Lambda> P:A\<rightarrow>*.\<Pi> a:A. P^a: ?T"
  by (depth_solve rules)

schematic_lemma (in CC) "A:* P:A\<rightarrow>* a:A \<turnstile> ?p : (\<Pi> a:A. P^a)\<rightarrow>P^a"
  apply (strip_asms rules)
  apply (rule lam_ss)
    apply (depth_solve1 rules)
   prefer 2
   apply (depth_solve1 rules)
  apply (erule pi_elim, assumption, assumption)
  done

subsection \<open>Some random examples\<close>

schematic_lemma (in LP2) "A:* c:A f:A\<rightarrow>A \<turnstile>
    \<Lambda> a:A. \<Pi> P:A\<rightarrow>*.P^c \<rightarrow> (\<Pi> x:A. P^x\<rightarrow>P^(f^x)) \<rightarrow> P^a : ?T"
  by (depth_solve rules)

schematic_lemma (in CC) "\<Lambda> A:*.\<Lambda> c:A. \<Lambda> f:A\<rightarrow>A.
    \<Lambda> a:A. \<Pi> P:A\<rightarrow>*.P^c \<rightarrow> (\<Pi> x:A. P^x\<rightarrow>P^(f^x)) \<rightarrow> P^a : ?T"
  by (depth_solve rules)

schematic_lemma (in LP2)
  "A:* a:A b:A \<turnstile> ?p: (\<Pi> P:A\<rightarrow>*.P^a\<rightarrow>P^b) \<rightarrow> (\<Pi> P:A\<rightarrow>*.P^b\<rightarrow>P^a)"
  -- \<open>Symmetry of Leibnitz equality\<close>
  apply (strip_asms rules)
  apply (rule lam_ss)
    apply (depth_solve1 rules)
   prefer 2
   apply (depth_solve1 rules)
  apply (erule_tac a = "\<Lambda> x:A. \<Pi> Q:A\<rightarrow>*.Q^x\<rightarrow>Q^a" in pi_elim)
   apply (depth_solve1 rules)
  apply (unfold beta)
  apply (erule imp_elim)
   apply (rule lam_bs)
     apply (depth_solve1 rules)
    prefer 2
    apply (depth_solve1 rules)
   apply (rule lam_ss)
     apply (depth_solve1 rules)
    prefer 2
    apply (depth_solve1 rules)
   apply assumption
  apply assumption
  done

end


(*  Title:      HOL/Proofs/Lambda/StrongNorm.thy
    Author:     Stefan Berghofer
    Copyright   2000 TU Muenchen
*)

section \<open>Strong normalization for simply-typed lambda calculus\<close>

theory StrongNorm imports LambdaType InductTermi begin

text \<open>
Formalization by Stefan Berghofer. Partly based on a paper proof by
Felix Joachimski and Ralph Matthes @{cite "Matthes-Joachimski-AML"}.
\<close>

subsection \<open>Properties of \<open>IT\<close>\<close>

lemma lift_IT [intro!]: "IT t \<Longrightarrow> IT (lift t i)"
  apply (induct arbitrary: i set: IT)
    apply (simp (no_asm))
    apply (rule conjI)
     apply
      (rule impI,
       rule IT.Var,
       erule listsp.induct,
       simp (no_asm),
       simp (no_asm),
       rule listsp.Cons,
       blast,
       assumption)+
     apply auto
   done

lemma lifts_IT: "listsp IT ts \<Longrightarrow> listsp IT (map (\<lambda>t. lift t 0) ts)"
  by (induct ts) auto

lemma subst_Var_IT: "IT r \<Longrightarrow> IT (r[Var i/j])"
  apply (induct arbitrary: i j set: IT)
    txt \<open>Case \<^term>\<open>Var\<close>:\<close>
    apply (simp (no_asm) add: subst_Var)
    apply
    ((rule conjI impI)+,
      rule IT.Var,
      erule listsp.induct,
      simp (no_asm),
      simp (no_asm),
      rule listsp.Cons,
      fast,
      assumption)+
   txt \<open>Case \<^term>\<open>Lambda\<close>:\<close>
   apply atomize
   apply simp
   apply (rule IT.Lambda)
   apply fast
  txt \<open>Case \<^term>\<open>Beta\<close>:\<close>
  apply atomize
  apply (simp (no_asm_use) add: subst_subst [symmetric])
  apply (rule IT.Beta)
   apply auto
  done

lemma Var_IT: "IT (Var n)"
  apply (subgoal_tac "IT (Var n \<degree>\<degree> [])")
   apply simp
  apply (rule IT.Var)
  apply (rule listsp.Nil)
  done

lemma app_Var_IT: "IT t \<Longrightarrow> IT (t \<degree> Var i)"
  apply (induct set: IT)
    apply (subst app_last)
    apply (rule IT.Var)
    apply simp
    apply (rule listsp.Cons)
     apply (rule Var_IT)
    apply (rule listsp.Nil)
   apply (rule IT.Beta [where ?ss = "[]", unfolded foldl_Nil [THEN eq_reflection]])
    apply (erule subst_Var_IT)
   apply (rule Var_IT)
  apply (subst app_last)
  apply (rule IT.Beta)
   apply (subst app_last [symmetric])
   apply assumption
  apply assumption
  done

subsection \<open>Well-typed substitution preserves termination\<close>

lemma subst_type_IT:
  "\<And>t e T u i. IT t \<Longrightarrow> e\<langle>i:U\<rangle> \<turnstile> t : T \<Longrightarrow>
    IT u \<Longrightarrow> e \<turnstile> u : U \<Longrightarrow> IT (t[u/i])"
  (is "PROP ?P U" is "\<And>t e T u i. _ \<Longrightarrow> PROP ?Q t e T u i U")
proof (induct U)
  fix T t
  assume MI1: "\<And>T1 T2. T = T1 \<Rightarrow> T2 \<Longrightarrow> PROP ?P T1"
  assume MI2: "\<And>T1 T2. T = T1 \<Rightarrow> T2 \<Longrightarrow> PROP ?P T2"
  assume "IT t"
  thus "\<And>e T' u i. PROP ?Q t e T' u i T"
  proof induct
    fix e T' u i
    assume uIT: "IT u"
    assume uT: "e \<turnstile> u : T"
    {
      case (Var rs n e1 T'1 u1 i1)
      assume nT: "e\<langle>i:T\<rangle> \<turnstile> Var n \<degree>\<degree> rs : T'"
      let ?ty = "\<lambda>t. \<exists>T'. e\<langle>i:T\<rangle> \<turnstile> t : T'"
      let ?R = "\<lambda>t. \<forall>e T' u i.
        e\<langle>i:T\<rangle> \<turnstile> t : T' \<longrightarrow> IT u \<longrightarrow> e \<turnstile> u : T \<longrightarrow> IT (t[u/i])"
      show "IT ((Var n \<degree>\<degree> rs)[u/i])"
      proof (cases "n = i")
        case True
        show ?thesis
        proof (cases rs)
          case Nil
          with uIT True show ?thesis by simp
        next
          case (Cons a as)
          with nT have "e\<langle>i:T\<rangle> \<turnstile> Var n \<degree> a \<degree>\<degree> as : T'" by simp
          then obtain Ts
              where headT: "e\<langle>i:T\<rangle> \<turnstile> Var n \<degree> a : Ts \<Rrightarrow> T'"
              and argsT: "e\<langle>i:T\<rangle> \<tturnstile> as : Ts"
            by (rule list_app_typeE)
          from headT obtain T''
              where varT: "e\<langle>i:T\<rangle> \<turnstile> Var n : T'' \<Rightarrow> Ts \<Rrightarrow> T'"
              and argT: "e\<langle>i:T\<rangle> \<turnstile> a : T''"
            by cases simp_all
          from varT True have T: "T = T'' \<Rightarrow> Ts \<Rrightarrow> T'"
            by cases auto
          with uT have uT': "e \<turnstile> u : T'' \<Rightarrow> Ts \<Rrightarrow> T'" by simp
          from T have "IT ((Var 0 \<degree>\<degree> map (\<lambda>t. lift t 0)
            (map (\<lambda>t. t[u/i]) as))[(u \<degree> a[u/i])/0])"
          proof (rule MI2)
            from T have "IT ((lift u 0 \<degree> Var 0)[a[u/i]/0])"
            proof (rule MI1)
              have "IT (lift u 0)" by (rule lift_IT [OF uIT])
              thus "IT (lift u 0 \<degree> Var 0)" by (rule app_Var_IT)
              show "e\<langle>0:T''\<rangle> \<turnstile> lift u 0 \<degree> Var 0 : Ts \<Rrightarrow> T'"
              proof (rule typing.App)
                show "e\<langle>0:T''\<rangle> \<turnstile> lift u 0 : T'' \<Rightarrow> Ts \<Rrightarrow> T'"
                  by (rule lift_type) (rule uT')
                show "e\<langle>0:T''\<rangle> \<turnstile> Var 0 : T''"
                  by (rule typing.Var) simp
              qed
              from Var have "?R a" by cases (simp_all add: Cons)
              with argT uIT uT show "IT (a[u/i])" by simp
              from argT uT show "e \<turnstile> a[u/i] : T''"
                by (rule subst_lemma) simp
            qed
            thus "IT (u \<degree> a[u/i])" by simp
            from Var have "listsp ?R as"
              by cases (simp_all add: Cons)
            moreover from argsT have "listsp ?ty as"
              by (rule lists_typings)
            ultimately have "listsp (\<lambda>t. ?R t \<and> ?ty t) as"
              by simp
            hence "listsp IT (map (\<lambda>t. lift t 0) (map (\<lambda>t. t[u/i]) as))"
              (is "listsp IT (?ls as)")
            proof induct
              case Nil
              show ?case by fastforce
            next
              case (Cons b bs)
              hence I: "?R b" by simp
              from Cons obtain U where "e\<langle>i:T\<rangle> \<turnstile> b : U" by fast
              with uT uIT I have "IT (b[u/i])" by simp
              hence "IT (lift (b[u/i]) 0)" by (rule lift_IT)
              hence "listsp IT (lift (b[u/i]) 0 # ?ls bs)"
                by (rule listsp.Cons) (rule Cons)
              thus ?case by simp
            qed
            thus "IT (Var 0 \<degree>\<degree> ?ls as)" by (rule IT.Var)
            have "e\<langle>0:Ts \<Rrightarrow> T'\<rangle> \<turnstile> Var 0 : Ts \<Rrightarrow> T'"
              by (rule typing.Var) simp
            moreover from uT argsT have "e \<tturnstile> map (\<lambda>t. t[u/i]) as : Ts"
              by (rule substs_lemma)
            hence "e\<langle>0:Ts \<Rrightarrow> T'\<rangle> \<tturnstile> ?ls as : Ts"
              by (rule lift_types)
            ultimately show "e\<langle>0:Ts \<Rrightarrow> T'\<rangle> \<turnstile> Var 0 \<degree>\<degree> ?ls as : T'"
              by (rule list_app_typeI)
            from argT uT have "e \<turnstile> a[u/i] : T''"
              by (rule subst_lemma) (rule refl)
            with uT' show "e \<turnstile> u \<degree> a[u/i] : Ts \<Rrightarrow> T'"
              by (rule typing.App)
          qed
          with Cons True show ?thesis
            by (simp add: comp_def)
        qed
      next
        case False
        from Var have "listsp ?R rs" by simp
        moreover from nT obtain Ts where "e\<langle>i:T\<rangle> \<tturnstile> rs : Ts"
          by (rule list_app_typeE)
        hence "listsp ?ty rs" by (rule lists_typings)
        ultimately have "listsp (\<lambda>t. ?R t \<and> ?ty t) rs"
          by simp
        hence "listsp IT (map (\<lambda>x. x[u/i]) rs)"
        proof induct
          case Nil
          show ?case by fastforce
        next
          case (Cons a as)
          hence I: "?R a" by simp
          from Cons obtain U where "e\<langle>i:T\<rangle> \<turnstile> a : U" by fast
          with uT uIT I have "IT (a[u/i])" by simp
          hence "listsp IT (a[u/i] # map (\<lambda>t. t[u/i]) as)"
            by (rule listsp.Cons) (rule Cons)
          thus ?case by simp
        qed
        with False show ?thesis by (auto simp add: subst_Var)
      qed
    next
      case (Lambda r e1 T'1 u1 i1)
      assume "e\<langle>i:T\<rangle> \<turnstile> Abs r : T'"
        and "\<And>e T' u i. PROP ?Q r e T' u i T"
      with uIT uT show "IT (Abs r[u/i])"
        by fastforce
    next
      case (Beta r a as e1 T'1 u1 i1)
      assume T: "e\<langle>i:T\<rangle> \<turnstile> Abs r \<degree> a \<degree>\<degree> as : T'"
      assume SI1: "\<And>e T' u i. PROP ?Q (r[a/0] \<degree>\<degree> as) e T' u i T"
      assume SI2: "\<And>e T' u i. PROP ?Q a e T' u i T"
      have "IT (Abs (r[lift u 0/Suc i]) \<degree> a[u/i] \<degree>\<degree> map (\<lambda>t. t[u/i]) as)"
      proof (rule IT.Beta)
        have "Abs r \<degree> a \<degree>\<degree> as \<rightarrow>\<^sub>\<beta> r[a/0] \<degree>\<degree> as"
          by (rule apps_preserves_beta) (rule beta.beta)
        with T have "e\<langle>i:T\<rangle> \<turnstile> r[a/0] \<degree>\<degree> as : T'"
          by (rule subject_reduction)
        hence "IT ((r[a/0] \<degree>\<degree> as)[u/i])"
          using uIT uT by (rule SI1)
        thus "IT (r[lift u 0/Suc i][a[u/i]/0] \<degree>\<degree> map (\<lambda>t. t[u/i]) as)"
          by (simp del: subst_map add: subst_subst subst_map [symmetric])
        from T obtain U where "e\<langle>i:T\<rangle> \<turnstile> Abs r \<degree> a : U"
          by (rule list_app_typeE) fast
        then obtain T'' where "e\<langle>i:T\<rangle> \<turnstile> a : T''" by cases simp_all
        thus "IT (a[u/i])" using uIT uT by (rule SI2)
      qed
      thus "IT ((Abs r \<degree> a \<degree>\<degree> as)[u/i])" by simp
    }
  qed
qed

subsection \<open>Well-typed terms are strongly normalizing\<close>

lemma type_implies_IT:
  assumes "e \<turnstile> t : T"
  shows "IT t"
  using assms
proof induct
  case Var
  show ?case by (rule Var_IT)
next
  case Abs
  show ?case by (rule IT.Lambda) (rule Abs)
next
  case (App e s T U t)
  have "IT ((Var 0 \<degree> lift t 0)[s/0])"
  proof (rule subst_type_IT)
    have "IT (lift t 0)" using \<open>IT t\<close> by (rule lift_IT)
    hence "listsp IT [lift t 0]" by (rule listsp.Cons) (rule listsp.Nil)
    hence "IT (Var 0 \<degree>\<degree> [lift t 0])" by (rule IT.Var)
    also have "Var 0 \<degree>\<degree> [lift t 0] = Var 0 \<degree> lift t 0" by simp
    finally show "IT \<dots>" .
    have "e\<langle>0:T \<Rightarrow> U\<rangle> \<turnstile> Var 0 : T \<Rightarrow> U"
      by (rule typing.Var) simp
    moreover have "e\<langle>0:T \<Rightarrow> U\<rangle> \<turnstile> lift t 0 : T"
      by (rule lift_type) (rule App.hyps)
    ultimately show "e\<langle>0:T \<Rightarrow> U\<rangle> \<turnstile> Var 0 \<degree> lift t 0 : U"
      by (rule typing.App)
    show "IT s" by fact
    show "e \<turnstile> s : T \<Rightarrow> U" by fact
  qed
  thus ?case by simp
qed

theorem type_implies_termi: "e \<turnstile> t : T \<Longrightarrow> termip beta t"
proof -
  assume "e \<turnstile> t : T"
  hence "IT t" by (rule type_implies_IT)
  thus ?thesis by (rule IT_implies_termi)
qed

end


(*  Title:      HOL/MicroJava/BV/JVMType.thy
    Author:     Gerwin Klein
    Copyright   2000 TUM
*)

section \<open>The JVM Type System as Semilattice\<close>

theory JVMType
imports JType
begin

type_synonym locvars_type = "ty err list"
type_synonym opstack_type = "ty list"
type_synonym state_type = "opstack_type \<times> locvars_type"
type_synonym state = "state_type option err"    \<comment> \<open>for Kildall\<close>
type_synonym method_type = "state_type option list"   \<comment> \<open>for BVSpec\<close>
type_synonym class_type = "sig \<Rightarrow> method_type"
type_synonym prog_type = "cname \<Rightarrow> class_type"

definition stk_esl :: "'c prog \<Rightarrow> nat \<Rightarrow> ty list esl" where
  "stk_esl S maxs == upto_esl maxs (JType.esl S)"

definition reg_sl :: "'c prog \<Rightarrow> nat \<Rightarrow> ty err list sl" where
  "reg_sl S maxr == Listn.sl maxr (Err.sl (JType.esl S))"

definition sl :: "'c prog \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> state sl" where
  "sl S maxs maxr ==
  Err.sl(Opt.esl(Product.esl (stk_esl S maxs) (Err.esl(reg_sl S maxr))))"

definition states :: "'c prog \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> state set" where
  "states S maxs maxr == fst(sl S maxs maxr)"

definition le :: "'c prog \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> state ord" where
  "le S maxs maxr == fst(snd(sl S maxs maxr))"

definition  sup :: "'c prog \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> state binop" where
  "sup S maxs maxr == snd(snd(sl S maxs maxr))"

definition sup_ty_opt :: "['code prog,ty err,ty err] \<Rightarrow> bool"
                 ("_ \<turnstile> _ <=o _" [71,71] 70) where
  "sup_ty_opt G == Err.le (subtype G)"

definition sup_loc :: "['code prog,locvars_type,locvars_type] \<Rightarrow> bool"
              ("_ \<turnstile> _ <=l _"  [71,71] 70) where
  "sup_loc G == Listn.le (sup_ty_opt G)"

definition sup_state :: "['code prog,state_type,state_type] \<Rightarrow> bool"
               ("_ \<turnstile> _ <=s _"  [71,71] 70) where
  "sup_state G == Product.le (Listn.le (subtype G)) (sup_loc G)"

definition sup_state_opt :: "['code prog,state_type option,state_type option] \<Rightarrow> bool"
                   ("_ \<turnstile> _ <='' _"  [71,71] 70) where
  "sup_state_opt G == Opt.le (sup_state G)"

lemma JVM_states_unfold:
  "states S maxs maxr == err(opt((\<Union>{list n (types S) |n. n <= maxs}) \<times>
                                  list maxr (err(types S))))"
  apply (unfold states_def sl_def Opt.esl_def Err.sl_def
         stk_esl_def reg_sl_def Product.esl_def
         Listn.sl_def upto_esl_def JType.esl_def Err.esl_def)
  by simp

lemma JVM_le_unfold:
 "le S m n ==
  Err.le(Opt.le(Product.le(Listn.le(subtype S))(Listn.le(Err.le(subtype S)))))"
  apply (unfold le_def sl_def Opt.esl_def Err.sl_def
         stk_esl_def reg_sl_def Product.esl_def
         Listn.sl_def upto_esl_def JType.esl_def Err.esl_def)
  by simp

lemma JVM_le_convert:
  "le G m n (OK t1) (OK t2) = G \<turnstile> t1 <=' t2"
  by (simp add: JVM_le_unfold Err.le_def lesub_def sup_state_opt_def
                sup_state_def sup_loc_def sup_ty_opt_def)

lemma JVM_le_Err_conv:
  "le G m n = Err.le (sup_state_opt G)"
  by (unfold sup_state_opt_def sup_state_def sup_loc_def
             sup_ty_opt_def JVM_le_unfold) simp

lemma zip_map [rule_format]:
  "\<forall>a. length a = length b \<longrightarrow>
  zip (map f a) (map g b) = map (\<lambda>(x,y). (f x, g y)) (zip a b)"
  apply (induct b)
   apply simp
  apply clarsimp
  apply (case_tac aa)
  apply simp_all
  done

lemma stk_convert:
  "Listn.le (subtype G) a b = G \<turnstile> map OK a <=l map OK b"
proof
  assume "Listn.le (subtype G) a b"

  hence le: "list_all2 (subtype G) a b"
    by (unfold Listn.le_def lesub_def)

  { fix x' y'
    assume "length a = length b"
           "(x',y') \<in> set (zip (map OK a) (map OK b))"
    then
    obtain x y where OK:
      "x' = OK x" "y' = OK y" "(x,y) \<in> set (zip a b)"
      by (auto simp add: zip_map)
    with le
    have "subtype G x y"
      by (simp add: list_all2_iff Ball_def)
    with OK
    have "G \<turnstile> x' <=o y'"
      by (simp add: sup_ty_opt_def)
  }

  with le
  show "G \<turnstile> map OK a <=l map OK b"
    by (unfold sup_loc_def Listn.le_def lesub_def list_all2_iff) auto
next
  assume "G \<turnstile> map OK a <=l map OK b"

  thus "Listn.le (subtype G) a b"
    apply (unfold sup_loc_def list_all2_iff Listn.le_def lesub_def)
    apply (clarsimp simp add: zip_map)
    apply (drule bspec, assumption)
    apply (auto simp add: sup_ty_opt_def subtype_def)
    done
qed

lemma sup_state_conv:
  "(G \<turnstile> s1 <=s s2) ==
  (G \<turnstile> map OK (fst s1) <=l map OK (fst s2)) \<and> (G \<turnstile> snd s1 <=l snd s2)"
  by (auto simp add: sup_state_def stk_convert lesub_def Product.le_def split_beta)

lemma subtype_refl [simp]:
  "subtype G t t"
  by (simp add: subtype_def)

theorem sup_ty_opt_refl [simp]:
  "G \<turnstile> t <=o t"
  by (simp add: sup_ty_opt_def Err.le_def lesub_def split: err.split)

lemma le_list_refl2 [simp]:
  "(\<And>xs. r xs xs) \<Longrightarrow> Listn.le r xs xs"
  by (induct xs, auto simp add: Listn.le_def lesub_def)

theorem sup_loc_refl [simp]:
  "G \<turnstile> t <=l t"
  by (simp add: sup_loc_def)

theorem sup_state_refl [simp]:
  "G \<turnstile> s <=s s"
  by (auto simp add: sup_state_def Product.le_def lesub_def)

theorem sup_state_opt_refl [simp]:
  "G \<turnstile> s <=' s"
  by (simp add: sup_state_opt_def Opt.le_def lesub_def split: option.split)

theorem anyConvErr [simp]:
  "(G \<turnstile> Err <=o any) = (any = Err)"
  by (simp add: sup_ty_opt_def Err.le_def split: err.split)

theorem OKanyConvOK [simp]:
  "(G \<turnstile> (OK ty') <=o (OK ty)) = (G \<turnstile> ty' \<preceq> ty)"
  by (simp add: sup_ty_opt_def Err.le_def lesub_def subtype_def)

theorem sup_ty_opt_OK:
  "G \<turnstile> a <=o (OK b) \<Longrightarrow> \<exists> x. a = OK x"
  by (clarsimp simp add: sup_ty_opt_def Err.le_def split: err.splits)

lemma widen_PrimT_conv1 [simp]:
  "\<lbrakk> G \<turnstile> S \<preceq> T; S = PrimT x\<rbrakk> \<Longrightarrow> T = PrimT x"
  by (auto elim: widen.cases)

theorem sup_PTS_eq:
  "(G \<turnstile> OK (PrimT p) <=o X) = (X=Err \<or> X = OK (PrimT p))"
  by (auto simp add: sup_ty_opt_def Err.le_def lesub_def subtype_def
              split: err.splits)

theorem sup_loc_Nil [iff]:
  "(G \<turnstile> [] <=l XT) = (XT=[])"
  by (simp add: sup_loc_def Listn.le_def)

theorem sup_loc_Cons [iff]:
  "(G \<turnstile> (Y#YT) <=l XT) = (\<exists>X XT'. XT=X#XT' \<and> (G \<turnstile> Y <=o X) \<and> (G \<turnstile> YT <=l XT'))"
  by (simp add: sup_loc_def Listn.le_def lesub_def list_all2_Cons1)

theorem sup_loc_Cons2:
  "(G \<turnstile> YT <=l (X#XT)) = (\<exists>Y YT'. YT=Y#YT' \<and> (G \<turnstile> Y <=o X) \<and> (G \<turnstile> YT' <=l XT))"
  by (simp add: sup_loc_def Listn.le_def lesub_def list_all2_Cons2)

lemma sup_state_Cons:
  "(G \<turnstile> (x#xt, a) <=s (y#yt, b)) =
   ((G \<turnstile> x \<preceq> y) \<and> (G \<turnstile> (xt,a) <=s (yt,b)))"
  by (auto simp add: sup_state_def stk_convert lesub_def Product.le_def)

theorem sup_loc_length:
  "G \<turnstile> a <=l b \<Longrightarrow> length a = length b"
proof -
  assume G: "G \<turnstile> a <=l b"
  have "\<forall>b. (G \<turnstile> a <=l b) \<longrightarrow> length a = length b"
    by (induct a, auto)
  with G
  show ?thesis by blast
qed

theorem sup_loc_nth:
  "\<lbrakk> G \<turnstile> a <=l b; n < length a \<rbrakk> \<Longrightarrow> G \<turnstile> (a!n) <=o (b!n)"
proof -
  assume a: "G \<turnstile> a <=l b" "n < length a"
  have "\<forall> n b. (G \<turnstile> a <=l b) \<longrightarrow> n < length a \<longrightarrow> (G \<turnstile> (a!n) <=o (b!n))"
    (is "?P a")
  proof (induct a)
    show "?P []" by simp

    fix x xs assume IH: "?P xs"

    show "?P (x#xs)"
    proof (intro strip)
      fix n b
      assume "G \<turnstile> (x # xs) <=l b" "n < length (x # xs)"
      with IH
      show "G \<turnstile> ((x # xs) ! n) <=o (b ! n)"
        by (cases n) auto
    qed
  qed
  with a
  show ?thesis by blast
qed

theorem all_nth_sup_loc:
  "\<forall>b. length a = length b \<longrightarrow> (\<forall> n. n < length a \<longrightarrow> (G \<turnstile> (a!n) <=o (b!n)))
  \<longrightarrow> (G \<turnstile> a <=l b)" (is "?P a")
proof (induct a)
  show "?P []" by simp

  fix l ls assume IH: "?P ls"

  show "?P (l#ls)"
  proof (intro strip)
    fix b
    assume f: "\<forall>n. n < length (l # ls) \<longrightarrow> (G \<turnstile> ((l # ls) ! n) <=o (b ! n))"
    assume l: "length (l#ls) = length b"

    then obtain b' bs where b: "b = b'#bs"
      by (cases b) (simp, simp add: neq_Nil_conv)

    with f
    have "\<forall>n. n < length ls \<longrightarrow> (G \<turnstile> (ls!n) <=o (bs!n))"
      by auto

    with f b l IH
    show "G \<turnstile> (l # ls) <=l b"
      by auto
  qed
qed

theorem sup_loc_append:
  "length a = length b \<Longrightarrow>
   (G \<turnstile> (a@x) <=l (b@y)) = ((G \<turnstile> a <=l b) \<and> (G \<turnstile> x <=l y))"
proof -
  assume l: "length a = length b"

  have "\<forall>b. length a = length b \<longrightarrow> (G \<turnstile> (a@x) <=l (b@y)) = ((G \<turnstile> a <=l b) \<and>
            (G \<turnstile> x <=l y))" (is "?P a")
  proof (induct a)
    show "?P []" by simp

    fix l ls assume IH: "?P ls"
    show "?P (l#ls)"
    proof (intro strip)
      fix b
      assume "length (l#ls) = length (b::ty err list)"
      with IH
      show "(G \<turnstile> ((l#ls)@x) <=l (b@y)) = ((G \<turnstile> (l#ls) <=l b) \<and> (G \<turnstile> x <=l y))"
        by (cases b) auto
    qed
  qed
  with l
  show ?thesis by blast
qed

theorem sup_loc_rev [simp]:
  "(G \<turnstile> (rev a) <=l rev b) = (G \<turnstile> a <=l b)"
proof -
  have "\<forall>b. (G \<turnstile> (rev a) <=l rev b) = (G \<turnstile> a <=l b)" (is "\<forall>b. ?Q a b" is "?P a")
  proof (induct a)
    show "?P []" by simp

    fix l ls assume IH: "?P ls"

    {
      fix b
      have "?Q (l#ls) b"
      proof (cases b)
        case Nil
        thus ?thesis by (auto dest: sup_loc_length)
      next
        case (Cons a list)
        show ?thesis
        proof
          assume "G \<turnstile> (l # ls) <=l b"
          thus "G \<turnstile> rev (l # ls) <=l rev b"
            by (clarsimp simp add: Cons IH sup_loc_length sup_loc_append)
        next
          assume "G \<turnstile> rev (l # ls) <=l rev b"
          hence G: "G \<turnstile> (rev ls @ [l]) <=l (rev list @ [a])"
            by (simp add: Cons)

          hence "length (rev ls) = length (rev list)"
            by (auto dest: sup_loc_length)

          from this G
          obtain "G \<turnstile> rev ls <=l rev list" "G \<turnstile> l <=o a"
            by (simp add: sup_loc_append)

          thus "G \<turnstile> (l # ls) <=l b"
            by (simp add: Cons IH)
        qed
      qed
    }
    thus "?P (l#ls)" by blast
  qed

  thus ?thesis by blast
qed

theorem sup_loc_update [rule_format]:
  "\<forall> n y. (G \<turnstile> a <=o b) \<longrightarrow> n < length y \<longrightarrow> (G \<turnstile> x <=l y) \<longrightarrow>
          (G \<turnstile> x[n := a] <=l y[n := b])" (is "?P x")
proof (induct x)
  show "?P []" by simp

  fix l ls assume IH: "?P ls"
  show "?P (l#ls)"
  proof (intro strip)
    fix n y
    assume "G \<turnstile>a <=o b" "G \<turnstile> (l # ls) <=l y" "n < length y"
    with IH
    show "G \<turnstile> (l # ls)[n := a] <=l y[n := b]"
      by (cases n) (auto simp add: sup_loc_Cons2 list_all2_Cons1)
  qed
qed

theorem sup_state_length [simp]:
  "G \<turnstile> s2 <=s s1 \<Longrightarrow>
   length (fst s2) = length (fst s1) \<and> length (snd s2) = length (snd s1)"
  by (auto dest: sup_loc_length simp add: sup_state_def stk_convert lesub_def Product.le_def)

theorem sup_state_append_snd:
  "length a = length b \<Longrightarrow>
  (G \<turnstile> (i,a@x) <=s (j,b@y)) = ((G \<turnstile> (i,a) <=s (j,b)) \<and> (G \<turnstile> (i,x) <=s (j,y)))"
  by (auto simp add: sup_state_def stk_convert lesub_def Product.le_def sup_loc_append)

theorem sup_state_append_fst:
  "length a = length b \<Longrightarrow>
  (G \<turnstile> (a@x,i) <=s (b@y,j)) = ((G \<turnstile> (a,i) <=s (b,j)) \<and> (G \<turnstile> (x,i) <=s (y,j)))"
  by (auto simp add: sup_state_def stk_convert lesub_def Product.le_def sup_loc_append)

theorem sup_state_Cons1:
  "(G \<turnstile> (x#xt, a) <=s (yt, b)) =
   (\<exists>y yt'. yt=y#yt' \<and> (G \<turnstile> x \<preceq> y) \<and> (G \<turnstile> (xt,a) <=s (yt',b)))"
  by (auto simp add: sup_state_def stk_convert lesub_def Product.le_def)

theorem sup_state_Cons2:
  "(G \<turnstile> (xt, a) <=s (y#yt, b)) =
   (\<exists>x xt'. xt=x#xt' \<and> (G \<turnstile> x \<preceq> y) \<and> (G \<turnstile> (xt',a) <=s (yt,b)))"
  by (auto simp add: sup_state_def stk_convert lesub_def Product.le_def sup_loc_Cons2)

theorem sup_state_ignore_fst:
  "G \<turnstile> (a, x) <=s (b, y) \<Longrightarrow> G \<turnstile> (c, x) <=s (c, y)"
  by (simp add: sup_state_def lesub_def Product.le_def)

theorem sup_state_rev_fst:
  "(G \<turnstile> (rev a, x) <=s (rev b, y)) = (G \<turnstile> (a, x) <=s (b, y))"
proof -
  have m: "\<And>f x. map f (rev x) = rev (map f x)" by (simp add: rev_map)
  show ?thesis by (simp add: m sup_state_def stk_convert lesub_def Product.le_def)
qed

lemma sup_state_opt_None_any [iff]:
  "(G \<turnstile> None <=' any) = True"
  by (simp add: sup_state_opt_def Opt.le_def split: option.split)

lemma sup_state_opt_any_None [iff]:
  "(G \<turnstile> any <=' None) = (any = None)"
  by (simp add: sup_state_opt_def Opt.le_def split: option.split)

lemma sup_state_opt_Some_Some [iff]:
  "(G \<turnstile> (Some a) <=' (Some b)) = (G \<turnstile> a <=s b)"
  by (simp add: sup_state_opt_def Opt.le_def lesub_def del: split_paired_Ex)

lemma sup_state_opt_any_Some [iff]:
  "(G \<turnstile> (Some a) <=' any) = (\<exists>b. any = Some b \<and> G \<turnstile> a <=s b)"
  by (simp add: sup_state_opt_def Opt.le_def lesub_def split: option.split)

lemma sup_state_opt_Some_any:
  "(G \<turnstile> any <=' (Some b)) = (any = None \<or> (\<exists>a. any = Some a \<and> G \<turnstile> a <=s b))"
  by (simp add: sup_state_opt_def Opt.le_def lesub_def split: option.split)

theorem sup_ty_opt_trans [trans]:
  "\<lbrakk>G \<turnstile> a <=o b; G \<turnstile> b <=o c\<rbrakk> \<Longrightarrow> G \<turnstile> a <=o c"
  by (auto intro: widen_trans
           simp add: sup_ty_opt_def Err.le_def lesub_def subtype_def
           split: err.splits)

theorem sup_loc_trans [trans]:
  "\<lbrakk>G \<turnstile> a <=l b; G \<turnstile> b <=l c\<rbrakk> \<Longrightarrow> G \<turnstile> a <=l c"
proof -
  assume G: "G \<turnstile> a <=l b" "G \<turnstile> b <=l c"

  hence "\<forall> n. n < length a \<longrightarrow> (G \<turnstile> (a!n) <=o (c!n))"
  proof (intro strip)
    fix n
    assume n: "n < length a"
    with G(1)
    have "G \<turnstile> (a!n) <=o (b!n)"
      by (rule sup_loc_nth)
    also
    from n G
    have "G \<turnstile> \<dots> <=o (c!n)"
      by - (rule sup_loc_nth, auto dest: sup_loc_length)
    finally
    show "G \<turnstile> (a!n) <=o (c!n)" .
  qed

  with G
  show ?thesis
    by (auto intro!: all_nth_sup_loc [rule_format] dest!: sup_loc_length)
qed

theorem sup_state_trans [trans]:
  "\<lbrakk>G \<turnstile> a <=s b; G \<turnstile> b <=s c\<rbrakk> \<Longrightarrow> G \<turnstile> a <=s c"
  by (auto intro: sup_loc_trans simp add: sup_state_def stk_convert Product.le_def lesub_def)

theorem sup_state_opt_trans [trans]:
  "\<lbrakk>G \<turnstile> a <=' b; G \<turnstile> b <=' c\<rbrakk> \<Longrightarrow> G \<turnstile> a <=' c"
  by (auto intro: sup_state_trans
           simp add: sup_state_opt_def Opt.le_def lesub_def
           split: option.splits)

end


section \<open>Model Semantics\<close>

(*
  Author: Frederik Lyhne Andersen, DTU Compute, 2023
*)

theory ModelSemantics imports DatalogBase
begin

subsection \<open>Definitions\<close>

definition solve_m :: \<open>rule set \<Rightarrow> atom set\<close> (\<open>\<bbbM>\<lparr>_\<rparr>\<close>) where
  \<open>\<bbbM>\<lparr>p\<rparr> \<equiv> \<Inter>{m. m \<Turnstile>\<^sub>p p}\<close>

definition solve_m_herbrand :: \<open>rule set \<Rightarrow> (nat \<Rightarrow> nat) \<Rightarrow> atom set\<close> (\<open>\<bbbM>\<^sub>\<bool>\<lparr>_\<rparr>\<^bsub>_\<^esub>\<close>) where
  \<open>\<bbbM>\<^sub>\<bool>\<lparr>p\<rparr>\<^bsub>ar\<^esub> \<equiv> \<Inter>{m. m \<subseteq> \<bool>\<lparr>p\<rparr>\<^bsub>ar\<^esub> \<and> m \<Turnstile>\<^sub>p p}\<close>

subsection \<open>Proofs\<close>

theorem finite_solve_m:
    \<open>wf_p p ar \<Longrightarrow>
     safe_p p \<Longrightarrow>
     finite \<bbbM>\<lparr>p\<rparr>\<close>
proof -
  assume a1: \<open>wf_p p ar\<close>
  assume a2: \<open>safe_p p\<close>
  then have \<open>\<exists>m. m \<Turnstile>\<^sub>p p \<and> finite m\<close>
    using a1 safe_wf_p_finite
    by simp
  then have \<open>finite (\<Inter> {m. m \<Turnstile>\<^sub>p p})\<close>
    using finite_Inter
    by auto
  then show \<open>finite \<bbbM>\<lparr>p\<rparr>\<close>
    using solve_m_def
    by simp
qed

theorem solve_m_subset_herbrand:
    \<open>wf_p p ar \<Longrightarrow>
     safe_p p \<Longrightarrow>
     \<bbbM>\<lparr>p\<rparr> \<subseteq> \<bool>\<lparr>p\<rparr>\<^bsub>ar\<^esub>\<close>
  unfolding solve_m_def
  using Inter_lower herbrand_sat_prog
  by auto

theorem solve_m_wf_interp:
    \<open>wf_p p ar \<Longrightarrow>
     safe_p p \<Longrightarrow>
     wf_i \<bbbM>\<lparr>p\<rparr> ar\<close>
proof -
  assume a1: \<open>wf_p p ar\<close>
  assume a2: \<open>safe_p p\<close>
  have a3: \<open>wf_i \<bool>\<lparr>p\<rparr>\<^bsub>ar\<^esub> ar\<close>
    using a1 herbrand_wf_i
    by simp
  have \<open>\<bbbM>\<lparr>p\<rparr> \<subseteq> \<bool>\<lparr>p\<rparr>\<^bsub>ar\<^esub>\<close>
    using a1 a2 solve_m_subset_herbrand
    by simp
  then have \<open>finite \<bbbM>\<lparr>p\<rparr> \<and> (\<forall>a\<in>\<bbbM>\<lparr>p\<rparr>. ground_a a \<and> wf_a a ar)\<close>
    using wf_i_def a3 finite_subset
    by blast
  then show \<open>wf_i \<bbbM>\<lparr>p\<rparr> ar\<close>
    using wf_i_def
    by simp
qed

lemma adom_eval_herbrand:
    \<open>wf_p p ar \<Longrightarrow>
     safe_p p \<Longrightarrow>
     adom \<bbbM>\<lparr>p\<rparr> \<subseteq> adom \<bool>\<lparr>p\<rparr>\<^bsub>ar\<^esub>\<close>
  using adom_subset solve_m_subset_herbrand
  by auto

lemma adom_eval_prog:
    \<open>wf_p p ar \<Longrightarrow>
     safe_p p \<Longrightarrow>
     adom \<bbbM>\<lparr>p\<rparr> \<subseteq> adom_p p\<close>
  using adom_eval_herbrand adom_herbrand_adom_p
  by blast

lemma solve_m_sat_rule:
    \<open>r \<in> p \<Longrightarrow>
     \<bbbM>\<lparr>p\<rparr> \<Turnstile>\<^sub>r r\<close>
proof (induct r)
  case (Rule h b)
  then show ?case
  proof -
    assume \<open>Rule h b \<in> p\<close>
    then have \<open>\<forall>x. (\<forall>r \<in> p. x \<Turnstile>\<^sub>r r) \<longrightarrow>
              (\<forall>v. (\<forall>a\<in>set b. \<lbrakk>a\<rbrakk>\<^sub>av \<in> x) \<longrightarrow> \<lbrakk>h\<rbrakk>\<^sub>av \<in> x)\<close>
      by auto
    then have \<open>\<forall>x v. (\<forall>a\<in>set b. (\<forall>r \<in> p. x \<Turnstile>\<^sub>r r) \<longrightarrow> \<lbrakk>a\<rbrakk>\<^sub>av \<in> x) \<longrightarrow>
                     (\<forall>r \<in> p. x \<Turnstile>\<^sub>r r) \<longrightarrow> \<lbrakk>h\<rbrakk>\<^sub>av \<in> x\<close>
      by simp
    then have \<open>\<forall>v. (\<forall>a\<in>set b. \<lbrakk>a\<rbrakk>\<^sub>av \<in> \<Inter> {m. \<forall>r \<in> p. m \<Turnstile>\<^sub>r r}) \<longrightarrow>
                   \<lbrakk>h\<rbrakk>\<^sub>av \<in> \<Inter> {m. \<forall>r \<in> p. m \<Turnstile>\<^sub>r r}\<close>
      by simp
    then have \<open>\<Inter> {m. \<forall>r \<in> p. m \<Turnstile>\<^sub>r r} \<Turnstile>\<^sub>r Rule h b\<close>
      by simp
    then show \<open>\<bbbM>\<lparr>p\<rparr> \<Turnstile>\<^sub>r Rule h b\<close>
      using solve_m_def sat_prog_def
      by auto
  qed
qed

theorem solve_m_sat_prog:
    \<open>\<bbbM>\<lparr>p\<rparr> \<Turnstile>\<^sub>p p\<close>
  unfolding sat_prog_def
  using solve_m_sat_rule
  by simp

theorem solve_m_herbrand_equiv:
    \<open>wf_p p ar \<Longrightarrow>
     safe_p p \<Longrightarrow>
     \<bbbM>\<lparr>p\<rparr> = \<bbbM>\<^sub>\<bool>\<lparr>p\<rparr>\<^bsub>ar\<^esub>\<close>
proof
  show \<open>\<bbbM>\<lparr>p\<rparr> \<subseteq> \<bbbM>\<^sub>\<bool>\<lparr>p\<rparr>\<^bsub>ar\<^esub>\<close>
    unfolding solve_m_herbrand_def solve_m_def
    by auto
next
  assume a1: \<open>wf_p p ar\<close>
  assume a2: \<open>safe_p p\<close>
  have \<open>\<bbbM>\<lparr>p\<rparr> \<subseteq> \<bool>\<lparr>p\<rparr>\<^bsub>ar\<^esub>\<close>
    using a1 a2 solve_m_subset_herbrand
    by simp
  then show \<open>\<bbbM>\<^sub>\<bool>\<lparr>p\<rparr>\<^bsub>ar\<^esub> \<subseteq> \<bbbM>\<lparr>p\<rparr>\<close>
    using solve_m_sat_prog solve_m_herbrand_def
    by auto
qed

lemma solve_m_no_sub:
    \<open>\<not> (\<exists>m\<subset>\<bbbM>\<lparr>p\<rparr>. m \<Turnstile>\<^sub>p p)\<close>
  unfolding solve_m_def
  by auto

theorem solve_m_mini:
    \<open>\<bbbM>\<lparr>p\<rparr> \<Turnstile>\<^sub>m\<^sub>i\<^sub>n p\<close>
  unfolding min_model_def
  using solve_m_no_sub solve_m_sat_prog
  by simp

theorem solve_m_mini_unique:
    \<open>min p = \<bbbM>\<lparr>p\<rparr>\<close>
  unfolding min_def
proof (rule the_equality)
  show \<open>\<bbbM>\<lparr>p\<rparr> \<Turnstile>\<^sub>m\<^sub>i\<^sub>n p\<close>
    using solve_m_mini
    by simp
next
  fix i
  assume a1: \<open>i \<Turnstile>\<^sub>m\<^sub>i\<^sub>n p\<close>
  then have \<open>i \<Turnstile>\<^sub>p p\<close>
    using min_model_def
    by simp
  then have \<open>\<bbbM>\<lparr>p\<rparr> \<subseteq> i\<close>
    using solve_m_def
    by auto
  then have \<open>i = \<bbbM>\<lparr>p\<rparr>\<close>
    using a1 min_model_def solve_m_sat_prog
    by blast
  then show \<open>i \<Turnstile>\<^sub>m\<^sub>i\<^sub>n p \<Longrightarrow> i = \<bbbM>\<lparr>p\<rparr>\<close>
    by auto
qed

theorem unique_minimal_model:
    \<open>min p \<Turnstile>\<^sub>m\<^sub>i\<^sub>n p\<close>
  using solve_m_mini solve_m_mini_unique
  by simp

lemma program_subset_model:
    \<open>p1 \<subseteq> p2 \<Longrightarrow>
     \<bbbM>\<lparr>p1\<rparr> \<subseteq> \<bbbM>\<lparr>p2\<rparr>\<close>
  unfolding solve_m_def sat_prog_def
  by auto

lemma program_subset_sat:
    \<open>p1 \<subseteq> p2 \<Longrightarrow>
     \<bbbM>\<lparr>p2\<rparr> \<Turnstile>\<^sub>p p1\<close>
  unfolding sat_prog_def
  using solve_m_sat_rule
  by auto

lemma fact_in_model:
    \<open>safe_p p \<Longrightarrow>
     Rule h [] \<in> p \<Longrightarrow>
     h \<in> \<bbbM>\<lparr>p\<rparr>\<close>
  using solve_m_sat_prog fact_in_interp
  by simp

lemma syms_solve_m_subset_herbrand_syms:
    \<open>wf_p p ar \<Longrightarrow>
     safe_p p \<Longrightarrow>
     syms \<bbbM>\<lparr>p\<rparr> \<subseteq> syms \<bool>\<lparr>p\<rparr>\<^bsub>ar\<^esub>\<close>
  unfolding syms_def
  using solve_m_subset_herbrand image_mono
  by auto

theorem syms_solve_m_subset_prog_syms:
    \<open>wf_p p ar \<Longrightarrow>
     safe_p p \<Longrightarrow>
     syms \<bbbM>\<lparr>p\<rparr> \<subseteq> syms_p p\<close>
  using syms_solve_m_subset_herbrand_syms syms_herbrand_in_prog_syms
  by blast

end


section \<open> Failures Divergences Semantics \<close>

theory ITree_FDSem
  imports ITree_CSP
begin

subsection \<open> Preliminaries \<close>

datatype ('e, 's) event = Ev (of_Ev: 'e) | Term 's

abbreviation "\<Sigma> \<equiv> range Ev"

adhoc_overloading
  tick Term

type_synonym ('e, 's) trace = "('e, 's) event list"
type_synonym ('e, 's) refusal = "('e, 's) event set"

lemma map_Ev_eq_iff [simp]: "map Ev xs = map Ev ys \<longleftrightarrow> xs = ys"
  by (metis event.inject(1) list.inj_map_strong)

lemma of_Ev_Ev [simp]: "(of_Ev \<circ> Ev) = id"
  by (auto)

lemma map_Ev_of_Ev [simp]: "set tr \<subseteq> range Ev \<Longrightarrow> map (Ev \<circ> of_Ev) tr = tr"
  by (metis (mono_tags, lifting) comp_def event.collapse(1) event.disc(1) map_idI rangeE subset_code(1))

lemma trace_EvE [elim]: "\<lbrakk> set tr \<subseteq> range Ev; \<And> tr'. tr = map Ev tr' \<Longrightarrow> P \<rbrakk> \<Longrightarrow> P"
  by (metis map_Ev_of_Ev map_map)

lemma map_of_Ev_append [simp]: "set tr \<subseteq> range Ev \<Longrightarrow> map of_Ev tr = tr\<^sub>1 @ tr\<^sub>2 \<longleftrightarrow> tr = (map Ev tr\<^sub>1 @ map Ev tr\<^sub>2)"
  by (auto)

lemma trace_last_Ev [simp]: "s @ [a] = map Ev tr \<longleftrightarrow> (tr \<noteq> [] \<and> s = map Ev (butlast tr) \<and> a = Ev (last tr))"
  by (auto simp add: snoc_eq_iff_butlast map_butlast last_map)

lemma Ev_subset_image [simp]: "(Ev ` A) \<subseteq> (Ev ` B) \<longleftrightarrow> A \<subseteq> B"
  by auto

lemma Ev_in_Ev_image [simp]: "Ev x \<in> Ev ` A \<longleftrightarrow> x \<in> A"
  by auto

text \<open> Roscoe's multi-step transition relation including termination events. We chose to have a
  process become @{const deadlock} after terminating. \<close>

definition mstep_to :: "('e, 's) itree \<Rightarrow> ('e, 's) trace \<Rightarrow> ('e, 's) itree \<Rightarrow> bool" ("_ \<Midarrow>_\<Rightarrow> _" [55, 0, 55] 55)
  where "P \<Midarrow>tr\<Rightarrow> P' \<equiv> ((set tr \<subseteq> range Ev \<and> P \<midarrow>map of_Ev tr\<leadsto> P') \<or>
                        (\<exists> tr' x. tr = (map Ev tr') @ [\<checkmark>(x)] \<and> P \<midarrow>tr'\<leadsto> Ret x \<and> P' = deadlock))"

lemma mstep_termE [elim]:
  "\<lbrakk> P \<Midarrow>tr @ [\<checkmark>(v)]\<Rightarrow> P'; \<And> tr'. \<lbrakk> tr = map Ev tr'; P \<midarrow>tr'\<leadsto> Ret v; P' = deadlock \<rbrakk> \<Longrightarrow> Q \<rbrakk> \<Longrightarrow> Q"
  by (auto simp add: mstep_to_def)

lemma mstep_stabilises: "\<lbrakk> P \<Midarrow>tr\<Rightarrow> P'; tr \<noteq> [] \<rbrakk> \<Longrightarrow> stabilises P"
  apply (auto simp add: mstep_to_def stabilises_traceI)
  apply (meson stabilises_traceI)
  apply (metis diverge_no_Ret_trans diverges_then_diverge)
  done

definition initials :: "('e, 's) itree \<Rightarrow> ('e, 's) event set" ("\<I>") where
"\<I>(P) = {e. \<exists> P'. P \<Midarrow>[e]\<Rightarrow> P'}"

lemma initials_Vis: "\<I>(Vis F) = Ev ` pdom F"
  by (auto simp add: initials_def mstep_to_def)

lemma initials_Ret: "\<I>(Ret x) = {\<checkmark> x}"
  by (auto simp add: initials_def mstep_to_def)

lemma initials_Sil: "\<I>(Sil P) = \<I>(P)"
  apply (auto simp add: initials_def mstep_to_def)
  apply (metis itree.distinct(5) trace_of_Sils trace_to_SilE trace_to_single_iff)
  apply blast
  done

subsection \<open> Traces \<close>

definition traces :: "('e, 's) itree \<Rightarrow> ('e, 's) trace set" where
"traces P = {map Ev tr | tr. \<exists> P'. P \<midarrow>tr\<leadsto> P'} \<union> {map Ev tr @ [\<checkmark>(v)] | tr v. P \<midarrow>tr\<leadsto> Ret v}"

lemma wbisim_eq_traces: "P \<approx> Q \<Longrightarrow> traces(P) = traces(Q)"
  apply (auto simp add: traces_def)
  apply (metis wbisim_step)
  apply (metis (no_types, opaque_lifting) wbisim_step_terminate)
  apply (metis (no_types, lifting) wbisim_step wbisim_sym)
  apply (metis (mono_tags, lifting) wbisim_step_terminate wbisim_sym)
  done

lemma trace_alt_def: "traces P = {s. \<exists> Q. P \<Midarrow>s\<Rightarrow> Q}"
  by (auto simp add: traces_def mstep_to_def)

definition straces :: "('e, 's) htree \<Rightarrow> ('s \<Rightarrow> ('e, 's) trace set)" ("traces\<^sub>s") where
"straces K = (\<lambda> s. traces (K s))"

lemma Nil_in_traces [simp]: "[] \<in> traces P"
  by (auto simp add: traces_def)

lemma traces_prefix_in_Ev: "tr @ [\<checkmark>(v)] \<in> traces(P) \<Longrightarrow> set tr \<subseteq> range Ev"
  by (auto simp add: traces_def)

lemma term_trace_iff [simp]: "tr @ [\<checkmark>(v)] \<in> traces(P) \<longleftrightarrow> (set tr \<subseteq> range Ev \<and> P \<midarrow>map of_Ev tr\<leadsto> Ret v)"
  by (auto simp add: traces_def map_idI)

lemma in_tracesI1:
  assumes "P \<midarrow>tr\<leadsto> P'" "t = map Ev tr"
  shows "t \<in> traces(P)"
  using assms traces_def by fastforce

lemma in_tracesE [elim]:
  assumes
  "tr \<in> traces P"
  "\<And> P' tr'. \<lbrakk> tr = map Ev tr'; P \<midarrow>tr'\<leadsto> P' \<rbrakk> \<Longrightarrow> R"
  "\<And> P' tr' v. \<lbrakk> tr = map Ev tr' @ [\<checkmark>(v)]; P \<midarrow>tr'\<leadsto> Ret v \<rbrakk> \<Longrightarrow> R"
  shows R
  using assms by (auto simp add: traces_def)

lemma not_in_traces [simp]: "set tr \<subseteq> range Ev \<Longrightarrow> tr \<notin> traces(P) \<longleftrightarrow> \<not> (\<exists> P'. P \<midarrow>map of_Ev tr\<leadsto> P')"
  by (simp add: traces_def, auto)

lemma traces_single_Term: "[\<checkmark> s] \<in> traces(P) \<Longrightarrow> \<exists> n. P = Sils n (Ret s)"
  by (auto simp add: traces_def)

lemma traces_Ret: "traces (Ret x) = {[], [\<checkmark>(x)]}"
  by (auto simp add: traces_def)

lemma traces_Tau: "traces (Sil P) = traces P"
  by (force simp add: traces_def)

lemma traces_Vis: "traces (Vis F) = {[]} \<union> {Ev a # tr | a tr. a \<in> pdom(F) \<and> tr \<in> traces(F a)}"
  apply (auto elim!: in_tracesE trace_to_VisE)
  apply (auto simp add: traces_def)
  apply (metis list.map(2) trace_to_Vis)
  apply (metis list.simps(9) trace_to_Vis)
  done

lemma traces_diverge: "traces diverge = {[]}"
  by (auto simp add: traces_def dest: trace_of_divergent)

lemma traces_bind:
  "traces (P \<bind> Q) =
  (traces(P) \<inter> lists (range Ev))
  \<union> {tr\<^sub>1 @ tr\<^sub>2 | tr\<^sub>1 tr\<^sub>2. \<exists> v. tr\<^sub>1 @ [\<checkmark>(v)] \<in> traces(P) \<and> tr\<^sub>2 \<in> traces(Q v)}"
  apply (auto elim!: in_tracesE trace_to_bindE bind_RetE')
  apply (auto simp add: traces_def)
  apply (metis (no_types, lifting) Nil_is_map_conv append_Nil2 image_subset_iff list.set_map map_of_Ev_append range_eqI)
  apply (smt (z3) Ev_subset_image UNIV_I bind_RetE list.set_map list.simps(8) map_of_Ev_append self_append_conv2 subsetI trace_to_Nil)
  apply (metis (no_types, opaque_lifting) List.map.id append.simps(1) id_apply image_subset_iff list.set_map list.simps(8) map_map of_Ev_Ev rangeI trace_to_Nil)
  apply (metis (mono_tags, lifting) Ev_subset_image append.right_neutral list.set_map list.simps(8) map_of_Ev_append top_greatest)
  apply (metis (no_types, lifting) append.right_neutral list.set_map list.simps(8) map_of_Ev_append subset_image_iff top_greatest)
  apply (meson trace_to_bind_left)
  apply (metis (no_types, lifting) map_Ev_of_Ev map_append map_map trace_to_bind)
  apply (metis (no_types, lifting) map_Ev_of_Ev map_append map_map trace_to_bind)
  done

lemma T1a [simp]: "traces(P) \<noteq> {}"
  by (auto simp add: traces_def)

lemma T1b:
  assumes "t\<^sub>1 @ t\<^sub>2 \<in> traces(P)"
  shows "t\<^sub>1 \<in> traces(P)"
proof (cases "t\<^sub>2 = []")
  case True
  then show ?thesis using assms by simp
next
  case False
  note t\<^sub>2 = this
  then show ?thesis
  using assms proof (erule_tac in_tracesE)
    fix P' tr
    assume a: "t\<^sub>1 @ t\<^sub>2 = map Ev tr" "P \<midarrow>tr\<leadsto> P'"
    then obtain P'' where "P \<midarrow>map of_Ev t\<^sub>1\<leadsto> P''"
      by (metis UNIV_I append_Nil2 list.set_map map_append map_of_Ev_append subsetI subset_image_iff trace_to_appendE)
    with a show ?thesis
      by (metis append_eq_map_conv in_tracesI1 trace_to_appendE)
  next
    fix P' tr v
    assume a: "t\<^sub>1 @ t\<^sub>2 = map Ev tr @ [\<checkmark> v]" "P \<midarrow>tr\<leadsto> Ret v"
    hence "(tr = map of_Ev (butlast (t\<^sub>1 @ t\<^sub>2)))"
      by (metis append_Nil2 assms butlast_snoc list.simps(8) map_of_Ev_append traces_prefix_in_Ev)
    hence P: "P \<midarrow>map of_Ev (butlast (t\<^sub>1 @ t\<^sub>2)) \<leadsto> Ret v"
      using a(2) by force
    then have "\<exists> P''. P \<midarrow>map of_Ev t\<^sub>1\<leadsto> P''"
    proof (cases "t\<^sub>1 = []")
      case True
      thus ?thesis by auto
    next
      case False
      with P t\<^sub>2 show ?thesis
        by (force elim:trace_to_appendE simp add: butlast_append)
    qed
    thus ?thesis
      by (metis (no_types, opaque_lifting) UNIV_I a(1) butlast_append butlast_snoc in_tracesI1 le_sup_iff list.set_map map_Ev_of_Ev map_map set_append subsetI subset_image_iff t\<^sub>2)
  qed
qed

lemmas T1 = T1a T1b

subsection \<open> Divergences \<close>

definition divergences :: "('a, 'b) itree \<Rightarrow> ('a, 'b) trace set" where
"divergences P = {s @ t | s t. set s \<subseteq> range Ev \<and> set t \<subseteq> range Ev \<and> (\<exists> Q. P \<Midarrow>s\<Rightarrow> Q \<and> Q\<Up>)}"

lemma divergences_alt_def:
  "divergences P = {map Ev (s @ t) | s t. (\<exists> Q. P \<midarrow>s\<leadsto> Q \<and> Q\<Up>)}"
  apply (auto elim!: trace_EvE simp add: divergences_def mstep_to_def)
  apply blast
   apply (metis Nil_is_map_conv event.distinct(1) last_map snoc_eq_iff_butlast)
  apply (force)
  done

lemma in_divergenceE [elim]:
  assumes
  "tr \<in> divergences P"
  "\<And> tr' s. \<lbrakk> tr = map Ev (tr' @ s); P \<midarrow>tr'\<leadsto> diverge \<rbrakk> \<Longrightarrow> R"
  shows R
  using assms by (auto simp add: divergences_alt_def diverges_then_diverge)

lemma in_divergence_tranI: "P \<midarrow>tr\<leadsto> diverge \<Longrightarrow> map Ev tr \<in> divergences(P)"
  by (force simp add: divergences_alt_def)

lemma D1:
  assumes "s \<in> divergences P" "t \<in> lists (range Ev)"
  shows "s @ t \<in> divergences P"
proof -
  obtain tr s' where "s = map Ev (tr @ s')" "P \<midarrow>tr\<leadsto> diverge"
    using assms(1) by blast
  with assms(2) show ?thesis
    apply (auto simp add: divergences_def mstep_to_def)
    apply (rule_tac x="map Ev tr" in exI)
    apply (force)
    done
qed

lemma D1_prefix: "\<lbrakk> s \<in> divergences P; set t \<subseteq> range Ev; s \<le> t \<rbrakk> \<Longrightarrow> t \<in> divergences P"
  by (metis (no_types, lifting) D1 Prefix_Order.prefixE in_listsI le_sup_iff set_append subset_code(1))

lemma no_divergences_then_div_free: "divergences P = {} \<Longrightarrow> div_free P"
  by (auto simp add: divergences_alt_def)
     (metis div_free_is_no_divergence no_divergence)

lemma div_free_iff_divergences_empty: "div_free P \<longleftrightarrow> divergences P = {}"
  by (metis div_free_is_no_divergence diverges_diverge ex_in_conv in_divergenceE no_divergence no_divergences_then_div_free)

lemma wbisim_le_divergences:
  assumes "P \<approx> Q"
  shows "divergences(P) \<subseteq> divergences(Q)"
  using assms
  by (auto simp add: divergences_alt_def)
     (metis diverge_wbisim1 diverges_then_diverge wbisim_step)

lemma wbisim_eq_divergences:
  assumes "P \<approx> Q"
  shows "divergences(P) = divergences(Q)"
  by (metis antisym_conv assms wbisim_le_divergences wbisim_sym)

definition divergence_strict_traces :: "('e, 's) itree \<Rightarrow> ('e, 's) trace set" ("traces\<^sub>\<bottom>") where
"divergence_strict_traces P = traces P \<union> divergences P"

lemma F1a: "traces\<^sub>\<bottom>(P) \<noteq> {}"
  by (simp add: divergence_strict_traces_def)

lemma non_divergent_prefix:
  assumes "t\<^sub>1 @ t\<^sub>2 \<in> divergences P" "t\<^sub>1 \<notin> divergences P"
  shows "t\<^sub>1 \<in> traces P"
proof -
  obtain tr s where tr: "t\<^sub>1 @ t\<^sub>2 = map Ev (tr @ s)" "P \<midarrow>tr\<leadsto> diverge"
    using assms(1) by blast
  hence t1: "set t\<^sub>1 \<subseteq> range Ev"
    by (metis Ev_subset_image le_sup_iff list.set_map set_append subset_UNIV)
  hence "\<not> (t\<^sub>1 \<ge> map Ev tr)"
    by (meson D1_prefix assms(2) in_divergence_tranI tr(2))
  hence "t\<^sub>1 < map Ev tr"
    by (smt (z3) Prefix_Order.prefix_prefix append_eq_append_conv2 less_list_def map_append order_refl tr(1))
  thus ?thesis
    by (metis Prefix_Order.strict_prefixE' T1b in_tracesI1 tr(2))
qed

lemma F1b: "t\<^sub>1 @ t\<^sub>2 \<in> traces\<^sub>\<bottom>(P) \<Longrightarrow> t\<^sub>1 \<in> traces\<^sub>\<bottom>(P)"
  by (auto simp add: divergence_strict_traces_def non_divergent_prefix, meson T1b)

lemma divergences_diverge: "divergences diverge = lists (range Ev)"
  by (auto simp add: divergences_alt_def)
     (metis diverges_diverge map_append self_append_conv2 subsetI trace_EvE trace_to_Nil)

lemma divergences_Ret: "divergences (Ret x) = {}"
  by (simp add: divergences_alt_def)

lemma divergences_Vis: "divergences (Vis F) = {[Ev e] @ s | e s. e \<in> pdom(F) \<and> s \<in> divergences(F(e)\<^sub>p)}"
  apply (auto simp add: divergences_alt_def)
  apply (metis (no_types, lifting) append_Cons diverge_not_Vis diverges_diverge diverges_implies_equal list.simps(9) trace_to_VisE)
  apply (metis Vis_Cons_trns append_Cons list.simps(9))
  done

lemma divergences_Sil: "divergences (Sil P) = divergences P"
  by (auto simp add: divergences_alt_def)
     (metis stabilises_Sil trace_to_Nil trace_to_SilE)

subsection \<open> Failures \<close>

text \<open> A failure is recorded when there is a trace leading to a stable interaction tree. At this
  point, the refusal is calculated. \<close>

definition refuses :: "('e, 's) itree \<Rightarrow> ('e, 's) refusal \<Rightarrow> bool" (infix "ref" 65) where
"refuses P B = ((\<exists> F. P = Vis F \<and> B \<inter> Ev ` pdom F = {}) \<or> (\<exists> x. P = Ret x \<and> \<checkmark>(x) \<notin> B))"

lemma stable_refuses [simp]: "P ref A \<Longrightarrow> stable P"
  by (auto simp add: refuses_def)

lemma Ret_refuses [simp]: "Ret x ref B \<longleftrightarrow> \<checkmark>(x) \<notin> B"
  by (simp add: refuses_def)

lemma Vis_refuses [simp]: "Vis F ref B \<longleftrightarrow> B \<inter> Ev ` pdom F = {}"
  by (simp add: refuses_def)

lemma Sil_refuses [simp]: "Sil P ref B = False"
  by (simp add: refuses_def)

lemma refuses_down_closed: "\<lbrakk> P ref X; Y \<subseteq> X \<rbrakk> \<Longrightarrow> P ref Y"
  by (force simp add: refuses_def)

definition failure_of :: "('e list \<times> 'e set) \<Rightarrow> ('e, 's) itree \<Rightarrow> bool" where
"failure_of = (\<lambda> (tr, E) P. \<exists> P'. P \<midarrow>tr\<leadsto> P' \<and> is_Vis P' \<and> E \<subseteq> (- pdom (un_Vis P')))"

lemma Vis_trace_to: "Vis F \<midarrow>tr\<leadsto> P \<longleftrightarrow> ((tr = [] \<and> P = Vis F) \<or> (\<exists> a tr'. a \<in> pdom(F) \<and> tr = a # tr' \<and> (F a) \<midarrow>tr'\<leadsto> P))"
  by (auto)

definition failures :: "('e, 's) itree \<Rightarrow> (('e, 's) trace \<times> ('e, 's) refusal) set" where
"failures P = {(s, X). \<exists> Q. P \<Midarrow>s\<Rightarrow> Q \<and> Q ref X} \<union> {(s @ [\<checkmark>(v)], X) | s v X. \<exists> Q. P \<Midarrow>s @ [\<checkmark>(v)]\<Rightarrow> Q}"

lemma failure_simpl_def: "failures P = {(s, X). \<exists> Q. P \<Midarrow>s\<Rightarrow> Q \<and> Q ref X}"
  by (force simp add: failures_def refuses_def deadlock_def)

lemma in_failuresE [elim]:
  assumes
  "f \<in> failures P"
  \<comment> \<open> The process reaches a visible choice, and is refusing all subsets of possible events \<close>
  "\<And> F B T tr. \<lbrakk> f = (map Ev tr, B); P \<midarrow>tr\<leadsto> Vis F; B \<inter> Ev ` pdom F = {} \<rbrakk> \<Longrightarrow> R"
  \<comment> \<open> The process reaches a termination event, and is refusing all non-termination events \<close>
  "\<And> x B T tr. \<lbrakk> f = (map Ev tr, B - {\<checkmark>(x)}); P \<midarrow>tr\<leadsto> Ret x \<rbrakk> \<Longrightarrow> R"
  \<comment> \<open> The process terminates; technically similar to the previous one. \<close>
  "\<And> x B T tr. \<lbrakk> f = (map Ev tr @ [\<checkmark> x], B); P \<midarrow>tr\<leadsto> Ret x \<rbrakk> \<Longrightarrow> R"
  shows R
  using assms
  by (auto simp add: failures_def refuses_def mstep_to_def deadlock_def)
     (metis Diff_insert_absorb map_Ev_of_Ev map_map)

lemma in_failuresI1: "\<lbrakk> P \<midarrow>tr\<leadsto> Vis F; B \<inter> Ev ` pdom(F) = {} \<rbrakk> \<Longrightarrow> (map Ev tr, B) \<in> failures P"
  by (auto simp add: failures_def mstep_to_def)

lemma in_failuresI2: "P \<midarrow>tr\<leadsto> Ret x \<Longrightarrow> (map Ev tr, B - {\<checkmark> x}) \<in> failures P"
  by (auto simp add: failures_def mstep_to_def)

lemma in_failures_iff:
  "(tr, B) \<in> failures P \<longleftrightarrow>
        (\<exists> F tr'. tr = map Ev tr' \<and> P \<midarrow>tr'\<leadsto> Vis F \<and> B \<inter> Ev ` pdom(F) = {})
        \<or> (\<exists> x tr'. tr = map Ev tr' \<and> \<checkmark> x \<notin> B \<and> P \<midarrow>tr'\<leadsto> Ret x)
        \<or> (\<exists> x tr'. tr = map Ev tr' @ [\<checkmark> x] \<and> P \<midarrow>tr'\<leadsto> Ret x)"
  by (auto simp add: failures_def mstep_to_def refuses_def)
     (metis map_Ev_of_Ev map_map, blast+)

lemma failures_term_iff:
  "(tr @ [\<checkmark>(v)], E) \<in> failures(P) \<longleftrightarrow> (\<exists> Q. P \<Midarrow>tr @ [\<checkmark>(v)]\<Rightarrow> Q)"
  by (auto simp add: failures_def)

lemma failures_term_Ev_iff:
  "(map Ev tr @ [\<checkmark>(v)], E) \<in> failures(P) \<longleftrightarrow> P \<midarrow>tr\<leadsto> Ret v"
  by (auto simp add: failures_def mstep_to_def)

lemma T2: "(s, X) \<in> failures(P) \<Longrightarrow> s \<in> traces(P)"
  by force

lemma F2: "\<lbrakk> (s, X) \<in> failures(P); Y \<subseteq> X \<rbrakk> \<Longrightarrow> (s, Y) \<in> failures(P)"
  by (auto simp add: failures_def mstep_to_def, meson refuses_down_closed)

lemma F3: "\<lbrakk> (s, X) \<in> failures(P); Y \<inter> {x. s @ [x] \<in> traces(P)} = {} \<rbrakk> \<Longrightarrow> (s, X \<union> Y) \<in> failures(P)"
  apply (auto simp add: in_failures_iff traces_def set_eq_iff)
  apply (rename_tac F tr')
   apply (drule_tac x="F" in spec)
  apply (auto)
  apply (rename_tac F tr' a)
  apply (drule_tac x="Ev a" in spec)
  apply (auto)
  apply (metis Vis_Cons_trns butlast_snoc snoc_eq_iff_butlast trace_to_ConsE trace_to_Nil trace_to_trans)
  done

lemma wbisim_refusals_eq: "\<lbrakk> P \<approx> Q; stable P; stable Q \<rbrakk> \<Longrightarrow> P ref A \<longleftrightarrow> Q ref A"
  apply (auto simp add: refuses_def elim!: wbisim_VisE)
  apply (metis Vis_Sils is_Ret_Sils is_Vis_Sils itree.exhaust_disc)
  apply (metis itree.discI(2) wbisim.cases wbisim_RetE)
  apply (metis (mono_tags, lifting) Vis_Sils is_Ret_Sils is_Vis_Sils itree.exhaust_disc wbisim_Vis_eq wbisim_sym)
  apply (metis itree.discI(2) wbisim.cases wbisim_RetE wbisim_sym)
  done

lemma wbisim_le_failures:
  assumes "P \<approx> Q"
  shows "failures(P) \<subseteq> failures(Q)"
proof (safe)
  fix s X
  assume "(s, X) \<in> failures P"
  thus "(s, X) \<in> failures Q"
    apply (auto simp add: in_failures_iff)
    apply (smt (verit, best) append.right_neutral assms trace_of_Sils trace_to_trans wbisim_VisE wbisim_step)
    apply (metis (no_types, lifting) assms wbisim_step_terminate)
    apply (metis assms wbisim_step_terminate)
  done
qed

lemma wbisim_eq_failures:
  assumes "P \<approx> Q"
  shows "failures(P) = failures(Q)"
  by (metis antisym_conv assms wbisim_le_failures wbisim_sym)

definition stable_failures :: "('e, 's) itree \<Rightarrow> (('e, 's) trace \<times> ('e, 's) refusal) set" ("failures\<^sub>\<bottom>") where
"stable_failures P = failures(P) \<union> {(s, X). s \<in> divergences(P) \<and> X \<subseteq> range Ev}"

lemma diverge_no_failures [dest]: "failure_of t diverge \<Longrightarrow> False"
  apply (simp add: failure_of_def prod.case_eq_if)
  apply (auto)
  done

lemma failures_diverge: "failures diverge = {}"
  by (auto simp add: failures_def refuses_def mstep_to_def)

lemma failures_Sil:
  "failures (Sil P) = failures P"
  by (simp add: failures_def mstep_to_def, auto)

lemma failures_Ret:
  "failures (Ret v) = {([], X) | X. \<checkmark>(v) \<notin> X} \<union> {([\<checkmark>(v)], X) | X. True}"
  by (simp add: failures_def mstep_to_def, safe, simp_all)

lemma failures_Vis:
  "failures (Vis F) = {([], X) | X. X \<inter> Ev ` pdom F = {}}
                      \<union> {(Ev a # tr, X) | tr a X. a \<in> pdom(F) \<and> (tr, X) \<in> failures(F a)}"
  apply (simp add: failures_def mstep_to_def Vis_trace_to)
  apply (safe, simp_all)
  apply force
  apply blast
  apply blast
  apply blast
  apply (metis list.simps(9) option.sel)
  apply (metis list.simps(9) option.sel)
  done

lemma failures_deadlock: "failures deadlock = {([], X) | X. True}"
  by (auto simp add: deadlock_def failures_Vis)

lemma failures_inp:
  "wb_prism c \<Longrightarrow>
   failures (inp_in c A) =
    {([], E) | E. \<forall> x\<in>A. Ev (build\<^bsub>c\<^esub> x) \<notin> E}
    \<union> {([Ev (build\<^bsub>c\<^esub> x)], E) | E x. x \<in> A \<and> \<checkmark> () \<notin> E}
    \<union> {([Ev (build\<^bsub>c\<^esub> x), \<checkmark> ()], E) | E x. x \<in> A}"
  by (simp add: inp_in_where_def failures_Vis failures_Ret, safe)
     (auto simp add: wb_prism.range_build failures_Ret)

lemma dom_bind [simp]: "Map.dom (\<lambda> x. P x \<bind> Q) = {x \<in> Map.dom P. the(P x) \<in> Map.dom Q}"
  by (auto)

lemma refuses_Term_iff: "Q ref (B \<union> range \<checkmark>) \<longleftrightarrow> (\<exists>F. Q = Vis F \<and> B \<inter> Ev ` pdom F = {})"
  by (auto simp add: refuses_def)

lemma failures_Term_iff:
  "(map Ev tr, B \<union> range \<checkmark>) \<in> failures P \<longleftrightarrow> (\<exists> F. P \<midarrow>tr\<leadsto> Vis F \<and> B \<inter> Ev ` pdom F = {})"
  by (auto simp add: failures_def mstep_to_def refuses_Term_iff)
     (metis event.simps(4) trace_last_Ev)+

text \<open> Refusing all termination events \<close>

lemma "(tr, B \<union> range \<checkmark>) \<in> failures P \<longleftrightarrow>
        (\<exists> F tr'. tr = map Ev tr' \<and> P \<midarrow>tr'\<leadsto> Vis F \<and> B \<inter> Ev ` pdom(F) = {})
        \<or> (\<exists> x tr'. tr = map Ev tr' @ [\<checkmark> x] \<and> P \<midarrow>tr'\<leadsto> Ret x)"
  apply (auto simp add: failures_def mstep_to_def refuses_def)
  apply (metis inf_sup_distrib2 map_Ev_of_Ev map_map sup_eq_bot_iff)
  apply (metis Vis_refuses refuses_Term_iff)
  done

lemma failures_bind:
  "failures (P \<bind> Q) =
    {(s, X). set s \<subseteq> range Ev \<and> (s, X \<union> (range Term)) \<in> failures(P)}
    \<union> {(s @ t, X) | s t X. \<exists> v. s @ [\<checkmark>(v)] \<in> traces(P) \<and> (t, X) \<in> failures(Q v)}"
  apply (rule set_eqI)
  apply (clarify)
  apply (simp add: in_failures_iff)
  apply (auto elim!: trace_to_bindE bind_VisE' bind_RetE')
              apply (meson Vis_refuses refuses_Term_iff)
             apply (metis (no_types, opaque_lifting) List.map.id append.right_neutral id_apply image_subset_iff list.set_map list.simps(8) map_map of_Ev_Ev rangeI trace_to_Nil)
            apply (metis (no_types, lifting) image_subset_iff list.set_map map_Ev_eq_iff map_Ev_of_Ev map_map rangeI)
           apply (metis (no_types, opaque_lifting) Ev_subset_image UNIV_I append.right_neutral list.map_comp list.set_map list.simps(8) map_Ev_eq_iff map_Ev_of_Ev subsetI trace_to_Nil)
          apply (metis (no_types, opaque_lifting) append.right_neutral list.set_map map_append map_of_Ev_append subset_image_iff top_greatest)
         apply (metis (no_types, opaque_lifting) append_Nil list.set_map list.simps(8) map_of_Ev_append subset_image_iff top_greatest trace_to_Nil)
        apply (metis (no_types, opaque_lifting) append_Nil list.set_map list.simps(8) map_of_Ev_append subset_image_iff top_greatest trace_to_Nil)
       apply (metis (no_types, opaque_lifting) append.right_neutral list.set_map list.simps(8) map_of_Ev_append subset_image_iff top_greatest)
      apply (metis (no_types, opaque_lifting) Ev_subset_image append_Nil list.set_map map_append map_of_Ev_append top_greatest)
     apply (rename_tac b F tr')
     apply (drule_tac x="map_pfun (\<lambda> x. bind_itree x Q) F" in spec)
     apply (simp)
     apply (metis Int_Un_distrib2 Un_Int_eq(1) bind_Vis disjoint_iff trace_to_bind_left)
    apply (metis (no_types, lifting) map_Ev_of_Ev map_append map_map trace_to_bind)+
  done

lemma failure_Ret_neq_Vis:
  assumes "failures(Ret x) = failures(Vis F)"
  shows "False"
proof -
  have "([\<checkmark> x], {}) \<in> failures(Ret x)"
    by (auto simp add: failures_Ret)
  moreover have "([\<checkmark> x], {}) \<notin> failures(Vis F)"
    by (auto simp add: failures_Vis)
  ultimately show ?thesis
    using assms by blast
qed

lemma mstep_to_term: "P \<Midarrow>[\<checkmark> v]\<Rightarrow> P' \<longleftrightarrow> (\<exists> n. P = Sils n (Ret v) \<and> P' = deadlock)"
  by (metis append_Nil map_is_Nil_conv mstep_termE mstep_to_def trace_of_Sils trace_to_NilE)

lemma
  assumes "P \<Midarrow>[a]\<Rightarrow> P'" "a \<notin> \<I>(P)" "is_Vis Q"
  shows "P \<box> Q \<Midarrow>[a]\<Rightarrow> P'"
proof -
  have "stabilises P"
    by (meson assms(1) mstep_stabilises not_Cons_self2)
  then obtain n P'' where P'': "P = Sils n P''" "stable P''"
    by (metis stabilises_def)
  have "P'' \<box> Q \<Midarrow>[a]\<Rightarrow> P'"
  proof (cases P'')
    case (Ret x1)
    then show ?thesis oops

 (*
    next
    case (Sil x2)
    then show ?thesis
      using P'' by force
  next
    case (Vis F)
    with assms(1) P'' obtain e where "a = Ev e" "e \<in> pdom F"
      by (auto simp add: mstep_to_def domIff)
    with assms P'' show ?thesis
      apply (simp)
  oops
*)

lemma
  assumes "\<I>(P) \<inter> \<I>(Q) = {}"
  shows "failures(P \<box> Q) = {([], X) | X. ([], X) \<in> failures(P) \<inter> failures(Q)}
                         \<union> {(s, X). (s, X) \<in> failures P \<union> failures Q \<and> s \<noteq> []}
                         \<union> {([], X) | X. X \<subseteq> range Ev \<and> (\<exists> v. [\<checkmark> v] \<in> traces(P) \<union> traces(Q))}"
  oops

subsection \<open> Determinism \<close>

definition "deterministic P = (divergences P = {} \<and> (\<forall> s a. s @ [a] \<in> traces(P) \<longrightarrow> (s, {a}) \<notin> failures(P)))"

text \<open> Interaction trees satisfy the CSP definition of determinism. \<close>

lemma div_free_is_determinsitic:
  "div_free P \<Longrightarrow> deterministic P"
  apply (auto simp add: deterministic_def divergences_def traces_def failures_def mstep_to_def refuses_def termination_determinsitic)
  apply (metis div_free_diverge diverges_diverge diverges_implies_equal trace_to_div_free)
  apply (simp add: domD trace_to_determinstic_choice)
  apply (metis event.simps(4) last_map list.simps(8) snoc_eq_iff_butlast)
  apply (metis append_butlast_last_id is_Ret_def trace_to_Ret_end)
  apply (metis Cons_eq_map_D append_eq_map_conv event.simps(4))
  apply (metis Nil_is_append_conv Nil_is_map_conv event.simps(4) last_map last_snoc not_Cons_self2)
  apply (meson trace_to_Ret_excl_Vis)
  apply (metis event.simps(4) trace_last_Ev)+
  done
hide_const Map.dom

lemma has_Nil_divergence_unstable: "[] \<in> divergences Q \<Longrightarrow> unstable Q"
  by (auto simp add: divergences_def diverges_implies_unstable diverges_then_diverge mstep_to_def trace_to_Nil_diverges)

lemma divergences_has_Nil_is_diverge:
  "[] \<in> divergences P \<Longrightarrow> P = diverge"
proof (coinduction arbitrary: P rule: itree_strong_coind')
case RetF
  then show ?case by (simp add: has_Nil_divergence_unstable itree.distinct_disc(2))
next
  case SilF
  then show ?case by (simp add: has_Nil_divergence_unstable)
next
  case VisF
  then show ?case by (simp, meson has_Nil_divergence_unstable itree.distinct_disc(6))
next
  case Ret
  then show ?case by (auto)
next
  case Sil
  then show ?case by (auto simp add: divergences_Sil, metis diverge.code itree.inject(2))
next
  case Vis
  then show ?case by (auto simp add: divergences_Vis)
qed

lemma dom_Vis_ref: "dom F = - (\<Union> {E. Vis F ref (Ev ` E)})"
  by (auto simp add: refuses_def)

lemma dom_from_traces: "pdom F = {a. \<exists> tr. Ev a # tr \<in> traces (Vis F)}"
  by (simp only: dom_Vis_ref traces_Vis, simp add: traces_def mstep_to_def, auto)

lemma dom_from_failures: "dom F = {a. \<forall> E. ([], E) \<in> failures (Vis F) \<longrightarrow> Ev a \<notin> E}"
  apply (simp only: dom_Vis_ref)
  apply (simp add: failures_def mstep_to_def refuses_def )
  apply safe
    apply (erule trace_to_VisE)
  apply (simp)
  apply (metis (no_types, opaque_lifting) Int_insert_left_if0 disjoint_iff image_empty image_insert inf_bot_left singletonI)
    apply (auto)
  done

lemma traces_eq_is_Vis: "\<lbrakk> traces P = traces Q; is_Vis P; stable Q \<rbrakk> \<Longrightarrow> is_Vis Q"
  by (metis append_Nil empty_subsetI is_Vis_Sils itree.collapse(1) itree.exhaust_disc list.set(1) list.simps(8) term_trace_iff trace_to.intros(1) traces_single_Term)

lemma traces_eq_is_Ret: "\<lbrakk> traces P = traces Q; is_Ret P; stable Q \<rbrakk> \<Longrightarrow> is_Ret Q"
  by (metis itree.distinct_disc(2) itree.distinct_disc(3) itree.exhaust_disc traces_eq_is_Vis)

theorem wbisim_implies_fd_equiv:
  assumes "failures(P) = failures(Q) \<and> divergences(P) = divergences(Q)"
  shows "P \<approx> Q"
  using assms
proof (coinduction arbitrary: P Q rule: wbisim_strong_Sil_coind)
  case (2 P Q)
  then show ?case
    using divergences_has_Nil_is_diverge by (auto simp add: failures_diverge divergences_diverge)
next
  case (3 P' P Q)
  then show ?case
    by (metis Sil_wbisim_iff2 failures_Sil wbisim_eq_divergences wbisim_refl)
next
  case (4 P Q)
  then show ?case
    by (metis failure_Ret_neq_Vis is_Ret_def is_VisE itree.exhaust_disc)
next
  case (5 F G P Q)

  hence 1: "failures (Vis F) = failures (Vis G)"
    by auto

  have 2: "divergences (Vis F) = divergences (Vis G)"
    using 5 by auto

  have dom: "dom F = dom G"
    by (simp add: 5 dom_from_failures)

  have fd: "(\<forall>e\<in>dom F. (\<exists>P Q. F(e)\<^sub>p = P \<and> G(e)\<^sub>p = Q \<and> failures P = failures Q \<and> divergences P = divergences Q))"
  proof
    fix e
    assume a: "e \<in> dom F"
    show "\<exists>P Q. F(e)\<^sub>p = P \<and> G(e)\<^sub>p = Q \<and> failures P = failures Q \<and> divergences P = divergences Q"
    proof -
      have "failures (F(e)\<^sub>p) = failures (G(e)\<^sub>p)"
      proof (auto simp add: set_eq_iff)
        fix tr E
        assume "(tr, E) \<in> failures (F(e)\<^sub>p)"
        hence i: "([Ev e] @ tr, E) \<in> failures (Vis F)"
          by (simp add: failures_Vis a)
        with 1 have "([Ev e] @ tr, E) \<in> failures (Vis G)"
          by auto
        thus "(tr, E) \<in> failures (G(e)\<^sub>p) "
          by (simp add: failures_Vis)
      next
        fix tr E
        assume "(tr, E) \<in> failures (G(e)\<^sub>p)"
        with dom[THEN sym] have i: "([Ev e] @ tr, E) \<in> failures (Vis G)"
          by (simp add: failures_Vis a)
        with 1 have "([Ev e] @ tr, E) \<in> failures (Vis F)"
          by auto
        thus "(tr, E) \<in> failures (F(e)\<^sub>p) "
          by (simp add: failures_Vis)
      qed
      moreover have "divergences(F(e)\<^sub>p) = divergences(G(e)\<^sub>p)"
      proof (auto simp add: set_eq_iff)
        fix tr
        assume "tr \<in> divergences (F(e)\<^sub>p)"
        hence i: "[Ev e] @ tr \<in> divergences (Vis F)"
          by (simp add: divergences_Vis a)
        with 2 have "[Ev e] @ tr \<in> divergences (Vis G)"
          by auto
        thus "tr \<in> divergences (G(e)\<^sub>p) "
          by (simp add: divergences_Vis)
      next
        fix tr
        assume "tr \<in> divergences (G(e)\<^sub>p)"
        with dom[THEN sym] have i: "[Ev e] @ tr \<in> divergences (Vis G)"
          by (simp add: divergences_Vis a)
        with 2 have "[Ev e] @ tr \<in> divergences (Vis F)"
          by auto
        thus "tr \<in> divergences (F(e)\<^sub>p) "
          by (simp add: divergences_Vis)
      qed
      ultimately show ?thesis
        by auto
    qed
  qed
  with dom show ?case by simp
next
  case (6 x y P Q)
  then show ?case
    by (force simp add: failures_Ret divergences_Ret)
qed (simp)

theorem wbisim_implies_trace_divergences_equiv:
  assumes "traces(P) = traces(Q) \<and> divergences(P) = divergences(Q)"
  shows "P \<approx> Q"
  using assms
proof (coinduction arbitrary: P Q rule: wbisim_strong_Sil_coind)
  case (2 P Q)
  then show ?case
    using divergences_has_Nil_is_diverge by (auto simp add: failures_diverge divergences_diverge)
next
  case (3 P' P Q)
  then show ?case
    by (metis divergences_Sil traces_Tau)
next
  case (4 P Q)
  then show ?case
    by (metis traces_eq_is_Ret traces_eq_is_Vis)
next
  case (5 F G P Q)

  hence 1: "traces (Vis F) = traces (Vis G)"
    by auto

  have 2: "divergences (Vis F) = divergences (Vis G)"
    using 5 by auto

  have dom: "dom F = dom G"
    by (simp add: 5 dom_from_traces)

  have fd: "(\<forall>e\<in>dom F. (\<exists>P Q. F(e)\<^sub>p = P \<and> G(e)\<^sub>p = Q \<and> traces P = traces Q \<and> divergences P = divergences Q))"
  proof
    fix e
    assume a: "e \<in> dom F"
    show "\<exists>P Q. F(e)\<^sub>p = P \<and> G(e)\<^sub>p = Q \<and> traces P = traces Q \<and> divergences P = divergences Q"
    proof -
      have "traces (F(e)\<^sub>p) = traces (G(e)\<^sub>p)"
      proof (auto simp add: set_eq_iff)
        fix tr
        assume "tr \<in> traces (F(e)\<^sub>p)"
        hence i: "[Ev e] @ tr \<in> traces (Vis F)"
          by (simp add: traces_Vis a)
        with 1 have "[Ev e] @ tr \<in> traces (Vis G)"
          by auto
        thus "tr \<in> traces (G(e)\<^sub>p) "
          by (simp add: traces_Vis)
      next
        fix tr
        assume "tr \<in> traces (G(e)\<^sub>p)"
        with dom[THEN sym] have i: "[Ev e] @ tr \<in> traces (Vis G)"
          by (simp add: traces_Vis a)
        with 1 have "[Ev e] @ tr \<in> traces (Vis F)"
          by auto
        thus "tr \<in> traces (F(e)\<^sub>p) "
          by (simp add: traces_Vis)
      qed
      moreover have "divergences(F(e)\<^sub>p) = divergences(G(e)\<^sub>p)"
      proof (auto simp add: set_eq_iff)
        fix tr
        assume "tr \<in> divergences (F(e)\<^sub>p)"
        hence i: "[Ev e] @ tr \<in> divergences (Vis F)"
          by (simp add: divergences_Vis a)
        with 2 have "[Ev e] @ tr \<in> divergences (Vis G)"
          by auto
        thus "tr \<in> divergences (G(e)\<^sub>p) "
          by (simp add: divergences_Vis)
      next
        fix tr
        assume "tr \<in> divergences (G(e)\<^sub>p)"
        with dom[THEN sym] have i: "[Ev e] @ tr \<in> divergences (Vis G)"
          by (simp add: divergences_Vis a)
        with 2 have "[Ev e] @ tr \<in> divergences (Vis F)"
          by auto
        thus "tr \<in> divergences (F(e)\<^sub>p) "
          by (simp add: divergences_Vis)
      qed
      ultimately show ?thesis
        by auto
    qed
  qed
  with dom show ?case by simp
next
  case (6 x y P Q)
  then show ?case
    by (force simp add: traces_Ret divergences_Ret)
qed (simp)

lemma wbisim_iff_traces_divergences_equiv:
  "P \<approx> Q \<longleftrightarrow> (traces P = traces Q \<and> divergences P = divergences Q)"
  by (meson wbisim_eq_divergences wbisim_eq_traces wbisim_implies_trace_divergences_equiv)

end