(*
   Title: Psi-calculi
   Author/Maintainer: Jesper Bengtson (jebe@itu.dk), 2012
*)
theory Tau_Stat_Imp
  imports Tau_Sim Weaken_Stat_Imp
begin

locale weakTauLaws = weak + tau
begin

lemma tauLaw1StatImpLeft:
  fixes \<Psi> :: 'b
  and   P :: "('a, 'b, 'c) psi"
  and   Q :: "('a, 'b, 'c) psi"

  assumes "\<Psi> \<rhd> P \<lessapprox>\<^sub>w<Rel> Q"
  and     "(\<Psi>, \<tau>.(P), Q) \<in> Rel"

  shows "\<Psi> \<rhd> \<tau>.(P) \<lessapprox>\<^sub>w<Rel> Q"
proof -
  have "\<Psi> \<rhd> Q \<Longrightarrow>\<^sup>^\<^sub>\<tau> Q" by simp
  moreover have "insertAssertion (extractFrame(\<tau>.(P))) \<Psi> \<simeq>\<^sub>F \<langle>\<epsilon>, \<Psi>\<rangle>" by(rule insertTauAssertion)
  hence "insertAssertion (extractFrame(\<tau>.(P))) \<Psi> \<hookrightarrow>\<^sub>F insertAssertion (extractFrame Q) \<Psi>"
    by(metis FrameStatImpTrans FrameStatEq_def insertAssertionWeaken)
  ultimately show ?thesis using \<open>(\<Psi>, \<tau>.(P), Q) \<in> Rel\<close>
    by(rule weakenStatImpI)
qed

lemma tauLaw1StatImpRight:
  fixes \<Psi> :: 'b
  and   P :: "('a, 'b, 'c) psi"
  and   Q :: "('a, 'b, 'c) psi"

  assumes "\<Psi> \<rhd> P \<lessapprox><Rel> Q"
  and     C1: "\<And>\<Psi> P Q R. \<lbrakk>(\<Psi>, P, Q) \<in> Rel; \<Psi> \<rhd> Q \<sim> R\<rbrakk> \<Longrightarrow> (\<Psi>, P, R) \<in> Rel'"

  shows "\<Psi> \<rhd> P \<lessapprox><Rel'> \<tau>.(Q)"
proof(induct rule: weakStatImpI)
  case(cStatImp \<Psi>')
  from \<open>\<Psi> \<rhd> P \<lessapprox><Rel> Q\<close> obtain Q' Q''
    where QChain: "\<Psi> \<rhd> Q \<Longrightarrow>\<^sup>^\<^sub>\<tau> Q'" and PImpQ': "insertAssertion (extractFrame P) \<Psi> \<hookrightarrow>\<^sub>F insertAssertion (extractFrame Q') \<Psi>"
      and Q'Chain: "\<Psi> \<otimes> \<Psi>' \<rhd> Q' \<Longrightarrow>\<^sup>^\<^sub>\<tau> Q''" and PRelQ'': "(\<Psi> \<otimes> \<Psi>', P, Q'') \<in> Rel"
    by(rule weakStatImpE)

  obtain Q''' where QTrans: "\<Psi> \<rhd> \<tau>.(Q) \<longmapsto>\<tau> \<prec> Q'''" and "\<Psi> \<rhd> Q \<sim> Q'''" using tauActionI by auto

  from \<open>\<Psi> \<rhd> Q \<sim> Q'''\<close> QChain bisimE(2) obtain Q'''' where Q'''Chain: "\<Psi> \<rhd> Q''' \<Longrightarrow>\<^sup>^\<^sub>\<tau> Q''''" and "\<Psi> \<rhd> Q' \<sim> Q''''"
    by(metis bisimE(4) simTauChain)

  from QTrans Q'''Chain have "\<Psi> \<rhd> \<tau>.(Q) \<Longrightarrow>\<^sup>^\<^sub>\<tau> Q''''" by(drule_tac tauActTauChain) auto
  moreover from \<open>\<Psi> \<rhd> Q' \<sim> Q''''\<close> have "insertAssertion (extractFrame Q') \<Psi> \<hookrightarrow>\<^sub>F insertAssertion (extractFrame Q'''') \<Psi>"
    by(metis bisimE FrameStatEq_def)
  with PImpQ'  have "insertAssertion (extractFrame P) \<Psi> \<hookrightarrow>\<^sub>F insertAssertion (extractFrame Q'''') \<Psi>"
    by(rule FrameStatImpTrans)
  moreover from \<open>\<Psi> \<rhd> Q' \<sim> Q''''\<close> have "\<Psi> \<otimes> \<Psi>' \<rhd> Q' \<sim> Q''''" by(rule bisimE)
  then obtain Q''''' where Q''''Chain: "\<Psi> \<otimes> \<Psi>' \<rhd> Q'''' \<Longrightarrow>\<^sup>^\<^sub>\<tau> Q'''''" and "\<Psi> \<otimes> \<Psi>' \<rhd> Q'' \<sim> Q'''''" using Q'Chain bisimE(2)
    by(metis bisimE(4) simTauChain)
  note Q''''Chain
  moreover from \<open>(\<Psi> \<otimes> \<Psi>', P, Q'') \<in> Rel\<close> \<open>\<Psi> \<otimes> \<Psi>' \<rhd> Q'' \<sim> Q'''''\<close> have "(\<Psi> \<otimes> \<Psi>', P, Q''''') \<in> Rel'"
    by(rule C1)
  ultimately show ?case by blast
qed

end

context tau begin

lemma tauLaw3StatImpLeft:
  fixes \<Psi> :: 'b
  and   P :: "('a, 'b, 'c) psi"
  and   Q :: "('a, 'b, 'c) psi"
  and   \<alpha> :: "'a prefix"

  assumes C1: "\<And>\<Psi>'. (\<Psi> \<otimes> \<Psi>', \<alpha>\<cdot>(\<tau>.(P)), \<alpha>\<cdot>Q) \<in> Rel"

  shows "\<Psi> \<rhd> \<alpha>\<cdot>(\<tau>.(P)) \<lessapprox><Rel> \<alpha>\<cdot>Q"
