section\<open>Generalize Simple Firewall\<close>
theory Generic_SimpleFw
imports SimpleFw_Semantics "Common/List_Product_More" "Common/Option_Helpers"
begin

subsection\<open>Semantics\<close>
  text\<open>The semantics of the @{term simple_fw} is quite close to @{const List.find}.
  The idea of the generalized @{term simple_fw} semantics is that you can have anything as the
  resulting action, not only a @{type simple_action}.\<close>

  definition generalized_sfw
    :: "('i::len simple_match \<times> 'a) list \<Rightarrow> ('i, 'pkt_ext) simple_packet_scheme \<Rightarrow> ('i simple_match \<times> 'a) option"
    where
    "generalized_sfw l p \<equiv> find (\<lambda>(m,a). simple_matches m p) l"

subsection\<open>Lemmas\<close>
  lemma generalized_sfw_simps:
    "generalized_sfw [] p = None"
    "generalized_sfw (a # as) p = (if (case a of (m,_) \<Rightarrow> simple_matches m p) then Some a else generalized_sfw as p)"
    unfolding generalized_sfw_def by simp_all

  lemma generalized_sfw_append:
    "generalized_sfw (a @ b) p = (case generalized_sfw a p of Some x \<Rightarrow> Some x
                                                           |  None \<Rightarrow> generalized_sfw b p)"
    by(induction a) (simp_all add: generalized_sfw_simps)

  lemma simple_generalized_undecided:
    "simple_fw fw p \<noteq> Undecided \<Longrightarrow> generalized_sfw (map simple_rule_dtor fw) p \<noteq> None"
    by(induction fw)
    (clarsimp simp add: generalized_sfw_def simple_fw_alt simple_rule_dtor_def
              split: prod.splits if_splits simple_action.splits simple_rule.splits)+

  lemma generalized_sfwSomeD: "generalized_sfw fw p = Some (r,d) \<Longrightarrow> (r,d) \<in> set fw \<and> simple_matches r p"
    unfolding generalized_sfw_def
    by(induction fw) (simp split: if_split_asm)+

  lemma generalized_sfw_NoneD: "generalized_sfw fw p = None \<Longrightarrow> \<forall>(a,b) \<in> set fw. \<not> simple_matches a p"
    by(induction fw) (clarsimp simp add: generalized_sfw_simps split: if_splits)+

  lemma generalized_fw_split: "generalized_sfw fw p = Some r \<Longrightarrow> \<exists>fw1 fw3. fw = fw1 @ r # fw3 \<and> generalized_sfw fw1 p = None"
    apply(induction fw rule: rev_induct)
     apply(simp add: generalized_sfw_simps generalized_sfw_append split: option.splits;fail)
    apply(clarsimp simp add: generalized_sfw_simps generalized_sfw_append split: option.splits if_splits)
      apply blast+
  done

  lemma generalized_sfw_filterD:
    "generalized_sfw (filter f fw) p = Some (r,d) \<Longrightarrow> simple_matches r p \<and> f (r,d)"
  by(induction fw) (simp_all add: generalized_sfw_simps split: if_splits)

  lemma generalized_sfw_mapsnd:
    "generalized_sfw (map (apsnd f) fw) p = map_option (apsnd f) (generalized_sfw fw p)"
    by(induction fw) (simp add: generalized_sfw_simps split: prod.splits)+

subsection\<open>Equality with the Simple Firewall\<close>

  text\<open>A matching action of the simple firewall directly corresponds to a filtering decision\<close>
  definition simple_action_to_decision :: "simple_action \<Rightarrow> state" where
    "simple_action_to_decision a \<equiv> case a of Accept \<Rightarrow> Decision FinalAllow
                                          |   Drop \<Rightarrow> Decision FinalDeny"

  text\<open>The @{const simple_fw} and the @{const generalized_sfw} are equal, if the state is translated appropriately.\<close>
  lemma simple_fw_iff_generalized_fw:
    "simple_fw fw p = simple_action_to_decision a \<longleftrightarrow> (\<exists>r. generalized_sfw (map simple_rule_dtor fw) p = Some (r,a))"
  by(induction fw)
    (clarsimp simp add: generalized_sfw_simps simple_rule_dtor_def simple_fw_alt simple_action_to_decision_def
              split: simple_rule.splits if_splits simple_action.splits)+

  lemma simple_fw_iff_generalized_fw_accept:
    "simple_fw fw p = Decision FinalAllow \<longleftrightarrow> (\<exists>r. generalized_sfw (map simple_rule_dtor fw) p = Some (r, Accept))"
    by(fact simple_fw_iff_generalized_fw[where a = simple_action.Accept,
                                         unfolded simple_action_to_decision_def simple_action.simps])
  lemma simple_fw_iff_generalized_fw_drop:
    "simple_fw fw p = Decision FinalDeny \<longleftrightarrow> (\<exists>r. generalized_sfw (map simple_rule_dtor fw) p = Some (r, Drop))"
    by(fact simple_fw_iff_generalized_fw[where a = simple_action.Drop,
                                         unfolded simple_action_to_decision_def simple_action.simps])

subsection\<open>Joining two firewalls, i.e. a packet is send through both sequentially.\<close>

  definition generalized_fw_join
    :: "('i::len simple_match \<times> 'a) list \<Rightarrow> ('i simple_match \<times> 'b) list \<Rightarrow> ('i simple_match \<times> 'a \<times> 'b) list"
    where
    "generalized_fw_join l1 l2 \<equiv> [(u,(a,b)). (m1,a) \<leftarrow> l1, (m2,b) \<leftarrow> l2, u \<leftarrow> option2list (simple_match_and m1 m2)]"

  lemma generalized_fw_join_1_Nil[simp]: "generalized_fw_join [] f2 = []"
  unfolding generalized_fw_join_def by(induction f2) simp+

  lemma generalized_fw_join_2_Nil[simp]: "generalized_fw_join f1 [] = []"
  unfolding generalized_fw_join_def by(induction f1) simp+

  lemma generalized_fw_join_cons_1:
    "generalized_fw_join ((am,ad) # l1) l2 =
      [(u,(ad,b)). (m2,b) \<leftarrow> l2, u \<leftarrow> option2list (simple_match_and am m2)] @ generalized_fw_join l1 l2"
  unfolding generalized_fw_join_def by(simp)

  lemma generalized_fw_join_1_nomatch:
    "\<not> simple_matches am p \<Longrightarrow>
      generalized_sfw [(u,(ad,b)). (m2,b) \<leftarrow> l2, u \<leftarrow> option2list (simple_match_and am m2)] p = None"
    by(induction l2)
    (clarsimp simp add: generalized_sfw_simps generalized_sfw_append option2list_def simple_match_and_SomeD
              split: prod.splits option.splits)+

  lemma generalized_fw_join_2_nomatch:
    "\<not> simple_matches bm p \<Longrightarrow>
      generalized_sfw (generalized_fw_join as ((bm, bd) # bs)) p = generalized_sfw (generalized_fw_join as bs) p"
  proof(induction as)
    case (Cons a as)
    note mIH = Cons.IH[OF Cons.prems]
    obtain am ad where a[simp]: "a = (am, ad)" by(cases a)
    have *: "generalized_sfw (concat (map (\<lambda>(m2, b). map (\<lambda>u. (u, ad, b)) (option2list (simple_match_and am m2))) ((bm, bd) # bs))) p =
      generalized_sfw (concat (map (\<lambda>(m2, b). map (\<lambda>u. (u, ad, b)) (option2list (simple_match_and am m2))) bs)) p"
      unfolding list.map prod.simps
      apply(cases "simple_match_and am bm")
       apply(simp add: option2list_def; fail)
      apply(frule simple_match_and_SomeD[of _ _ _ p])
      apply(subst option2list_def)
      apply(unfold concat.simps)
      apply(simp add: generalized_sfw_simps Cons.prems)
    done
    show ?case
      unfolding a
      unfolding generalized_fw_join_cons_1
      unfolding generalized_sfw_append
      unfolding mIH
      unfolding *
      ..
  qed(simp add: generalized_fw_join_def)

  lemma generalized_fw_joinI:
    "\<lbrakk>generalized_sfw f1 p = Some (r1,d1); generalized_sfw f2 p = Some (r2,d2)\<rbrakk> \<Longrightarrow>
       generalized_sfw (generalized_fw_join f1 f2) p = Some (the (simple_match_and r1 r2), d1,d2)"
  proof(induction f1)
    case (Cons a as)
    obtain am ad where a[simp]: "a = Pair am ad" by(cases a)
    show ?case proof(cases "simple_matches am p")
      case True
      hence dra: "d1 = ad" "r1 = am" using Cons.prems by(simp_all add: generalized_sfw_simps)
      from Cons.prems(2) show ?thesis unfolding a dra
      proof(induction f2)
        case (Cons b bs)
        obtain bm bd where b[simp]: "b = Pair bm bd" by(cases b)
        thus ?case
        proof(cases "simple_matches bm p")
          case True
          hence drb: "d2 = bd" "r2 = bm" using Cons.prems by(simp_all add: generalized_sfw_simps)
          from True \<open>simple_matches am p\<close> obtain ruc where sma[simp]:
            "simple_match_and am bm = Some ruc" "simple_matches ruc p"
            using simple_match_and_correct[of am p bm]
            by(simp split: option.splits)
          show ?thesis unfolding b
            by(simp add: generalized_fw_join_def option2list_def generalized_sfw_simps drb)
        next
          case False
          with Cons.prems have bd:
            "generalized_sfw (b # bs) p = generalized_sfw bs p"
            "generalized_sfw (b # bs) p = Some (r2, d2)"
          by(simp_all add: generalized_sfw_simps)
          note mIH = Cons.IH[OF bd(2)[unfolded bd(1)]]
          show ?thesis
            unfolding mIH[symmetric] b
            using generalized_fw_join_2_nomatch[OF False, of "(am, ad) # as" bd bs]
            .
        qed
      qed(simp add: generalized_sfw_simps generalized_fw_join_def)
        (*and empty_concat: "concat (map (\<lambda>x. []) ms) = []" by simp*)
    next
      case False
      with Cons.prems have "generalized_sfw (a # as) p = generalized_sfw as p"
        by(simp add: generalized_sfw_simps)
      with Cons.prems have "generalized_sfw as p = Some (r1, d1)" by simp
      note mIH = Cons.IH[OF this Cons.prems(2)]
      show ?thesis
        unfolding mIH[symmetric] a
        unfolding generalized_fw_join_cons_1
        unfolding generalized_sfw_append
        unfolding generalized_fw_join_1_nomatch[OF False, of ad f2]
        by simp
    qed
  qed(simp add: generalized_fw_join_def generalized_sfw_simps;fail)

  (* The structure is nearly the same as with generalized_fw_joinI, so it should be possible to show
     it in one proof. But I felt like this is the better way *)
  lemma generalized_fw_joinD:
    "generalized_sfw (generalized_fw_join f1 f2) p = Some (u, d1,d2) \<Longrightarrow>
      \<exists>r1 r2. generalized_sfw f1 p = Some (r1,d1) \<and> generalized_sfw f2 p = Some (r2,d2) \<and> Some u = simple_match_and r1 r2"
  proof(induction f1)
    case (Cons a as)
    obtain am ad where a[simp]: "a = Pair am ad" by(cases a)
    show ?case proof(cases "simple_matches am p", rule exI)
      case True
      show "\<exists>r2. generalized_sfw (a # as) p = Some (am, d1) \<and> generalized_sfw f2 p = Some (r2, d2) \<and> Some u = simple_match_and am r2"
      using Cons.prems
      proof(induction f2)
        case (Cons b bs)
        obtain bm bd where b[simp]: "b = Pair bm bd" by(cases b)
        show ?case
        proof(cases "simple_matches bm p", rule exI)
          case True
          with \<open>simple_matches am p\<close> obtain u' (* u' = u, but I don't need that yet. *)
            where sma: "simple_match_and am bm = Some u' \<and> simple_matches u' p"
            using simple_match_and_correct[of am p bm] by(simp split: option.splits)
          show "generalized_sfw (a # as) p = Some (am, d1) \<and> generalized_sfw (b # bs) p = Some (bm, d2) \<and> Some u = simple_match_and am bm"
          using Cons.prems True \<open>simple_matches am p\<close>
          by(simp add: generalized_fw_join_def generalized_sfw_append sma generalized_sfw_simps)
        next
          case False
          have "generalized_sfw (generalized_fw_join (a # as) bs) p = Some (u, d1, d2)"
            using Cons.prems unfolding b unfolding generalized_fw_join_2_nomatch[OF False] .
          note Cons.IH[OF this]
          moreover have "generalized_sfw (b # bs) p = generalized_sfw bs p" using False by(simp add: generalized_sfw_simps)
          ultimately show ?thesis by presburger
        qed
      qed(simp add: generalized_sfw_simps)
    next
      case False
      with Cons.prems have "generalized_sfw (generalized_fw_join as f2) p = Some (u, d1, d2)" by(simp add: generalized_fw_join_cons_1 generalized_sfw_append generalized_fw_join_1_nomatch)
      note Cons.IH[OF this]
      moreover have "generalized_sfw (a # as) p = generalized_sfw as p" using False by(simp add: generalized_sfw_simps)
      ultimately show ?thesis by presburger
    qed
  qed(simp add: generalized_fw_join_def generalized_sfw_simps)

  text\<open>We imagine two firewalls are positioned directly after each other.
        The first one has ruleset rs1 installed, the second one has ruleset rs2 installed.
        A packet needs to pass both firewalls.\<close>

  theorem simple_fw_join:
    defines "rule_translate \<equiv>
      map (\<lambda>(u,a,b). SimpleRule u (if a = Accept \<and> b = Accept then Accept else Drop))"
    shows
    "simple_fw rs1 p = Decision FinalAllow \<and> simple_fw rs2 p = Decision FinalAllow \<longleftrightarrow>
      simple_fw (rule_translate (generalized_fw_join (map simple_rule_dtor rs1) (map simple_rule_dtor rs2))) p = Decision FinalAllow"
  proof -
    have hlp1:
      "simple_rule_dtor \<circ> (\<lambda>(u, a, b). SimpleRule u (if a = Accept \<and> b = Accept then Accept else Drop)) =
        apsnd (\<lambda>(a, b). if a = Accept \<and> b = Accept then Accept else Drop)"
    unfolding fun_eq_iff comp_def by(simp add: simple_rule_dtor_def)
    show ?thesis
    unfolding simple_fw_iff_generalized_fw_accept
      apply(rule)
       apply(clarify)
       apply(drule (1) generalized_fw_joinI)
       apply(simp add: hlp1 rule_translate_def generalized_sfw_mapsnd ;fail)
      apply(clarsimp simp add: hlp1 generalized_sfw_mapsnd rule_translate_def)
      apply(drule generalized_fw_joinD)
      apply(clarsimp split: if_splits)
    done
  qed

  theorem simple_fw_join2:
    --\<open>translates a @{text "(match, action1, action2)"} tuple of the joined generalized
       firewall to a @{typ "'i::len simple_rule list"}. The two actions are translated such
       that you only get @{const Accept} if both actions are @{const Accept}\<close>
    defines "to_simple_rule_list \<equiv> map (apsnd (\<lambda>(a,b) \<Rightarrow> (case a of Accept \<Rightarrow> b
                                                                 |  Drop \<Rightarrow> Drop)))"
    shows "simple_fw rs1 p = Decision FinalAllow \<and> simple_fw rs2 p = Decision FinalAllow \<longleftrightarrow>
           (\<exists>m. (generalized_sfw (to_simple_rule_list
            (generalized_fw_join (map simple_rule_dtor rs1) (map simple_rule_dtor rs2))) p) = Some (m, Accept))"
  unfolding simple_fw_iff_generalized_fw_accept
    apply(rule)
     apply(clarify)
     apply(drule (1) generalized_fw_joinI)
     apply(clarsimp simp add: to_simple_rule_list_def generalized_sfw_mapsnd; fail)
    apply(clarsimp simp add: to_simple_rule_list_def generalized_sfw_mapsnd)
    apply(drule generalized_fw_joinD)
    apply(clarsimp split: if_splits simple_action.splits)
  done

  lemma generalized_fw_join_1_1:
    "generalized_fw_join [(m1,d1)] fw2 = foldr (\<lambda>(m2,d2). op @ (case simple_match_and m1 m2 of None \<Rightarrow> [] | Some mu \<Rightarrow> [(mu,d1,d2)])) fw2 []"
  proof -
    have concat_map_foldr: "concat (map (\<lambda>x. f x) l) = foldr (\<lambda>x. op @ (f x)) l []" for f :: "'x \<Rightarrow> 'y list" and l
      by(induction l) simp_all
    show ?thesis
    apply(simp add: generalized_fw_join_cons_1 option2list_def)
    apply(simp add: concat_map_foldr)
    apply(unfold list.map  prod.case_distrib option.case_distrib)
    by simp
  qed

  lemma generalized_sfw_2_join_None:
    "generalized_sfw fw2 p = None \<Longrightarrow> generalized_sfw (generalized_fw_join fw1 fw2) p = None"
    by(induction fw2) (simp_all add: generalized_sfw_simps generalized_sfw_append generalized_fw_join_2_nomatch split: if_splits option.splits prod.splits)

  lemma generalized_sfw_1_join_None:
    "generalized_sfw fw1 p = None \<Longrightarrow> generalized_sfw (generalized_fw_join fw1 fw2) p = None"
    by(induction fw1) (simp_all add: generalized_sfw_simps generalized_fw_join_cons_1 generalized_sfw_append generalized_fw_join_1_nomatch split: if_splits option.splits prod.splits)

  lemma generalized_sfw_join_set: "(a, b1, b2) \<in> set (generalized_fw_join f1 f2) \<longleftrightarrow>
    (\<exists>a1 a2. (a1, b1) \<in> set f1 \<and> (a2, b2) \<in> set f2 \<and> simple_match_and a1 a2 = Some a)"
   unfolding generalized_fw_join_def
   apply(rule iffI)
    subgoal unfolding generalized_fw_join_def by(clarsimp simp: option2set_def split: option.splits) blast
   by(clarsimp simp: option2set_def split: option.splits) fastforce