proof(induct rule: weakStatImpI)
  case(cStatImp \<Psi>')
  have "\<Psi> \<rhd> \<alpha>\<cdot>Q \<Longrightarrow>\<^sup>^\<^sub>\<tau> \<alpha>\<cdot>Q" by auto
  moreover have "insertAssertion (extractFrame(\<alpha>\<cdot>(\<tau>.(P)))) \<Psi> \<hookrightarrow>\<^sub>F insertAssertion (extractFrame(\<alpha>\<cdot>Q)) \<Psi>" using insertTauAssertion
    by(nominal_induct \<alpha> rule: prefix.strong_inducts) (auto simp add: FrameStatEq_def intro: FrameStatImpTrans)
  moreover have "\<Psi> \<otimes> \<Psi>' \<rhd> \<alpha>\<cdot>Q \<Longrightarrow>\<^sup>^\<^sub>\<tau> \<alpha>\<cdot>Q" by auto
  moreover have "(\<Psi> \<otimes> \<Psi>', \<alpha>\<cdot>(\<tau>.(P)), \<alpha>\<cdot>Q) \<in> Rel" by(rule C1)
  ultimately show ?case by blast
qed

lemma tauLaw3StatImpRight:
  fixes \<Psi> :: 'b
  and   P :: "('a, 'b, 'c) psi"
  and   Q :: "('a, 'b, 'c) psi"

  assumes C1: "\<And>\<Psi>'. (\<Psi> \<otimes> \<Psi>', \<alpha>\<cdot>P, \<alpha>\<cdot>(\<tau>.(Q))) \<in> Rel"

  shows "\<Psi> \<rhd> \<alpha>\<cdot>P \<lessapprox><Rel> \<alpha>\<cdot>(\<tau>.(Q))"
proof(induct rule: weakStatImpI)
  case(cStatImp \<Psi>')
  have "\<Psi> \<rhd>  \<alpha>\<cdot>(\<tau>.(Q)) \<Longrightarrow>\<^sup>^\<^sub>\<tau>  \<alpha>\<cdot>(\<tau>.(Q))" by auto
  moreover have "insertAssertion (extractFrame(\<alpha>\<cdot>P)) \<Psi> \<hookrightarrow>\<^sub>F insertAssertion (extractFrame(\<alpha>\<cdot>(\<tau>.(Q)))) \<Psi>" using insertTauAssertion
    by(nominal_induct \<alpha> rule: prefix.strong_inducts) (auto simp add: FrameStatEq_def intro: FrameStatImpTrans)
  moreover have "\<Psi> \<otimes> \<Psi>' \<rhd>  \<alpha>\<cdot>(\<tau>.(Q)) \<Longrightarrow>\<^sup>^\<^sub>\<tau>  \<alpha>\<cdot>(\<tau>.(Q))" by auto
  moreover have "(\<Psi> \<otimes> \<Psi>', \<alpha>\<cdot>P, \<alpha>\<cdot>(\<tau>.(Q))) \<in> Rel" by(rule C1)
  ultimately show ?case by blast
qed

end

context tauSum begin

lemma tauLaw2StatImpLeft:
  fixes \<Psi> :: 'b
  and   P :: "('a, 'b, 'c) psi"

  assumes C1: "\<And>\<Psi>'. (\<Psi> \<otimes> \<Psi>', P \<oplus> \<tau>.(P), \<tau>.(P)) \<in> Rel"

  shows "\<Psi> \<rhd> P \<oplus> \<tau>.(P) \<lessapprox><Rel> \<tau>.(P)"
proof(induct rule: weakStatImpI)
  case(cStatImp \<Psi>')
  have "\<Psi> \<rhd> \<tau>.(P) \<Longrightarrow>\<^sup>^\<^sub>\<tau> \<tau>.(P)" by auto
  moreover have "insertAssertion (extractFrame(\<tau>.(P))) \<Psi> \<simeq>\<^sub>F \<langle>\<epsilon>, \<Psi>\<rangle>" by(rule insertTauAssertion)
  hence "insertAssertion (extractFrame(P \<oplus> \<tau>.(P))) \<Psi> \<hookrightarrow>\<^sub>F insertAssertion (extractFrame(\<tau>.(P))) \<Psi>" using Identity
    by(rule_tac FrameStatImpTrans) (auto simp add: FrameStatEq_def AssertionStatEq_def)
  moreover have "\<Psi> \<otimes> \<Psi>' \<rhd> \<tau>.(P) \<Longrightarrow>\<^sup>^\<^sub>\<tau> \<tau>.(P)" by auto
  moreover have "(\<Psi> \<otimes> \<Psi>', P \<oplus> \<tau>.(P), \<tau>.(P)) \<in> Rel" by(rule C1)
  ultimately show ?case by blast
qed

lemma tauLaw2StatImpRight:
  fixes \<Psi> :: 'b
  and   P :: "('a, 'b, 'c) psi"

  assumes C1: "\<And>\<Psi>'. (\<Psi> \<otimes> \<Psi>', \<tau>.(P), P \<oplus> \<tau>.(P)) \<in> Rel"

  shows "\<Psi> \<rhd> \<tau>.(P) \<lessapprox><Rel> P \<oplus> \<tau>.(P)"
proof(induct rule: weakStatImpI)
  case(cStatImp \<Psi>')
  have "\<Psi> \<rhd> P \<oplus> \<tau>.(P) \<Longrightarrow>\<^sup>^\<^sub>\<tau> P \<oplus> \<tau>.(P)" by auto
  moreover have "insertAssertion (extractFrame(\<tau>.(P))) \<Psi> \<simeq>\<^sub>F \<langle>\<epsilon>, \<Psi>\<rangle>" by(rule insertTauAssertion)
  hence "insertAssertion (extractFrame(\<tau>.(P))) \<Psi> \<hookrightarrow>\<^sub>F insertAssertion (extractFrame(P \<oplus> \<tau>.(P))) \<Psi>" using Identity
    by(rule_tac FrameStatImpTrans) (auto simp add: FrameStatEq_def AssertionStatEq_def)
  moreover have "\<Psi> \<otimes> \<Psi>' \<rhd> P \<oplus> \<tau>.(P) \<Longrightarrow>\<^sup>^\<^sub>\<tau> P \<oplus> \<tau>.(P)" by auto
  moreover have "(\<Psi> \<otimes> \<Psi>', \<tau>.(P), P \<oplus> \<tau>.(P)) \<in> Rel" by(rule C1)
  ultimately show ?case by blast
qed

lemma tauLaw4StatImpLeft:
  fixes \<Psi> :: 'b
  and   P :: "('a, 'b, 'c) psi"
  and   Q :: "('a, 'b, 'c) psi"
  and   M :: 'a
  and   N :: 'a

  assumes C1: "\<And>\<Psi>'. (\<Psi> \<otimes> \<Psi>', \<alpha>\<cdot>P \<oplus> \<alpha>\<cdot>(\<tau>.(P) \<oplus> Q), \<alpha>\<cdot>(\<tau>.(P) \<oplus> Q)) \<in> Rel"

  shows "\<Psi> \<rhd> \<alpha>\<cdot>P \<oplus> \<alpha>\<cdot>(\<tau>.(P) \<oplus> Q) \<lessapprox><Rel> \<alpha>\<cdot>(\<tau>.(P) \<oplus> Q)"
proof(induct rule: weakStatImpI)
  case(cStatImp \<Psi>')
  have "\<Psi> \<rhd> \<alpha>\<cdot>(\<tau>.(P) \<oplus> Q) \<Longrightarrow>\<^sup>^\<^sub>\<tau> \<alpha>\<cdot>(\<tau>.(P) \<oplus> Q)" by auto
  hence "insertAssertion (extractFrame(\<alpha>\<cdot>P \<oplus> \<alpha>\<cdot>(\<tau>.(P) \<oplus> Q))) \<Psi> \<hookrightarrow>\<^sub>F insertAssertion (extractFrame(\<alpha>\<cdot>(\<tau>.(P) \<oplus> Q))) \<Psi>"
    using insertTauAssertion Identity
    by(nominal_induct \<alpha> rule: prefix.strong_inducts, auto)
  (rule FrameStatImpTrans[where G="\<langle>\<epsilon>, \<Psi>\<rangle>"], auto simp add: FrameStatEq_def AssertionStatEq_def)
  moreover have "\<Psi> \<otimes> \<Psi>' \<rhd> \<alpha>\<cdot>(\<tau>.(P) \<oplus> Q) \<Longrightarrow>\<^sup>^\<^sub>\<tau> \<alpha>\<cdot>(\<tau>.(P) \<oplus> Q)" by auto
  moreover have "(\<Psi> \<otimes> \<Psi>', \<alpha>\<cdot>P \<oplus> \<alpha>\<cdot>(\<tau>.(P) \<oplus> Q), \<alpha>\<cdot>(\<tau>.(P) \<oplus> Q)) \<in> Rel" by(rule C1)
  ultimately show ?case by blast
qed

lemma tauLaw4StatImpRight:
  fixes \<Psi> :: 'b
  and   P :: "('a, 'b, 'c) psi"
  and   Q :: "('a, 'b, 'c) psi"
  and   \<alpha> :: "'a prefix"

  assumes C1: "\<And>\<Psi>'. (\<Psi> \<otimes> \<Psi>', \<alpha>\<cdot>(\<tau>.(P) \<oplus> Q), \<alpha>\<cdot>P \<oplus> \<alpha>\<cdot>(\<tau>.(P) \<oplus> Q)) \<in> Rel"

  shows "\<Psi> \<rhd> \<alpha>\<cdot>(\<tau>.(P) \<oplus> Q) \<lessapprox><Rel> \<alpha>\<cdot>P \<oplus> \<alpha>\<cdot>(\<tau>.(P) \<oplus> Q)"
proof(induct rule: weakStatImpI)
  case(cStatImp \<Psi>')
  have "\<Psi> \<rhd> \<alpha>\<cdot>P \<oplus> \<alpha>\<cdot>(\<tau>.(P) \<oplus> Q) \<Longrightarrow>\<^sup>^\<^sub>\<tau> \<alpha>\<cdot>P \<oplus> \<alpha>\<cdot>(\<tau>.(P) \<oplus> Q)" by auto
  hence "insertAssertion (extractFrame(\<alpha>\<cdot>(\<tau>.(P) \<oplus> Q))) \<Psi> \<hookrightarrow>\<^sub>F insertAssertion (extractFrame(\<alpha>\<cdot>P \<oplus> \<alpha>\<cdot>(\<tau>.(P) \<oplus> Q))) \<Psi>"
    using insertTauAssertion Identity
    by(nominal_induct \<alpha> rule: prefix.strong_inducts, auto)
  (rule FrameStatImpTrans[where G="\<langle>\<epsilon>, \<Psi>\<rangle>"], auto simp add: FrameStatEq_def AssertionStatEq_def)
  moreover have "\<Psi> \<otimes> \<Psi>' \<rhd> \<alpha>\<cdot>P \<oplus> \<alpha>\<cdot>(\<tau>.(P) \<oplus> Q) \<Longrightarrow>\<^sup>^\<^sub>\<tau> \<alpha>\<cdot>P \<oplus> \<alpha>\<cdot>(\<tau>.(P) \<oplus> Q)" by auto
  moreover have "(\<Psi> \<otimes> \<Psi>', \<alpha>\<cdot>(\<tau>.(P) \<oplus> Q), \<alpha>\<cdot>P \<oplus> \<alpha>\<cdot>(\<tau>.(P) \<oplus> Q)) \<in> Rel" by(rule C1)
  ultimately show ?case by blast
qed

end

end


           (*-------------------------------------------*
            |                DFP package                |
            |                    May 2005               |
            |               December 2005  (modified)   |
            |                                           |
            |   DFP on CSP-Prover ver.3.0               |
            |              September 2006  (modified)   |
            |                  April 2007  (modified)   |
            |                                           |
            |        CSP-Prover on Isabelle2016         |
            |                    May 2016  (modified)   |
            |                                           |
            |        CSP-Prover on Isabelle2017         |
            |                  April 2018  (modified)   |
            |                                           |
            |        Yoshinao Isobe (AIST JAPAN)        |
            *-------------------------------------------*)

theory DFP_Block
imports DFP_Deadlock
begin

(*  The following simplification rules are deleted in this theory file *)
(*  because they unexpectly rewrite UnionT and InterT.                 *)
(*                  Union (B ` A) = (UN x:A. B x)                      *)
(*                  Inter (B ` A) = (INT x:A. B x)                     *)
(*
declare Union_image_eq [simp del]
declare Inter_image_eq [simp del]
*)

(* no simp rules in Isabelle 2017
declare Sup_image_eq [simp del]
declare Inf_image_eq [simp del]
*)

(*  The following simplification rules are deleted in this theory file *)
(*  because they unexpectly rewrite (notick | t = []t)                 *)
(*                                                                     *)
(*                  disj_not1: (~ P | Q) = (P --> Q)                   *)

declare disj_not1 [simp del]

(*****************************************************************

         1.
         2.
         3.
         4.

 *****************************************************************)

(*********************************************************
                    definitions
 *********************************************************)

definition
  triple_disjoint :: "('i,'a) NetworkF => bool"
  where
  triple_disjoint_def :
    "triple_disjoint VF ==
       (ALL i: fst VF. ALL j: fst VF. ALL k: fst VF. i ~= j & j ~= k & k ~= i
          --> (snd ((snd VF) i) Int snd ((snd VF) j) Int snd ((snd VF) k) = {}))"

definition
  VocabularyOf :: "('i,'a) NetworkF => 'a set"
  where
  VocabularyOf_def :
    "VocabularyOf VF ==
     Union {X. EX i: fst VF. EX j: fst VF. i ~= j &
               X = snd((snd VF) i) Int snd((snd VF) j)}"
    (* internal communication *)

definition
  BusyNetworkP :: "('i,'p,'a) Network => bool"
  where
  BusyNetworkP_def :
    "BusyNetworkP V ==
     ALL i: fst V. DeadlockFreeNetwork ({i}, snd V)"

definition
  BusyNetwork  :: "('i,'a) NetworkF => bool"
  where
  BusyNetwork_def :
    "BusyNetwork VF ==
     ALL i: fst VF. (ALL sigma. ~(sigma isDeadlockStateOf ({i}, snd VF)))"

definition
  isRequestOf :: "('i,'a) NetworkF => 'i => ('i,'a) net_state => 'i => bool"
     ("(1_ >> /(0_ (1/--[_]-->) /_))" [800, 800,100,800] 900)
  where
  isRequestOf_def :
    "VF >> i --[sigma]--> j ==
        sigma isStateOf VF &
        i ~= j & i : fst VF & j : fst VF &
        (Ev ` (snd (snd VF i)) - (snd sigma) i) Int
         Ev ` (snd (snd VF j)) ~= {}"

definition
  isStrongRequestOf :: "('i,'a) NetworkF => 'i => ('i,'a) net_state => 'i => bool"
     ("(1_ >> /(0_ (1/==[_]==>) /_))" [800, 800,100,800] 900)
  where
  isStrongRequestOf_def :
    "VF >> i ==[sigma]==> j ==
        sigma isStateOf VF &
        i ~= j & i : fst VF & j : fst VF &
        Ev ` (snd (snd VF i)) - (snd sigma) i ~= {} &
        Ev ` (snd (snd VF i)) - (snd sigma) i <= Ev ` (snd (snd VF j))"

definition
  isUngrantedRequestOf ::
      "('i,'a) NetworkF => 'i => ('i,'a) net_state => 'i => bool"
      ("(1_ >> /(0_ (1/--[_]-->o) /_))" [800, 800,0,800] 900)
  where
  isUngrantedRequestOf_def :
    "VF >> i --[sigma]-->o j == VF >> i --[sigma]--> j &
        Ev ` (snd (snd VF i)) Int Ev ` (snd (snd VF j))
        <= (snd sigma) i Un (snd sigma) j"

definition
  isUngrantedStrongRequestOf ::
      "('i,'a) NetworkF => 'i => ('i,'a) net_state => 'i => bool"
      ("(1_ >> /(0_ (1/==[_]==>o) /_))" [800, 800,0,800] 900)
  where
  isUngrantedStrongRequestOf_def :
    "VF >> i ==[sigma]==>o j == VF >> i ==[sigma]==> j &
        Ev ` (snd (snd VF i)) Int Ev ` (snd (snd VF j))
        <= (snd sigma) i Un (snd sigma) j"

definition
  isUngrantedRequestOfwrt ::
      "('i,'a) NetworkF => 'i => ('i,'a) net_state => 'a set => 'i => bool"
      ("(1_ >> /(0_ (1/--[(0_,/_)]-->o) /_))" [800, 800,0,0,800] 900)
  where
  isUngrantedRequestOfwrt_def :
    "VF >> i --[sigma,Lambda]-->o j == VF >> i --[sigma]-->o j &
        ((Ev ` (snd (snd VF i))) - (snd sigma) i) Un
        ((Ev ` (snd (snd VF j))) - (snd sigma) j) <= Ev ` Lambda"

(*** Block ***)

definition
  isBlockedIn ::
      "('i,'a) NetworkF => 'i => ('i,'a) net_state => bool"
      ("(_ >> _ isBlockedIn _)" [800, 800, 800] 900)
  where
  isBlockedIn_def :
    "VF >> i isBlockedIn sigma ==
          triple_disjoint VF &
          (EX j. VF >> i --[sigma]--> j) &
          (ALL j. VF >> i --[sigma]--> j
          --> (VF >> i --[sigma, (VocabularyOf VF)]-->o j))"

(*********************************************************
                  BusyNetwork lemmas
 *********************************************************)

lemma BusyNetwork_BusyNetworkP :
    "[| I ~= {} ; finite I ; (I,FXf) isFailureOf (I,PXf) |]
     ==> BusyNetwork (I,FXf) = BusyNetworkP (I,PXf)"
apply (simp add: BusyNetwork_def)
apply (simp add: BusyNetworkP_def)
apply (rule)

 apply (rule ballI)
 apply (drule_tac x="i" in bspec, simp)
 apply (subgoal_tac "({i}, FXf) isFailureOf ({i}, PXf)")
 apply (simp add: DeadlockFree_notDeadlockState)
 apply (rule isFailureOf_subset_index)
 apply (simp)
 apply (simp)

 apply (rule ballI)
 apply (drule_tac x="i" in bspec, simp)
 apply (subgoal_tac "({i}, FXf) isFailureOf ({i}, PXf)")
 apply (simp add: DeadlockFree_notDeadlockState)
 apply (rule isFailureOf_subset_index)
 apply (simp)
 apply (simp)
done

(*-----------------------------------*
 |     How to check BusyNetworkF     |
 *-----------------------------------*)

lemma check_BusyNetwork:
   "[| ALL i:I. ALL s Y. (s, Y) : fst (FXf i) --> Y ~= Ev ` (snd (FXf i)) |]
    ==> BusyNetwork (I,FXf)"
apply (simp add: BusyNetwork_def)
apply (intro allI ballI)
apply (rename_tac s Yf)
apply (drule_tac x="i" in bspec, simp)

apply (simp add: isDeadlockStateOf_def)
apply (simp add: disj_not1)
apply (intro impI)
apply (simp add: isStateOf_def)
apply (drule_tac x="s rest-tr (snd (FXf i))" in spec)
apply (drule_tac x="Yf i" in spec)
apply (simp)
apply (simp add: ALP_def)
done

(*********************************************************
                     in index I
 *********************************************************)

lemma in_index_I1:
  "(I, FXf) >> i --[sigma]--> j ==> i : I & j : I & i ~= j"
by (simp add: isRequestOf_def)

lemma in_index_I2:
  "(I, FXf) >> i ==[sigma]==> j ==> i : I & j : I & i ~= j"
by (simp add: isStrongRequestOf_def)

lemma in_index_I3:
  "(I, FXf) >> i --[sigma]-->o j ==> i : I & j : I & i ~= j"
apply (simp add: isUngrantedRequestOf_def)
apply (elim conjE)
by (simp add: in_index_I1)

lemma in_index_I4:
  "(I, FXf) >> i ==[sigma]==>o j ==> i : I & j : I & i ~= j"
apply (simp add: isUngrantedStrongRequestOf_def)
apply (elim conjE)
by (simp add: in_index_I2)

lemma in_index_I5:
  "(I, FXf) >> i --[sigma,Lambda]-->o j ==> i : I & j : I & i ~= j"
apply (simp add: isUngrantedRequestOfwrt_def)
apply (elim conjE)
by (simp add: in_index_I3)

lemmas in_index_I = in_index_I1 in_index_I2 in_index_I3 in_index_I4 in_index_I5

(*********************************************************
                       note (P.7)
 *********************************************************)

lemma isUngrantedRequestOfwrt_note1:
  "[| Lambda1 <= Lambda2 ; VF >> i --[sigma,Lambda1]-->o j |]
   ==> VF >> i --[sigma,Lambda2]-->o j"
apply (simp add: isUngrantedRequestOfwrt_def)
by (blast)

lemma isUngrantedRequestOfwrt_note2:
  "(snd (snd VF i)) Un (snd (snd VF j)) <= Lambda
   ==> (VF >> i --[sigma,Lambda]-->o j) = (VF >> i --[sigma]-->o j)"
by (auto simp add: isUngrantedRequestOfwrt_def)

(*********************************************************
                     sub request
 *********************************************************)

lemma isRequestOf_subsetI:
  "[| (I, FXf) >> i --[(t,Yf)]--> j; J <= I; i:J ; j:J ;
      X = Union {snd (FXf i)|i. i:J} |]
   ==> (J, FXf) >> i --[(t rest-tr X,Yf)]--> j"
apply (simp add: isRequestOf_def)
apply (rule isStateOf_subsetI)
apply (simp_all)
done

lemma isStrongRequestOf_subsetI:
  "[| (I, FXf) >> i ==[(t,Yf)]==> j; J <= I; i:J ; j:J ;
      X = Union {snd (FXf i)|i. i:J} |]
   ==> (J, FXf) >> i ==[(t rest-tr X,Yf)]==> j"
apply (simp add: isStrongRequestOf_def)
apply (rule isStateOf_subsetI)
apply (simp_all)
done

lemma isUngrantedRequestOf_subsetI:
  "[| (I, FXf) >> i --[(t,Yf)]-->o j; J <= I; i:J ; j:J ;
      X = Union {snd (FXf i)|i. i:J} |]
   ==> (J, FXf) >> i --[(t rest-tr X,Yf)]-->o j"
apply (simp add: isUngrantedRequestOf_def)
apply (rule isRequestOf_subsetI)
apply (simp_all)
done

lemma isUngrantedStrongRequestOf_subsetI:
  "[| (I, FXf) >> i ==[(t,Yf)]==>o j; J <= I; i:J ; j:J ;
      X = Union {snd (FXf i)|i. i:J} |]
   ==> (J, FXf) >> i ==[(t rest-tr X,Yf)]==>o j"
apply (simp add: isUngrantedStrongRequestOf_def)
apply (rule isStrongRequestOf_subsetI)
apply (simp_all)
done

lemma isUngrantedRequestOfwrt_subsetI:
  "[| (I, FXf) >> i --[(t,Yf), Lambda1]-->o j; J <= I; i:J ; j:J ;
      Lambda1 <= Lambda2 ; X = Union {snd (FXf i)|i. i:J} |]
   ==> (J, FXf) >> i --[(t rest-tr X,Yf), Lambda2]-->o j"
apply (simp add: isUngrantedRequestOfwrt_def)
apply (rule conjI)
apply (rule isUngrantedRequestOf_subsetI)
apply (simp_all)
apply (blast)
done

(*********************************************************
                      blocked
 *********************************************************)

(*---------------------------------*
 | lemma 1 [Roscoe_Dathi_1987 P.7] |
 *---------------------------------*)

(*** only if ***)

lemma Lemma1_Roscoe_Dathi_1987_only_if:
  "[| triple_disjoint (I,FXf) ; BusyNetwork (I,FXf) ;
      (t,Yf) isDeadlockStateOf (I,FXf) |]
   ==> ALL i:I. (I,FXf) >> i isBlockedIn (t,Yf)"
apply (intro ballI)
apply (subgoal_tac "ALL i:I. Yf i <= (Ev ` (snd (FXf i)))")
 apply (simp only: isBlockedIn_def)
  apply (rule conjI)
  apply (simp)
  apply (rule conjI)

 (* 1 *)

 (* busy --> i is deadlock-free *)
  apply (simp add: isRequestOf_def)
  apply (simp add: BusyNetwork_def)
  apply (drule_tac x="i" in bspec, simp)

  (* i is deadlock-free --> EX j *)
  apply (rule conjI)
  apply (simp add: isDeadlockStateOf_def)

  apply (simp add: isDeadlockStateOf_def)
  apply (simp add: disj_not1)
  apply (elim conjE)
  apply (drule_tac x="t rest-tr (snd (FXf i))" in spec)
  apply (drule_tac x="Yf" in spec)
  apply (simp add: isStateOf_each_element)
  apply (simp add: ALP_def)

  apply (subgoal_tac "EX a: Ev ` snd (FXf i). a ~: Yf i")
                                                  (* ... sub 1 *)
   apply (elim bexE)
   apply (subgoal_tac "a : Ev ` {a. EX i:I. a : snd (FXf i)}")
                                                  (* ... sub 2 *)
    apply (rotate_tac 4)
    apply (drule sym)
    apply (simp)
    apply (elim conjE exE)
    apply (simp)
    apply (rule_tac x="ia" in exI)
    apply (case_tac "i = ia", simp)
    apply (simp)
    apply (drule_tac x="ia" in bspec, simp)
    apply (blast)
   (* sub 2 *)
   apply (blast)
  (* sub 1 *)
  apply (blast)

(* 2 *)
 apply (intro allI impI)
 apply (unfold isUngrantedRequestOfwrt_def)
 apply (rule conjI)

 (* 2-1 *)
  apply (simp add: isUngrantedRequestOf_def)
  apply (rule)

  apply (subgoal_tac "x : Union {Yf i |i. i : I}")
   apply (simp)
   apply (elim conjE bexE exE)
   apply (case_tac "ia = i", simp)
   apply (case_tac "ia = j", simp)
   (* ia ~= i & ia ~= j ==> contradict with triple_dijoint *)
   apply (drule_tac x="ia" in bspec, simp)
   apply (simp add: isDeadlockStateOf_def isStateOf_def)
   apply (simp add: triple_disjoint_def)
   apply (drule_tac x="i" in bspec, simp)
   apply (drule_tac x="j" in bspec, simp add: isRequestOf_def)
   apply (drule_tac x="ia" in bspec, simp)
    apply (drule mp)
    apply (simp add: isRequestOf_def)
   apply (rotate_tac -1)
   apply (erule contrapos_pp)
   apply (blast)

  apply (simp add: isDeadlockStateOf_def)
  apply (simp add: ALP_def)
  apply (simp add: image_iff)
  apply (elim conjE bexE, simp)
  apply (rule_tac x="i" in bexI)
  apply (simp)
  apply (simp)

 (* 2-2 *)
  apply (rule)
  apply (simp add: VocabularyOf_def)
  apply (subgoal_tac "x : Union {Yf i |i. i : I}")

   apply (simp)
   apply (elim conjE bexE exE)
   apply (simp add: image_iff)
   apply (elim disjE conjE bexE)

    apply (case_tac "i = ia", simp)
    apply (drule_tac x="ia" in bspec, simp)
    apply (simp add: isDeadlockStateOf_def isStateOf_def)
    apply (rule_tac x="snd (FXf i) Int snd (FXf ia)" in exI)
    apply (rule conjI)
     apply (rule_tac x="i" in bexI)
     apply (rule_tac x="ia" in bexI)
     apply (simp)
     apply (simp)
     apply (simp)
     apply (blast)

    apply (case_tac "j = ia", simp)
    apply (drule_tac x="ia" in bspec, simp)
    apply (simp add: isDeadlockStateOf_def isStateOf_def)
    apply (rule_tac x="snd (FXf j) Int snd (FXf ia)" in exI)
    apply (rule conjI)
     apply (rule_tac x="j" in bexI)
     apply (rule_tac x="ia" in bexI)
     apply (simp)
     apply (simp)
     apply (simp add: isRequestOf_def)
     apply (blast)

  apply (simp add: isDeadlockStateOf_def)
  apply (simp add: ALP_def)
  apply (simp add: image_iff)
  apply (elim disjE conjE bexE)

   apply (rule_tac x="xa" in exI)
   apply (simp)
   apply (fast)

   apply (rule_tac x="xa" in exI)
   apply (simp)
   apply (rule_tac x="j" in bexI)
   apply (simp)
   apply (simp add: isRequestOf_def)

apply (simp add: isDeadlockStateOf_def)
apply (simp add: isStateOf_def)
done

(*** if ***)

lemma Lemma1_Roscoe_Dathi_1987_if:
  "[| triple_disjoint (I,FXf) ; BusyNetwork (I,FXf) ;
      (t,Yf) isStateOf (I,FXf) ;
      ALL i:I. (I,FXf) >> i isBlockedIn (t,Yf) |]
   ==> (t,Yf) isDeadlockStateOf (I,FXf)"
apply (simp add: isDeadlockStateOf_def)
apply (simp add: ALP_def)
apply (rule)

 (* <= *)
 apply (rule)
 apply (simp)
 apply (elim exE conjE)
 apply (simp)
 apply (drule_tac x="i" in bspec, simp)
 apply (simp add: isStateOf_def)
 apply (elim conjE)
 apply (drule_tac x="i" in bspec, simp)
 apply (simp add: ALP_def)
 apply (force)

 (* => *)
 apply (rule)
 apply (simp)
 apply (simp only: isBlockedIn_def)
 apply (simp add: image_iff)
 apply (elim conjE exE bexE)
 apply (simp)

 apply (case_tac "Ev xa : Yf i")
  apply (rule_tac x="Yf i" in exI)
  apply (fast)

 (* Ev xa ~: Yf i *)
  apply (subgoal_tac "xa : VocabularyOf (I,FXf)")
   apply (simp add: VocabularyOf_def)
   apply (elim conjE exE bexE)
   apply (simp)

   apply (case_tac "ia = i")
    apply (simp)
    apply (drule_tac x="i" in bspec, simp)
    apply (elim conjE exE)

    apply (drule_tac x="j" in spec)
    apply (drule mp)
    apply (simp add: isRequestOf_def)
    apply (blast)

    apply (simp add: isUngrantedRequestOfwrt_def)
    apply (simp add: isUngrantedRequestOf_def)
    apply (rule_tac x="Yf j" in exI)
    apply (fast)

   apply (case_tac "j = i")
    apply (simp)
    apply (drule_tac x="i" in bspec, simp)
    apply (elim conjE exE)
     apply (drule_tac x="ia" in spec)
     apply (drule mp)
     apply (simp add: isRequestOf_def)
     apply (blast)

     apply (simp add: isUngrantedRequestOfwrt_def)
     apply (simp add: isUngrantedRequestOf_def)
     apply (rule_tac x="Yf ia" in exI)
     apply (fast)

   (* ia ~= i; j ~= i; ia ~= j, but xa : snd (PXf i), ... *)
   apply (simp add: triple_disjoint_def)
   apply (drule_tac x="i" in bspec, simp)
   apply (rotate_tac -1)
   apply (drule_tac x="ia" in bspec, simp)
   apply (rotate_tac -1)
   apply (drule_tac x="j" in bspec, simp)
   apply (fast)

  (* xa : VocabularyOf VF *)
   apply (drule_tac x="i" in bspec, simp)
   apply (elim exE conjE)
   apply (drule_tac x="xb" in spec)
   apply (simp add: isUngrantedRequestOfwrt_def)
   apply (fast)