subsection\<open>Validity\<close>
  text\<open>There's validity of matches on @{const generalized_sfw}, too, even on the join.\<close>

  definition gsfw_valid :: "('i::len simple_match \<times> 'c) list \<Rightarrow> bool" where
    "gsfw_valid \<equiv> list_all (simple_match_valid \<circ> fst)"

  lemma gsfw_join_valid: "gsfw_valid f1 \<Longrightarrow> gsfw_valid f2 \<Longrightarrow> gsfw_valid (generalized_fw_join f1 f2)"
    unfolding gsfw_valid_def
    apply(induction f1)
     apply(simp;fail)
    apply(simp)
    apply(rename_tac a f1)
    apply(case_tac a)
    apply(simp add: generalized_fw_join_cons_1)
    apply(clarify)
    apply(thin_tac "list_all _ f1")
    apply(thin_tac "list_all _ (generalized_fw_join _ _)")
    apply(induction f2)
     apply(simp;fail)
    apply(simp)
    apply(clarsimp simp add: option2list_def list_all_iff)
    using simple_match_and_valid apply metis
    done

  lemma gsfw_validI: "simple_fw_valid fw \<Longrightarrow> gsfw_valid (map simple_rule_dtor fw)"
    unfolding gsfw_valid_def simple_fw_valid_def
    by(clarsimp simp add: simple_rule_dtor_def list_all_iff split: simple_rule.splits) fastforce

end


section \<open>Coupled Similarity\<close>

theory Coupled_Simulation
  imports Contrasimulation
begin

context lts_tau
begin

subsection \<open>Van Glabbeeks's Coupled Simulation\<close>

text \<open>We mainly use van Glabbeek's coupled simulation from his 2017 CSP paper @{cite "glabbeek2017"}.
  Later on, we will compare it to other definitions of coupled (delay/weak) simulations.\<close>

definition coupled_simulation ::
  \<open>('s \<Rightarrow> 's \<Rightarrow> bool) \<Rightarrow> bool\<close>