done

lemma Lemma1_Roscoe_Dathi_1987:
  "[| triple_disjoint (I,FXf) ; BusyNetwork (I,FXf) ;
      (t,Yf) isStateOf (I,FXf) |]
   ==> (t,Yf) isDeadlockStateOf (I,FXf)
       = (ALL i:I. (I,FXf) >> i isBlockedIn (t,Yf))"
apply (rule)
apply (simp add: Lemma1_Roscoe_Dathi_1987_only_if)
apply (simp add: Lemma1_Roscoe_Dathi_1987_if)
done

(****************** to add it again ******************)

declare disj_not1   [simp]
(*
declare Union_image_eq [simp]
declare Inter_image_eq [simp]
*)
(*
declare Sup_image_eq [simp]
declare Inf_image_eq [simp]
*)
end


section \<open> Modelica Core \<close>

theory Modelica_Core
imports "UTP1-Hybrid.utp_hrd"
begin

named_theorems mo_defs

alphabet 'l mst =
  mtime   :: real
  mintern :: "'l" \<comment> \<open> Internal continuous variables \<close>

setup_lifting type_definition_mst_ext

text \<open> Syntax for internal variables \<close>

notation mintern ("\<^bold>i")

syntax
  "_svid_mintern"  :: "svid" ("\<^bold>i")

translations
  "_svid_mintern" => "CONST mintern"

instantiation mst_ext :: (t2_space,t2_space) t2_space
begin
  lift_definition open_mst_ext :: "('a, 'b) mst_scheme set \<Rightarrow> bool" is "open" .
  instance by (intro_classes, (transfer, auto simp add: separation_t2)+)
end

definition map_mst ::
  "('\<sigma> \<Rightarrow> '\<tau>) \<Rightarrow>
   ('\<sigma>, 'c) mst_scheme \<Rightarrow> ('\<tau>, 'c) mst_scheme" where
[lens_defs]: "map_mst f = (\<lambda>r. \<lparr>mtime\<^sub>v = mtime\<^sub>v r, mintern\<^sub>v = f (mintern\<^sub>v r), \<dots> = more r\<rparr>)"

definition map_mst_lens ::
  "('\<sigma> \<Longrightarrow> '\<tau>) \<Rightarrow>
   (('\<sigma>, 'b) mst_scheme, 't::trace, 'c) rsp \<Longrightarrow> (('\<tau>, 'b) mst_scheme, 't, 'c) rsp" ("map'_mst\<^sub>L") where
[lens_defs]:
"map_mst_lens l = map_st\<^sub>L \<lparr>
  lens_get = map_mst (get\<^bsub>l\<^esub>),
  lens_put = map_mst o (put\<^bsub>l\<^esub>) o mintern\<^sub>v\<rparr>"

lemma map_mst_vwb [simp]: "vwb_lens X \<Longrightarrow> vwb_lens (map_mst\<^sub>L X)"
  by (unfold_locales, simp_all add: lens_defs des_vars.defs rp_vars.defs rsp_vars.defs)

abbreviation "abs_mst\<^sub>L \<equiv> (map_mst\<^sub>L 0\<^sub>L) \<times>\<^sub>L (map_mst\<^sub>L 0\<^sub>L)"

type_synonym ('l, 'c) mrel = "(('l, 'c) mst_ext, ('l, 'c) mst_ext) hyrel"
type_synonym ('d, 'l, 'c) mpred = "('d, ('l, 'c) mst_ext) hybs upred"
type_synonym ('a, 'l, 'c) mexpr = "('a, ('l, 'c) mst_ext) uexpr"

translations
  (type) "('l,'c) mrel" <= (type) "(('l, 'c) mst_scheme, ('l', 'c') mst_scheme) hyrel"
  (type) "('d,'l,'c) mpred" <= (type) "('d, ('l, 'c) mst_scheme) hybs upred"
  (type) "('a,'l,'c) mexpr" <= (type) "('a, ('l, 'c) mst_scheme) uexpr"

text \<open> Preconditions are captured by negating the continuous divergences, that is the set of
  trajectories that eventually violate the precondition. Every divergence can be extended
  aribtrarily. The precondition effectively states that no trace must violate the precondition
  at the limit. \<close>

definition ModelicaPre ("\<lceil>_\<rceil>\<^sub>M") where
[upred_defs]: "\<lceil>P\<rceil>\<^sub>M = (\<not>\<^sub>r (\<lceil>\<not> P\<rceil>\<^sup>\<rightarrow> ;; true\<^sub>r))"

lemma true_ModelicaPre [rpred]: "\<lceil>true\<rceil>\<^sub>M = true\<^sub>r"
  by (rel_auto)

lemma ModelicaPre_RC [closure]: "\<lceil>P\<rceil>\<^sub>M is RC"
  apply (rel_auto)
  apply (meson less_iff minus_gr_zero_iff order_refl)
  apply (metis (no_types, lifting) diff_add_cancel_left' minus_gr_zero_iff order.trans trace_class.add_diff_cancel_left trace_class.add_left_mono)
done

definition ModelicaBlock ("[_ | _]\<^sub>M") where
"[P | Q]\<^sub>M = \<^bold>R\<^sub>s(\<lceil>P\<rceil>\<^sub>M \<turnstile> Q \<diamondop> false)"

lemma preR_simple_block [rdes]: "pre\<^sub>R([P\<^sub>1 | \<lceil>Q\<^sub>1\<rceil>\<^sub>h]\<^sub>M) = \<lceil>P\<^sub>1\<rceil>\<^sub>M"
  by (simp add: ModelicaBlock_def preR_srdes closure)

lemma periR_simple_block [rdes]: "peri\<^sub>R([P\<^sub>1 | \<lceil>Q\<^sub>1\<rceil>\<^sub>h]\<^sub>M) = (\<lceil>P\<^sub>1\<rceil>\<^sub>M \<Rightarrow>\<^sub>r \<lceil>Q\<^sub>1\<rceil>\<^sub>h)"
  by (simp add: ModelicaBlock_def rdes closure)

lemma postR_simple_block [rdes]: "post\<^sub>R([P | \<lceil>Q\<rceil>\<^sub>h]\<^sub>M) = (\<not>\<^sub>r \<lceil>P\<rceil>\<^sub>M)"
  by (simp add: ModelicaBlock_def rdes closure)

lemma NSRD_simple_block [closure]: "[P\<^sub>1 | \<lceil>Q\<^sub>1\<rceil>\<^sub>h]\<^sub>M is NSRD"
  apply (rule NSRD_intro)
  apply (simp add: ModelicaBlock_def)
  apply (rule RHS_tri_design_is_SRD)
  apply (simp_all add: unrest rdes closure RC1_prop RC_implies_RC1)
done

end


           (*-------------------------------------------------*
            |                 (a part of) ep2                 |
            |                  September 2004                 |
            |                   December 2004 (modified)      |
            |                   November 2005 (modified)      |
            |                      April 2006 (modified)      |
            |                      March 2007  (modified)     |
            |                                                 |
            |        CSP-Prover on Isabelle2009               |
            |                       June 2009  (modified)     |
            |                                                 |
            |        CSP-Prover on Isabelle2016               |
            |                        May 2016  (modified)     |
            |                                                 |
            |  Markus Roggenbach (Univ of Wales Swansea, UK)  |
            |  Yoshinao Isobe    (AIST, Japan)                |
            *-------------------------------------------------*)

theory ep2_nucleus
imports CSP_F
begin

(*** To automatically unfold syntactic sugar ***)

declare csp_prefix_ss_def [simp]
declare inj_on_def        [simp]

(*********************************************************
              data type passed on channels
 *********************************************************)

typedecl init_d typedecl request_d typedecl response_d typedecl exit_d

datatype Data = Init    init_d    | Exit     exit_d
              | Request request_d | Response response_d

(*********************************************************
                     event (channel)
 *********************************************************)

datatype Event = c Data

(*********************************************************
         abstract component description level
 *********************************************************)

datatype ACName = Acquirer | AcConfigManagement
                | Terminal | TerminalConfigManagement

primrec
  ACfun :: "ACName => (ACName, Event) proc"
where
  "ACfun Acquirer
         = c ? x:(range Init) -> $AcConfigManagement"

 |"ACfun AcConfigManagement
         = c !? exit:(range Exit) -> SKIP
           |~|
           c !? request:(range Request)
             -> c ? response:(range Response)
             -> $AcConfigManagement"

 |"ACfun Terminal
         = c !? init:(range Init) -> $TerminalConfigManagement"

 |"ACfun TerminalConfigManagement
         = c ? x -> IF (x:range Request)
                    THEN (c !? response:(range Response)
                          -> $TerminalConfigManagement)
                    ELSE IF (x:range Exit)
                         THEN SKIP
                         ELSE STOP"
(*
defs (overloaded)
Set_ACfun_def [simp]: "PNfun == ACfun"
*)

overloading Set_ACfun ==
  "PNfun :: (ACName, Event) pnfun"
begin
  definition "PNfun == ACfun"
end

declare Set_ACfun_def [simp]

definition
  AC :: "(ACName, Event) proc"
  where
  AC_def: "AC == ($Acquirer |[range c]| $Terminal)"

(*---------------------------------------------------------------*
 |                          NOTE                                 |
 |                                                               |
 | c ! v -> P       : sends a value v to c, then behaves like P. |
 |                                                               |
 | c ? x:X -> P(x)  : receives a value v from c if c in X,       |
 |                    then behaves like P(v).                    |
 |                                                               |
 | c !? x:X -> P(x) : sends a value v selected from X to c,      |
 |                    then behaves like P(v).                    |
 |                                                               |
 *---------------------------------------------------------------*)

(*********************************************************
              equivalent sequential behavior
 *********************************************************)

datatype SeqName = SeqInit | Loop

primrec
  Seqfun :: "SeqName => (SeqName, Event) proc"
where
  "Seqfun SeqInit
          = c !? init:(range Init) -> $Loop"

 |"Seqfun Loop
          = c !? exit:(range Exit) -> SKIP
            |~|
            c !? request:(range Request)
              -> c !? response:(range Response)
              -> $Loop"
(*
defs (overloaded)
Set_Seqfun_def [simp]: "PNfun == Seqfun"
*)

overloading Set_Seqfun ==
  "PNfun :: (SeqName, Event) pnfun"
begin
  definition "PNfun == Seqfun"
end

declare Set_Seqfun_def [simp]

definition
  Seq :: "(SeqName, Event) proc"
  where
  Seq_def: "Seq == $SeqInit"

(*********************************************************
        relating function between ACName and SeqName
 *********************************************************)

primrec
  Seq_to_AC :: "SeqName => (ACName, Event) proc"
where
  "Seq_to_AC (SeqInit)
          = ($Acquirer |[range c]| $Terminal)"

 |"Seq_to_AC (Loop)
          = ($AcConfigManagement |[range c]| $TerminalConfigManagement)"

(*********************************************************
               gProc lemmas (routine work)
 *********************************************************)

lemma guardedfun_AC_Seq[simp]:
      "guardedfun ACfun"
      "guardedfun Seqfun"
by (simp add: guardedfun_def, rule allI, induct_tac p, simp_all)+

(*********************************************************
           a theorem for verifying Seq <=F AC
 *********************************************************)
(*
defs FPmode_def [simp]: "FPmode == CMSmode"
*)

overloading FPmode ==
  "FPmode :: fpmode"
begin
  definition "FPmode == CMSmode"
end

declare FPmode_def [simp]

theorem ep2: "Seq =F AC"
apply (unfold Seq_def AC_def)
apply (rule cspF_fp_induct_left[of _ "Seq_to_AC"])
apply (simp_all)
apply (simp)
apply (induct_tac p)
apply (simp_all)

(* 1st subgoal *)
apply (cspF_unwind)
apply (cspF_hsf)+
apply (rule cspF_decompo, auto)
apply (cspF_hsf)+
apply (rule cspF_decompo, auto)
apply (cspF_hsf)+

(* 2nd subgoal *)
apply (cspF_auto | rule cspF_decompo | rule cspF_decompo_ref |
       auto simp add: image_iff)+
done

end


(*  Title:      JinjaDCI/BV/TF_JVM.thy

    Author:     Tobias Nipkow, Gerwin Klein, Susannah Mansky
    Copyright   2000 TUM, 2019-20 UIUC

    Based on the Jinja theory BV/TF_JVM.thy by Tobias Nipkow and Gerwin Klein
*)

section \<open> The Typing Framework for the JVM \label{sec:JVM} \<close>

theory TF_JVM
imports Jinja.Typing_Framework_err EffectMono BVSpec
begin

definition exec :: "jvm_prog \<Rightarrow> nat \<Rightarrow> ty \<Rightarrow> ex_table \<Rightarrow> instr list \<Rightarrow> ty\<^sub>i' err step_type"
where
  "exec G maxs rT et bs \<equiv>
  err_step (size bs) (\<lambda>pc. app (bs!pc) G maxs rT pc (size bs) et)
                     (\<lambda>pc. eff (bs!pc) G pc et)"

locale JVM_sl =
  fixes P :: jvm_prog and mxs and mxl\<^sub>0 and n
  fixes b and Ts :: "ty list" and "is" and xt and T\<^sub>r

  fixes mxl and A and r and f and app and eff and step
  defines [simp]: "mxl \<equiv> (case b of Static \<Rightarrow> 0 | NonStatic \<Rightarrow> 1)+size Ts+mxl\<^sub>0"
  defines [simp]: "A   \<equiv> states P mxs mxl"
  defines [simp]: "r   \<equiv> JVM_SemiType.le P mxs mxl"
  defines [simp]: "f   \<equiv> JVM_SemiType.sup P mxs mxl"

  defines [simp]: "app \<equiv> \<lambda>pc. Effect.app (is!pc) P mxs T\<^sub>r pc (size is) xt"
  defines [simp]: "eff \<equiv> \<lambda>pc. Effect.eff (is!pc) P pc xt"
  defines [simp]: "step \<equiv> err_step (size is) app eff"

  defines [simp]: "n \<equiv> size is"
  assumes staticb: "b = Static \<or> b = NonStatic"

locale start_context = JVM_sl +
  fixes p and C

  assumes wf: "wf_prog p P"
  assumes C:  "is_class P C"
  assumes Ts: "set Ts \<subseteq> types P"

  fixes first :: ty\<^sub>i' and start
  defines [simp]:
  "first \<equiv> Some ([],(case b of Static \<Rightarrow> [] | NonStatic \<Rightarrow> [OK (Class C)]) @ map OK Ts @ replicate mxl\<^sub>0 Err)"
  defines [simp]:
  "start \<equiv> (OK first) #  replicate (size is - 1) (OK None)"
thm start_context.intro

lemma start_context_intro_auxi:
  fixes  P b Ts p C
  assumes "b = Static \<or> b = NonStatic "
      and "wf_prog p P"
      and "is_class P C"
      and "set Ts \<subseteq> types P"
    shows " start_context P b Ts p C"
  using start_context.intro[OF JVM_sl.intro] start_context_axioms_def assms  by auto

subsection \<open> Connecting JVM and Framework \<close>

lemma (in start_context) semi: "semilat (A, r, f)"
  apply (insert semilat_JVM[OF wf])
  apply (unfold A_def r_def f_def JVM_SemiType.le_def JVM_SemiType.sup_def states_def)
  apply auto
  done

lemma (in JVM_sl) step_def_exec: "step \<equiv> exec P mxs T\<^sub>r xt is"
  by (simp add: exec_def)

lemma special_ex_swap_

lemma ex_in_list [iff]:
  "(\<exists>n. ST \<in> nlists n A \<and> n \<le> mxs) = (set ST \<subseteq> A \<and> size ST \<le> mxs)"
  by (unfold nlists_def) auto

lemma singleton_nlists:
  "(\<exists>n. [Class C] \<in> nlists n (types P) \<and> n \<le> mxs) = (is_class P C \<and> 0 < mxs)"
  by auto

lemma set_drop_subset:
  "set xs \<subseteq> A \<Longrightarrow> set (drop n xs) \<subseteq> A"
  by (auto dest: in_set_dropD)

lemma Suc_minus_minus_le:
  "n < mxs \<Longrightarrow> Suc (n - (n - b)) \<le> mxs"
  by arith

lemma in_nlistsE:
  "\<lbrakk> xs \<in> nlists n A; \<lbrakk>size xs = n; set xs \<subseteq> A\<rbrakk> \<Longrightarrow> P \<rbrakk> \<Longrightarrow> P"
  by (unfold nlists_def) blast

declare is_relevant_entry_def [simp]
declare set_drop_subset [simp]

theorem (in start_context) exec_pres_type:
  "pres_type step (size is) A"
(*<*)
proof -
  let ?n = "size is" and ?app = app and ?step = eff
  let ?mxl = "(case b of Static \<Rightarrow> 0 | NonStatic \<Rightarrow> 1) + length Ts + mxl\<^sub>0"
  let ?A = "opt((Union {nlists n (types P) |n. n <= mxs}) \<times>
                                 nlists ?mxl (err(types P)))"
  have "pres_type (err_step ?n ?app ?step) ?n (err ?A)"
  proof(rule pres_type_lift)
    have "\<And>s pc pc' s'. s\<in>?A \<Longrightarrow> pc < ?n \<Longrightarrow> ?app pc s
             \<Longrightarrow> (pc', s')\<in>set (?step pc s) \<Longrightarrow> s' \<in> ?A"
    proof -
      fix s pc pc' s'
      assume asms: "s\<in>?A" "pc < ?n" "?app pc s" "(pc', s')\<in>set (?step pc s)"
      show "s' \<in> ?A"
      proof(cases s)
        case None
        then show ?thesis using asms by (fastforce dest: effNone)
      next
        case (Some ab)
        then show ?thesis using asms proof(cases "is!pc")
          case Load
          then show ?thesis using asms
            by (fastforce simp: Effect.app_def xcpt_app_def Effect.eff_def
                                xcpt_eff_def norm_eff_def
                          dest: nlistsE_nth_in)
        next
          case Push
          then show ?thesis using asms Some
            by (fastforce simp: Effect.app_def xcpt_app_def Effect.eff_def
                                xcpt_eff_def norm_eff_def typeof_lit_is_type)
        next
          case Getfield
          then show ?thesis using asms wf
            by (fastforce simp: Effect.app_def xcpt_app_def Effect.eff_def
                                xcpt_eff_def norm_eff_def
                          dest: sees_field_is_type)
        next
          case Getstatic
          then show ?thesis using asms wf
            by (fastforce simp: Effect.app_def xcpt_app_def Effect.eff_def
                                xcpt_eff_def norm_eff_def
                          dest: sees_field_is_type)
        next
          case (Invoke M n)
          obtain a b where [simp]: "s = \<lfloor>(a,b)\<rfloor>" using Some asms(1) by blast
          show ?thesis
          proof(cases "a!n = NT")
            case True
            then show ?thesis using Invoke asms wf
              by (fastforce simp: Effect.app_def xcpt_app_def Effect.eff_def
                                  xcpt_eff_def norm_eff_def)
          next
            case False
            have "(pc', s') \<in> set (norm_eff (Invoke M n) P pc (a, b)) \<or>
              (pc', s') \<in> set (xcpt_eff (Invoke M n) P pc (a, b) xt)"
              using Invoke asms(4) by (simp add: Effect.eff_def)
            then show ?thesis proof(rule disjE)
              assume "(pc', s') \<in> set (xcpt_eff (Invoke M n) P pc (a, b) xt)"
              then show ?thesis using Invoke asms(1-3)
                by (fastforce simp: Effect.app_def xcpt_app_def xcpt_eff_def)
            next
              assume norm: "(pc', s') \<in> set (norm_eff (Invoke M n) P pc (a, b))"
              also have "Suc (length a - Suc n) \<le> mxs" using Invoke asms(1,3)
                by (simp add: Effect.app_def xcpt_app_def) arith
              ultimately show ?thesis using False Invoke asms(1-3) wf
                by (auto simp: Effect.app_def xcpt_app_def norm_eff_def wf_mdecl_def
                         dest!: sees_wf_mdecl)
            qed
          qed
        next
          case (Invokestatic C M n)
          obtain a b where [simp]: "s = \<lfloor>(a,b)\<rfloor>" using Some asms(1) by blast
          have "(pc', s') \<in> set (norm_eff (Invokestatic C M n) P pc (a, b)) \<or>
            (pc', s') \<in> set (xcpt_eff (Invokestatic C M n) P pc (a, b) xt)"
            using Invokestatic asms(4) by (simp add: Effect.eff_def)
          then show ?thesis proof(rule disjE)
            assume "(pc', s') \<in> set (xcpt_eff (Invokestatic C M n) P pc (a, b) xt)"
            then show ?thesis using Invokestatic asms(1-3)
              by (fastforce simp: Effect.app_def xcpt_app_def xcpt_eff_def)
          next
            assume norm: "(pc', s') \<in> set (norm_eff (Invokestatic C M n) P pc (a, b))"
            also have "Suc (length a - Suc n) \<le> mxs" using Invokestatic asms(1,3)
              by (simp add: Effect.app_def xcpt_app_def) arith
            ultimately show ?thesis using Invokestatic asms(1-3) wf
              by (auto simp: Effect.app_def xcpt_app_def norm_eff_def wf_mdecl_def
                       dest!: sees_wf_mdecl)
          qed
        qed (fastforce simp: Effect.app_def xcpt_app_def Effect.eff_def
                             xcpt_eff_def norm_eff_def)+
      qed
    qed
    then show "\<forall>s\<in>?A. \<forall>p. p < ?n \<longrightarrow> ?app p s \<longrightarrow> (\<forall>(q, s')\<in>set (?step p s). s' \<in> ?A)"
      by clarsimp
  qed
  then show ?thesis by (simp add: JVM_states_unfold)
qed
(*>*)

declare is_relevant_entry_def [simp del]
declare set_drop_subset [simp del]

lemma lesubstep_type_simple:
  "xs [\<sqsubseteq>\<^bsub>Product.le (=) r\<^esub>] ys \<Longrightarrow> set xs {\<sqsubseteq>\<^bsub>r\<^esub>} set ys"