where
  \<open>coupled_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')) \<and>
      (\<exists> q'. q \<longmapsto>*tau q' \<and> R q' p)\<close>

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

abbreviation coupled_similar :: \<open>'s \<Rightarrow> 's \<Rightarrow> bool\<close> ("_ \<equiv>cs  _" [60, 60] 65)
  where \<open>coupled_similar p q \<equiv> p \<sqsubseteq>cs q \<and> q \<sqsubseteq>cs p\<close>

text \<open>We call \<open>\<sqsubseteq>cs\<close> "coupled simulation preorder" and \<open>\<equiv>cs\<close> coupled similarity.\<close>

subsection \<open>Position between Weak Simulation and Weak Bisimulation\<close>

text \<open>Coupled simulations are special weak simulations, and symmetric weak bisimulations also
  are coupled simulations.\<close>

lemma coupled_simulation_weak_simulation:
  \<open>coupled_simulation R =
    (weak_simulation R \<and> (\<forall> p q . R p q \<longrightarrow> (\<exists> q'. q \<longmapsto>*tau q' \<and> R q' p)))\<close>
  unfolding coupled_simulation_def weak_simulation_def by blast

corollary coupled_simulation_implies_weak_simulation:
  assumes \<open>coupled_simulation R\<close>
  shows \<open>weak_simulation R\<close>
  using assms unfolding coupled_simulation_weak_simulation ..

corollary coupledsim_enabled_subs:
  assumes
    \<open>p \<sqsubseteq>cs q\<close>
    \<open>weak_enabled p a\<close>
    \<open>\<not> tau a\<close>
  shows \<open>weak_enabled q a\<close>
  using assms weak_sim_enabled_subs coupled_simulation_implies_weak_simulation by blast

lemma coupled_simulation_implies_coupling:
  assumes
    \<open>coupled_simulation R\<close>
    \<open>R p q\<close>
  shows
    \<open>\<exists> q'. q \<longmapsto>*tau q' \<and> R q' p\<close>
  using assms unfolding coupled_simulation_weak_simulation by blast

lemma weak_bisim_implies_coupled_sim_gla17:
  assumes
    wbisim:   \<open>weak_bisimulation R\<close> and
    symmetry: \<open>\<And> p q . R p q \<Longrightarrow> R q p\<close>
    \<comment>\<open>symmetry is needed here, which is alright because bisimilarity is symmetric.\<close>
  shows \<open>coupled_simulation R\<close>
unfolding coupled_simulation_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 wbisim unfolding weak_bisimulation_def by simp
next
  fix p q
  assume \<open>R p q\<close>
  thus \<open>\<exists>q'. q \<longmapsto>* tau  q' \<and> R q' p\<close>
    using symmetry steps.refl[of q tau] by auto
qed

subsection \<open>Coupled Simulation and Silent Steps\<close>

text \<open>Coupled simulation shares important patterns with weak simulation when it comes to the
  treatment of silent steps.\<close>

lemma coupledsim_step_gla17:
  \<open>coupled_simulation (\<lambda> p1 q1 . q1 \<longmapsto>* tau p1)\<close>
  unfolding coupled_simulation_def
  using lts.steps.simps by metis

corollary coupledsim_step:
  assumes
    \<open>p \<longmapsto>* tau  q\<close>
  shows
    \<open>q \<sqsubseteq>cs p\<close>
  using assms coupledsim_step_gla17 by auto

text \<open>A direct implication of this is that states on a tau loop are coupled similar.\<close>
corollary strongly_tau_connected_coupled_similar:
  assumes
    \<open>p \<longmapsto>* tau  q\<close>
    \<open>q \<longmapsto>* tau  p\<close>
  shows \<open>p \<equiv>cs q\<close>
  using assms coupledsim_step by auto

lemma silent_steps_retain_coupled_simulation:
assumes
  \<open>coupled_simulation R\<close>
  \<open>R p q\<close>
  \<open>p \<longmapsto>* A  p'\<close>
  \<open>A = tau\<close>
shows \<open>\<exists> q' . q \<longmapsto>* A q' \<and> R p' q'\<close>
  using assms(1,3,2,4) steps_retain_weak_sim
  unfolding coupled_simulation_weak_simulation by blast

lemma coupled_simulation_weak_premise:
  \<open>coupled_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')) \<and>
      (\<exists> q'. q \<longmapsto>*tau q' \<and> R q' p))\<close>
  unfolding coupled_simulation_weak_simulation weak_sim_weak_premise by blast

subsection \<open>Closure, Preorder and Symmetry Properties\<close>

text \<open>The coupled simulation preorder \<open>\<sqsubseteq>cs\<close> @{emph \<open>is\<close>} a preoder and symmetric at the
  stable states.\<close>

lemma coupledsim_union:
  assumes
    \<open>coupled_simulation R1\<close>
    \<open>coupled_simulation R2\<close>
  shows
    \<open>coupled_simulation (\<lambda> p q . R1 p q \<or> R2 p q)\<close>
  using assms unfolding coupled_simulation_def by (blast)

lemma coupledsim_refl:
  \<open>p \<sqsubseteq>cs p\<close>
  using coupledsim_step steps.refl by auto

lemma coupledsim_trans:
  assumes
    \<open>p \<sqsubseteq>cs pq\<close>
    \<open>pq \<sqsubseteq>cs q\<close>
  shows
    \<open>p \<sqsubseteq>cs q\<close>
proof -
  obtain R1 where R1_def: \<open>coupled_simulation R1\<close> \<open>R1 p pq\<close>
    using assms(1) by blast
  obtain R2 where R2_def: \<open>coupled_simulation R2\<close> \<open>R2 pq q\<close>
    using assms(2) by blast
  define R where R_def: \<open>R \<equiv> \<lambda> p q . \<exists> pq . (R1 p pq \<and> R2 pq q) \<or> (R2 p pq \<and> R1 pq q)\<close>
  have \<open>weak_simulation R\<close> \<open>R p q\<close>
    using weak_sim_trans_constructive
      R1_def(2) R2_def(2)
      coupled_simulation_implies_weak_simulation[OF R1_def(1)]
      coupled_simulation_implies_weak_simulation[OF R2_def(1)]
    unfolding R_def by auto
  moreover have \<open>(\<forall> p q . R p q \<longrightarrow> (\<exists> q'. q \<longmapsto>*tau q' \<and> R q' p))\<close>
    unfolding R_def
  proof safe
    fix p q pq
    assume r1r2: \<open>R1 p pq\<close> \<open>R2 pq q\<close>
    then obtain pq' where \<open>R1 pq' p\<close> \<open>pq \<longmapsto>* tau  pq'\<close>
      using r1r2 R1_def(1) unfolding coupled_simulation_weak_premise by blast
    then moreover obtain q' where \<open>R2 pq' q'\<close> \<open>q \<longmapsto>* tau q'\<close>
      using r1r2 R2_def(1) weak_step_tau_tau[OF `pq \<longmapsto>* tau  pq'`] tau_tau
      unfolding coupled_simulation_weak_premise by blast
    then moreover obtain q'' where \<open>R2 q'' pq'\<close> \<open>q' \<longmapsto>* tau  q''\<close>
      using R2_def(1) unfolding coupled_simulation_weak_premise by blast
    ultimately show \<open>\<exists>q'. q \<longmapsto>* tau  q' \<and> (\<exists>pq. R1 q' pq \<and> R2 pq p \<or> R2 q' pq \<and> R1 pq p)\<close>
      using steps_concat by blast
  next \<comment>\<open>analogous with R2 and R1 swapped\<close>
    fix p q pq
    assume r2r1: \<open>R2 p pq\<close> \<open>R1 pq q\<close>
    then obtain pq' where \<open>R2 pq' p\<close> \<open>pq \<longmapsto>* tau  pq'\<close>
      using r2r1 R2_def(1) unfolding coupled_simulation_weak_premise by blast
    then moreover obtain q' where \<open>R1 pq' q'\<close> \<open>q \<longmapsto>* tau q'\<close>
      using r2r1 R1_def(1) weak_step_tau_tau[OF `pq \<longmapsto>* tau  pq'`] tau_tau
      unfolding coupled_simulation_weak_premise by blast
    then moreover obtain q'' where \<open>R1 q'' pq'\<close> \<open>q' \<longmapsto>* tau  q''\<close>
      using R1_def(1) unfolding coupled_simulation_weak_premise by blast
    ultimately show \<open>\<exists>q'. q \<longmapsto>* tau  q' \<and> (\<exists>pq. R1 q' pq \<and> R2 pq p \<or> R2 q' pq \<and> R1 pq p)\<close>
      using steps_concat by blast
  qed
  ultimately have \<open>R p q\<close> \<open>coupled_simulation R\<close>
    using coupled_simulation_weak_simulation by auto
  thus ?thesis by blast
qed

interpretation preorder \<open>\<lambda> p q. p \<sqsubseteq>cs q\<close> \<open>\<lambda> p q. p \<sqsubseteq>cs q \<and> \<not>(q \<sqsubseteq>cs p)\<close>
  by (standard, blast, fact coupledsim_refl, fact coupledsim_trans)

lemma coupled_similarity_equivalence:
  \<open>equivp (\<lambda> p q. p \<equiv>cs q)\<close>
proof (rule equivpI)
  show \<open>reflp coupled_similar\<close>
    unfolding reflp_def by blast
next
  show \<open>symp coupled_similar\<close>
    unfolding symp_def by blast
next
  show \<open>transp coupled_similar\<close>
    unfolding transp_def using coupledsim_trans by meson
qed

lemma coupledsim_tau_max_eq:
  assumes
    \<open>p \<sqsubseteq>cs q\<close>
    \<open>tau_max q\<close>
  shows  \<open>p \<equiv>cs q\<close>
  using assms using coupled_simulation_weak_simulation coupling_tau_max_symm by metis

corollary coupledsim_stable_eq:
  assumes
    \<open>p \<sqsubseteq>cs q\<close>
    \<open>stable_state q\<close>
  shows  \<open>p \<equiv>cs q\<close>
  using assms using coupled_simulation_weak_simulation coupling_stability_symm by metis

subsection \<open>Coinductive Coupled Simulation Preorder\<close>

text \<open>\<open>\<sqsubseteq>cs\<close> can also be characterized coinductively. \<open>\<sqsubseteq>cs\<close> is the greatest
  coupled simulation.\<close>

coinductive greatest_coupled_simulation :: \<open>'s \<Rightarrow> 's \<Rightarrow> bool\<close>
  where gcs:
    \<open>\<lbrakk>\<And> a p' . p \<longmapsto>a p' \<Longrightarrow> \<exists>q'. q \<Rightarrow>^^ a q' \<and> greatest_coupled_simulation p' q';
      \<exists> q' . q \<longmapsto>* tau q' \<and> greatest_coupled_simulation q' p\<rbrakk>
  \<Longrightarrow> greatest_coupled_simulation p q\<close>

lemma gcs_implies_gws:
  assumes \<open>greatest_coupled_simulation p q\<close>
  shows \<open>greatest_weak_simulation p q\<close>
  using assms by (metis greatest_coupled_simulation.cases greatest_weak_simulation.coinduct)

lemma gcs_is_coupled_simulation:
  shows \<open>coupled_simulation greatest_coupled_simulation\<close>
  unfolding coupled_simulation_def
proof safe
  \<comment>\<open>identical to ws\<close>
  fix p q p' a
  assume ih:
    \<open>greatest_coupled_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_coupled_simulation xa q'))\<close>
    by (meson greatest_coupled_simulation.simps)
  then obtain q' where \<open>q \<Rightarrow>^^ a  q' \<and> greatest_coupled_simulation p' q'\<close> using ih by blast
  thus \<open>\<exists>q'. greatest_coupled_simulation p' q' \<and> q \<Rightarrow>^a  q'\<close>
    unfolding weak_step_tau2_def by blast
next
  fix p q
  assume
    \<open>greatest_coupled_simulation p q\<close>
  thus \<open>\<exists>q'. q \<longmapsto>* tau  q' \<and> greatest_coupled_simulation q' p\<close>
    by (meson greatest_coupled_simulation.simps)
qed

lemma coupled_similarity_implies_gcs:
  assumes \<open>p \<sqsubseteq>cs q\<close>
  shows \<open>greatest_coupled_simulation p q\<close>
  using assms
proof (coinduct, simp del: weak_step_tau2_def, safe)
  fix x1 x2 R a xa
  assume ih: \<open>coupled_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 coupled_simulation_def weak_step_tau2_def by blast
  thus \<open>\<exists>q'. x2 \<Rightarrow>^^ a  q' \<and> (xa \<sqsubseteq>cs  q' \<or> greatest_coupled_simulation xa q')\<close>
    using ih by blast
next
  fix x1 x2 R
  assume ih: \<open>coupled_simulation R\<close> \<open>R x1 x2\<close>
  then obtain q' where \<open>x2 \<longmapsto>* tau  q'\<close> \<open>R q' x1\<close>
    unfolding coupled_simulation_def by blast
  thus \<open>\<exists>q'. x2 \<longmapsto>* tau  q' \<and> (q' \<sqsubseteq>cs  x1 \<or> greatest_coupled_simulation q' x1)\<close>
    using ih by blast
qed

lemma gcs_eq_coupled_sim_by:
  shows \<open>p \<sqsubseteq>cs q = greatest_coupled_simulation p q\<close>
  using coupled_similarity_implies_gcs gcs_is_coupled_simulation by blast

lemma coupled_sim_by_is_coupled_sim:
  shows
    \<open>coupled_simulation (\<lambda> p q . p \<sqsubseteq>cs q)\<close>
  unfolding gcs_eq_coupled_sim_by using gcs_is_coupled_simulation .

lemma coupledsim_unfold:
  shows \<open>p \<sqsubseteq>cs q =
    ((\<forall>a p'. p \<longmapsto>a  p' \<longrightarrow> (\<exists>q'. q \<Rightarrow>^a  q' \<and> p' \<sqsubseteq>cs q')) \<and>
       (\<exists>q'. q \<longmapsto>* tau  q' \<and> q' \<sqsubseteq>cs p))\<close>
  unfolding gcs_eq_coupled_sim_by weak_step_tau2_def[symmetric]
  by (metis lts_tau.greatest_coupled_simulation.simps)

subsection \<open>Coupled Simulation Join\<close>

text \<open>The following lemmas reproduce Proposition 3 from @{cite glabbeek2017} that internal choice
  acts as a least upper bound within the semi-lattice of CSP terms related by \<open>\<sqsubseteq>cs\<close> taking \<open>\<equiv>cs\<close>
  as equality.\<close>

lemma coupledsim_choice_1:
  assumes
    \<open>p \<sqsubseteq>cs q\<close>
    \<open>\<And> pq a . pqc \<longmapsto>a pq \<longleftrightarrow> (a = \<tau> \<and> (pq = p \<or> pq = q))\<close>
  shows
    \<open>pqc \<sqsubseteq>cs q\<close>
    \<open>q \<sqsubseteq>cs pqc\<close>
proof -
  define R1 where \<open>R1 \<equiv> (\<lambda>p1 q1. q1 \<longmapsto>* tau  p1)\<close>
  have \<open>R1 q pqc\<close>
    using assms(2) steps_one_step R1_def by simp
  moreover have \<open>coupled_simulation R1\<close>
    unfolding R1_def using coupledsim_step_gla17 .
  ultimately show q_pqc: \<open>q \<sqsubseteq>cs pqc\<close> by blast
\<comment>\<open>next case\<close>
  define R where \<open>R \<equiv> \<lambda> p0 q0 . p0 = q \<and> q0 = pqc \<or> p0 = pqc \<and> q0 = q \<or> p0 = p \<and> q0 = q\<close>
  hence \<open>R pqc q\<close> by blast
  thus \<open>pqc \<sqsubseteq>cs  q\<close>
    unfolding gcs_eq_coupled_sim_by
  proof (coinduct, auto)
    fix x1 x2 x xa
    assume ih:
      \<open>R x1 x2\<close>
      \<open>x1 \<longmapsto>x  xa\<close>
    hence \<open>x1 = q \<and> x2 = pqc \<or> x1 = pqc \<and> x2 = q \<or> x1 = p \<and> x2 = q\<close> using R_def by auto
    thus \<open>\<exists>q'. (tau x \<longrightarrow> x2 \<longmapsto>* tau  q') \<and>
      (\<not> tau x \<longrightarrow> (\<exists>pq1. x2 \<longmapsto>* tau  pq1 \<and>
        (\<exists>pq2. pq1 \<longmapsto>x  pq2 \<and> pq2 \<longmapsto>* tau  q'))) \<and>
      (R xa q' \<or> greatest_coupled_simulation xa q')\<close>
    proof safe
      assume \<open>x1 = q\<close> \<open>x2 = pqc\<close>
      thus \<open>\<exists>q'.
        (tau x \<longrightarrow> pqc \<longmapsto>* tau  q') \<and>
        (\<not>tau x \<longrightarrow> (\<exists>pq1. pqc \<longmapsto>* tau  pq1 \<and>
          (\<exists>pq2. pq1 \<longmapsto>x  pq2 \<and> pq2 \<longmapsto>* tau  q'))) \<and>
        (R xa q' \<or> greatest_coupled_simulation xa q')\<close>
        using ih `q \<sqsubseteq>cs pqc`
          coupled_simulation_implies_weak_simulation[OF gcs_is_coupled_simulation]
        unfolding gcs_eq_coupled_sim_by
        by (metis (full_types) weak_sim_ruleformat)
    next
      assume \<open>x1 = pqc\<close> \<open>x2 = q\<close>
      hence \<open>x = \<tau> \<and> (xa = q \<or> xa = p)\<close> using ih(2) assms(2) by blast
      thus \<open>\<exists>q'.
        (tau x \<longrightarrow> q \<longmapsto>* tau  q') \<and>
        (\<not> tau x \<longrightarrow> (\<exists>pq1. q \<longmapsto>* tau  pq1 \<and>
          (\<exists>pq2. pq1 \<longmapsto>x  pq2 \<and> pq2 \<longmapsto>* tau  q'))) \<and>
        (R xa q' \<or> greatest_coupled_simulation xa q')\<close>
        unfolding gcs_eq_coupled_sim_by[symmetric]
        using steps.refl[of q tau] `p \<sqsubseteq>cs q` tau_tau
        by auto
    next
      assume \<open>x1 = p\<close> \<open>x2 = q\<close>
      thus \<open>\<exists>q'.
         (tau x \<longrightarrow> q \<longmapsto>* tau  q') \<and>
         (\<not> tau x \<longrightarrow> (\<exists>pq1. q \<longmapsto>* tau  pq1 \<and>
            (\<exists>pq2. pq1 \<longmapsto>x  pq2 \<and> pq2 \<longmapsto>* tau  q'))) \<and>
         (R xa q' \<or> greatest_coupled_simulation xa q')\<close>
        using ih `p \<sqsubseteq>cs q`
          coupled_simulation_implies_weak_simulation[OF gcs_is_coupled_simulation]
        unfolding gcs_eq_coupled_sim_by
        by (metis (full_types) weak_sim_ruleformat)
    qed
  next
    fix x1 x2
    assume
      \<open>R x1 x2\<close>
    hence \<open>x1 = q \<and> x2 = pqc \<or> x1 = pqc \<and> x2 = q \<or> x1 = p \<and> x2 = q\<close> using R_def by auto
    thus \<open>\<exists>q'. x2 \<longmapsto>* tau  q' \<and> (R q' x1 \<or> greatest_coupled_simulation q' x1)\<close>
    proof (auto)
      show \<open>\<exists>q'. pqc \<longmapsto>* tau  q' \<and> (R q' q \<or> greatest_coupled_simulation q' q)\<close>
        using \<open>R pqc q\<close> steps.simps by blast
    next
      show \<open>\<exists>q'. q \<longmapsto>* tau  q' \<and> (R q' pqc \<or> greatest_coupled_simulation q' pqc)\<close>
        using \<open>R1 q pqc\<close> \<open>coupled_simulation R1\<close> coupled_similarity_implies_gcs steps.refl
        by blast
    next
      show \<open>\<exists>q'. q \<longmapsto>* tau  q' \<and> (R q' p \<or> greatest_coupled_simulation q' p)\<close>
        using assms(1) coupled_simulation_weak_simulation
          lts_tau.coupled_similarity_implies_gcs by fastforce
    qed
  qed
qed

lemma coupledsim_choice_2:
  assumes
    \<open>pqc \<sqsubseteq>cs q\<close>
    \<open>\<And> pq a . pqc \<longmapsto>a pq \<longleftrightarrow> (a = \<tau> \<and> (pq = p \<or> pq = q))\<close>
  shows
    \<open>p \<sqsubseteq>cs q\<close>
proof -
  have \<open>pqc \<longmapsto>\<tau> p\<close> using assms(2) by blast
  then obtain q' where \<open>q \<longmapsto>* tau q'\<close> \<open>p \<sqsubseteq>cs q'\<close>
    using assms(1) tau_tau unfolding coupled_simulation_def by blast
  then moreover have \<open>q' \<sqsubseteq>cs q\<close> using coupledsim_step_gla17 by blast
  ultimately show ?thesis using coupledsim_trans tau_tau by blast
qed

lemma coupledsim_choice_join:
  assumes
    \<open>\<And> pq a . pqc \<longmapsto>a pq \<longleftrightarrow> (a = \<tau> \<and> (pq = p \<or> pq = q))\<close>
  shows
    \<open>p \<sqsubseteq>cs q \<longleftrightarrow> pqc \<equiv>cs q\<close>
  using  coupledsim_choice_1[OF _ assms] coupledsim_choice_2[OF _ assms] by blast

subsection \<open>Coupled Delay Simulation\<close>

text \<open>\<open>\<sqsubseteq>cs\<close> can also be characterized in terms of coupled delay simulations, which are
 conceptionally simpler than van Glabbeek's coupled simulation definition.\<close>

text \<open>In the greatest coupled simulation, \<open>\<tau>\<close>-challenges can be answered by stuttering.\<close>
lemma coupledsim_tau_challenge_trivial:
  assumes
    \<open>p \<sqsubseteq>cs q\<close>
    \<open>p \<longmapsto>* tau p'\<close>
  shows
    \<open>p' \<sqsubseteq>cs q\<close>
  using assms coupledsim_trans coupledsim_step by blast

lemma coupled_similarity_s_delay_simulation:
  \<open>delay_simulation (\<lambda> p q. p \<sqsubseteq>cs q)\<close>
  unfolding delay_simulation_def
proof safe
  fix p q R p' a
  assume assms:
    \<open>coupled_simulation R\<close>
    \<open>R p q\<close>
    \<open>p \<longmapsto>a p'\<close>
  {
    assume \<open>tau a\<close>
    then show \<open>p' \<sqsubseteq>cs  q\<close>
      using assms coupledsim_tau_challenge_trivial steps_one_step by blast
  } {
    show \<open>\<exists>q'. p' \<sqsubseteq>cs  q' \<and> q =\<rhd>a  q'\<close>
    proof -
      obtain q''' where q'''_spec: \<open>q \<Rightarrow>^a q'''\<close> \<open>p' \<sqsubseteq>cs q'''\<close>
        using assms coupled_simulation_implies_weak_simulation weak_sim_ruleformat by metis
      show ?thesis
      proof (cases \<open>tau a\<close>)
        case True
        then have \<open>q \<longmapsto>* tau q'''\<close> using q'''_spec by blast
        thus ?thesis using q'''_spec(2) True assms(1) steps.refl by blast
      next
        case False
        then obtain q' q'' where q'q''_spec:
            \<open>q \<longmapsto>* tau q'\<close> \<open>q' \<longmapsto>a q''\<close> \<open>q'' \<longmapsto>* tau q'''\<close>
          using q'''_spec by blast
        hence \<open>q''' \<sqsubseteq>cs q''\<close> using coupledsim_step by blast
        hence \<open>p' \<sqsubseteq>cs q''\<close> using q'''_spec(2) coupledsim_trans by blast
        thus ?thesis using q'q''_spec(1,2) False by blast
      qed
    qed
  }
qed

definition coupled_delay_simulation ::
  \<open>('s \<Rightarrow> 's \<Rightarrow> bool) \<Rightarrow> bool\<close>
  where
  \<open>coupled_delay_simulation R  \<equiv>
    delay_simulation R \<and> coupling R\<close>

lemma coupled_sim_by_eq_coupled_delay_simulation:
  \<open>(p \<sqsubseteq>cs q) = (\<exists>R. R p q \<and> coupled_delay_simulation R)\<close>
  unfolding coupled_delay_simulation_def
proof
  assume \<open>p \<sqsubseteq>cs q\<close>
  define R where \<open>R \<equiv> coupled_simulated_by\<close>
  hence \<open>R p q \<and> delay_simulation R \<and> coupling R\<close>
    using coupled_similarity_s_delay_simulation coupled_sim_by_is_coupled_sim
        coupled_simulation_implies_coupling \<open>p \<sqsubseteq>cs q\<close> by blast
  thus \<open>\<exists>R. R p q \<and> delay_simulation R \<and> coupling R\<close> by blast
next
  assume \<open>\<exists>R. R p q \<and> delay_simulation R \<and> coupling R\<close>
  then obtain R where \<open>R p q\<close> \<open>delay_simulation R\<close> \<open>coupling R\<close> by blast
  hence \<open>coupled_simulation R\<close>
    using delay_simulation_implies_weak_simulation coupled_simulation_weak_simulation by blast
  thus \<open>p \<sqsubseteq>cs q\<close> using \<open>R p q\<close> by blast
qed

subsection \<open>Relationship to Contrasimulation and Weak Simulation\<close>

text \<open>Coupled simulation is precisely the intersection of contrasimulation and weak simulation.\<close>

lemma weak_sim_and_contrasim_implies_coupled_sim:
  assumes
    \<open>contrasimulation R\<close>
    \<open>weak_simulation R\<close>
  shows
    \<open>coupled_simulation R\<close>
  unfolding coupled_simulation_weak_simulation
  using contrasim_coupled assms by blast

lemma coupledsim_implies_contrasim:
  assumes
    \<open>coupled_simulation R\<close>
  shows
    \<open>contrasimulation R\<close>
proof -
  have \<open>contrasim_step R\<close>
  unfolding contrasim_step_def
  proof (rule allI impI)+
    fix p q p' a
    assume
      \<open>R p q \<and> p \<Rightarrow>^a  p'\<close>
    then obtain q' where q'_def: \<open>R p' q'\<close> \<open>q \<Rightarrow>^a  q'\<close>
      using assms unfolding coupled_simulation_weak_premise by blast
    then obtain q'' where q''_def: \<open>R q'' p'\<close> \<open>q' \<longmapsto>* tau  q''\<close>
      using assms unfolding coupled_simulation_weak_premise by blast
    then have \<open>q \<Rightarrow>^a  q''\<close> using q'_def(2) steps_concat by blast
    thus \<open>\<exists>q'. q \<Rightarrow>^a  q' \<and> R q' p'\<close>
      using q''_def(1) by blast
  qed
  thus \<open>contrasimulation R\<close> using contrasim_step_seq_coincide_for_sims
      coupled_simulation_implies_weak_simulation[OF assms] by blast
qed

lemma coupled_simulation_iff_weak_sim_and_contrasim:
  shows \<open>coupled_simulation R \<longleftrightarrow> contrasimulation R \<and> weak_simulation R\<close>
  using weak_sim_and_contrasim_implies_coupled_sim
    coupledsim_implies_contrasim coupled_simulation_weak_simulation by blast

text \<open>If there is a sink every state can reach via tau steps, then weak simulation implies
  (and thus coincides with) coupled simulation.\<close>
lemma tau_sink_sim_coupledsim:
  assumes
    \<open>\<And> p . (p \<longmapsto>* tau sink)\<close>
    \<open>\<And> p . R sink p\<close>
    \<open>weak_simulation R\<close>
  shows
    \<open>coupled_simulation R\<close>
  unfolding coupled_simulation_def
proof safe
  show \<open> \<And>p q p' a. R p q \<Longrightarrow> p \<longmapsto>a  p' \<Longrightarrow> \<exists>q'. R p' q' \<and> q \<Rightarrow>^a  q'\<close>
    using assms(3) unfolding weak_simulation_def by blast
next
  fix p q
  assume \<open>R p q\<close>
  hence \<open>q \<longmapsto>* tau sink \<and> R sink p\<close>
    using assms(1,2) by blast
  thus \<open>\<exists>q'. q \<longmapsto>* tau  q' \<and> R q' p\<close> by blast
qed

subsection \<open>\<open>\<tau>\<close>-Reachability (and Divergence)\<close>

text \<open>Coupled similarity comes close to (weak) bisimilarity in two respects:\<close>

text \<open>If there are no \<open>\<tau>\<close> transitions, coupled similarity coincides with bisimilarity.\<close>

text \<open>If there are only finite \<open>\<tau>\<close> reachable portions, then coupled similarity contains a
  bisimilarity on the \<open>\<tau>\<close>-maximal states. (For this,  \<open>\<tau>\<close>-cycles have to be ruled out, which, as
  we show, is no problem because their removal is transparent to coupled similarity.) \<close>

lemma taufree_coupledsim_symm:
  assumes
    \<open>\<And> p1 a p2 . (p1 \<longmapsto>a p2 \<Longrightarrow> \<not> tau a)\<close>
    \<open>coupled_simulation R\<close>
    \<open>R p q\<close>
  shows \<open>R q p\<close>
  using assms(1,3) coupledsim_implies_contrasim[OF assms(2)] contrasim_taufree_symm
  by blast

lemma taufree_coupledsim_weak_bisim:
  assumes
    \<open>\<And> p1 a p2 . (p1 \<longmapsto>a p2 \<Longrightarrow> \<not> tau a)\<close>
    \<open>coupled_simulation R\<close>
  shows \<open>weak_bisimulation R\<close>
  using assms contrasim_taufree_symm symm_contrasim_is_weak_bisim coupledsim_implies_contrasim[OF assms(2)]
  by blast

lemma coupledsim_stable_state_symm:
  assumes
    \<open>coupled_simulation R\<close>
    \<open>R p q\<close>
    \<open>stable_state q\<close>
  shows
    \<open>R q p\<close>
  using assms steps_left unfolding coupled_simulation_def by metis

text \<open>In finite systems, coupling is guaranteed to happen through \<open>\<tau>\<close>-maximal states.\<close>
lemma coupledsim_max_coupled:
  assumes
    \<open>p \<sqsubseteq>cs q\<close>
    \<open>\<And> r1 r2 . r1 \<longmapsto>* tau r2 \<and> r2 \<longmapsto>* tau r1 \<Longrightarrow> r1 = r2\<close> \<comment>\<open>contracted tau cycles\<close>
    \<open>\<And> r. finite {r'. r \<longmapsto>* tau r'}\<close>
  shows
    \<open>\<exists> q' . q \<longmapsto>* tau q' \<and> q' \<sqsubseteq>cs p \<and> tau_max q'\<close>
proof -
  obtain q1 where q1_spec: \<open>q \<longmapsto>* tau q1\<close> \<open>q1 \<sqsubseteq>cs p\<close>
    using assms(1) coupled_simulation_implies_coupling coupledsim_implies_contrasim by blast
  then obtain q' where \<open>q1 \<longmapsto>* tau q'\<close> \<open>(\<forall>q''. q' \<longmapsto>* tau q'' \<longrightarrow> q' = q'')\<close>
    using tau_max_deadlock assms(2,3) by blast
  then moreover have \<open>q' \<sqsubseteq>cs p\<close> \<open>q \<longmapsto>* tau q'\<close>
    using q1_spec coupledsim_trans coupledsim_step steps_concat[of q1 tau q' q]
    by blast+
  ultimately show ?thesis by blast
qed

text \<open>In the greatest coupled simulation, \<open>a\<close>-challenges can be answered by a weak move without
  trailing \<open>\<tau>\<close>-steps. (This property is what bridges the gap between weak and delay simulation for
  coupled simulation.)\<close>
lemma coupledsim_step_challenge_short_answer:
  assumes
    \<open>p \<sqsubseteq>cs q\<close>
    \<open>p \<longmapsto>a p'\<close>
    \<open>\<not> tau a\<close>
  shows
    \<open>\<exists> q' q1. p' \<sqsubseteq>cs q' \<and> q \<longmapsto>* tau q1 \<and> q1 \<longmapsto>a q'\<close>
  using assms
  unfolding coupled_sim_by_eq_coupled_delay_simulation
    coupled_delay_simulation_def delay_simulation_def by blast

text \<open>If two states share the same outgoing edges with except for one \<open>\<tau>\<close>-loop, then they cannot
  be distinguished by coupled similarity.\<close>
lemma coupledsim_tau_loop_ignorance:
  assumes
    \<open>\<And> a p'. p \<longmapsto>a p' \<or> p' = pp \<and> a = \<tau> \<longleftrightarrow> pp \<longmapsto>a p'\<close>
  shows
    \<open>pp \<equiv>cs p\<close>
proof -
  define R where \<open>R \<equiv> \<lambda> p1 q1. p1 = q1 \<or> p1 = pp \<and> q1 = p \<or> p1 = p \<and> q1 = pp\<close>
  have \<open>coupled_simulation R\<close>
    unfolding coupled_simulation_def R_def
  proof (safe)
    fix pa q p' a
    assume
      \<open>q \<longmapsto>a  p'\<close>
    thus \<open>\<exists>q'. (p' = q' \<or> p' = pp \<and> q' = p \<or> p' = p \<and> q' = pp) \<and> q \<Rightarrow>^a  q'\<close>
      using assms step_weak_step_tau by auto
  next
    fix pa q
    show \<open>\<exists>q'. q \<longmapsto>* tau  q' \<and> (q' = q \<or> q' = pp \<and> q = p \<or> q' = p \<and> q = pp)\<close>
      using steps.refl by blast
  next
    fix pa q p' a
    assume
      \<open>pp \<longmapsto>a  p'\<close>
    thus \<open>\<exists>q'. (p' = q' \<or> p' = pp \<and> q' = p \<or> p' = p \<and> q' = pp) \<and> p \<Rightarrow>^a  q'\<close>
      using assms by (metis lts.steps.simps tau_def)
  next
    fix pa q
    show \<open>\<exists>q'. p \<longmapsto>* tau  q' \<and> (q' = pp \<or> q' = pp \<and> pp = p \<or> q' = p \<and> pp = pp)\<close>
      using steps.refl[of p tau] by blast
  next
    fix pa q p' a
    assume
      \<open>p \<longmapsto>a  p'\<close>
    thus \<open>\<exists>q'. (p' = q' \<or> p' = pp \<and> q' = p \<or> p' = p \<and> q' = pp) \<and> pp \<Rightarrow>^a  q'\<close>
      using assms step_weak_step_tau by fastforce
  next
    fix pa q
    show \<open>\<exists>q'. pp \<longmapsto>* tau  q' \<and> (q' = p \<or> q' = pp \<and> p = p \<or> q' = p \<and> p = pp)\<close>
      using steps.refl[of pp tau] by blast
  qed
  moreover have \<open>R p pp\<close> \<open>R pp p\<close> unfolding R_def by auto
  ultimately show ?thesis by blast
qed

subsection \<open>On the Connection to Weak Bisimulation\<close>

text \<open>When one only considers steps leading to \<open>\<tau>\<close>-maximal states in a system without infinite
  \<open>\<tau>\<close>-reachable regions (e.g. a finite system), then \<open>\<equiv>cs\<close> on these steps is a bisimulation.\<close>

text \<open>This lemma yields a neat argument why one can use a signature refinement algorithm to
  pre-select the tuples which come into question for further checking of coupled simulation
  by contraposition.\<close>
lemma coupledsim_eventual_symmetry:
  assumes
    contracted_cycles: \<open>\<And> r1 r2 . r1 \<longmapsto>* tau r2 \<and> r2 \<longmapsto>* tau r1 \<Longrightarrow> r1 = r2\<close> and
    finite_taus: \<open>\<And> r. finite {r'. r \<longmapsto>* tau r'}\<close> and
    cs: \<open>p \<sqsubseteq>cs q\<close> and
    step: \<open>p \<Rightarrow>^a p'\<close> and
    tau_max_p': \<open>tau_max p'\<close>
  shows
    \<open>\<exists> q'. tau_max q' \<and> q \<Rightarrow>^a q' \<and> p' \<equiv>cs q'\<close>
proof-
  obtain q' where q'_spec: \<open>q \<Rightarrow>^a q'\<close> \<open>p' \<sqsubseteq>cs q'\<close>
    using cs step unfolding coupled_simulation_weak_premise by blast
  then obtain q'' where q''_spec: \<open>q' \<longmapsto>* tau q''\<close> \<open>q'' \<sqsubseteq>cs p'\<close>
    using cs unfolding coupled_simulation_weak_simulation by blast
  then obtain q_max where q_max_spec: \<open>q'' \<longmapsto>* tau q_max\<close> \<open>tau_max q_max\<close>
    using tau_max_deadlock contracted_cycles finite_taus by force
  hence \<open>q_max \<sqsubseteq>cs p'\<close> using q''_spec coupledsim_tau_challenge_trivial by blast
  hence \<open>q_max \<equiv>cs p'\<close> using tau_max_p' coupledsim_tau_max_eq by blast
  moreover have \<open>q \<Rightarrow>^a q_max\<close> using q_max_spec q'_spec q''_spec steps_concat by blast
  ultimately show ?thesis using q_max_spec(2) by blast
qed

text \<open>Even without the assumption that the left-hand-side step \<open>p \<Rightarrow>^a p'\<close> ends in a \<open>\<tau>\<close>-maximal state,
a situation resembling bismulation can be set up -- with the drawback that it only refers to
a \<open>\<tau>\<close>-maximal sibling of \<open>p'\<close>.\<close>
lemma coupledsim_eventuality_2:
  assumes
    contracted_cycles: \<open>\<And> r1 r2 . r1 \<longmapsto>* tau r2 \<and> r2 \<longmapsto>* tau r1 \<Longrightarrow> r1 = r2\<close> and
    finite_taus: \<open>\<And> r. finite {r'. r \<longmapsto>* tau r'}\<close> and
    cbisim: \<open>p \<equiv>cs q\<close> and
    step: \<open>p \<Rightarrow>^a p'\<close>
  shows
    \<open>\<exists> p'' q'. tau_max p'' \<and> tau_max q' \<and> p \<Rightarrow>^a p'' \<and> q \<Rightarrow>^a q' \<and> p'' \<equiv>cs q'\<close>
proof-
  obtain q' where q'_spec: \<open>q \<Rightarrow>^a q'\<close>
    using cbisim step unfolding coupled_simulation_weak_premise by blast
  then obtain q_max where q_max_spec: \<open>q' \<longmapsto>* tau q_max\<close> \<open>tau_max q_max\<close>
    using tau_max_deadlock contracted_cycles finite_taus by force
  hence \<open>q \<Rightarrow>^a q_max\<close> using q'_spec steps_concat by blast
  then obtain p'' where p''_spec: \<open>p \<Rightarrow>^a p''\<close> \<open>q_max \<sqsubseteq>cs p''\<close>
    using cbisim unfolding coupled_simulation_weak_premise by blast
  then obtain p''' where p'''_spec: \<open>p'' \<longmapsto>* tau p'''\<close> \<open>p''' \<sqsubseteq>cs q_max\<close>
    using cbisim unfolding coupled_simulation_weak_simulation  by blast
  then obtain p_max where p_max_spec: \<open>p''' \<longmapsto>* tau p_max\<close> \<open>tau_max p_max\<close>
    using tau_max_deadlock contracted_cycles finite_taus by force
  hence \<open>p_max \<sqsubseteq>cs p'''\<close> using coupledsim_step by blast
  hence \<open>p_max \<sqsubseteq>cs q_max\<close> using p'''_spec coupledsim_trans by blast
  hence \<open>q_max \<equiv>cs p_max\<close> using coupledsim_tau_max_eq q_max_spec by blast
  moreover have  \<open>p \<Rightarrow>^a p_max\<close>
    using  p''_spec(1) steps_concat[OF p_max_spec(1) p'''_spec(1)] steps_concat by blast
  ultimately show ?thesis using p_max_spec(2) q_max_spec(2) `q \<Rightarrow>^a q_max` by blast
qed

lemma coupledsim_eq_reducible_1:
  assumes
    contracted_cycles: \<open>\<And> r1 r2 . r1 \<longmapsto>* tau r2 \<and> r2 \<longmapsto>* tau r1 \<Longrightarrow> r1 = r2\<close> and
    finite_taus: \<open>\<And> r. finite {r'. r \<longmapsto>* tau r'}\<close> and
    tau_shortcuts:
      \<open>\<And>r a r'. r \<longmapsto>* tau r' \<Longrightarrow> \<exists>r''. tau_max r'' \<and> r \<longmapsto>\<tau> r'' \<and> r' \<sqsubseteq>cs r''\<close>  and
    sim_vis_p:
      \<open>\<And>p' a. \<not>tau a \<Longrightarrow> p \<Rightarrow>^a p' \<Longrightarrow> \<exists>p'' q'. q \<Rightarrow>^a q' \<and> p' \<sqsubseteq>cs q'\<close> and
    sim_tau_max_p:
      \<open>\<And>p'. tau_max p' \<Longrightarrow> p \<longmapsto>* tau p' \<Longrightarrow> \<exists>q'. tau_max q' \<and> q \<longmapsto>* tau q' \<and> p' \<equiv>cs q'\<close>
  shows
    \<open>p \<sqsubseteq>cs q\<close>
proof-
  have
    \<open>((\<forall>a p'. p \<longmapsto>a  p' \<longrightarrow> (\<exists>q'. q \<Rightarrow>^a  q' \<and> p' \<sqsubseteq>cs q')) \<and>
    (\<exists>q'. q \<longmapsto>* tau  q' \<and> q' \<sqsubseteq>cs p))\<close>
  proof safe
    fix a p'
    assume
      step: \<open>p \<longmapsto>a  p'\<close>
    thus \<open>\<exists>q'. q \<Rightarrow>^a  q' \<and> p' \<sqsubseteq>cs  q'\<close>
    proof (cases \<open>tau a\<close>)
      case True
      then obtain p'' where p''_spec: \<open>p \<longmapsto>\<tau> p''\<close> \<open>tau_max p''\<close> \<open>p' \<sqsubseteq>cs p''\<close>
        using tau_shortcuts step tau_def steps_one_step[of p \<tau> p']
        by (metis (no_types, lifting))
      then obtain q' where q'_spec: \<open>q \<longmapsto>* tau q'\<close> \<open>p'' \<equiv>cs q'\<close>
        using sim_tau_max_p steps_one_step[OF step, of tau, OF `tau a`]
          steps_one_step[of p \<tau> p''] tau_def
        by metis
      then show ?thesis using `tau a` p''_spec(3) using coupledsim_trans by blast
    next
      case False
      then show ?thesis using sim_vis_p step_weak_step_tau[OF step] by blast
    qed
  next
    obtain p_max where \<open>p \<longmapsto>* tau p_max\<close> \<open>tau_max p_max\<close>
      using tau_max_deadlock contracted_cycles finite_taus by blast
    then obtain q_max where \<open>q \<longmapsto>* tau  q_max\<close> \<open>q_max \<sqsubseteq>cs p_max\<close>
      using sim_tau_max_p[of p_max] by force
    moreover have \<open>p_max \<sqsubseteq>cs  p\<close> using `p \<longmapsto>* tau p_max` coupledsim_step by blast
    ultimately show \<open>\<exists>q'. q \<longmapsto>* tau  q' \<and> q' \<sqsubseteq>cs  p\<close>
      using coupledsim_trans by blast
  qed
  thus \<open>p \<sqsubseteq>cs q\<close> using coupledsim_unfold[symmetric] by auto
qed

lemma coupledsim_eq_reducible_2:
  assumes
    cs: \<open>p \<sqsubseteq>cs q\<close> and
    contracted_cycles: \<open>\<And>r1 r2 . r1 \<longmapsto>* tau r2 \<and> r2 \<longmapsto>* tau r1 \<Longrightarrow> r1 = r2\<close> and
    finite_taus: \<open>\<And>r. finite {r'. r \<longmapsto>* tau r'}\<close>
  shows
    sim_vis_p:
      \<open>\<And>p' a. \<not>tau a \<Longrightarrow> p \<Rightarrow>^a p' \<Longrightarrow> \<exists>q'. q \<Rightarrow>^a q' \<and> p' \<sqsubseteq>cs q'\<close> and
    sim_tau_max_p:
      \<open>\<And>p'. tau_max p' \<Longrightarrow> p \<longmapsto>* tau p' \<Longrightarrow> \<exists>q'. tau_max q' \<and> q \<longmapsto>* tau q' \<and> p' \<equiv>cs q'\<close>
proof-
  fix p' a
  assume
    \<open>\<not> tau a\<close>
    \<open>p \<Rightarrow>^a  p'\<close>
  thus \<open>\<exists>q'. q \<Rightarrow>^a  q' \<and> p' \<sqsubseteq>cs  q'\<close>
    using cs unfolding coupled_simulation_weak_premise by blast
next
  fix p'
  assume step:
    \<open>p \<longmapsto>* tau p'\<close>
    \<open>tau_max p'\<close>
  hence \<open>p \<Rightarrow>^\<tau>  p'\<close>  by auto
  hence \<open>\<exists> q'. tau_max q' \<and> q \<Rightarrow>^\<tau> q' \<and> p' \<equiv>cs q'\<close>
    using coupledsim_eventual_symmetry[OF _ finite_taus, of p q \<tau> p']
      contracted_cycles cs step(2) by blast
  thus \<open>\<exists> q'. tau_max q' \<and> q \<longmapsto>* tau q' \<and> p' \<equiv>cs q'\<close>
    by auto
qed

subsection \<open>Reduction Semantics Coupled Simulation\<close>

text \<open>The tradition to described coupled simulation as special delay/weak simulation is quite
  common for coupled simulations on reduction semantics as in @{cite "gp15" and "Fournet2005"},
  of which @{cite "gp15"} can also be found in the AFP @{cite "Encodability_Process_Calculi-AFP"}.
  The notions coincide (in systems just with \<open>\<tau>\<close>-transitions).\<close>

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

lemma weak_bisim_implies_coupled_sim_gp15:
  assumes
    wbisim: \<open>weak_bisimulation R\<close> and
    symmetry: \<open>\<And> p q . R p q \<Longrightarrow> R q p\<close>
  shows \<open>coupled_simulation_gp15 R\<close>
unfolding coupled_simulation_gp15_def proof safe
  fix p q p'
  assume Rpq: \<open>R p q\<close> \<open>p \<longmapsto>* (\<lambda>a. True)  p'\<close>
  have always_tau: \<open>\<And>a. tau a \<Longrightarrow> (\<lambda>a. True) a\<close> by simp
  hence \<open>\<exists>q'. q \<longmapsto>* (\<lambda>a. True)  q' \<and> R p' q'\<close>
    using steps_retain_weak_bisim[OF wbisim Rpq] by auto
  moreover hence \<open>\<exists>q'. q \<longmapsto>* (\<lambda>a. True)  q' \<and> R q' p'\<close>
    using symmetry by auto
  ultimately show
    \<open>(\<exists>q'. q \<longmapsto>* (\<lambda>a. True)  q' \<and> R p' q')\<close>
    \<open>(\<exists>q'. q \<longmapsto>* (\<lambda>a. True)  q' \<and> R q' p')\<close> .
qed

lemma coupledsim_gla17_implies_gp15:
  assumes
    \<open>coupled_simulation R\<close>
  shows
    \<open>coupled_simulation_gp15 R\<close>
  unfolding coupled_simulation_gp15_def
proof safe
  fix p q p'
  assume challenge:
    \<open>R p q\<close>
    \<open>p \<longmapsto>*(\<lambda>a. True)p'\<close>
  have tau_true: \<open>\<And>a. tau a \<Longrightarrow> (\<lambda>a. True) a\<close> by simp
  thus \<open>\<exists>q'. q \<longmapsto>* (\<lambda>a. True)  q' \<and> R p' q'\<close>
    using steps_retain_weak_sim assms challenge
    unfolding coupled_simulation_weak_simulation by meson
  then obtain q' where q'_def: \<open>q \<longmapsto>* (\<lambda>a. True)  q'\<close> \<open>R p' q'\<close> by blast
  then obtain q'' where \<open>q' \<longmapsto>* tau  q''\<close> \<open>R q'' p'\<close>
    using assms unfolding coupled_simulation_weak_simulation by blast
  moreover hence \<open>q \<longmapsto>* (\<lambda>a. True)  q''\<close>
    using q'_def(1) steps_concat steps_spec tau_true by meson
  ultimately show \<open>\<exists>q'. q \<longmapsto>* (\<lambda>a. True)  q' \<and> R q' p'\<close> by blast
qed

lemma coupledsim_gp15_implies_gla17_on_tau_systems:
  assumes
    \<open>coupled_simulation_gp15 R\<close>
    \<open>\<And> a . tau a\<close>
  shows
    \<open>coupled_simulation R\<close>
  unfolding coupled_simulation_def
proof safe
  fix p q p' a
  assume challenge:
    \<open>R p q\<close>
    \<open>p \<longmapsto>a  p'\<close>
  hence \<open>p \<longmapsto>* (\<lambda>a. True)  p'\<close> using steps_one_step by metis
  then obtain q' where \<open>q \<longmapsto>* (\<lambda>a. True)  q'\<close> \<open>R p' q'\<close>
    using challenge(1) assms(1) unfolding coupled_simulation_gp15_def by blast
  hence \<open>q \<Rightarrow>^a  q'\<close> using assms(2) steps_concat steps_spec by meson
  thus \<open>\<exists>q'. R p' q' \<and> q \<Rightarrow>^a  q'\<close> using `R p' q'` by blast
next
  fix p q
  assume
    \<open>R p q\<close>
  moreover have \<open>p \<longmapsto>* (\<lambda>a. True) p\<close> using steps.refl by blast
  ultimately have \<open>\<exists>q'. q \<longmapsto>* (\<lambda>a. True)  q' \<and> R q' p\<close>
    using assms(1) unfolding coupled_simulation_gp15_def by blast
  thus \<open>\<exists>q'. q \<longmapsto>* tau  q' \<and> R q' p\<close> using assms(2) steps_spec by blast
qed

subsection \<open>Coupled Simulation as Two Simulations\<close>

text \<open>Historically, coupled similarity has been defined in terms of @{emph \<open>two\<close>} weak simulations
  coupled in some way @{cite "sangiorgi2012" and "ps1994"}.
  We reproduce these (more well-known) formulations and show that they are equivalent to the
  coupled (delay) simulations we are using.\<close>

\<comment>\<open>From @{cite "sangiorgi2012"}\<close>
definition coupled_simulation_san12 ::
  \<open>('s \<Rightarrow> 's \<Rightarrow> bool) \<Rightarrow> ('s \<Rightarrow> 's \<Rightarrow> bool) \<Rightarrow> bool\<close>
where
  \<open>coupled_simulation_san12 R1 R2 \<equiv>
    weak_simulation R1 \<and> weak_simulation (\<lambda> p q . R2 q p)
  \<and> (\<forall> p q . R1 p q \<longrightarrow> (\<exists> q' . q \<longmapsto>* tau q' \<and> R2 p q'))
  \<and> (\<forall> p q . R2 p q \<longrightarrow> (\<exists> p' . p \<longmapsto>* tau p' \<and> R1 p' q))\<close>

lemma weak_bisim_implies_coupled_sim_san12:
  assumes \<open>weak_bisimulation R\<close>
  shows \<open>coupled_simulation_san12 R R\<close>
  using assms weak_bisim_weak_sim steps.refl[of _ tau]
  unfolding coupled_simulation_san12_def
  by blast

lemma coupledsim_gla17_resembles_san12:
  shows
    \<open>coupled_simulation R1 =
    coupled_simulation_san12 R1 (\<lambda> p q . R1 q p)\<close>
  unfolding coupled_simulation_weak_simulation coupled_simulation_san12_def by blast

lemma coupledsim_san12_impl_gla17:
  assumes
    \<open>coupled_simulation_san12 R1 R2\<close>
  shows
    \<open>coupled_simulation (\<lambda> p q. R1 p q \<or> R2 q p)\<close>
  unfolding coupled_simulation_weak_simulation
proof safe
  have \<open>weak_simulation R1\<close> \<open>weak_simulation (\<lambda>p q. R2 q p)\<close>
    using assms unfolding coupled_simulation_san12_def by auto
  thus \<open>weak_simulation (\<lambda>p q. R1 p q \<or> R2 q p)\<close>
    using weak_sim_union_cl by blast
next
  fix p q
  assume
    \<open>R1 p q\<close>
  hence \<open>\<exists>q'. q \<longmapsto>* tau  q' \<and> R2 p q'\<close>
    using assms unfolding coupled_simulation_san12_def by auto
  thus \<open>\<exists>q'. q \<longmapsto>* tau  q' \<and> (R1 q' p \<or> R2 p q')\<close> by blast
next
  fix p q
  assume
    \<open>R2 q p\<close>
  hence \<open>\<exists>q'. q \<longmapsto>* tau  q' \<and> R1 q' p\<close>
    using assms unfolding coupled_simulation_san12_def by auto
  thus \<open>\<exists>q'. q \<longmapsto>* tau  q' \<and> (R1 q' p \<or> R2 p q')\<close> by blast
qed

subsection \<open>S-coupled Simulation\<close>

text \<open>Originally coupled simulation was introduced as two weak simulations coupled at the stable
  states. We give the definitions from @{cite "parrow1992" and "ps1994"} and a proof connecting
  this notion to "our" coupled similarity in the absence of divergences following
  @{cite "sangiorgi2012"}.\<close>

\<comment>\<open>From @{cite "parrow1992"}\<close>
definition coupled_simulation_p92 ::
  \<open>('s \<Rightarrow> 's \<Rightarrow> bool) \<Rightarrow> ('s \<Rightarrow> 's \<Rightarrow> bool) \<Rightarrow> bool\<close>
where
  \<open>coupled_simulation_p92 R1 R2 \<equiv> \<forall> p q .
    (R1 p q \<longrightarrow>
      ((\<forall> p' a. p \<longmapsto>a p' \<longrightarrow>
        (\<exists> q'. R1 p' q' \<and>
          (q \<Rightarrow>^a q'))) \<and>
      (stable_state p \<longrightarrow> R2 p q))) \<and>
    (R2 p q \<longrightarrow>
      ((\<forall> q' a. q \<longmapsto>a q' \<longrightarrow>
        (\<exists> p'. R2 p' q' \<and>
          (p \<Rightarrow>^a p'))) \<and>
      (stable_state q \<longrightarrow> R1 p q)))\<close>

lemma weak_bisim_implies_coupled_sim_p92:
  assumes \<open>weak_bisimulation R\<close>
  shows \<open>coupled_simulation_p92 R R\<close>
using assms unfolding weak_bisimulation_def coupled_simulation_p92_def by blast

lemma coupled_sim_p92_symm:
  assumes \<open>coupled_simulation_p92 R1 R2\<close>
  shows \<open>coupled_simulation_p92 (\<lambda> p q. R2 q p) (\<lambda> p q. R1 q p)\<close>
using assms unfolding coupled_simulation_p92_def by blast

definition s_coupled_simulation_san12 ::
  \<open>('s \<Rightarrow> 's \<Rightarrow> bool) \<Rightarrow> ('s \<Rightarrow> 's \<Rightarrow> bool) \<Rightarrow> bool\<close>
where
  \<open>s_coupled_simulation_san12 R1 R2 \<equiv>
    weak_simulation R1 \<and> weak_simulation (\<lambda> p q . R2 q p)
  \<and> (\<forall> p q . R1 p q \<longrightarrow> stable_state p \<longrightarrow> R2 p q)
  \<and> (\<forall> p q . R2 p q \<longrightarrow> stable_state q \<longrightarrow> R1 p q)\<close>

abbreviation s_coupled_simulated_by :: \<open>'s \<Rightarrow> 's \<Rightarrow> bool\<close> ("_ \<sqsubseteq>scs  _" [60, 60] 65)
  where \<open>s_coupled_simulated_by p q \<equiv>
    \<exists> R1 R2 . s_coupled_simulation_san12 R1 R2 \<and> R1 p q\<close>

abbreviation s_coupled_similar :: \<open>'s \<Rightarrow> 's \<Rightarrow> bool\<close> ("_ \<equiv>scs  _" [60, 60] 65)
  where \<open>s_coupled_similar p q \<equiv>
    \<exists> R1 R2 . s_coupled_simulation_san12 R1 R2 \<and> R1 p q \<and> R2 p q\<close>

lemma s_coupled_sim_is_original_coupled:
  \<open>s_coupled_simulation_san12 = coupled_simulation_p92\<close>
unfolding coupled_simulation_p92_def
  s_coupled_simulation_san12_def weak_simulation_def by blast

corollary weak_bisim_implies_s_coupled_sim:
  assumes \<open>weak_bisimulation R\<close>
  shows \<open>s_coupled_simulation_san12 R R\<close>
  using assms s_coupled_sim_is_original_coupled weak_bisim_implies_coupled_sim_p92 by simp

corollary s_coupled_sim_symm:
  assumes \<open>s_coupled_simulation_san12 R1 R2\<close>
  shows \<open>s_coupled_simulation_san12 (\<lambda> p q. R2 q p) (\<lambda> p q. R1 q p)\<close>
  using assms coupled_sim_p92_symm s_coupled_sim_is_original_coupled by simp

corollary s_coupled_sim_union_cl:
  assumes
    \<open>s_coupled_simulation_san12 RA1 RA2\<close>
    \<open>s_coupled_simulation_san12 RB1 RB2\<close>
  shows
    \<open>s_coupled_simulation_san12 (\<lambda> p q. RA1 p q \<or> RB1 p q) (\<lambda> p q. RA2 p q \<or> RB2 p q)\<close>
  using assms weak_sim_union_cl unfolding s_coupled_simulation_san12_def by auto

corollary s_coupled_sim_symm_union:
  assumes \<open>s_coupled_simulation_san12 R1 R2\<close>
  shows \<open>s_coupled_simulation_san12 (\<lambda> p q. R1 p q \<or> R2 q p) (\<lambda> p q. R2 p q \<or> R1 q p)\<close>
  using s_coupled_sim_union_cl[OF assms s_coupled_sim_symm[OF assms]] .

lemma s_coupledsim_stable_eq:
  assumes
    \<open>p \<sqsubseteq>scs q\<close>
    \<open>stable_state p\<close>
  shows  \<open>p \<equiv>scs q\<close>
proof -
  obtain R1 R2 where
      \<open>R1 p q\<close>
      \<open>weak_simulation R1\<close>
      \<open>weak_simulation (\<lambda>p q. R2 q p)\<close>
      \<open>\<forall>p q. R1 p q \<longrightarrow> stable_state p \<longrightarrow> R2 p q\<close>
      \<open>\<forall>p q. R2 p q \<longrightarrow> stable_state q \<longrightarrow> R1 p q\<close>
    using assms(1)  unfolding s_coupled_simulation_san12_def by blast
  moreover hence \<open>R2 p q\<close> using assms(2) by blast
  ultimately show ?thesis unfolding s_coupled_simulation_san12_def by blast
qed

lemma s_coupledsim_symm:
  assumes
    \<open>p \<equiv>scs q\<close>
  shows
    \<open>q \<equiv>scs p\<close>
  using assms s_coupled_sim_symm by blast

lemma s_coupledsim_eq_parts:
  assumes
    \<open>p \<equiv>scs q\<close>
  shows
    \<open>p \<sqsubseteq>scs q\<close>
    \<open>q \<sqsubseteq>scs p\<close>
  using assms s_coupledsim_symm by metis+

\<comment>\<open>From @{cite "sangiorgi2012"}, p.~226\<close>
lemma divergence_free_coupledsims_coincidence_1:
  defines
    \<open>R1 \<equiv> (\<lambda> p q . p \<sqsubseteq>cs q \<and> (stable_state p \<longrightarrow> stable_state q))\<close> and
    \<open>R2 \<equiv> (\<lambda> p q . q \<sqsubseteq>cs p \<and> (stable_state q \<longrightarrow> stable_state p))\<close>
  assumes
    non_divergent_system: \<open>\<And> p . \<not> divergent_state p\<close>
  shows
    \<open>s_coupled_simulation_san12 R1 R2\<close>
  unfolding s_coupled_simulation_san12_def
proof safe
  show \<open>weak_simulation R1\<close> unfolding weak_simulation_def
  proof safe
    fix p q p' a
    assume sub_assms:
      \<open>R1 p q\<close>
      \<open>p \<longmapsto>a  p'\<close>
    then obtain q' where q'_def: \<open>q \<Rightarrow>^a q'\<close> \<open>p' \<sqsubseteq>cs q'\<close>
      using coupled_sim_by_is_coupled_sim unfolding R1_def coupled_simulation_def by blast
    show \<open>\<exists>q'. R1 p' q' \<and> q \<Rightarrow>^a  q'\<close>
    proof (cases \<open>stable_state p'\<close>)
      case True
      obtain  q'' where q''_def: \<open>q' \<longmapsto>* tau q''\<close> \<open>q'' \<sqsubseteq>cs  p'\<close>
        using coupled_sim_by_is_coupled_sim q'_def(2)
        unfolding coupled_simulation_weak_simulation by blast
      then obtain q''' where q'''_def: \<open>q'' \<longmapsto>* tau q'''\<close> \<open>stable_state q'''\<close>
        using non_divergence_implies_eventual_stability non_divergent_system by blast
      hence \<open>q''' \<sqsubseteq>cs p'\<close>
        using coupledsim_step_gla17 coupledsim_trans[OF _ q''_def(2)] by blast
      hence \<open>p' \<sqsubseteq>cs q'''\<close>
        using `stable_state p'` coupled_sim_by_is_coupled_sim coupledsim_stable_state_symm
        by blast
      moreover have \<open>q \<Rightarrow>^a q'''\<close> using q'_def(1) q''_def(1) q'''_def(1) steps_concat by blast
      ultimately show ?thesis using q'''_def(2) unfolding R1_def by blast
    next
      case False
      then show ?thesis using q'_def unfolding R1_def by blast
    qed
  qed
  \<comment>\<open>analogous to previous case\<close>
  then show \<open>weak_simulation (\<lambda>p q. R2 q p)\<close> unfolding R1_def R2_def .
next
  fix p q
  assume
    \<open>R1 p q\<close>
    \<open>stable_state p\<close>
  thus \<open>R2 p q\<close>
    unfolding R1_def R2_def
    using coupled_sim_by_is_coupled_sim coupledsim_stable_state_symm by blast
next \<comment>\<open>analogous\<close>
  fix p q
  assume
    \<open>R2 p q\<close>
    \<open>stable_state q\<close>
  thus \<open>R1 p q\<close>
    unfolding R1_def R2_def
    using coupled_sim_by_is_coupled_sim coupledsim_stable_state_symm by blast
qed

\<comment>\<open>From @{cite "sangiorgi2012"}, p.~227\<close>
lemma divergence_free_coupledsims_coincidence_2:
  defines
    \<open>R \<equiv> (\<lambda> p q . p \<sqsubseteq>scs q \<or> (\<exists> q' . q \<longmapsto>* tau q' \<and> p \<equiv>scs q'))\<close>
  assumes
    non_divergent_system: \<open>\<And> p . \<not> divergent_state p\<close>
  shows
    \<open>coupled_simulation R\<close>
  unfolding coupled_simulation_weak_simulation
proof safe
  show \<open>weak_simulation R\<close>
    unfolding weak_simulation_def
  proof safe
    fix p q p' a
    assume sub_assms:
      \<open>R p q\<close>
      \<open>p \<longmapsto>a  p'\<close>
    thus \<open>\<exists>q'. R p' q' \<and> q \<Rightarrow>^a  q'\<close>
      unfolding R_def
    proof (cases \<open>p \<sqsubseteq>scs q\<close>)
      case True
      then obtain q' where \<open>p' \<sqsubseteq>scs  q'\<close> \<open>q \<Rightarrow>^a  q'\<close>
        using s_coupled_simulation_san12_def sub_assms(2) weak_sim_ruleformat by metis
      thus \<open>\<exists>q'. (p' \<sqsubseteq>scs  q' \<or> (\<exists>q'a. q' \<longmapsto>* tau  q'a \<and> p' \<equiv>scs  q'a)) \<and> q \<Rightarrow>^a  q'\<close>
        by blast
    next
      case False
      then obtain q' where \<open>q \<longmapsto>* tau  q'\<close> \<open>p \<equiv>scs  q'\<close>
          using sub_assms(1) unfolding R_def by blast
      then obtain q'' where \<open>q' \<Rightarrow>^a  q''\<close> \<open>p' \<sqsubseteq>scs  q''\<close>
        using s_coupled_simulation_san12_def sub_assms(2) weak_sim_ruleformat by metis
      hence \<open>p' \<sqsubseteq>scs  q'' \<and> q \<Rightarrow>^a  q''\<close> using steps_concat `q \<longmapsto>* tau  q'` by blast
      thus \<open>\<exists>q'. (p' \<sqsubseteq>scs  q' \<or> (\<exists>q'a. q' \<longmapsto>* tau  q'a \<and> p' \<equiv>scs  q'a)) \<and> q \<Rightarrow>^a  q'\<close>
        by blast
    qed
  qed
next
  fix p q
  assume
    \<open>R p q\<close>
  thus \<open>\<exists>q'. q \<longmapsto>* tau  q' \<and> R q' p\<close> unfolding R_def
  proof safe
    fix R1 R2
    assume sub_assms:
      \<open>s_coupled_simulation_san12 R1 R2\<close>
      \<open>R1 p q\<close>
    thus \<open>\<exists>q'. q \<longmapsto>* tau  q' \<and> (q' \<sqsubseteq>scs  p \<or> (\<exists>q'a. p \<longmapsto>* tau  q'a \<and> q' \<equiv>scs  q'a))\<close>
    proof -
      \<comment>\<open>dropped a superfluous case distinction from @cite{sangiorgi2012}\<close>
      obtain p' where \<open>stable_state p'\<close> \<open>p \<longmapsto>* tau p'\<close>
        using non_divergent_system non_divergence_implies_eventual_stability by blast
      hence \<open>p \<Rightarrow>^\<tau>  p'\<close> using tau_tau by blast
      then obtain q' where \<open>q \<longmapsto>* tau q'\<close> \<open>p' \<sqsubseteq>scs q'\<close>
        using s_coupled_simulation_san12_def weak_sim_weak_premise sub_assms tau_tau
        by metis
      moreover hence \<open>p' \<equiv>scs q'\<close> using `stable_state p'` s_coupledsim_stable_eq by blast
      ultimately show ?thesis using `p \<longmapsto>* tau p'` s_coupledsim_symm by blast
    qed
  qed (metis s_coupledsim_symm)
qed

text \<open>While this proof follows @{cite "sangiorgi2012"}, we needed to deviate from them by also
  requiring rootedness (shared stability) for the compared states.\<close>
theorem divergence_free_coupledsims_coincidence:
  assumes
    non_divergent_system: \<open>\<And> p . \<not> divergent_state p\<close> and
    stability_rooted: \<open>stable_state p \<longleftrightarrow> stable_state q\<close>
  shows
    \<open>(p \<equiv>cs q) = (p \<equiv>scs q)\<close>
proof rule
  assume \<open>p \<equiv>cs q\<close>
  hence \<open>p \<sqsubseteq>cs q\<close> \<open>q \<sqsubseteq>cs p\<close> by auto
  thus \<open>p \<equiv>scs q\<close>
    using stability_rooted divergence_free_coupledsims_coincidence_1[OF non_divergent_system]
    by blast
next
  assume \<open>p \<equiv>scs q\<close>
  thus \<open>p \<equiv>cs q\<close>
    using stability_rooted divergence_free_coupledsims_coincidence_2[OF non_divergent_system]
      s_coupledsim_eq_parts by blast
qed

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

text \<open>The following example shows that a system might be related by s-coupled-simulation without
  being connected by coupled-simulation.\<close>

datatype ex_state = a0 | a1 | a2 | a3 | b0 | b1 | b2

locale ex_lts = lts_tau trans \<tau>
  for trans :: \<open>ex_state \<Rightarrow> nat \<Rightarrow> ex_state \<Rightarrow> bool\<close> and \<tau> +
  assumes
    sys:
  \<open>trans = (\<lambda> p act q .
     1 = act \<and> (p = a0 \<and> q = a1
              \<or> p = a0 \<and> q = a2
              \<or> p = a2 \<and> q = a3
              \<or> p = b0 \<and> q = b1
              \<or> p = b1 \<and> q = b2) \<or>
     0 = act \<and> (p = a1 \<and> q = a1))\<close>
   \<open>\<tau> = 0\<close>
begin

lemma no_root_coupled_sim:
  fixes R1 R2
  assumes
    coupled:
      \<open>coupled_simulation_san12 R1 R2\<close> and
    root:
      \<open>R1 a0 b0\<close> \<open>R2 a0 b0\<close>
  shows
    False
proof -
  have
    R1sim:
      \<open>weak_simulation R1\<close> and
    R1coupling:
      \<open>\<forall>p q. R1 p q \<longrightarrow> (\<exists>q'. q \<longmapsto>* tau  q' \<and> R2 p q')\<close> and
    R2sim:
      \<open>weak_simulation (\<lambda>p q. R2 q p)\<close>
    using coupled unfolding coupled_simulation_san12_def by auto
  hence R1sim_rf:
      \<open>\<And> p q. R1 p q \<Longrightarrow>
        (\<forall>p' a. p \<longmapsto>a  p' \<longrightarrow>
          (\<exists>q'. R1 p' q' \<and> (\<not> tau a \<longrightarrow> q \<Rightarrow>a  q') \<and>
          (tau a \<longrightarrow> q \<longmapsto>* tau  q')))\<close>
    unfolding weak_simulation_def by blast
  have \<open>a0 \<longmapsto>1 a1\<close> using sys by auto
  hence \<open>\<exists>q'. R1 a1 q' \<and> b0 \<Rightarrow>1 q'\<close>
    using R1sim_rf[OF root(1), rule_format, of 1 a1] tau_def
    by (auto simp add: sys)
  then obtain q' where q': \<open>R1 a1 q'\<close> \<open>b0 \<Rightarrow>1 q'\<close> by blast
  have b0_quasi_stable: \<open>\<forall> q' . b0 \<longmapsto>*tau q' \<longrightarrow> b0 = q'\<close>
    using steps_no_step[of b0 tau] tau_def by (auto simp add: sys)
  have b0_only_b1: \<open>\<forall> q' . b0 \<longmapsto>1 q' \<longrightarrow> q' = b1\<close> by (auto simp add: sys)
  have b1_quasi_stable: \<open>\<forall> q' . b1 \<longmapsto>*tau q' \<longrightarrow> b1 = q'\<close>
    using steps_no_step[of b1 tau] tau_def by (auto simp add: sys)
  have \<open>\<forall> q' . b0 \<Rightarrow>1 q' \<longrightarrow> q' = b1\<close>
    using b0_quasi_stable b0_only_b1 b1_quasi_stable by auto
  hence \<open>q' = b1\<close> using q'(2) by blast
  hence \<open>R1 a1 b1\<close> using q'(1) by simp
  hence \<open>R2 a1 b1\<close>
    using b1_quasi_stable R1coupling by auto
  have b1_b2: \<open>b1 \<longmapsto>1 b2\<close>
    by (auto simp add: sys)
  hence a1_sim: \<open>\<exists> q' . R2 q' b2 \<and> a1 \<Rightarrow>1  q'\<close>
    using `R2 a1 b1` R2sim b1_b2
    unfolding weak_simulation_def tau_def by (auto simp add: sys)
  have a1_quasi_stable: \<open>\<forall> q' . a1 \<longmapsto>*tau q' \<longrightarrow> a1 = q'\<close>
    using steps_loop[of a1] by (auto simp add: sys)
  hence a1_stuck: \<open>\<forall> q' . \<not> a1 \<Rightarrow>1 q'\<close>
    by (auto simp add: sys)
  show ?thesis using a1_sim  a1_stuck by blast
qed

lemma root_s_coupled_sim:
  defines
    \<open>R1 \<equiv> \<lambda> a b .
      a = a0 \<and> b = b0 \<or>
      a = a1 \<and> b = b1 \<or>
      a = a2 \<and> b = b1 \<or>
      a = a3 \<and> b = b2\<close>
  and
    \<open>R2 \<equiv> \<lambda> a b .
      a = a0 \<and> b = b0 \<or>
      a = a2 \<and> b = b1 \<or>
      a = a3 \<and> b = b2\<close>
  shows
    coupled:
      \<open>s_coupled_simulation_san12 R1 R2\<close>
  unfolding s_coupled_simulation_san12_def
proof safe
  show \<open>weak_simulation R1\<close>
    unfolding weak_simulation_def proof (clarify)
    fix p q p' a
    show \<open>R1 p q \<Longrightarrow> p \<longmapsto>a  p' \<Longrightarrow> \<exists>q'. R1 p' q' \<and> (q \<Rightarrow>^a  q')\<close>
      using step_tau_refl unfolding sys assms tau_def using sys(2) tau_def by (cases p, auto)
  qed
next
  show \<open>weak_simulation (\<lambda>p q. R2 q p)\<close>
    unfolding weak_simulation_def proof (clarify)
    fix p q p' a
    show \<open>R2 q p \<Longrightarrow> p \<longmapsto>a  p' \<Longrightarrow> \<exists>q'. R2 q' p' \<and> (q \<Rightarrow>^a  q')\<close>
      using steps.refl[of _ tau] tau_def unfolding assms sys
      using sys(2) tau_def by (cases p, auto)
  qed
next
  fix p q
  assume \<open>R1 p q\<close> \<open>stable_state p\<close>
  thus \<open>R2 p q\<close> unfolding assms sys using sys(2) tau_def by auto
next
  fix p q
  assume \<open>R2 p q\<close> \<open>stable_state q\<close>
  thus \<open>R1 p q\<close> unfolding assms sys using tau_def by auto
qed

end \<comment>\<open>@{locale ex_lts}// example lts\<close>

end


(*  Title:      HOL/SMT.thy
    Author:     Sascha Boehme, TU Muenchen
*)

section \<open>Bindings to Satisfiability Modulo Theories (SMT) solvers based on SMT-LIB 2\<close>

theory SMT
imports Divides
keywords "smt_status" :: diag
begin

subsection \<open>A skolemization tactic and proof method\<close>

lemma choices:
  "\<And>Q. \<forall>x. \<exists>y ya. Q x y ya \<Longrightarrow> \<exists>f fa. \<forall>x. Q x (f x) (fa x)"
  "\<And>Q. \<forall>x. \<exists>y ya yb. Q x y ya yb \<Longrightarrow> \<exists>f fa fb. \<forall>x. Q x (f x) (fa x) (fb x)"
  "\<And>Q. \<forall>x. \<exists>y ya yb yc. Q x y ya yb yc \<Longrightarrow> \<exists>f fa fb fc. \<forall>x. Q x (f x) (fa x) (fb x) (fc x)"
  "\<And>Q. \<forall>x. \<exists>y ya yb yc yd. Q x y ya yb yc yd \<Longrightarrow>
     \<exists>f fa fb fc fd. \<forall>x. Q x (f x) (fa x) (fb x) (fc x) (fd x)"
  "\<And>Q. \<forall>x. \<exists>y ya yb yc yd ye. Q x y ya yb yc yd ye \<Longrightarrow>
     \<exists>f fa fb fc fd fe. \<forall>x. Q x (f x) (fa x) (fb x) (fc x) (fd x) (fe x)"
  "\<And>Q. \<forall>x. \<exists>y ya yb yc yd ye yf. Q x y ya yb yc yd ye yf \<Longrightarrow>
     \<exists>f fa fb fc fd fe ff. \<forall>x. Q x (f x) (fa x) (fb x) (fc x) (fd x) (fe x) (ff x)"
  "\<And>Q. \<forall>x. \<exists>y ya yb yc yd ye yf yg. Q x y ya yb yc yd ye yf yg \<Longrightarrow>
     \<exists>f fa fb fc fd fe ff fg. \<forall>x. Q x (f x) (fa x) (fb x) (fc x) (fd x) (fe x) (ff x) (fg x)"
  by metis+

lemma bchoices:
  "\<And>Q. \<forall>x \<in> S. \<exists>y ya. Q x y ya \<Longrightarrow> \<exists>f fa. \<forall>x \<in> S. Q x (f x) (fa x)"
  "\<And>Q. \<forall>x \<in> S. \<exists>y ya yb. Q x y ya yb \<Longrightarrow> \<exists>f fa fb. \<forall>x \<in> S. Q x (f x) (fa x) (fb x)"
  "\<And>Q. \<forall>x \<in> S. \<exists>y ya yb yc. Q x y ya yb yc \<Longrightarrow> \<exists>f fa fb fc. \<forall>x \<in> S. Q x (f x) (fa x) (fb x) (fc x)"
  "\<And>Q. \<forall>x \<in> S. \<exists>y ya yb yc yd. Q x y ya yb yc yd \<Longrightarrow>
    \<exists>f fa fb fc fd. \<forall>x \<in> S. Q x (f x) (fa x) (fb x) (fc x) (fd x)"
  "\<And>Q. \<forall>x \<in> S. \<exists>y ya yb yc yd ye. Q x y ya yb yc yd ye \<Longrightarrow>
    \<exists>f fa fb fc fd fe. \<forall>x \<in> S. Q x (f x) (fa x) (fb x) (fc x) (fd x) (fe x)"
  "\<And>Q. \<forall>x \<in> S. \<exists>y ya yb yc yd ye yf. Q x y ya yb yc yd ye yf \<Longrightarrow>
    \<exists>f fa fb fc fd fe ff. \<forall>x \<in> S. Q x (f x) (fa x) (fb x) (fc x) (fd x) (fe x) (ff x)"
  "\<And>Q. \<forall>x \<in> S. \<exists>y ya yb yc yd ye yf yg. Q x y ya yb yc yd ye yf yg \<Longrightarrow>
    \<exists>f fa fb fc fd fe ff fg. \<forall>x \<in> S. Q x (f x) (fa x) (fb x) (fc x) (fd x) (fe x) (ff x) (fg x)"
  by metis+

ML \<open>
fun moura_tac ctxt =
  Atomize_Elim.atomize_elim_tac ctxt THEN'
  SELECT_GOAL (Clasimp.auto_tac (ctxt addSIs @{thms choice choices bchoice bchoices}) THEN
    ALLGOALS (Metis_Tactic.metis_tac (take 1 ATP_Proof_Reconstruct.partial_type_encs)
        ATP_Proof_Reconstruct.default_metis_lam_trans ctxt [] ORELSE'
      blast_tac ctxt))
\<close>

method_setup moura = \<open>
  Scan.succeed (SIMPLE_METHOD' o moura_tac)
\<close> "solve skolemization goals, especially those arising from Z3 proofs"

hide_fact (open) choices bchoices

subsection \<open>Triggers for quantifier instantiation\<close>

text \<open>
Some SMT solvers support patterns as a quantifier instantiation
heuristics. Patterns may either be positive terms (tagged by "pat")
triggering quantifier instantiations -- when the solver finds a
term matching a positive pattern, it instantiates the corresponding
quantifier accordingly -- or negative terms (tagged by "nopat")
inhibiting quantifier instantiations. A list of patterns
of the same kind is called a multipattern, and all patterns in a
multipattern are considered conjunctively for quantifier instantiation.
A list of multipatterns is called a trigger, and their multipatterns
act disjunctively during quantifier instantiation. Each multipattern
should mention at least all quantified variables of the preceding
quantifier block.
\<close>

typedecl 'a symb_list

consts
  Symb_Nil :: "'a symb_list"
  Symb_Cons :: "'a \<Rightarrow> 'a symb_list \<Rightarrow> 'a symb_list"

typedecl pattern

consts
  pat :: "'a \<Rightarrow> pattern"
  nopat :: "'a \<Rightarrow> pattern"

definition trigger :: "pattern symb_list symb_list \<Rightarrow> bool \<Rightarrow> bool" where
  "trigger _ P = P"

subsection \<open>Higher-order encoding\<close>

text \<open>
Application is made explicit for constants occurring with varying
numbers of arguments. This is achieved by the introduction of the
following constant.
\<close>

definition fun_app :: "'a \<Rightarrow> 'a" where "fun_app f = f"

text \<open>
Some solvers support a theory of arrays which can be used to encode
higher-order functions. The following set of lemmas specifies the
properties of such (extensional) arrays.
\<close>

lemmas array_rules = ext fun_upd_apply fun_upd_same fun_upd_other  fun_upd_upd fun_app_def

subsection \<open>Normalization\<close>

lemma case_bool_if[abs_def]: "case_bool x y P = (if P then x else y)"
  by simp

lemmas Ex1_def_raw = Ex1_def[abs_def]
lemmas Ball_def_raw = Ball_def[abs_def]
lemmas Bex_def_raw = Bex_def[abs_def]
lemmas abs_if_raw = abs_if[abs_def]
lemmas min_def_raw = min_def[abs_def]
lemmas max_def_raw = max_def[abs_def]

subsection \<open>Integer division and modulo for Z3\<close>

text \<open>
The following Z3-inspired definitions are overspecified for the case where \<open>l = 0\<close>. This
Schönheitsfehler is corrected in the \<open>div_as_z3div\<close> and \<open>mod_as_z3mod\<close> theorems.
\<close>

definition z3div :: "int \<Rightarrow> int \<Rightarrow> int" where
  "z3div k l = (if l \<ge> 0 then k div l else - (k div - l))"

definition z3mod :: "int \<Rightarrow> int \<Rightarrow> int" where
  "z3mod k l = k mod (if l \<ge> 0 then l else - l)"

lemma div_as_z3div:
  "\<forall>k l. k div l = (if l = 0 then 0 else if l > 0 then z3div k l else z3div (- k) (- l))"
  by (simp add: z3div_def)

lemma mod_as_z3mod:
  "\<forall>k l. k mod l = (if l = 0 then k else if l > 0 then z3mod k l else - z3mod (- k) (- l))"
  by (simp add: z3mod_def)

subsection \<open>Setup\<close>

ML_file "Tools/SMT/smt_util.ML"
ML_file "Tools/SMT/smt_failure.ML"
ML_file "Tools/SMT/smt_config.ML"
ML_file "Tools/SMT/smt_builtin.ML"
ML_file "Tools/SMT/smt_datatypes.ML"
ML_file "Tools/SMT/smt_normalize.ML"
ML_file "Tools/SMT/smt_translate.ML"
ML_file "Tools/SMT/smtlib.ML"
ML_file "Tools/SMT/smtlib_interface.ML"
ML_file "Tools/SMT/smtlib_proof.ML"
ML_file "Tools/SMT/smtlib_isar.ML"
ML_file "Tools/SMT/z3_proof.ML"
ML_file "Tools/SMT/z3_isar.ML"
ML_file "Tools/SMT/smt_solver.ML"
ML_file "Tools/SMT/cvc4_interface.ML"
ML_file "Tools/SMT/cvc4_proof_parse.ML"
ML_file "Tools/SMT/verit_proof.ML"
ML_file "Tools/SMT/verit_isar.ML"
ML_file "Tools/SMT/verit_proof_parse.ML"
ML_file "Tools/SMT/conj_disj_perm.ML"
ML_file "Tools/SMT/z3_interface.ML"
ML_file "Tools/SMT/z3_replay_util.ML"
ML_file "Tools/SMT/z3_replay_rules.ML"
ML_file "Tools/SMT/z3_replay_methods.ML"
ML_file "Tools/SMT/z3_replay.ML"
ML_file "Tools/SMT/smt_systems.ML"

method_setup smt = \<open>
  Scan.optional Attrib.thms [] >>
    (fn thms => fn ctxt =>
      METHOD (fn facts => HEADGOAL (SMT_Solver.smt_tac ctxt (thms @ facts))))
\<close> "apply an SMT solver to the current goal"

subsection \<open>Configuration\<close>

text \<open>
The current configuration can be printed by the command
\<open>smt_status\<close>, which shows the values of most options.
\<close>

subsection \<open>General configuration options\<close>

text \<open>
The option \<open>smt_solver\<close> can be used to change the target SMT
solver. The possible values can be obtained from the \<open>smt_status\<close>
command.
\<close>

declare [[smt_solver = z3]]

text \<open>
Since SMT solvers are potentially nonterminating, there is a timeout
(given in seconds) to restrict their runtime.
\<close>

declare [[smt_timeout = 20]]

text \<open>
SMT solvers apply randomized heuristics. In case a problem is not
solvable by an SMT solver, changing the following option might help.
\<close>

declare [[smt_random_seed = 1]]

text \<open>
In general, the binding to SMT solvers runs as an oracle, i.e, the SMT
solvers are fully trusted without additional checks. The following
option can cause the SMT solver to run in proof-producing mode, giving
a checkable certificate. This is currently only implemented for Z3.
\<close>

declare [[smt_oracle = false]]

text \<open>
Each SMT solver provides several commandline options to tweak its
behaviour. They can be passed to the solver by setting the following
options.
\<close>

declare [[cvc3_options = ""]]
declare [[cvc4_options = "--full-saturate-quant --inst-when=full-last-call --inst-no-entail --term-db-mode=relevant"]]
declare [[verit_options = ""]]
declare [[z3_options = ""]]

text \<open>
The SMT method provides an inference mechanism to detect simple triggers
in quantified formulas, which might increase the number of problems
solvable by SMT solvers (note: triggers guide quantifier instantiations
in the SMT solver). To turn it on, set the following option.
\<close>

declare [[smt_infer_triggers = false]]

text \<open>
Enable the following option to use built-in support for datatypes,
codatatypes, and records in CVC4. Currently, this is implemented only
in oracle mode.
\<close>

declare [[cvc4_extensions = false]]

text \<open>
Enable the following option to use built-in support for div/mod, datatypes,
and records in Z3. Currently, this is implemented only in oracle mode.
\<close>

declare [[z3_extensions = false]]

subsection \<open>Certificates\<close>

text \<open>
By setting the option \<open>smt_certificates\<close> to the name of a file,
all following applications of an SMT solver a cached in that file.
Any further application of the same SMT solver (using the very same
configuration) re-uses the cached certificate instead of invoking the
solver. An empty string disables caching certificates.

The filename should be given as an explicit path. It is good
practice to use the name of the current theory (with ending
\<open>.certs\<close> instead of \<open>.thy\<close>) as the certificates file.
Certificate files should be used at most once in a certain theory context,
to avoid race conditions with other concurrent accesses.
\<close>

declare [[smt_certificates = ""]]

text \<open>
The option \<open>smt_read_only_certificates\<close> controls whether only
stored certificates are should be used or invocation of an SMT solver
is allowed. When set to \<open>true\<close>, no SMT solver will ever be
invoked and only the existing certificates found in the configured
cache are used;  when set to \<open>false\<close> and there is no cached
certificate for some proposition, then the configured SMT solver is
invoked.
\<close>

declare [[smt_read_only_certificates = false]]

subsection \<open>Tracing\<close>

text \<open>
The SMT method, when applied, traces important information. To
make it entirely silent, set the following option to \<open>false\<close>.
\<close>

declare [[smt_verbose = true]]

text \<open>
For tracing the generated problem file given to the SMT solver as
well as the returned result of the solver, the option
\<open>smt_trace\<close> should be set to \<open>true\<close>.
\<close>

declare [[smt_trace = false]]

subsection \<open>Schematic rules for Z3 proof reconstruction\<close>

text \<open>
Several prof rules of Z3 are not very well documented. There are two
lemma groups which can turn failing Z3 proof reconstruction attempts
into succeeding ones: the facts in \<open>z3_rule\<close> are tried prior to
any implemented reconstruction procedure for all uncertain Z3 proof
rules;  the facts in \<open>z3_simp\<close> are only fed to invocations of
the simplifier when reconstructing theory-specific proof steps.
\<close>

lemmas [z3_rule] =
  refl eq_commute conj_commute disj_commute simp_thms nnf_simps
  ring_distribs field_simps times_divide_eq_right times_divide_eq_left
  if_True if_False not_not
  NO_MATCH_def

lemma [z3_rule]:
  "(P \<and> Q) = (\<not> (\<not> P \<or> \<not> Q))"
  "(P \<and> Q) = (\<not> (\<not> Q \<or> \<not> P))"
  "(\<not> P \<and> Q) = (\<not> (P \<or> \<not> Q))"
  "(\<not> P \<and> Q) = (\<not> (\<not> Q \<or> P))"
  "(P \<and> \<not> Q) = (\<not> (\<not> P \<or> Q))"
  "(P \<and> \<not> Q) = (\<not> (Q \<or> \<not> P))"
  "(\<not> P \<and> \<not> Q) = (\<not> (P \<or> Q))"
  "(\<not> P \<and> \<not> Q) = (\<not> (Q \<or> P))"
  by auto

lemma [z3_rule]:
  "(P \<longrightarrow> Q) = (Q \<or> \<not> P)"
  "(\<not> P \<longrightarrow> Q) = (P \<or> Q)"
  "(\<not> P \<longrightarrow> Q) = (Q \<or> P)"
  "(True \<longrightarrow> P) = P"
  "(P \<longrightarrow> True) = True"
  "(False \<longrightarrow> P) = True"
  "(P \<longrightarrow> P) = True"
  "(\<not> (A \<longleftrightarrow> \<not> B)) \<longleftrightarrow> (A \<longleftrightarrow> B)"
  by auto

lemma [z3_rule]:
  "((P = Q) \<longrightarrow> R) = (R | (Q = (\<not> P)))"
  by auto

lemma [z3_rule]:
  "(\<not> True) = False"
  "(\<not> False) = True"
  "(x = x) = True"
  "(P = True) = P"
  "(True = P) = P"
  "(P = False) = (\<not> P)"
  "(False = P) = (\<not> P)"
  "((\<not> P) = P) = False"
  "(P = (\<not> P)) = False"
  "((\<not> P) = (\<not> Q)) = (P = Q)"
  "\<not> (P = (\<not> Q)) = (P = Q)"
  "\<not> ((\<not> P) = Q) = (P = Q)"
  "(P \<noteq> Q) = (Q = (\<not> P))"
  "(P = Q) = ((\<not> P \<or> Q) \<and> (P \<or> \<not> Q))"
  "(P \<noteq> Q) = ((\<not> P \<or> \<not> Q) \<and> (P \<or> Q))"
  by auto

lemma [z3_rule]:
  "(if P then P else \<not> P) = True"
  "(if \<not> P then \<not> P else P) = True"
  "(if P then True else False) = P"
  "(if P then False else True) = (\<not> P)"
  "(if P then Q else True) = ((\<not> P) \<or> Q)"
  "(if P then Q else True) = (Q \<or> (\<not> P))"
  "(if P then Q else \<not> Q) = (P = Q)"
  "(if P then Q else \<not> Q) = (Q = P)"
  "(if P then \<not> Q else Q) = (P = (\<not> Q))"
  "(if P then \<not> Q else Q) = ((\<not> Q) = P)"
  "(if \<not> P then x else y) = (if P then y else x)"
  "(if P then (if Q then x else y) else x) = (if P \<and> (\<not> Q) then y else x)"
  "(if P then (if Q then x else y) else x) = (if (\<not> Q) \<and> P then y else x)"
  "(if P then (if Q then x else y) else y) = (if P \<and> Q then x else y)"
  "(if P then (if Q then x else y) else y) = (if Q \<and> P then x else y)"
  "(if P then x else if P then y else z) = (if P then x else z)"
  "(if P then x else if Q then x else y) = (if P \<or> Q then x else y)"
  "(if P then x else if Q then x else y) = (if Q \<or> P then x else y)"
  "(if P then x = y else x = z) = (x = (if P then y else z))"
  "(if P then x = y else y = z) = (y = (if P then x else z))"
  "(if P then x = y else z = y) = (y = (if P then x else z))"
  by auto

lemma [z3_rule]:
  "0 + (x::int) = x"
  "x + 0 = x"
  "x + x = 2 * x"
  "0 * x = 0"
  "1 * x = x"
  "x + y = y + x"
  by (auto simp add: mult_2)

lemma [z3_rule]:  (* for def-axiom *)
  "P = Q \<or> P \<or> Q"
  "P = Q \<or> \<not> P \<or> \<not> Q"
  "(\<not> P) = Q \<or> \<not> P \<or> Q"
  "(\<not> P) = Q \<or> P \<or> \<not> Q"
  "P = (\<not> Q) \<or> \<not> P \<or> Q"
  "P = (\<not> Q) \<or> P \<or> \<not> Q"
  "P \<noteq> Q \<or> P \<or> \<not> Q"
  "P \<noteq> Q \<or> \<not> P \<or> Q"
  "P \<noteq> (\<not> Q) \<or> P \<or> Q"
  "(\<not> P) \<noteq> Q \<or> P \<or> Q"
  "P \<or> Q \<or> P \<noteq> (\<not> Q)"
  "P \<or> Q \<or> (\<not> P) \<noteq> Q"
  "P \<or> \<not> Q \<or> P \<noteq> Q"
  "\<not> P \<or> Q \<or> P \<noteq> Q"
  "P \<or> y = (if P then x else y)"
  "P \<or> (if P then x else y) = y"
  "\<not> P \<or> x = (if P then x else y)"
  "\<not> P \<or> (if P then x else y) = x"
  "P \<or> R \<or> \<not> (if P then Q else R)"
  "\<not> P \<or> Q \<or> \<not> (if P then Q else R)"
  "\<not> (if P then Q else R) \<or> \<not> P \<or> Q"
  "\<not> (if P then Q else R) \<or> P \<or> R"
  "(if P then Q else R) \<or> \<not> P \<or> \<not> Q"
  "(if P then Q else R) \<or> P \<or> \<not> R"
  "(if P then \<not> Q else R) \<or> \<not> P \<or> Q"
  "(if P then Q else \<not> R) \<or> P \<or> R"
  by auto

hide_type (open) symb_list pattern
hide_const (open) Symb_Nil Symb_Cons trigger pat nopat fun_app z3div z3mod

end