(*<*)
proof -
  assume assm: "xs [\<sqsubseteq>\<^bsub>Product.le (=) r\<^esub>] ys"
  have "\<And>a b i y. (a, b) = xs ! i \<Longrightarrow> i < length xs
     \<Longrightarrow> \<exists>\<tau>'. (\<exists>i. (a, \<tau>') = ys ! i \<and> i < length xs) \<and> b \<sqsubseteq>\<^bsub>r\<^esub> \<tau>'"
  proof -
    fix a b i assume ith: "(a, b) = xs ! i" and len: "i < length xs"
    obtain \<tau> where "ys ! i = (a, \<tau>) \<and> r b \<tau>"
      using le_listD[OF assm len] ith
      by (clarsimp simp: lesub_def Product.le_def)
    then have "(a, \<tau>) = ys ! i \<and> b \<sqsubseteq>\<^bsub>r\<^esub> \<tau>"
      by (clarsimp simp: lesub_def)
    with len show "\<exists>\<tau>'. (\<exists>i. (a, \<tau>') = ys ! i \<and> i < length xs) \<and> b \<sqsubseteq>\<^bsub>r\<^esub> \<tau>'"
      by fastforce
  qed
  then show "set xs {\<sqsubseteq>\<^bsub>r\<^esub>} set ys" using assm
    by (clarsimp simp: lesubstep_type_def set_conv_nth)
qed
(*>*)

declare is_relevant_entry_def [simp del]

lemma conjI2: "\<lbrakk> A; A \<Longrightarrow> B \<rbrakk> \<Longrightarrow> A \<and> B" by blast

lemma (in JVM_sl) eff_mono:
assumes wf: "wf_prog p P" and "pc < length is" and
  lesub: "s \<sqsubseteq>\<^bsub>sup_state_opt P\<^esub> t" and app: "app pc t"
shows "set (eff pc s) {\<sqsubseteq>\<^bsub>sup_state_opt P\<^esub>} set (eff pc t)"
(*<*)
proof(cases t)
  case None then show ?thesis using lesub
   by (simp add: Effect.eff_def lesub_def)
next
  case tSome: (Some a)
  show ?thesis proof(cases s)
    case None then show ?thesis using lesub
     by (simp add: Effect.eff_def lesub_def)
  next
    case (Some b)
    let ?norm = "\<lambda>x. norm_eff (is ! pc) P pc x"
    let ?xcpt = "\<lambda>x. xcpt_eff (is ! pc) P pc x xt"
    let ?r = "Product.le (=) (sup_state_opt P)"
    let ?\<tau>' = "\<lfloor>eff\<^sub>i (is ! pc, P, a)\<rfloor>"
    {
      fix x assume xb: "x \<in> set (succs (is ! pc) b pc)"
      then have appi: "app\<^sub>i (is ! pc, P, pc, mxs, T\<^sub>r, a)" and
                bia: "P \<turnstile> b \<le>\<^sub>i a" and appa: "app pc \<lfloor>a\<rfloor>"
        using lesub app tSome Some by (auto simp add: lesub_def Effect.app_def)
      have xa: "x \<in> set (succs (is ! pc) a pc)"
        using xb succs_mono[OF wf appi bia] by auto
      then have "(x, ?\<tau>') \<in> (\<lambda>pc'. (pc', ?\<tau>')) ` set (succs (is ! pc) a pc)"
        by (rule imageI)
      moreover have "P \<turnstile> \<lfloor>eff\<^sub>i (is ! pc, P, b)\<rfloor> \<le>' ?\<tau>'"
        using xb xa eff\<^sub>i_mono[OF wf bia] appa by fastforce
      ultimately have "\<exists>\<tau>'. (x, \<tau>') \<in> (\<lambda>pc'. (pc', \<lfloor>eff\<^sub>i (is ! pc, P, a)\<rfloor>)) ` set (succs (is ! pc) a pc) \<and>
              P \<turnstile> \<lfloor>eff\<^sub>i (is ! pc, P, b)\<rfloor> \<le>' \<tau>'" by blast
    }
    then have norm: "set (?norm b) {\<sqsubseteq>\<^bsub>sup_state_opt P\<^esub>} set (?norm a)"
      using tSome Some by (clarsimp simp: norm_eff_def lesubstep_type_def lesub_def)
    obtain a1 b1 a2 b2 where a: "a = (a1, b1)" and b: "b = (a2, b2)"
      using tSome Some by fastforce
    then have a12: "size a2 = size a1" using lesub tSome Some
      by (clarsimp simp: lesub_def list_all2_lengthD)
    have "length (?xcpt b) = length (?xcpt a)"
      by (simp add: xcpt_eff_def split_beta)
    moreover have "\<And>n. n < length (?xcpt b) \<Longrightarrow> (?xcpt b) ! n \<sqsubseteq>\<^bsub>?r\<^esub> (?xcpt a) ! n"
      using lesub tSome Some a b a12
      by (simp add: xcpt_eff_def split_beta fun_of_def) (simp add: lesub_def)
    ultimately have "?xcpt b [\<sqsubseteq>\<^bsub>?r\<^esub>] ?xcpt a"
      by(rule le_listI)
    then have "set (?xcpt b) {\<sqsubseteq>\<^bsub>sup_state_opt P\<^esub>} set (?xcpt a)"
      by (rule lesubstep_type_simple)
    moreover note norm
    ultimately have
     "set (?norm b) \<union> set (?xcpt b) {\<sqsubseteq>\<^bsub>sup_state_opt P\<^esub>} set (?norm a) \<union> set (?xcpt a)"
      by(intro lesubstep_union)
    then show ?thesis using tSome Some by(simp add: Effect.eff_def)
  qed
qed
(*>*)

lemma (in JVM_sl) bounded_step: "bounded step (size is)"
(*<*)
  by (auto simp: bounded_def err_step_def Effect.app_def Effect.eff_def
                 error_def map_snd_def
          split: err.splits option.splits)
(*>*)

theorem (in JVM_sl) step_mono:
  "wf_prog wf_mb P \<Longrightarrow> mono r step (size is) A"
(*<*)
 apply (simp add: JVM_le_Err_conv)
  apply (insert bounded_step)
  apply (unfold JVM_states_unfold)
  apply (rule mono_lift)
  apply (subgoal_tac "b = Static \<or> b = NonStatic")
      apply (fastforce split:if_splits)\<comment>\<open> order_sup_state_opt' order_sup_state_opt'' \<close>
     apply (simp only:staticb)
     apply (unfold app_mono_def lesub_def)
    apply clarsimp
    apply (erule (2) app_mono)
   apply simp
  apply clarify
  apply (drule eff_mono)
      apply (auto simp add: lesub_def)
  done
(*
proof -
  assume wf: "wf_prog wf_mb P"
  let ?r = "sup_state_opt P" and ?n = "length is" and ?app = app and ?step = eff
  let ?A = "opt (\<Union> {list n (types P) |n. n \<le> mxs} \<times>
                list ((case b of Static \<Rightarrow> 0 | NonStatic \<Rightarrow> 1) + length Ts + mxl\<^sub>0)
                 (err (types P)))"
  have "order ?r ?A" using wf by simp
  moreover have "app_mono ?r ?app ?n ?A" using app_mono[OF wf]
    by (clarsimp simp: app_mono_def lesub_def)
  moreover have "bounded (err_step ?n ?app ?step) ?n" using bounded_step
    by simp
  moreover have "\<forall>s p t. s \<in> ?A \<and> p < ?n \<and> s \<sqsubseteq>\<^bsub>?r\<^esub> t \<longrightarrow>
   ?app p t \<longrightarrow> set (?step p s) {\<sqsubseteq>\<^bsub>?r\<^esub>} set (?step p t)"
     using eff_mono[OF wf] by simp
  ultimately have "mono (Err.le ?r) (err_step ?n ?app ?step) ?n (err ?A)"
    by(rule mono_lift)
  then show "mono r step (size is) A" using bounded_step
    by (simp add: JVM_le_Err_conv JVM_states_unfold)
qed
*)
(*>*)

lemma (in start_context) first_in_A [iff]: "OK first \<in> A"
  using Ts C by (cases b; force intro!: nlists_appendI simp add: JVM_states_unfold)

lemma (in JVM_sl) wt_method_def2:
  "wt_method P C' b Ts T\<^sub>r mxs mxl\<^sub>0 is xt \<tau>s =
  (is \<noteq> [] \<and>
   (b = Static \<or> b = NonStatic) \<and>
   size \<tau>s = size is \<and>
   OK ` set \<tau>s \<subseteq> states P mxs mxl \<and>
   wt_start P C' b Ts mxl\<^sub>0 \<tau>s \<and>
   wt_app_eff (sup_state_opt P) app eff \<tau>s)"
(*<*)using staticb
  by (unfold wt_method_def wt_app_eff_def wt_instr_def lesub_def
             check_types_def) auto
(*>*)

end


           (*-------------------------------------------*
            |        CSP-Prover on Isabelle2004         |
            |               December 2004               |
            |                   June 2005  (modified)   |
            |              September 2005  (modified)   |
            |                                           |
            |        CSP-Prover on Isabelle2005         |
            |               November 2005  (modified)   |
            |                  March 2007  (modified)   |
            |                                           |
            |        Yoshinao Isobe (AIST JAPAN)        |
            *-------------------------------------------*)

theory CSP_F_law_ref
imports CSP_F_law_basic CSP_T_law_ref
begin

(*****************************************************************

         1. rules for refinement

 *****************************************************************)

(*-------------------------------------------------------*
 |            refinement and equality                    |
 *-------------------------------------------------------*)

lemma cspF_ref_eq_iff: "(P <=F[M,M] Q) = (P =F[M,M] Q |~| P)"
apply (simp add: cspF_cspT_semantics)
apply (simp add: cspT_ref_eq_iff)
apply (rule)

(* <= *)
 apply (simp)
 apply (rule order_antisym)
 apply (simp add: subsetF_iff)
 apply (simp add: in_failures)
 apply (simp add: subsetF_iff)
 apply (simp add: in_failures)

(* => *)
 apply (simp)
 apply (erule conjE)
 apply (erule order_antisymE)
 apply (rule)
 apply (rotate_tac 2)
 apply (erule subsetFE_ALL)
 apply (drule_tac x="s" in spec)
 apply (drule_tac x="X" in spec)
 apply (simp add: in_failures)
done

(*-------------------------------------------------------*
 |              decompose Internal choice                |
 *-------------------------------------------------------*)

(*** or <= ***)                                         (* unsafe *)

lemma cspF_Int_choice_left1:
  "P1 <=F[M1,M2] Q ==> P1 |~| P2 <=F[M1,M2] Q"
apply (simp add: cspF_cspT_semantics)
apply (simp add: cspT_Int_choice_left1)
apply (rule, simp add: in_failures)
apply (force)
done

lemma cspF_Int_choice_left2:
  "P2 <=F[M1,M2] Q ==> P1 |~| P2 <=F[M1,M2] Q"
apply (rule cspF_rw_left)
apply (rule cspF_commut)
by (simp add: cspF_Int_choice_left1)

(*** <= and ***)                                          (* safe *)

lemma cspF_Int_choice_right:
  "[| P <=F[M1,M2] Q1 ; P <=F[M1,M2] Q2 |]
      ==> P <=F[M1,M2] Q1 |~| Q2"
apply (simp add: cspF_cspT_semantics)
apply (simp add: cspT_Int_choice_right)
apply (rule, simp add: in_failures)
apply (force)
done

(*-------------------------------------------------------*
 |        decompose Replicated internal choice           |
 *-------------------------------------------------------*)

(*** EX <= ***)                                           (* unsafe *)

lemma cspF_Rep_int_choice_nat_left:
  "(EX n. n:N & Pf n <=F[M1,M2] Q)
      ==> !nat :N .. Pf <=F[M1,M2] Q"
apply (simp add: cspF_cspT_semantics)
apply (rule conjI)

apply (rule cspT_Rep_int_choice_left)
apply (fast)

apply (rule, simp add: in_failures)
apply (force)
done

lemma cspF_Rep_int_choice_nat_left_x:
  "[| n:N ; Pf n <=F[M1,M2] Q |]
  ==> !nat :N .. Pf <=F[M1,M2] Q"
apply (rule cspF_Rep_int_choice_nat_left)
by (fast)

lemma cspF_Rep_int_choice_set_left:
  "(EX X. X:Xs & Pf X <=F[M1,M2] Q)
      ==> !set :Xs .. Pf <=F[M1,M2] Q"
apply (simp add: cspF_cspT_semantics)
apply (rule conjI)

apply (rule cspT_Rep_int_choice_left)
apply (fast)

apply (rule, simp add: in_failures)
apply (force)
done

lemma cspF_Rep_int_choice_set_left_x:
  "[| X:Xs ; Pf X <=F[M1,M2] Q |]
  ==> !set :Xs .. Pf <=F[M1,M2] Q"
apply (rule cspF_Rep_int_choice_set_left)
by (fast)

lemma cspF_Rep_int_choice_com_left:
  "(EX a. a:X & Pf a <=F[M1,M2] Q)
      ==> ! :X .. Pf <=F[M1,M2] Q"
apply (simp add: Rep_int_choice_com_def)
apply (rule cspF_Rep_int_choice_set_left)
apply (erule exE)
apply (rule_tac x="{a}" in exI)
apply (auto)
done

lemma cspF_Rep_int_choice_com_left_x:
  "[| a:X ; Pf a <=F[M1,M2] Q |]
  ==> ! :X .. Pf <=F[M1,M2] Q"
apply (rule cspF_Rep_int_choice_com_left)
by (fast)

lemma cspF_Rep_int_choice_f_left:
  "[| inj f ; (EX a. a:X & Pf a <=F[M1,M2] Q) |]
      ==> !<f> :X .. Pf <=F[M1,M2] Q"
apply (simp add: Rep_int_choice_f_def)
apply (rule cspF_Rep_int_choice_com_left)
apply (erule exE)
apply (rule_tac x="f a" in exI)
apply (auto)
done

lemma cspF_Rep_int_choice_f_left_x:
  "[| inj f ; a:X ; Pf a <=F[M1,M2] Q |]
  ==> !<f> :X .. Pf <=F[M1,M2] Q"
apply (rule cspF_Rep_int_choice_f_left)
apply (simp)
by (fast)

lemmas cspF_Rep_int_choice_left = cspF_Rep_int_choice_nat_left
                                  cspF_Rep_int_choice_set_left
                                  cspF_Rep_int_choice_com_left
                                  cspF_Rep_int_choice_f_left

lemmas cspF_Rep_int_choice_left_x = cspF_Rep_int_choice_nat_left_x
                                  cspF_Rep_int_choice_set_left_x
                                  cspF_Rep_int_choice_com_left_x
                                  cspF_Rep_int_choice_f_left_x

(*** <= ALL ***)                                         (* safe *)

lemma cspF_Rep_int_choice_nat_right:
  "[| !!n. n:N ==> P <=F[M1,M2] Qf n |]
               ==> P <=F[M1,M2] !nat :N .. Qf"
apply (simp add: cspF_cspT_semantics)
apply (simp add: cspT_Rep_int_choice_right)
apply (rule, simp add: in_failures)
apply (force)
done

lemma cspF_Rep_int_choice_set_right:
  "[| !!X. X:Xs ==> P <=F[M1,M2] Qf X |]
               ==> P <=F[M1,M2] !set :Xs .. Qf"
apply (simp add: cspF_cspT_semantics)
apply (simp add: cspT_Rep_int_choice_right)
apply (rule, simp add: in_failures)
apply (force)
done

lemma cspF_Rep_int_choice_com_right:
  "[| !!a. a:X ==> P <=F[M1,M2] Qf a |]
               ==> P <=F[M1,M2] ! :X .. Qf"
apply (simp add: cspF_cspT_semantics)
apply (simp add: cspT_Rep_int_choice_right)
apply (rule, simp add: in_failures)
apply (force)
done

lemma cspF_Rep_int_choice_f_right:
  "[| inj f ; !!a. a:X ==> P <=F[M1,M2] Qf a |]
               ==> P <=F[M1,M2] !<f> :X .. Qf"
apply (simp add: cspF_cspT_semantics)
apply (simp add: cspT_Rep_int_choice_right)
apply (rule, simp add: in_failures)
apply (force)
done

lemmas cspF_Rep_int_choice_right
     = cspF_Rep_int_choice_nat_right
       cspF_Rep_int_choice_set_right
       cspF_Rep_int_choice_com_right
       cspF_Rep_int_choice_f_right

(* 1,2,3,f E *)

lemma cspF_Rep_int_choice_nat_rightE:
  "[| P <=F[M1,M2] !nat :N .. Qf ;
      ALL n:N. P <=F[M1,M2] Qf n ==> R
   |] ==> R"
apply (simp add: cspF_cspT_semantics)
apply (elim conjE exE)
apply (erule cspT_Rep_int_choice_rightE)

apply (simp add: subsetF_iff)
apply (simp add: in_failures)
apply (force)
done

lemma cspF_Rep_int_choice_set_rightE:
  "[| P <=F[M1,M2] !set :Xs .. Qf ;
      ALL X:Xs. P <=F[M1,M2] Qf X ==> R
   |] ==> R"
apply (simp add: cspF_cspT_semantics)
apply (elim conjE exE)
apply (erule cspT_Rep_int_choice_rightE)

apply (simp add: subsetF_iff)
apply (simp add: in_failures)
apply (force)
done

lemma cspF_Rep_int_choice_com_rightE:
  "[| P <=F[M1,M2] ! :X .. Qf ;
      ALL a:X. P <=F[M1,M2] Qf a ==> R
   |] ==> R"
apply (simp add: cspF_cspT_semantics)
apply (elim conjE exE)
apply (erule cspT_Rep_int_choice_rightE)

apply (simp add: subsetF_iff)
apply (simp add: in_failures)
apply (force)
done

lemma cspF_Rep_int_choice_f_rightE:
  "[| P <=F[M1,M2] !<f> :X .. Qf ; inj f ;
      [| ALL a:X. P <=F[M1,M2] Qf a |] ==> R
   |] ==> R"
apply (simp add: cspF_cspT_semantics)
apply (elim conjE exE)
apply (erule cspT_Rep_int_choice_rightE)
apply (simp)

apply (simp add: subsetF_iff)
apply (simp add: in_failures)
apply (force)
done

lemmas cspF_Rep_int_choice_rightE =
       cspF_Rep_int_choice_nat_rightE
       cspF_Rep_int_choice_set_rightE
       cspF_Rep_int_choice_com_rightE
       cspF_Rep_int_choice_f_rightE

(*-------------------------------------------------------*
 |             decomposition with subset                 |
 *-------------------------------------------------------*)

lemma cspF_Rep_int_choice_nat_subset:
  "[| N2 <= N1  ; !!n. n:N2 ==> Pf n <=F[M1,M2] Qf n |]
                    ==> !nat :N1 .. Pf <=F[M1,M2] !nat :N2 .. Qf"
apply (simp add: cspF_cspT_semantics)
apply (simp add: cspT_Rep_int_choice_subset)
apply (rule, simp add: in_failures)
apply (force)
done

lemma cspF_Rep_int_choice_set_subset:
  "[| Ys <= Xs  ; !!X. X:Ys ==> Pf X <=F[M1,M2] Qf X |]
                    ==> !set :Xs .. Pf <=F[M1,M2] !set :Ys .. Qf"
apply (simp add: cspF_cspT_semantics)
apply (simp add: cspT_Rep_int_choice_subset)
apply (rule, simp add: in_failures)
apply (force)
done

lemma cspF_Rep_int_choice_com_subset:
  "[| Y <= X  ; !!a. a:Y ==> Pf a <=F[M1,M2] Qf a |]
                    ==> ! :X .. Pf <=F[M1,M2] ! :Y .. Qf"
apply (simp add: cspF_cspT_semantics)
apply (simp add: cspT_Rep_int_choice_subset)
apply (rule, simp add: in_failures)
apply (force)
done

lemma cspF_Rep_int_choice_f_subset:
  "[| inj f ; Y <= X  ; !!a. a:Y ==> Pf a <=F[M1,M2] Qf a |]
                    ==> !<f> :X .. Pf <=F[M1,M2] !<f> :Y .. Qf"
apply (simp add: cspF_cspT_semantics)
apply (simp add: cspT_Rep_int_choice_subset)
apply (rule, simp add: in_failures)
apply (force)
done

lemmas cspF_Rep_int_choice_subset
     = cspF_Rep_int_choice_nat_subset
       cspF_Rep_int_choice_set_subset
       cspF_Rep_int_choice_com_subset
       cspF_Rep_int_choice_f_subset

(*** ! x:X .. and ? -> ***)

lemma cspF_Int_Ext_pre_choice_subset:
  "[| Y ~={} ; Y <= X ; !!a. a:Y ==> Pf a <=F[M1,M2] Qf a |]
        ==> ! x:X .. (x -> Pf x) <=F[M1,M2]
            ? :Y -> Qf"
apply (simp add: cspF_cspT_semantics)
apply (simp add: cspT_Int_Ext_pre_choice_subset)
apply (rule, simp add: in_failures)
apply (force)
done

lemmas cspF_decompo_subset = cspF_Rep_int_choice_subset
                             cspF_Int_Ext_pre_choice_subset

(*-------------------------------------------------------*
 |               decompose external choice               |
 *-------------------------------------------------------*)

lemma cspF_Ext_choice_right:
  "[| P <=F[M1,M2] Q1 ;
      P <=F[M1,M2] Q2 |]
      ==> P <=F[M1,M2] Q1 [+] Q2"
apply (simp add: cspF_cspT_semantics)
apply (simp add: cspT_Ext_choice_right)
apply (rule)

 apply (simp add: in_failures)
 apply (elim disjE conjE exE, simp)
 apply (force, force, force)
 apply (simp_all)

 apply (subgoal_tac "(<>, X) :f failures(Q1) M2")
 apply (force)
 apply (rule proc_F2_F4)
 apply (simp_all)
 apply (rule proc_F2_F4)
 apply (simp_all)
 apply (simp add: cspT_semantics)
 apply (auto)
done

end


theory InstanceFsetalt
imports NonFreeAnimation
begin

(*
datatype 'a fset2 = Emp | Ins 'a ('a fset2)
where
  Ins a (Ins a s) = Ins a s
  Ins a1 (Ins a2 s) = Ins a2 (Ins a1 s)
*)

locale results =
  fixes alpha :: tyvar
    and finset_name :: tyco
    and ins_name :: oper
    and emp_name :: oper
    and dummy :: 'a
begin

lemma [ffact]: "decl_tyvars () [alpha]" ..
lemma [ffact]: "alpha tyinterpr TYPE('a)" ..

lemma [ffact]: "finset_name tycohaskind (ExtType =K=> IntType)" ..

lemma [ffact]: "ins_name operhasty (alpha =T=> finset_name ** alpha =T=> finset_name ** alpha)" ..
lemma [ffact]: "emp_name operhasty (finset_name ** alpha)" ..

definition "ins_clause1_name = (0::nat)"
definition "ins_clause2_name = (0::nat)"

lemma [ffact]: "decl_hcl ins_clause1_name (QUANT a:alpha. QUANT S: finset_name**alpha.
  ins_name $ a $ (ins_name $ a $ S) === ins_name $ a $ S)" ..
lemma [ffact]: "decl_hcl ins_clause2_name (QUANT a:alpha. QUANT a2:alpha. QUANT S: finset_name**alpha.
  ins_name $ a $ (ins_name $ a2 $ S) === ins_name $ a2 $ (ins_name $ a $ S))" ..

local_setup {* MetaRec.run_expl_frules *}

end

thm results.ins_clause1
thm results.ins_clause2

locale algebra_results = results  alpha finset_name ins_name emp_name dummy
    for alpha :: tyvar
    and finset_name :: tyco
    and emp_name :: oper
    and ins_name :: oper
    and dummy :: 'a
begin

lemma [ffact]: "(finset_name ** alpha) alginterpr TYPE('a set)" ..
lemma [ffact]: "ins_name operalginterpr (% (x::'a) (xs :: 'a set). {x} Un xs)" ..
lemma [ffact]: "emp_name operalginterpr ({} :: 'a set)" ..

lemma [ffact]: "proven_hcl (ALL (x::'a) (S::'a set). {x} Un ({x} Un S) = {x} Un S)"
  unfolding proven_hcl_def by blast
lemma [ffact]: "proven_hcl (ALL (x::'a) (x2::'a) (S::'a set). {x} Un ({x2} Un S) = {x2} Un ({x} Un S))"
  unfolding proven_hcl_def by blast

local_setup {* MetaRec.run_expl_frules *}

end

thm algebra_results.iter_op_clauses0

end


(*
 * Copyright 2014, General Dynamics C4 Systems
 *
 * SPDX-License-Identifier: GPL-2.0-only
 *)

(* Title:   Confinement_S
 * Description: Rephrasing of the confinement proof using the concept of islands.
 *)

theory Islands_S
imports Confine_S
begin

definition
  island :: "state \<Rightarrow> entity_id \<Rightarrow> entity_id set" where
  "island s x \<equiv> {e\<^sub>i. s \<turnstile> x \<leftrightarrow>* e\<^sub>i}"

definition
  island_caps :: "state \<Rightarrow> entity_id \<Rightarrow> cap set" where
  "island_caps s x \<equiv> \<Union>(caps_of s ` island s x)"

lemma island_caps_def2:
  "island_caps s x \<equiv> \<Union> e \<in> island s x. caps_of s e"
  by(simp add: island_caps_def)

lemma island_caps_def3:
  "island_caps s x =  \<Union>(direct_caps_of s ` island s x)"
  apply (clarsimp simp: island_caps_def)
  apply rule
   apply (clarsimp simp: island_def caps_of_def)
   apply (drule store_connected_directly_tgs_connected)
   apply (metis directly_tgs_connected_rtrancl_into_rtrancl)
  apply (fastforce simp: caps_of_def store_connected_def)
  done

lemma island_caps_dom:
  "island_caps s e\<^sub>x \<le>cap c =
  (\<forall>e\<^sub>i. (e\<^sub>x, e\<^sub>i) \<in> tgs_connected s \<longrightarrow> caps_of s e\<^sub>i \<le>cap c)"
  by (auto simp add: island_caps_def caps_dominated_by_def island_def)

lemma authority_confinement_islands:
  "\<lbrakk>s' \<in> execute cmds s;
    island_caps s x \<le>cap c\<rbrakk>
  \<Longrightarrow> island_caps s' x \<le>cap c"
  apply (simp add: island_caps_dom)
  apply clarsimp
  apply (frule (1) tgs_connected_preserved)
  apply (subst (asm) tgs_connected_comm_eq)
  apply (erule authority_confinement)
  apply clarsimp
  apply (erule_tac x=e\<^sub>i' in allE)
  apply (erule impE)
  apply (metis (opaque_lifting, no_types) tgs_connected_comm_eq tgs_connected_def rtrancl_trans)
  apply clarsimp
  done

end


(*  Title:      HOL/HOLCF/Powerdomains.thy
    Author:     Brian Huffman
*)

section {* Powerdomains *}

theory Powerdomains
imports ConvexPD Domain
begin

subsection {* Universal domain embeddings *}

definition "upper_emb = udom_emb (\<lambda>i. upper_map\<cdot>(udom_approx i))"
definition "upper_prj = udom_prj (\<lambda>i. upper_map\<cdot>(udom_approx i))"

definition "lower_emb = udom_emb (\<lambda>i. lower_map\<cdot>(udom_approx i))"
definition "lower_prj = udom_prj (\<lambda>i. lower_map\<cdot>(udom_approx i))"

definition "convex_emb = udom_emb (\<lambda>i. convex_map\<cdot>(udom_approx i))"
definition "convex_prj = udom_prj (\<lambda>i. convex_map\<cdot>(udom_approx i))"

lemma ep_pair_upper: "ep_pair upper_emb upper_prj"
  unfolding upper_emb_def upper_prj_def
  by (simp add: ep_pair_udom approx_chain_upper_map)

lemma ep_pair_lower: "ep_pair lower_emb lower_prj"
  unfolding lower_emb_def lower_prj_def
  by (simp add: ep_pair_udom approx_chain_lower_map)

lemma ep_pair_convex: "ep_pair convex_emb convex_prj"
  unfolding convex_emb_def convex_prj_def
  by (simp add: ep_pair_udom approx_chain_convex_map)

subsection {* Deflation combinators *}

definition upper_defl :: "udom defl \<rightarrow> udom defl"
  where "upper_defl = defl_fun1 upper_emb upper_prj upper_map"

definition lower_defl :: "udom defl \<rightarrow> udom defl"
  where "lower_defl = defl_fun1 lower_emb lower_prj lower_map"

definition convex_defl :: "udom defl \<rightarrow> udom defl"
  where "convex_defl = defl_fun1 convex_emb convex_prj convex_map"

lemma cast_upper_defl:
  "cast\<cdot>(upper_defl\<cdot>A) = upper_emb oo upper_map\<cdot>(cast\<cdot>A) oo upper_prj"
using ep_pair_upper finite_deflation_upper_map
unfolding upper_defl_def by (rule cast_defl_fun1)

lemma cast_lower_defl:
  "cast\<cdot>(lower_defl\<cdot>A) = lower_emb oo lower_map\<cdot>(cast\<cdot>A) oo lower_prj"
using ep_pair_lower finite_deflation_lower_map
unfolding lower_defl_def by (rule cast_defl_fun1)

lemma cast_convex_defl:
  "cast\<cdot>(convex_defl\<cdot>A) = convex_emb oo convex_map\<cdot>(cast\<cdot>A) oo convex_prj"
using ep_pair_convex finite_deflation_convex_map
unfolding convex_defl_def by (rule cast_defl_fun1)

subsection {* Domain class instances *}

instantiation upper_pd :: ("domain") "domain"
begin

definition
  "emb = upper_emb oo upper_map\<cdot>emb"

definition
  "prj = upper_map\<cdot>prj oo upper_prj"

definition
  "defl (t::'a upper_pd itself) = upper_defl\<cdot>DEFL('a)"

definition
  "(liftemb :: 'a upper_pd u \<rightarrow> udom u) = u_map\<cdot>emb"

definition
  "(liftprj :: udom u \<rightarrow> 'a upper_pd u) = u_map\<cdot>prj"

definition
  "liftdefl (t::'a upper_pd itself) = liftdefl_of\<cdot>DEFL('a upper_pd)"

instance proof
  show "ep_pair emb (prj :: udom \<rightarrow> 'a upper_pd)"
    unfolding emb_upper_pd_def prj_upper_pd_def
    by (intro ep_pair_comp ep_pair_upper ep_pair_upper_map ep_pair_emb_prj)
next
  show "cast\<cdot>DEFL('a upper_pd) = emb oo (prj :: udom \<rightarrow> 'a upper_pd)"
    unfolding emb_upper_pd_def prj_upper_pd_def defl_upper_pd_def cast_upper_defl
    by (simp add: cast_DEFL oo_def cfun_eq_iff upper_map_map)
qed (fact liftemb_upper_pd_def liftprj_upper_pd_def liftdefl_upper_pd_def)+

end

instantiation lower_pd :: ("domain") "domain"
begin

definition
  "emb = lower_emb oo lower_map\<cdot>emb"

definition
  "prj = lower_map\<cdot>prj oo lower_prj"

definition
  "defl (t::'a lower_pd itself) = lower_defl\<cdot>DEFL('a)"

definition
  "(liftemb :: 'a lower_pd u \<rightarrow> udom u) = u_map\<cdot>emb"

definition
  "(liftprj :: udom u \<rightarrow> 'a lower_pd u) = u_map\<cdot>prj"

definition
  "liftdefl (t::'a lower_pd itself) = liftdefl_of\<cdot>DEFL('a lower_pd)"

instance proof
  show "ep_pair emb (prj :: udom \<rightarrow> 'a lower_pd)"
    unfolding emb_lower_pd_def prj_lower_pd_def
    by (intro ep_pair_comp ep_pair_lower ep_pair_lower_map ep_pair_emb_prj)
next
  show "cast\<cdot>DEFL('a lower_pd) = emb oo (prj :: udom \<rightarrow> 'a lower_pd)"
    unfolding emb_lower_pd_def prj_lower_pd_def defl_lower_pd_def cast_lower_defl
    by (simp add: cast_DEFL oo_def cfun_eq_iff lower_map_map)
qed (fact liftemb_lower_pd_def liftprj_lower_pd_def liftdefl_lower_pd_def)+

end

instantiation convex_pd :: ("domain") "domain"
begin

definition
  "emb = convex_emb oo convex_map\<cdot>emb"

definition
  "prj = convex_map\<cdot>prj oo convex_prj"

definition
  "defl (t::'a convex_pd itself) = convex_defl\<cdot>DEFL('a)"

definition
  "(liftemb :: 'a convex_pd u \<rightarrow> udom u) = u_map\<cdot>emb"

definition
  "(liftprj :: udom u \<rightarrow> 'a convex_pd u) = u_map\<cdot>prj"

definition
  "liftdefl (t::'a convex_pd itself) = liftdefl_of\<cdot>DEFL('a convex_pd)"

instance proof
  show "ep_pair emb (prj :: udom \<rightarrow> 'a convex_pd)"
    unfolding emb_convex_pd_def prj_convex_pd_def
    by (intro ep_pair_comp ep_pair_convex ep_pair_convex_map ep_pair_emb_prj)
next
  show "cast\<cdot>DEFL('a convex_pd) = emb oo (prj :: udom \<rightarrow> 'a convex_pd)"
    unfolding emb_convex_pd_def prj_convex_pd_def defl_convex_pd_def cast_convex_defl
    by (simp add: cast_DEFL oo_def cfun_eq_iff convex_map_map)
qed (fact liftemb_convex_pd_def liftprj_convex_pd_def liftdefl_convex_pd_def)+

end

lemma DEFL_upper: "DEFL('a::domain upper_pd) = upper_defl\<cdot>DEFL('a)"
by (rule defl_upper_pd_def)

lemma DEFL_lower: "DEFL('a::domain lower_pd) = lower_defl\<cdot>DEFL('a)"
by (rule defl_lower_pd_def)

lemma DEFL_convex: "DEFL('a::domain convex_pd) = convex_defl\<cdot>DEFL('a)"
by (rule defl_convex_pd_def)

subsection {* Isomorphic deflations *}

lemma isodefl_upper:
  "isodefl d t \<Longrightarrow> isodefl (upper_map\<cdot>d) (upper_defl\<cdot>t)"
apply (rule isodeflI)
apply (simp add: cast_upper_defl cast_isodefl)
apply (simp add: emb_upper_pd_def prj_upper_pd_def)
apply (simp add: upper_map_map)
done

lemma isodefl_lower:
  "isodefl d t \<Longrightarrow> isodefl (lower_map\<cdot>d) (lower_defl\<cdot>t)"
apply (rule isodeflI)
apply (simp add: cast_lower_defl cast_isodefl)
apply (simp add: emb_lower_pd_def prj_lower_pd_def)
apply (simp add: lower_map_map)
done

lemma isodefl_convex:
  "isodefl d t \<Longrightarrow> isodefl (convex_map\<cdot>d) (convex_defl\<cdot>t)"
apply (rule isodeflI)
apply (simp add: cast_convex_defl cast_isodefl)
apply (simp add: emb_convex_pd_def prj_convex_pd_def)
apply (simp add: convex_map_map)
done

subsection {* Domain package setup for powerdomains *}

lemmas [domain_defl_simps] = DEFL_upper DEFL_lower DEFL_convex
lemmas [domain_map_ID] = upper_map_ID lower_map_ID convex_map_ID
lemmas [domain_isodefl] = isodefl_upper isodefl_lower isodefl_convex

lemmas [domain_deflation] =
  deflation_upper_map deflation_lower_map deflation_convex_map

setup {*
  fold Domain_Take_Proofs.add_rec_type
    [(@{type_name "upper_pd"}, [true]),
     (@{type_name "lower_pd"}, [true]),
     (@{type_name "convex_pd"}, [true])]
*}

end