(*File: HuntSands.thy*)
(*Authors: Lennart Beringer and Martin Hofmann, LMU Munich 2008*)
theory HuntSands imports VDM Lattice begin
section\<open>Flow-sensitivity a la Hunt and Sands\<close>

text\<open>\label{sec:HuntSands}\footnote{As the Isabelle theory representing this section is
dependent only on VDM.thy and Lattice.thy, name conflicts with
notions defined in Section \ref{sec:BaseLineNI} are avoided.} The
paper \<^cite>\<open>"HuntSands:POPL2006"\<close> by Hunt and Sands presents a
generalisation of the type system of Volpano et al.~to
flow-sensitivity. Thus, programs such as $l:=h; l:=5$ are not rejected
any longer by the type system. Following the description in Section 4
of our paper~\<^cite>\<open>"BeringerHofmann:CSF2007"\<close>, we embed Hunt and Sands'
type system into the program logic given in Section \ref{sec:VDM}.\<close>

subsection\<open>General $A; R \Rightarrow S$-security\<close>
text\<open>\label{sec:ARSsecurity}Again, we define the type $TT$ of
intermediate formulae $\Phi$, and an assertion operator
$\mathit{Sec}$. The latter is now parametrised not only by the
intermediate formulae but also by the (possibly differing) pre- and
post-relations $R$ and $S$ (both instantiated to $\approx$ in Section
\ref{sec:BaseLineNI}), and by a specification $A$ that directly links
pre- and post-states.\<close>

type_synonym TT = "(State \<times> State) \<Rightarrow> bool"

definition RSsecure::"(State \<Rightarrow> State \<Rightarrow> bool) \<Rightarrow>
                      (State \<Rightarrow> State \<Rightarrow> bool) \<Rightarrow> IMP \<Rightarrow> bool"
where "RSsecure R S c = (\<forall> s t ss tt . R s t \<longrightarrow> (s,c \<Down> ss) \<longrightarrow>
                          (t,c \<Down> tt) \<longrightarrow> S ss tt)"

definition ARSsecure::"VDMAssn \<Rightarrow> (State \<Rightarrow> State \<Rightarrow> bool) \<Rightarrow>
                      (State \<Rightarrow> State \<Rightarrow> bool) \<Rightarrow> IMP \<Rightarrow> bool"
where "ARSsecure A R S c = ((\<Turnstile> c : A) \<and> RSsecure R S c)"

text\<open>Definition 3 of our paper follows.\<close>

definition Sec :: "VDMAssn \<Rightarrow> (State \<Rightarrow> State \<Rightarrow> bool) \<Rightarrow>
                  (State \<Rightarrow> State \<Rightarrow> bool) \<Rightarrow> TT \<Rightarrow> VDMAssn"
where "Sec A R S \<Phi> s t = (A s t \<and>
                   (\<forall> r . R s r \<longrightarrow> \<Phi>(t,r)) \<and> (\<forall> r . \<Phi>(r,s) \<longrightarrow> S r t))"

text\<open>With these definitions, we can prove Proposition 4 of our
paper.\<close>

lemma Prop4A: "\<Turnstile> c : Sec A R S \<Phi> \<Longrightarrow> ARSsecure A R S c"
(*<*)
by (simp add:  VDM_valid_def Sec_def ARSsecure_def RSsecure_def)
(*>*)

lemma Prop4B : "ARSsecure A R S c \<Longrightarrow>
   \<Turnstile> c : Sec A R S (\<lambda> (r,t) . \<exists> s . (s , c \<Down> r) \<and> R s t)"
(*<*)
apply (simp add: VDM_valid_def Sec_def)
apply clarsimp
apply (unfold ARSsecure_def RSsecure_def VDM_valid_def)
apply rule apply fastforce
apply rule
apply (rule, rule) apply (rule_tac x=s in exI, rule, assumption+)
apply (rule, rule, erule exE, erule conjE) apply fast
done
(*>*)

subsection\<open>Basic definitions\<close>

text\<open>Contexts map program variables to lattice elements.\<close>

type_synonym "CONTEXT" = "Var \<Rightarrow> L"

definition upd ::"CONTEXT \<Rightarrow> Var \<Rightarrow> L \<Rightarrow> CONTEXT"
where "upd G x p = (\<lambda> y . if x=y then p else G y)"

text\<open>We also define the predicate $\mathit{EQ}$
%(in our paper denoted by the symbol $\ltimes$)
which expresses when two states agree on all
variables whose entry in a given context is below a certain security
level.\<close>

definition EQ:: "CONTEXT \<Rightarrow> L \<Rightarrow> State \<Rightarrow> State \<Rightarrow> bool"
where "EQ G p = (\<lambda> s t . \<forall> x . LEQ (G x) p \<longrightarrow>  s x = t x)"

lemma EQ_LEQ: "\<lbrakk>EQ G p s t; LEQ pp p\<rbrakk> \<Longrightarrow> EQ G pp s t"
(*<*)
apply (simp add: EQ_def, clarsimp)
apply (erule_tac x=x in allE, erule mp)
apply (erule LAT2, assumption)
done
(*>*)

text\<open>The assertion called $\mathcal{Q}$ in our paper:\<close>

definition Q::"L \<Rightarrow> CONTEXT \<Rightarrow> VDMAssn"
where "Q p H = (\<lambda> s t . \<forall> x . (\<not> LEQ p (H x)) \<longrightarrow> t x = s x)"

text\<open>$Q$ expresses the preservation of values in a single execution,
and corresponds to the first clause of Definition 3.2 in
\<^cite>\<open>"HuntSands:POPL2006"\<close>. In accordance with this, the following
definition of security instantiates the $A$ position of $A; R
\Rightarrow S$-security with $Q$, while the context-dependent binary
state relations are plugged in as the $R$ and $S$ components.\<close>

definition secure :: "L \<Rightarrow> CONTEXT \<Rightarrow> IMP \<Rightarrow> CONTEXT \<Rightarrow> bool"
where "secure p G c H = (\<forall> q . ARSsecure (Q p H) (EQ G q) (EQ H q) c)"

text\<open>Indeed, one may show that this notion of security amounds to the
conjunction of a unary (i.e.~one-execution-)property and a binary
(i.e.~two-execution-) property, as expressed in Hunt \& Sands'
Definition 3.2.\<close>

definition secure1 :: "L \<Rightarrow> CONTEXT \<Rightarrow> IMP \<Rightarrow> CONTEXT \<Rightarrow> bool"
where "secure1 p G c H = (\<forall> s t . (s,c \<Down> t) \<longrightarrow> Q p H s t)"

definition secure2 :: "L \<Rightarrow> CONTEXT \<Rightarrow> IMP \<Rightarrow> CONTEXT \<Rightarrow> bool"
where "secure2 p G c H = ((\<forall> s t ss tt . (s,c \<Down> t) \<longrightarrow> (ss,c \<Down> tt) \<longrightarrow>
                                    EQ G p s ss \<longrightarrow> EQ H p t tt))"

lemma secureEQUIV:
  "secure p G c H = (\<forall> q . secure1 p G c H \<and> secure2 q G c H)"
(*<*)by (simp add: secure1_def secure2_def secure_def ARSsecure_def
              RSsecure_def Q_def VDM_valid_def, auto)
(*>*)

subsection\<open>Type system\<close>

text\<open>The type system of Hunt and Sands -- our language formalisation
uses a concrete datatype of expressions, so we add the obvious typing
rules for expressions and prove the expected evaluation lemmas.\<close>

inductive_set HS_E:: "(CONTEXT \<times> Expr \<times> L) set"
where
HS_E_var: "(G, varE x, G x) : HS_E"
| HS_E_val: "(G, valE c, bottom) : HS_E"
| HS_E_op: "\<lbrakk>(G, e1,p1):HS_E; (G, e2,p2):HS_E; p= LUB p1 p2\<rbrakk>
           \<Longrightarrow> (G,opE f e1 e2,p) : HS_E"
| HS_E_sup: "\<lbrakk>(G,e,p):HS_E; LEQ p q\<rbrakk> \<Longrightarrow> (G,e,q):HS_E"

lemma HS_E_eval[rule_format]:
"(G, e, t) \<in> HS_E \<Longrightarrow>
 \<forall> r s q. EQ G q r s \<longrightarrow> LEQ t q \<longrightarrow> evalE e r = evalE e s"
(*<*)
apply (erule HS_E.induct)
apply clarsimp  apply (simp add: EQ_def)
apply clarsimp
apply clarsimp
  apply (erule_tac x=r in allE, erule_tac x=r in allE)
  apply (erule_tac x=s in allE, erule_tac x=s in allE)
  apply (erule_tac x=q in allE, erule_tac x=q in allE, clarsimp)
  apply (erule impE) apply (rule LAT2) prefer 2 apply assumption
    apply (simp add: LAT3)
  apply (erule impE) apply (rule LAT2) prefer 2 apply assumption
    apply (subgoal_tac "LEQ p2 (LUB p2 p1)")
      apply (simp add: LAT4)
    apply (simp add: LAT3)
  apply clarsimp
apply clarsimp
  apply (erule_tac x=r in allE, erule_tac x=s in allE, erule_tac x=qa in allE, erule impE)
    apply clarsimp
  apply (erule mp) apply (erule LAT2, assumption)
done
(*>*)

text\<open>Likewise for boolean expressions:\<close>

inductive_set HS_B:: "(CONTEXT \<times> BExpr \<times> L) set"
where
HS_B_compB: "\<lbrakk>(G, e1,p1):HS_E; (G, e2,p2):HS_E; p= LUB p1 p2\<rbrakk>
             \<Longrightarrow> (G,compB f e1 e2,p) : HS_B"
| HS_B_sup: "\<lbrakk>(G,b,p):HS_B; LEQ p q\<rbrakk> \<Longrightarrow> (G,b,q):HS_B"

lemma HS_B_eval[rule_format]:
"(G, b, t) \<in> HS_B \<Longrightarrow>
 \<forall> r s pp . EQ G pp r s \<longrightarrow> LEQ t pp \<longrightarrow>  evalB b r = evalB b s"
(*<*)
apply (erule HS_B.induct)
apply clarsimp
  apply (subgoal_tac "evalE e1 r = evalE e1 s", clarsimp)
  prefer 2 apply (erule HS_E_eval) apply assumption
           apply (rule LAT2) prefer 2 apply assumption apply (simp add: LAT3)
  apply (subgoal_tac "evalE e2 r = evalE e2 s", clarsimp)
    apply (erule HS_E_eval) apply assumption
           apply (rule LAT2) prefer 2 apply assumption
           apply (subgoal_tac "LEQ p2 (LUB p2 p1)", simp add: LAT4)
           apply (simp add: LAT3)
apply clarsimp
  apply (erule_tac x=r in allE, erule_tac x=s in allE, erule_tac x=pp in allE, erule impE)
    apply clarsimp
  apply (erule mp) apply (erule LAT2, assumption)
done
(*>*)

text\<open>The typing rules for commands follow.\<close>

inductive_set HS::"(L \<times> CONTEXT \<times> IMP \<times> CONTEXT) set"
where
HS_Skip:   "(p,G,Skip,G):HS"

| HS_Assign:
  "(G,e,t):HS_E \<Longrightarrow> (p,G,Assign x e,upd G x (LUB p t)):HS"

| HS_Seq:
  "\<lbrakk>(p,G,c,K):HS; (p,K,d,H):HS\<rbrakk> \<Longrightarrow> (p,G, Comp c d,H):HS"

| HS_If:
  "\<lbrakk>(G,b,t):HS_B; (LUB p t,G,c,H):HS; (LUB p t,G,d,H):HS\<rbrakk> \<Longrightarrow>
   (p,G,Iff b c d,H):HS"

| HS_If_alg:
  "\<lbrakk>(G,b,p):HS_B; (p,G,c,H):HS; (p,G,d,H):HS\<rbrakk> \<Longrightarrow>
   (p,G,Iff b c d,H):HS"

| HS_While:
  "\<lbrakk>(G,b,t):HS_B; (LUB p t,G,c,H):HS;H=G\<rbrakk> \<Longrightarrow>
   (p,G,While b c,H):HS"

| HS_Sub:
  "\<lbrakk> (pp,GG,c,HH):HS; LEQ p pp; \<forall> x . LEQ (G x) (GG x);
       \<forall> x . LEQ (HH x) (H x)\<rbrakk> \<Longrightarrow>
   (p,G,c,H):HS"

text \<open>Using \<open>HS_Sub\<close>, rules \<open>If\<close> and \<open>If_alg\<close> are
inter-derivable.\<close>

lemma IF_derivable_from_If_alg:
  "\<lbrakk>(G,b,t):HS_B; (LUB p t,G,c1,H):HS; (LUB p t,G,c2,H):HS\<rbrakk>
   \<Longrightarrow> (p,G,Iff b c1 c2,H):HS"
apply (subgoal_tac "(LUB p t,G,Iff b c1 c2,H):HS")
  apply (erule HS_Sub) apply (rule LAT3)
    apply (clarsimp, rule LAT6) apply (clarsimp, rule LAT6)
apply (rule HS_If_alg) apply (erule HS_B_sup)
  apply (subgoal_tac "LEQ t (LUB t p)", simp add: LAT4)
  apply (rule LAT3) apply assumption+
done

lemma IF_alg_derivable_from_If:
  "\<lbrakk>(G,b,p):HS_B; (p,G,c1,H):HS; (p,G,c2,H):HS\<rbrakk>
  \<Longrightarrow> (p,G,Iff b c1 c2,H):HS"
apply (erule HS_If) apply (subgoal_tac "LUB p p = p", clarsimp)
  apply (subgoal_tac "p = LUB p p", fastforce) apply (rule LAT7)
apply (subgoal_tac "LUB p p = p", clarsimp)
  apply (subgoal_tac "p = LUB p p", fastforce) apply (rule LAT7)
done

text\<open>An easy induction on typing derivations shows the following property.\<close>

lemma HS_Aux1:
 "(p,G,c,H):HS \<Longrightarrow> \<forall> x. LEQ (G x) (H x) \<or> LEQ p (H x)"
(*<*)
apply (erule HS.induct)
(*Skip*)
apply (simp add: LAT6)
(*Assign*)
apply (simp add: upd_def) apply clarsimp apply rule
  apply clarsimp apply (simp add: LAT3)
  apply clarsimp apply (simp add: LAT6)
(*Seq*)
apply clarsimp
   apply (erule_tac x=x in allE, erule disjE)
   apply (erule_tac x=x in allE, erule disjE)
     apply (erule LAT2) apply assumption apply fast
   apply (erule_tac x=x in allE, erule disjE)
     apply(subgoal_tac "LEQ p (H x)", fast)
     apply (erule LAT2) apply assumption apply fast
(*If*)
apply clarsimp
   apply (erule_tac x=x in allE, erule disjE) apply assumption
     apply(subgoal_tac "LEQ p (H x)", fast)
     apply (subgoal_tac "LEQ p (LUB p t)", rotate_tac -1)
     apply (erule LAT2) apply assumption
     apply (rule LAT3)
(*If2*)
apply clarsimp
(*While*)
apply clarsimp
   apply (simp add: LAT6)
(*Sub*)
apply clarsimp
   apply (erule_tac x=x in allE, erule disjE)
   apply (erule_tac x=x in allE)
   apply (erule_tac x=x in allE)
     apply (erule LAT2)
     apply (erule LAT2) apply assumption
   apply (erule_tac x=x in allE)
     apply (erule LAT2)
   apply (erule_tac x=x in allE)
     apply (subgoal_tac "LEQ p (H x)", fast)
     apply (erule LAT2)
     apply (erule LAT2) apply assumption
done
(*>*)

subsection\<open>Derived proof rules\<close>

text\<open>In order to show the derivability of the properties given in
Theorem 3.3 of Hunt and Sands' paper, we give the following derived
proof rules. By including the $Q$ property in the $A$ position of
$Sec$, we prove both parts of theorem in one proof, and can exploit
the first property ($Q$) in the proof of the second.\<close>

lemma SKIP:
 "X \<rhd> Skip : Sec (Q p H) (EQ G q) (EQ G q)
                  (\<lambda> (s,t) . EQ G q s t)"
(*<*)
apply (rule VDMConseq, rule VDMSkip)
  apply (simp add: Sec_def EQ_def Q_def)
done
(*>*)

lemma ASSIGN:
  "\<lbrakk>H = upd G x (LUB p t);
    \<forall> s ss . EQ G t s ss \<longrightarrow> evalE e s = evalE e ss\<rbrakk>
  \<Longrightarrow> X \<rhd> Assign x e : Sec (Q p H) (EQ G q) (EQ H q)
            (\<lambda> (s,t) . \<exists> r . s = update r x (evalE e r) \<and> EQ G q r t)"
(*<*)
  apply (rule VDMConseq, rule VDMAssign) apply clarsimp
  apply (simp add: Sec_def EQ_def Q_def)
  apply (rule, clarsimp) apply (simp add: update_def upd_def)
    apply (case_tac "x=xa", clarsimp) apply (simp add: LAT3)
    apply clarsimp
  apply (rule, clarsimp) apply (rule_tac x=s in exI, simp)
  apply clarsimp
    apply (case_tac "x=xa", clarsimp, hypsubst_thin)
      apply (simp add: update_def upd_def)
        apply (erule_tac x=ra in allE, erule_tac x=s in allE, erule mp, clarsimp)
        apply (erule_tac x=x in allE, erule mp)
        apply (erule LAT2, rule LAT2) prefer 2 apply assumption
        apply (subgoal_tac "LEQ t (LUB t p)", simp add: LAT4)  apply (rule LAT3)
      apply (simp add: update_def upd_def)
done
(*>*)

lemma COMP:
  "\<lbrakk> X \<rhd> c1 : Sec (Q p K) (EQ G q) (EQ K q) \<Phi>;
     X \<rhd> c2 : Sec (Q p H) (EQ K q) (EQ H q) \<Psi>;
    \<forall> x . LEQ (G x) (K x) \<or> LEQ p (K x);
    \<forall> x . LEQ (K x) (H x) \<or> LEQ p (H x)\<rbrakk>
   \<Longrightarrow> X \<rhd> Comp c1 c2 : Sec (Q p H) (EQ G q) (EQ H q)
        (\<lambda> (x, y) . \<exists> z . \<Phi> (z, y) \<and>
                          (\<forall> w . EQ K q z w \<longrightarrow> \<Psi> (x, w)))"
(*<*)
  apply (rule VDMConseq, rule VDMComp, assumption, assumption, clarsimp)
    apply (erule thin_rl, erule thin_rl)
  apply (simp add: Sec_def, rule, clarsimp)
    apply (simp add: Q_def, clarsimp)
    apply (rotate_tac 3, erule_tac x=x in allE, erule impE, assumption)
    apply (erule_tac x=x in allE, clarsimp)
    apply (erule_tac x=x in allE, clarsimp)
    apply (subgoal_tac "LEQ p (H x)", fast)
    apply (erule LAT2) apply assumption
  apply (rule, clarsimp)
    apply (rule_tac x=r in exI, simp)
  apply clarsimp
done
(*>*)

text\<open>We distinguish, for any given $q$, \emph{parallel} conditionals
from \emph{diagonal} ones. Speaking operationally (i.e.~in terms of
two executions), conditionals of the former kind evaluate the branch
condition identically in both executions. The following rule
expresses this condition explicitly, in the first side condition. The
formula inside the $\mathit{Sec}$-operator of the conclusion resembles
the conclusion of the VDM rule for conditionals in that the formula
chosen depends on the outcome of the branch.\<close>

lemma IF_PARALLEL:
  "\<lbrakk> \<forall> s ss . EQ G p s ss \<longrightarrow> evalB b s = evalB b ss;
     \<forall> x. LEQ (G x) (H x) \<or> LEQ p (H x);
     \<exists> x . LEQ p (H x) \<and> LEQ (H x) q;
     X \<rhd> c1 : Sec (Q p H) (EQ G q) (EQ H q) \<Phi>;
     X \<rhd> c2 : Sec (Q p H) (EQ G q) (EQ H q) \<Psi>\<rbrakk>
  \<Longrightarrow> X \<rhd> Iff b c1 c2 : Sec (Q p H) (EQ G q) (EQ H q)
                       (\<lambda> (r, u) . (evalB b u \<longrightarrow> \<Phi> (r, u)) \<and>
                                   ( (\<not> evalB b u) \<longrightarrow> \<Psi> (r, u)))"
(*<*)
    apply (rule VDMConseq, rule VDMIff) apply (assumption, assumption) apply clarsimp
    apply (simp add: Sec_def Q_def)
    apply (subgoal_tac "(\<forall>x. \<not> LEQ p (H x) \<longrightarrow> t x = s x)", simp)
    prefer 2 apply (case_tac "evalB b s", clarsimp,clarsimp)
    apply (rule, clarsimp)
    (*left component of Sec*)
      apply (subgoal_tac "evalB b s = evalB b r")
      prefer 2 apply (erule_tac x=s in allE, rotate_tac -1, erule_tac x=r in allE, erule mp)
        apply (erule EQ_LEQ) apply (erule LAT2, assumption)
      apply (case_tac "evalB b s")
              apply clarsimp
              apply clarsimp
    (*right component of Sec*)
      apply clarsimp
      apply (case_tac "evalB b s")
        apply clarsimp
        apply clarsimp
done
(*>*)

text\<open>An alternative formulation replaces the first side condition
with a typing hypothesis on the branch condition, thus exploiting
lemma HS\_B\_eval.\<close>

lemma IF_PARALLEL_tp:
  "\<lbrakk> (G, b, p) \<in> HS_B; (p , G, c1, H) \<in> HS; (p, G, c2, H) \<in> HS;
     \<exists> x . LEQ p (H x) \<and> LEQ (H x) q;
     X \<rhd> c1 : Sec (Q p H) (EQ G q) (EQ H q) \<Phi>;
     X \<rhd> c2 : Sec (Q p H) (EQ G q) (EQ H q) \<Psi>\<rbrakk>
  \<Longrightarrow> X \<rhd> Iff b c1 c2 : Sec (Q p H) (EQ G q) (EQ H q)
                       (\<lambda> (r, u) . (evalB b u \<longrightarrow> \<Phi> (r, u)) \<and>
                                   ( (\<not> evalB b u) \<longrightarrow> \<Psi> (r, u)))"
(*<*)
  apply (rule IF_PARALLEL)
    apply (clarsimp, erule HS_B_eval) apply assumption apply (rule LAT6)
    apply (erule HS_Aux1)
    apply assumption+
done
(*>*)

text\<open>Diagonal conditionals, in contrast, capture cases where (from
the perspective of an observer at level $q$) the two executions may
evaluate the branch condition differently. In this case, the formula
inside the $\mathit{Sec}$-operator in the conclusion cannot depend
upon the branch outcome, so the least common denominator of the two
branches must be taken, which is given by the equality condition
w.r.t.~the post-context $H$. A side condition (the first one given in
the rule) ensures that indeed no information leaks during the
execution of either branch, by relating $G$ and $H$.\<close>

lemma IF_DIAGONAL:
  "\<lbrakk> \<forall>x. LEQ (G x) (H x) \<or> LEQ p (H x);
      \<not> (\<exists>x. LEQ p (H x) \<and> LEQ (H x) q);
      X \<rhd> c1 : Sec (Q p H) (EQ G q) (EQ H q) \<Phi>;
      X \<rhd> c2 : Sec (Q p H) (EQ G q) (EQ H q) \<Psi>\<rbrakk>
   \<Longrightarrow> X \<rhd> Iff b c1 c2 : Sec (Q p H) (EQ G q) (EQ H q)
                             (\<lambda> (s,t). EQ H q s t)"
(*<*)
  apply clarsimp
  apply (rule VDMConseq, rule VDMIff) apply (assumption, assumption) apply clarsimp
  apply (simp add: Sec_def Q_def)
  apply (subgoal_tac "(\<forall>x. \<not> LEQ p (H x) \<longrightarrow> t x = s x)", simp)
  prefer 2 apply (case_tac "evalB b s")
           apply clarsimp
           apply clarsimp
  apply (rule, clarsimp)
  (*Left component*)
    apply (simp (no_asm) add: EQ_def, clarsimp)
    apply (case_tac "LEQ p (H x)") apply clarsimp
    apply (rotate_tac -4, erule_tac x=x in allE, clarsimp)
    apply (simp add: EQ_def)
    apply (erule_tac x=x in allE, erule mp)
    apply (rotate_tac -4, erule_tac x=x in allE, clarsimp)
    apply (erule LAT2, assumption)
  (*right component*)
    apply clarsimp
    apply (simp add: EQ_def, clarsimp)
    apply (case_tac "LEQ p (H x)")
    apply clarsimp
    apply clarsimp
done
(*>*)

text\<open>Again, the first side condition of the rule may be replaced by a
typing condition, but now this condition is on the commands (instead
of the branch condition) -- in fact, a derivation for either branch
suffices.\<close>

lemma IF_DIAGONAL_tp:
  "\<lbrakk> (p, G, c1, H) \<in> HS \<or> (p, G, c2, H) \<in> HS;
      \<not> (\<exists>x. LEQ p (H x) \<and> LEQ (H x) q);
      X \<rhd> c1 : Sec (Q p H) (EQ G q) (EQ H q) \<Phi>;
      X \<rhd> c2 : Sec (Q p H) (EQ G q) (EQ H q) \<Psi>\<rbrakk>
   \<Longrightarrow> X \<rhd> Iff b c1 c2 : Sec (Q p H) (EQ G q) (EQ H q)
                             (\<lambda> (s,t). EQ H q s t)"
(*<*)
  apply (rule IF_DIAGONAL)
    apply (erule disjE) apply (erule HS_Aux1) apply (erule HS_Aux1)
    apply assumption+
done
(*>*)

text\<open>Obviously, given $q$, any conditional is either parallel or
diagonal as the second side conditions of the diagonal rules and the
parallel rules are exclusive.\<close>

lemma if_algorithmic:
  "\<lbrakk>\<exists> x . LEQ p (H x) \<and> LEQ (H x) q;
    \<not> (\<exists>x. LEQ p (H x) \<and> LEQ (H x) q)\<rbrakk>
   \<Longrightarrow> False"
(*<*) by simp (*>*)

text\<open>As in Section \ref{sec:BaseLineNI} we define a fixed point
construction, useful for the (parallel) while rule.\<close>

definition FIX::"(TT \<Rightarrow> TT) \<Rightarrow> TT"
where "FIX \<phi> = (\<lambda> (s,t). \<forall> \<Phi> . (\<forall> ss tt . \<phi> \<Phi> (ss, tt) \<longrightarrow> \<Phi> (ss, tt))
                            \<longrightarrow> \<Phi> (s, t))"

text\<open>For monotone invariant transformers, the construction indeed
yields a fixed point.\<close>

definition Monotone::"(TT \<Rightarrow> TT) \<Rightarrow> bool"
where "Monotone \<phi> = (\<forall> \<Phi> \<Psi> . (\<forall> s t . \<Phi>(s,t) \<longrightarrow> \<Psi>(s,t)) \<longrightarrow>
                        (\<forall> s t . \<phi> \<Phi> (s,t) \<longrightarrow> \<phi> \<Psi> (s,t)))"

(*<*)
lemma Fix2: "\<lbrakk>Monotone \<phi>; \<phi> (FIX \<phi>) (s, t)\<rbrakk> \<Longrightarrow> FIX \<phi> (s,t)"
apply (simp add: FIX_def) apply clarsimp
apply (subgoal_tac "\<phi> \<Phi> (s,t)", simp)
apply (subgoal_tac "\<forall> r u . FIX \<phi> (r,u) \<longrightarrow> \<Phi>(r,u)")
prefer 2 apply (erule thin_rl) apply (simp add: FIX_def) apply clarsimp
  apply (erule_tac x=\<Phi> in allE, simp)
apply (unfold Monotone_def)
  apply (erule_tac x="FIX \<phi>" in allE, erule_tac x=\<Phi> in allE)
  apply (erule impE) apply assumption
  apply (simp add: FIX_def)
done

lemma Fix1: "\<lbrakk>Monotone \<phi>; FIX \<phi> (s,t)\<rbrakk> \<Longrightarrow> \<phi> (FIX \<phi>) (s,t)"
apply (simp add: FIX_def)
apply (erule_tac x="\<phi>(FIX \<phi>)" in allE)
apply (erule impE)
prefer 2 apply (simp add: FIX_def)
apply (subgoal_tac "\<forall> r u . \<phi> (FIX \<phi>) (r,u) \<longrightarrow> FIX \<phi> (r,u)")
  prefer 2 apply clarsimp apply (erule Fix2) apply assumption
apply (unfold Monotone_def)
  apply (erule_tac x="\<phi>(FIX \<phi>)" in allE, erule_tac x="FIX \<phi>" in allE, erule impE) apply assumption
apply simp
done
(*>*)
lemma Fix_lemma:"Monotone \<phi> \<Longrightarrow> \<phi> (FIX \<phi>) = FIX \<phi>"
(*<*)
apply (rule ext, rule iffI)
apply clarsimp apply (erule Fix2) apply assumption
apply clarsimp apply (erule Fix1) apply assumption
done
(*>*)

text\<open>Next, the definition of a while-operator.\<close>

definition PhiWhilePOp::
          "VDMAssn \<Rightarrow> BExpr \<Rightarrow> TT \<Rightarrow> TT \<Rightarrow> TT"
where "PhiWhilePOp A b \<Phi> =
  (\<lambda> \<Psi> . (\<lambda>(r, u). (evalB b u \<longrightarrow> (\<exists>z. \<Phi> (z, u) \<and>
                                        (\<forall>w. A z w \<longrightarrow> \<Psi> (r, w)))) \<and>
                     ((\<not> evalB b u) \<longrightarrow> A r u)))"

text\<open>This operator is monotone in $\Phi$.\<close>

lemma PhiWhilePOp_Monotone:"Monotone (PhiWhilePOp A b \<Phi>)"
(*<*)
apply (simp add: PhiWhilePOp_def Monotone_def) apply clarsimp
  apply (rule_tac x=z in exI, simp)
done
(*>*)

text\<open>Therefore, we can define the following fixed point.\<close>

definition PhiWhileP::"VDMAssn \<Rightarrow> BExpr \<Rightarrow> TT \<Rightarrow> TT"
where "PhiWhileP A b \<Phi> = FIX (PhiWhilePOp A b \<Phi>)"

text\<open>As as a function on $\phi$, this PhiWhileP is itself monotone
in $\phi$:\<close>

lemma PhiWhilePMonotone: "Monotone (\<lambda> \<Phi> . PhiWhileP A b \<Phi>)"
(*<*)
apply (simp add: Monotone_def) apply clarsimp
apply (simp add: PhiWhileP_def)
apply (simp add: FIX_def) apply clarsimp
apply (erule_tac x=\<Phi>' in allE, erule mp)
apply (clarsimp) apply (erule_tac x=ss in allE, erule_tac x=tt in allE, erule mp)
apply (simp add: PhiWhilePOp_def) apply clarsimp
apply (rule_tac x=z in exI, simp)
done
(*>*)

text\<open>Now the rule for parallel while loops, i.e.~loops where the
branch condition evaluates identically in both executions.\<close>

lemma WHILE_PARALLEL:
 "\<lbrakk> X \<rhd> c : Sec (Q p G) (EQ G q) (EQ G q) \<Phi>;
    \<forall> s ss . EQ G p s ss \<longrightarrow> evalB b s = evalB b ss; LEQ p q\<rbrakk>
 \<Longrightarrow> X \<rhd> While b c : Sec (Q p G) (EQ G q) (EQ G q)
                         (PhiWhileP (EQ G q) b \<Phi>)"
(*<*)
apply (rule VDMConseq)
apply (rule VDMWhile)
prefer 4 apply (subgoal_tac "\<forall>s t. Sec (Q p G) (EQ G q) (EQ G q) (PhiWhilePOp (EQ G q) b \<Phi> (PhiWhileP (EQ G q) b \<Phi>)) s t \<and> \<not> evalB b t \<longrightarrow> Sec (Q p G) (EQ G q) (EQ G q) (PhiWhileP (EQ G q) b \<Phi>) s t") apply assumption
  apply clarsimp apply (subgoal_tac "PhiWhilePOp (EQ G q) b \<Phi> (PhiWhileP (EQ G q) b \<Phi>) = PhiWhileP (EQ G q) b \<Phi>", clarsimp)
                 apply (simp add: PhiWhileP_def) apply (rule Fix_lemma) apply (rule PhiWhilePOp_Monotone)
apply assumption
apply clarsimp apply (simp add: Sec_def)
  apply rule apply (simp add: Q_def)
  apply (rule, clarsimp) apply (simp add: PhiWhilePOp_def) apply clarsimp
      apply (erule_tac x=s in allE, erule_tac x=r in allE, erule impE) apply (erule EQ_LEQ) apply assumption apply clarsimp
  apply clarsimp apply (simp add: PhiWhilePOp_def)
apply clarsimp apply (simp add: Sec_def)
  apply rule apply clarsimp apply (simp add: Q_def)
  apply rule
  prefer 2 apply clarsimp
    apply (subgoal_tac "\<exists>r. \<Phi> (r, s) \<and> (\<forall>w. EQ G q r w \<longrightarrow> (PhiWhileP (EQ G q) b \<Phi>) (ra, w))")
    prefer 2 apply (simp add: PhiWhilePOp_def)
    apply clarsimp apply (rotate_tac -3, erule thin_rl)
    apply (rotate_tac -1, erule_tac x=ra in allE, erule mp)
    apply (rotate_tac 1, erule_tac x=r in allE, erule impE) apply fast
    apply (subgoal_tac "PhiWhilePOp (EQ G q) b \<Phi> (PhiWhileP (EQ G q) b \<Phi>) = PhiWhileP (EQ G q) b \<Phi>", clarsimp)
    apply (simp add: PhiWhileP_def)
    apply (rule Fix_lemma) apply (rule PhiWhilePOp_Monotone)
  apply clarsimp
    apply (simp (no_asm_simp) add: PhiWhilePOp_def)
    apply rule
    prefer 2  apply clarsimp
              apply (erule_tac x=s in allE, rotate_tac -1, erule_tac x=ra in allE, erule impE)
               apply (erule EQ_LEQ) apply assumption apply clarsimp
    apply clarsimp
    apply (rotate_tac 2, erule_tac x=ra in allE, clarsimp)
    apply (rule_tac x=r in exI, rule) apply simp
    apply clarsimp
    apply (rotate_tac 5, erule_tac x=w in allE, clarsimp)
    apply (subgoal_tac "PhiWhilePOp (EQ G q) b \<Phi> (PhiWhileP (EQ G q) b \<Phi>) = PhiWhileP (EQ G q) b \<Phi>", clarsimp)
    apply (simp add: PhiWhileP_def)
    apply (rule Fix_lemma) apply (rule PhiWhilePOp_Monotone)
done
(*>*)

text\<open>The side condition regarding the evalution of the branch
condsition may be replaced by a typing hypothesis, thanks to lemma
\<open>HS_B_eval\<close>.\<close>

lemma WHILE_PARALLEL_tp:
 "\<lbrakk> X \<rhd> c : Sec (Q p G) (EQ G q) (EQ G q) \<Phi>;
    (G, b, p) \<in> HS_B; LEQ p q\<rbrakk>
 \<Longrightarrow> X \<rhd> While b c : Sec (Q p G) (EQ G q) (EQ G q)
                         (PhiWhileP (EQ G q) b \<Phi>)"
(*<*)
apply (erule WHILE_PARALLEL)
apply clarsimp
  apply (erule HS_B_eval) apply assumption apply (rule LAT6)
apply assumption
done
(*>*)

text\<open>One may also give an inductive formulation of FIX:\<close>

inductive_set var::"(BExpr \<times> VDMAssn \<times> TT \<times> State \<times> State) set"
where
varFalse:
   "\<lbrakk>\<not> evalB b t; A s t\<rbrakk> \<Longrightarrow> (b,A,\<Phi>,s,t):var"
| varTrue:
   "\<lbrakk>evalB b t; \<Phi>(r,t); (\<forall> w . A r w \<longrightarrow>
    (b,A,\<Phi>,s,w): var) \<rbrakk> \<Longrightarrow> (b,A,\<Phi>,s,t):var"

(*<*)
lemma varFIX: "(b,A,\<Phi>,s,t):var \<Longrightarrow> PhiWhileP A b \<Phi> (s,t)"
apply (erule var.induct)
apply (simp add: PhiWhileP_def)
  apply (subgoal_tac "PhiWhilePOp A b \<Phi> (FIX (PhiWhilePOp A b \<Phi>)) (s,t)")
  apply (subgoal_tac "PhiWhilePOp A b \<Phi> (FIX (PhiWhilePOp A b \<Phi>)) = FIX (PhiWhilePOp A b \<Phi>)", clarsimp)
  apply (rule Fix_lemma) apply (rule PhiWhilePOp_Monotone)
  apply (simp add: PhiWhilePOp_def)
apply (simp (no_asm_simp) add: PhiWhileP_def)
apply (subgoal_tac "PhiWhilePOp A b \<Phi> (FIX (PhiWhilePOp A b \<Phi>)) (s,t)")
  apply (subgoal_tac "PhiWhilePOp A b \<Phi> (FIX (PhiWhilePOp A b \<Phi>)) = FIX (PhiWhilePOp A b \<Phi>)", clarsimp)
  apply (rule Fix_lemma) apply (rule PhiWhilePOp_Monotone)
  apply (simp add: PhiWhilePOp_def)
  apply (rule_tac x=r in exI, simp)
  apply clarsimp
  apply (erule_tac x=w in allE, clarsimp)
  apply (simp add: PhiWhileP_def)
  apply (simp add: PhiWhilePOp_def)
done

lemma FIXvar: "PhiWhileP A b \<Phi> (s,t) \<Longrightarrow> (b,A,\<Phi>,s,t):var"
apply (simp add: PhiWhileP_def)
apply (subgoal_tac "PhiWhilePOp A b \<Phi> (FIX (PhiWhilePOp A b \<Phi>)) (s, t)")
prefer 2
  apply (subgoal_tac "PhiWhilePOp A b \<Phi> (FIX (PhiWhilePOp A b \<Phi>)) = FIX (PhiWhilePOp A b \<Phi>)", clarsimp)
  apply (rule Fix_lemma) apply (rule PhiWhilePOp_Monotone)
apply (erule thin_rl, simp add: PhiWhilePOp_def) apply clarsimp
  apply (case_tac "evalB b t")
  prefer 2 apply clarsimp apply (rule varFalse) apply assumption+
  apply clarsimp apply (rule varTrue) apply assumption apply assumption
    apply clarsimp apply (erule_tac x=w in allE, clarsimp)
    apply (unfold FIX_def) apply clarify
    apply (erule_tac x="\<lambda> (x,y) . (b,A,\<Phi>,x,y):var" in allE, erule impE) prefer 2 apply simp
    apply clarsimp
    apply (case_tac "evalB b tt")
    prefer 2 apply clarsimp apply (rule varFalse) apply assumption+
    apply clarsimp apply (rule varTrue) apply assumption+
done
(*>*)

text\<open>The inductive formulation and the fixed point formulation are
equivalent.\<close>
(*<*)
lemma varFIXvar: "(PhiWhileP A b \<Phi> (s,t)) = ((b,A,\<Phi>,s,t):var)"
apply rule
apply (erule FIXvar)
apply (erule varFIX)
done
(*>*)
(*<*)
lemma FIXvarFIX': "(PhiWhileP A b \<Phi>) = (\<lambda> (s,t) . (b,A,\<Phi>,s,t):var)"
apply (rule ext, rule iffI)
apply (case_tac x, clarsimp) apply (erule FIXvar)
apply (case_tac x, clarsimp) apply (simp add: varFIXvar)
done
(*>*)
lemma FIXvarFIX:
"PhiWhileP A b = (\<lambda> \<Phi> . (\<lambda> (s,t) . (b,A,\<Phi>,s,t):var))"
(*<*)
by (rule, rule FIXvarFIX')
(*>*)

text\<open>Thus, the above while rule may also be written using the
inductive formulation.\<close>

lemma WHILE_PARALLEL_IND:
 "\<lbrakk> X \<rhd> c : Sec (Q p G) (EQ G q) (EQ G q) \<Phi>;
    \<forall> s ss . EQ G p s ss \<longrightarrow> evalB b s = evalB b ss; LEQ p q\<rbrakk> \<Longrightarrow>
   X \<rhd> While b c : (Sec (Q p G) (EQ G q) (EQ G q)
                    (\<lambda> (s,t) . (b,EQ G q,\<Phi>,s,t):var))"
(*<*)
apply (rule VDMConseq)
apply (rule WHILE_PARALLEL) apply assumption+
apply clarsimp
apply (simp add: FIXvarFIX)
done
(*>*)

text\<open>Again, we may replace the side condition regarding the branch
condition by a typing hypothesis.\<close>

lemma WHILE_PARALLEL_IND_tp:
 "\<lbrakk> X \<rhd> c : Sec (Q p G) (EQ G q) (EQ G q) \<Phi>;
    (G, b, p) \<in> HS_B; LEQ p q \<rbrakk> \<Longrightarrow>
 X \<rhd> (While b c) :
  (Sec (Q p G) (EQ G q) (EQ G q) (\<lambda> (s,t) . (b,EQ G q,\<Phi>,s,t):var))"
(*<*)
apply (erule WHILE_PARALLEL_IND)
apply clarsimp
  apply (erule HS_B_eval) apply assumption apply (rule LAT6)
apply assumption
done
(*>*)
(*<*)
lemma varMonotoneAux[rule_format]:
 "(b, A, \<Phi>, s, t) \<in> var \<Longrightarrow>
  (\<forall>s t. \<Phi> (s, t) \<longrightarrow> \<Psi> (s, t)) \<longrightarrow>
  (b, A, \<Psi>, s, t) \<in> var"
apply (erule var.induct)
apply clarsimp apply (erule varFalse, simp)
apply clarsimp apply (erule varTrue) apply fast apply simp
done
(*>*)
text\<open>Of course, the inductive formulation is also monotone:\<close>

lemma var_MonotoneInPhi:
  "Monotone (\<lambda> \<Phi> . (\<lambda> (s,t) .(b,A, \<Phi>,s,t):var))"
(*<*)
apply (simp add: Monotone_def)
apply clarsimp
apply (rule varMonotoneAux) apply assumption apply simp
done
(*>*)
(*<*)
lemma varMonotone_byFIX: "Monotone (\<lambda> \<Phi> . (\<lambda> (s,t) .(b,A, \<Phi>,s,t):var))"
apply (subgoal_tac "Monotone (\<lambda> \<Phi> . PhiWhileP A b \<Phi>)")
apply (simp add: FIXvarFIX)
apply (rule PhiWhilePMonotone)
done
(*>*)

text\<open>In order to derive a diagonal while rule, we directly define an
inductive relation that calculates the transitive closure of relation
$A$, such that all but the last state evaluate $b$ to
$\mathit{True}$.\<close>

inductive_set varD::"(BExpr \<times> VDMAssn \<times> State \<times> State) set"
where
varDFalse: "\<lbrakk>\<not> evalB b s; A s t\<rbrakk> \<Longrightarrow> (b,A,s,t):varD"
| varDTrue: "\<lbrakk>evalB b s; A s w; (b,A,w,t): varD \<rbrakk> \<Longrightarrow> (b,A,s,t):varD"

text\<open>Here is the obvious definition of transitivity for assertions.\<close>

definition transitive::"VDMAssn \<Rightarrow> bool"
where "transitive P = (\<forall> x y z . P x y \<longrightarrow> P y z \<longrightarrow> P x z)"

text\<open>The inductive relation satisfies the following property.\<close>

lemma varD_transitive[rule_format]:
 "(b,A,s,t):varD \<Longrightarrow> transitive A \<longrightarrow> A s t"
(*<*)
apply (erule varD.induct)
apply clarsimp
apply clarsimp
  apply (unfold transitive_def) apply (erule_tac x=s in allE, erule_tac x=w in allE, erule_tac x=t in allE, simp)
done
(*>*)

text\<open>On the other hand, the assertion $\mathit{Q}$ defined above is transitive,\<close>

lemma Q_transitive:"transitive (Q q G)"
(*<*)
by (simp add: Q_def transitive_def)
(*>*)

text\<open>and is hence respected by the inductive closure:\<close>

lemma varDQ:"(b,Q q G,s,t):varD \<Longrightarrow> Q q G s t"
(*<*)by (erule varD_transitive,rule Q_transitive)(*>*)

text\<open>The diagonal while rule has a conclusion that is independent of
$\phi$.\<close>

lemma WHILE_DIAGONAL:
 "\<lbrakk>X \<rhd> c : Sec (Q p G) (EQ G q) (EQ G q) \<Phi>; \<not> LEQ p q\<rbrakk>
       \<Longrightarrow> X \<rhd> While b c : Sec (Q p G) (EQ G q) (EQ G q)
                               (\<lambda> (s,t). EQ G q s t)"
(*<*)
apply (subgoal_tac "\<forall>x. LEQ p (G x) \<longrightarrow> \<not> LEQ (G x) q")
prefer 2 apply (case_tac "\<forall>x. LEQ p (G x) \<longrightarrow> \<not> LEQ (G x) q", assumption) apply clarsimp
  apply (subgoal_tac "LEQ p q", fast)
  apply (erule LAT2, assumption)
apply (rule VDMConseq)
apply (insert VDMWhile)
  apply (erule VDMWhile [of X c "Sec (Q p G) (EQ G q) (EQ G q) \<Phi>" b "(\<lambda> s t . (b,Q p G,s,t):varD)"])
    apply clarsimp apply (erule varDFalse) apply (simp add: Q_def)
    apply clarsimp apply (simp add: Sec_def) apply clarsimp
      apply (rule varDTrue) apply assumption prefer 2 apply assumption
        apply (erule_tac x=s in allE, erule impE, simp add: EQ_def) apply assumption
apply clarsimp
apply (simp add: Sec_def)
apply rule apply (erule varDQ)
apply (rule, clarsimp)
  apply (drule varDQ)  apply (simp add: Q_def EQ_def, clarsimp)
  apply (case_tac "LEQ p (G x)") prefer 2 apply simp
  apply (rotate_tac -1, drule LAT2) apply assumption apply fast
apply (drule varDQ)  apply (simp add: Q_def EQ_def, clarsimp)
  apply (case_tac "LEQ p (G x)") prefer 2 apply simp
  apply (rotate_tac -1, drule LAT2) apply assumption apply fast
done
(*>*)

text\<open>$\mathit{varD}$ is monotone in the assertion position.\<close>

(*<*)
text\<open>As $\mathit{varD}$ does not depend on $\Phi$, the monotonicity
property in this position is trivially fulfilled.\<close>

lemma varDMonotoneInPhi[rule_format]:
  "\<lbrakk>(b, A, s, t) \<in> varD; \<forall>s t. \<Phi>(s, t) \<longrightarrow> \<Psi>(s, t)\<rbrakk>
  \<Longrightarrow> (b, A, s, t) \<in> varD"
by simp
(*>*)

text\<open>Finally, the subsumption rule.\<close>

lemma SUB:
  "\<lbrakk> LEQ p pp; \<forall>x. LEQ (G x) (GG x); \<forall>x. LEQ (HH x) (H x);
     X \<rhd> c : Sec (Q pp HH) (EQ GG q) (EQ HH q) \<Phi>\<rbrakk>
   \<Longrightarrow> X \<rhd> c : Sec (Q p H) (EQ G q) (EQ H q) \<Phi>"
(*<*)
apply (erule VDMConseq)
  apply (simp add: Sec_def EQ_def, clarsimp)
  apply (rule, simp add: Q_def, clarsimp)
    apply (erule_tac x=x in allE, erule mp, clarsimp)
    apply (subgoal_tac "LEQ p (H x)", fast)
    apply (rotate_tac 2, erule_tac x=x in allE)
    apply (erule LAT2)
    apply (erule LAT2, assumption)
  apply (rule, clarsimp)
    apply (erule_tac x=r in allE, erule mp, clarsimp)
    apply (erule_tac x=x in allE, erule mp)
    apply (erule_tac x=x in allE, erule LAT2,assumption)
  apply clarsimp
    apply (erule_tac x=r in allE, erule impE, assumption)
    apply (erule_tac x=x in allE, erule mp)
    apply (erule_tac x=x in allE, erule LAT2, assumption)
done
(*>*)

subsection\<open>Soundness results\<close>

(*<*)
definition Theorem3derivProp::"VDMAssn set \<Rightarrow> L \<Rightarrow> CONTEXT \<Rightarrow> IMP \<Rightarrow> CONTEXT \<Rightarrow> L \<Rightarrow> bool"
where "Theorem3derivProp X p G c H q = (\<exists> \<Phi> . X \<rhd> c : (Sec (Q p H) (EQ G q) (EQ H q) \<Phi>))"

lemma Theorem3_derivAux[rule_format]:
"(p,G,c,H):HS \<Longrightarrow> Theorem3derivProp X p G c H q"
apply (erule HS.induct)
apply (simp_all add: Theorem3derivProp_def)
(*Skip*)
  apply (rule, rule SKIP)
(*Assign*)
  apply (rule, rule ASSIGN[simplified]) apply simp
  apply (clarsimp, erule HS_E_eval) apply assumption apply (rule LAT6)
(*COMP*)
apply clarsimp
  apply (rule, rule COMP) apply (assumption, assumption) apply (erule HS_Aux1)
  apply (erule HS_Aux1)
(*IFF*)
  apply clarsimp
  apply (subgoal_tac "(G, b, LUB p t) \<in> HS_B", erule thin_rl)
  prefer 2 apply (erule HS_B_sup) apply (subgoal_tac "LEQ t (LUB t p)", simp add: LAT4) apply (rule LAT3)
  apply (subgoal_tac "\<exists> psi. X \<rhd> Iff b c d : Sec (Q (LUB p t) H) (EQ G q) (EQ H q) psi", clarsimp)
  apply (rule_tac x=psi in exI, erule VDMConseq, clarsimp)
    apply (simp add: Sec_def, clarsimp)
    apply (simp add: Q_def, clarsimp)
    apply (erule_tac x=x in allE, erule mp, clarsimp)
    apply (subgoal_tac "LEQ p (LUB p t)")
    prefer 2 apply (rule LAT3)
    apply (rotate_tac -1, drule LAT2) apply assumption apply simp
  apply (case_tac "\<exists> x . LEQ (LUB p t) (H x) \<and> LEQ (H x) q")
    apply (rule, erule IF_PARALLEL_tp) apply assumption+
    apply (rule, rule IF_DIAGONAL) apply (erule HS_Aux1) apply assumption+
(*If2*)
  apply clarsimp
  apply (case_tac "\<exists> x . LEQ p (H x) \<and> LEQ (H x) q")
    apply (rule, erule IF_PARALLEL_tp) apply assumption+
    apply (rule, rule IF_DIAGONAL) apply (erule HS_Aux1) apply assumption+
(*While*)
  apply clarsimp
  apply (subgoal_tac "(G, b, LUB p t) \<in> HS_B", erule thin_rl)
  prefer 2 apply (erule HS_B_sup) apply (subgoal_tac "LEQ t (LUB t p)", simp add: LAT4) apply (rule LAT3)
  apply (subgoal_tac "\<exists> psi. X \<rhd> While b c : Sec (Q (LUB p t) G) (EQ G q) (EQ G q) psi", clarsimp)
  apply (rule_tac x=psi in exI, erule VDMConseq, clarsimp)
    apply (simp add: Sec_def, clarsimp)
    apply (simp add: Q_def, clarsimp)
    apply (erule_tac x=x in allE, erule mp, clarsimp)
    apply (subgoal_tac "LEQ p (LUB p t)")
    prefer 2 apply (rule LAT3)
    apply (rotate_tac -1, drule LAT2) apply assumption apply simp
  apply (case_tac "LEQ (LUB p t) q")
    apply (rule, rule WHILE_PARALLEL) apply assumption
      apply clarsimp apply (erule HS_B_eval)  apply assumption apply (rule LAT6) apply assumption
  (*OTHER CASE*)
  apply (rule, erule WHILE_DIAGONAL) apply assumption
(*Sub*)
  apply clarsimp
  apply (rule, erule SUB, assumption+)
done
(*>*)

text\<open>An induction on the typing rules now proves the main theorem
which was called Theorem 4 in~\<^cite>\<open>"BeringerHofmann:CSF2007"\<close>.\<close>

theorem Theorem4[rule_format]:
  "(p,G,c,H):HS \<Longrightarrow>
  (\<exists> \<Phi> . X \<rhd> c : (Sec (Q p H) (EQ G q) (EQ H q) \<Phi>))"
(*<*)
by (drule Theorem3_derivAux, simp add: Theorem3derivProp_def)
(*>*)

text\<open>By the construction of the operator $\mathit{Sec}$ (lemmas
\<open>Prop4A\<close> and \<open>Prop4A\<close> in Section \ref{sec:ARSsecurity}) we
obtain the soundness property with respect to the oprational
semantics, i.e.~the result stated as Theorem 3.3 in
\<^cite>\<open>"HuntSands:POPL2006"\<close>.\<close>

theorem HuntSands33: "(p,G,c,H):HS \<Longrightarrow> secure p G c H"
(*<*)
apply (simp add: secure_def, clarsimp)
apply (drule Theorem4, clarsimp)
apply (rule Prop4A)
apply (rule VDM_Sound_emptyCtxt)  apply fast
done
(*>*)

text \<open>Both parts of this theorem may also be shown
individually. We factor both proofs by the program logic.\<close>

lemma Sec1_deriv: "(p,G,c,H):HS \<Longrightarrow> X \<rhd> c : (Q p H)"
(*<*)
apply (drule Theorem4, clarsimp)
apply (erule VDMConseq)
apply (simp add: Sec_def) apply clarsimp
done
(*>*)

(*<*)
lemma
 "(p,G,c,H):HS \<Longrightarrow>
  X \<rhd> c : (\<lambda> s t . \<forall> x . \<not> LEQ p (H x) \<longrightarrow> s x = t x)"
apply (drule Sec1_deriv) apply (erule VDMConseq) apply (simp add: Q_def)
done
(*>*)

theorem HuntSands33_1:"(p,G,c,H):HS \<Longrightarrow> secure1 p G c H"
(*<*)
apply (subgoal_tac "{} \<rhd> c : Q p H")
apply (drule VDM_Sound)
  apply (simp add: Q_def secure1_def valid_def VDM_valid_def Ctxt_valid_def)
apply (erule Sec1_deriv)
done(*>*)

lemma Sec2_deriv:
  "(p,G,c,H):HS \<Longrightarrow>
  (\<exists> A . X \<rhd> c : (Sec (Q p H) (EQ G q) (EQ H q) A))"
(*<*)
by (drule Theorem4 [of p G c H "X" q], clarsimp)
(*>*)

(*<*)
lemma Sec2:
  "(p,G,c,H):HS \<Longrightarrow>
   (\<exists> \<Phi> . \<Turnstile> c : (Sec (Q p H) (EQ G q) (EQ H q) \<Phi>))"
apply (drule Theorem4 [of p G c H "{}" q], clarsimp)
apply (rule_tac x=\<Phi> in exI, erule VDM_Sound_emptyCtxt)
done
(*>*)

theorem HuntSands33_2: "(p,G,c,H):HS \<Longrightarrow> secure2 q G c H"
(*<*)
apply (subgoal_tac "\<forall> q . ARSsecure (Q p H) (EQ G q) (EQ H q) c")
prefer 2 apply clarsimp
         apply (drule Sec2_deriv[of p G c H "{}"], erule exE)
         apply (rule Prop4A) apply (erule VDM_Sound_emptyCtxt)
apply (insert secureEQUIV [of p G c H]) apply (simp add: secure_def)
done
(*>*)

text\<open>Again, the call rule is formulated for an arbitrary fixed point
of a monotone transformer.\<close>

lemma CALL:
  "\<lbrakk> ({B} \<union> X) \<rhd> body : Sec A R S (\<phi>(FIX \<phi>));
      Monotone \<phi>; B = Sec A R S (FIX \<phi>) \<rbrakk>
   \<Longrightarrow> X \<rhd> Call : B"
(*<*)
apply (rule VDMCall)
apply (subgoal_tac "\<phi> (FIX \<phi>) = FIX \<phi>", clarsimp)
apply (erule Fix_lemma)
done
(*>*)

(*<*)
text\<open>Monotonicity lemmas for the operators occurring in the derived proof rules.\<close>
lemma SkipMonotone:"Monotone (\<lambda> T (s,t). EQ G p s t)"
by (simp add: Monotone_def)

lemma AssignMonotone:"Monotone (\<lambda> T (s,t). \<exists>r. s = update r x (evalE e r) \<and> EQ G p r t)"
by (simp add: Monotone_def)

lemma CompMonotone: "Monotone (\<lambda> T (s,t). \<exists> r. A r t \<and> (\<forall>w. EQ K q r w \<longrightarrow> B s w))"
by (simp add: Monotone_def)

lemma IfPMonotone1: "Monotone (\<lambda> T (s,t). (evalB b t \<longrightarrow> T(s,t)) \<and> (\<not> evalB b t \<longrightarrow> B (s,t)))"
by (simp add: Monotone_def)

lemma IfPMonotone2: "Monotone (\<lambda> T (s,t). (evalB b t \<longrightarrow> A(s,t)) \<and> (\<not> evalB b t \<longrightarrow> T (s,t)))"
by (simp add: Monotone_def)

lemma IfDMonotone:"Monotone (\<lambda> T (s,t). EQ G p s t)"
by (simp add: Monotone_def)

lemma WhileDMonotone: "Monotone (\<lambda> T (s,t). EQ G q s t)"
by (simp add: Monotone_def)

lemma SubMonotone: "Monotone (\<lambda>T. T)"
by (simp add: Monotone_def)
(*>*)

text\<open>As in Section \ref{sec:BaseLineNI}, we define a formal derivation system
comprising all derived rules and show that all derivable judgements
are of the for $\mathit{Sec}(\Phi)$ for some monotone $\Phi$.\<close>

inductive_set Deriv:: "(VDMAssn set \<times> IMP \<times> VDMAssn) set"
where
D_SKIP:
  "\<Omega> = (\<lambda> (s,t). EQ G q s t)
 \<Longrightarrow> (X, Skip, Sec (Q p H) (EQ G q) (EQ G q) \<Omega>) : Deriv"

| D_ASSIGN:
  "\<lbrakk>H = upd G x (LUB p t);
    \<forall> s ss . EQ G t s ss \<longrightarrow> evalE e s = evalE e ss;
    \<Omega> = (\<lambda> (s, t) . \<exists> r . s = update r x (evalE e r) \<and> EQ G q r t)\<rbrakk>
\<Longrightarrow> (X, Assign x e, Sec (Q p H) (EQ G q) (EQ H q) \<Omega>) : Deriv"

| D_COMP:
  "\<lbrakk> (X, c, Sec (Q p K) (EQ G q) (EQ K q) \<Phi>) : Deriv;
     (X, d, Sec (Q p H) (EQ K q) (EQ H q) \<Psi>) : Deriv;
    \<forall> x . LEQ (G x) (K x) \<or> LEQ p (K x);
    \<forall> x . LEQ (K x) (H x) \<or> LEQ p (H x);
    \<Omega> = (\<lambda> (x, y) . \<exists> z . \<Phi>(z,y) \<and> (\<forall> w . EQ K q z w \<longrightarrow> \<Psi>(x,w)))\<rbrakk>
 \<Longrightarrow> (X, Comp c d, Sec (Q p H) (EQ G q) (EQ H q) \<Omega>) : Deriv"

| D_IF_PARALLEL:
  "\<lbrakk> \<forall> s ss . EQ G p s ss \<longrightarrow> evalB b s = evalB b ss;
     \<forall> x. LEQ (G x) (H x) \<or> LEQ p (H x);
     \<exists> x . LEQ p (H x) \<and> LEQ (H x) q;
     (X, c, Sec (Q p H) (EQ G q) (EQ H q) \<Phi>) : Deriv;
     (X, d, Sec (Q p H) (EQ G q) (EQ H q) \<Psi>) : Deriv;
     \<Omega> = (\<lambda> (r, u) . (evalB b u \<longrightarrow> \<Phi>(r,u)) \<and>
                      ( (\<not> evalB b u) \<longrightarrow> \<Psi>(r,u)))\<rbrakk>
  \<Longrightarrow> (X, Iff b c d, Sec (Q p H) (EQ G q) (EQ H q) \<Omega>) : Deriv"

| D_IF_DIAGONAL:
  "\<lbrakk> \<forall>x. LEQ (G x) (H x) \<or> LEQ p (H x);
     \<not> (\<exists>x. LEQ p (H x) \<and> LEQ (H x) q);
     (X, c, Sec (Q p H) (EQ G q) (EQ H q) \<Phi>) : Deriv;
     (X, d, Sec (Q p H) (EQ G q) (EQ H q) \<Psi>) : Deriv;
     \<Omega> = (\<lambda> (s,t) . EQ H q s t)\<rbrakk>
   \<Longrightarrow> (X, Iff b c d, Sec (Q p H) (EQ G q) (EQ H q) \<Omega>) : Deriv"

| D_WHILE_PARALLEL:
 "\<lbrakk> (X, c, Sec (Q p G) (EQ G q) (EQ G q) \<Phi>):Deriv;
    \<forall> s ss . EQ G p s ss \<longrightarrow> evalB b s = evalB b ss; LEQ p q;
    \<Omega> = (\<lambda> (s,t) . (b,EQ G q,\<Phi>,s,t):var)\<rbrakk>
   \<Longrightarrow> (X, While b c, Sec (Q p G) (EQ G q) (EQ G q) \<Omega>):Deriv"

| D_WHILE_DIAGONAL:
 "\<lbrakk>(X, c, Sec (Q p G) (EQ G q) (EQ G q) \<Phi>) : Deriv; \<not> LEQ p q;
   \<Omega> = (\<lambda> (s,t) . EQ G q s t)\<rbrakk>
 \<Longrightarrow> (X, While b c, Sec (Q p G) (EQ G q) (EQ G q) \<Omega>) : Deriv"

| D_SUB:
  "\<lbrakk> LEQ p pp; \<forall>x. LEQ (G x) (GG x); \<forall>x. LEQ (HH x) (H x);
     (X, c, Sec (Q pp HH) (EQ GG q) (EQ HH q) \<Phi>) : Deriv\<rbrakk>
   \<Longrightarrow> (X, c, Sec (Q p H) (EQ G q) (EQ H q) \<Phi>) :Deriv"

| D_CALL:
  "({A} \<union> X,body,A): Deriv \<Longrightarrow> (X,Call,A) : Deriv"

(*<*)
definition DProp :: "VDMAssn \<Rightarrow> bool"
where "DProp B = (\<exists> A R S \<phi> . B =  Sec A R S (\<phi> (FIX \<phi>)) \<and> Monotone \<phi>)"

lemma DerivProp_Aux: "(X,c,A):Deriv \<Longrightarrow> DProp A"
apply (erule Deriv.induct)
apply (simp_all add: DProp_def)
apply (rule_tac x="Q p H" in exI,
       rule_tac x="EQ G q" in exI,
       rule_tac x="EQ G q" in exI)
       apply rule apply rule
       apply simp
       apply (simp add: Monotone_def)
apply (rule_tac x="(Q p (upd G x (LUB p t)))" in exI,
       rule_tac x="EQ G q" in exI,
       rule_tac x="(EQ (upd G x (LUB p t)) q)" in exI)
       apply rule apply rule
       apply simp
       apply (simp add: Monotone_def)
apply clarsimp
apply (rule_tac x="Q p H" in exI,
       rule_tac x="EQ G q" in exI,
       rule_tac x="EQ H q" in exI)
       apply rule apply rule
       apply simp
       apply (simp add: Monotone_def)
apply clarsimp
apply (rule_tac x="Q p H" in exI,
       rule_tac x="EQ G q" in exI,
       rule_tac x="EQ H q" in exI)
       apply rule apply rule apply simp
       apply (simp add: Monotone_def)
apply clarsimp
apply (rule_tac x="Q p H" in exI,
       rule_tac x="EQ G q" in exI,
       rule_tac x="EQ H q" in exI)
       apply rule apply rule
       apply simp
       apply (simp add: Monotone_def)
apply clarsimp
apply (rule_tac x="Q p G" in exI,
       rule_tac x="EQ G q" in exI,
       rule_tac x="EQ G q" in exI)
       apply rule apply rule
       apply simp
       apply (simp add: Monotone_def)
apply clarsimp
apply (rule_tac x="Q p G" in exI,
       rule_tac x="EQ G q" in exI,
       rule_tac x="EQ G q" in exI)
       apply rule apply rule
       apply simp
       apply (simp add: Monotone_def)
apply clarsimp
apply (rule_tac x="Q p H" in exI,
       rule_tac x="EQ G q" in exI,
       rule_tac x="EQ H q" in exI)
       apply rule apply rule apply simp
       apply (simp add: Monotone_def)
done
(*>*)

lemma DerivMono:
 "(X,c,B):Deriv \<Longrightarrow>
  \<exists> A R S \<phi> . B =  Sec A R S (\<phi> (FIX \<phi>)) \<and> Monotone \<phi>"
(*<*)
by (drule DerivProp_Aux, simp add: DProp_def)
(*>*)

text\<open>Also, the \<open>Deriv\<close> is indeed a subsystem of the program
logic.\<close>

theorem Deriv_derivable: "(X,c,A):Deriv \<Longrightarrow> X \<rhd> c :A"
(*<*)
apply (erule Deriv.induct)
apply clarify apply (rule SKIP)
apply clarify apply (rule_tac t=t in ASSIGN) apply simp apply assumption
apply clarify apply (rule COMP) apply assumption apply assumption apply assumption apply assumption
apply clarify apply (rule IF_PARALLEL) apply assumption apply assumption apply (rule_tac x=x in exI, simp) apply assumption apply assumption
apply clarify apply (rule IF_DIAGONAL) apply assumption apply assumption apply assumption apply assumption
apply clarify apply (rule WHILE_PARALLEL_IND) apply assumption apply assumption apply assumption
apply clarify apply (rule WHILE_DIAGONAL) apply assumption apply assumption
apply (rule SUB) apply assumption apply assumption apply assumption apply assumption
apply (frule DerivMono) apply (erule exE)+ apply clarsimp
  apply (subgoal_tac "X \<rhd> Call : Sec Aa R S (FIX \<phi>)")
  prefer 2 apply (rule CALL)
    prefer 2 apply assumption
    apply (simp add: Fix_lemma)
    apply simp
  apply (simp add: Fix_lemma)
done
(*>*)
text\<open>End of theory HuntSands\<close>
end


theory prop_70
imports Main
        "$HIPSTER_HOME/IsaHipster"
begin
  datatype Nat = Z | S "Nat"
  fun le :: "Nat => Nat => bool" where
  "le (Z) y = True"
  | "le (S z) (Z) = False"
  | "le (S z) (S x2) = le z x2"
  (*hipster le *)
  theorem x0 :
    "(le m n) ==> (le m (S n))"
    by (tactic \<open>Subgoal.FOCUS_PARAMS (K (Tactic_Data.hard_tac @{context})) @{context} 1\<close>)
end


           (*-------------------------------------------*
            |        CSP-Prover on Isabelle2004         |
            |               December 2004               |
            |                   June 2005  (modified)   |
            |              September 2005  (modified)   |
            |                                           |
            |        CSP-Prover on Isabelle2005         |
            |                October 2005  (modified)   |
            |                January 2006  (modified)   |
            |                  April 2006  (modified)   |
            |                  March 2007  (modified)   |
            |                 August 2007  (modified)   |
            |                                           |
            |        CSP-Prover on Isabelle2009         |
            |                   June 2009  (modified)   |
            |                                           |
            |        Yoshinao Isobe (AIST JAPAN)        |
            *-------------------------------------------*)

theory CSP_F_law_basic
imports CSP_F_law_decompo CSP_T_law_basic
begin

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

         1. Commutativity
         2. Associativity
         3. Idempotence
         4. Left Commutativity
         5. IF

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

(*********************************************************
                       IF bool
 *********************************************************)

(*------------------*
 |      csp law     |
 *------------------*)

lemma cspF_IF_split:
  "IF b THEN P ELSE Q =F[M,M] (if b then P else Q)"
apply (simp add: cspF_semantics)
apply (simp add: traces_iff)
apply (simp add: failures_iff)
done

lemma cspF_IF_True:
  "IF True THEN P ELSE Q =F[M,M] P"
apply (rule cspF_rw_left)
apply (rule cspF_IF_split)
by (simp)

lemma cspF_IF_False:
  "IF False THEN P ELSE Q =F[M,M] Q"
apply (rule cspF_rw_left)
apply (rule cspF_IF_split)
by (simp)

lemmas cspF_IF = cspF_IF_True cspF_IF_False

(*-----------------------------------*
 |           Idempotence             |
 *-----------------------------------*)

lemma cspF_Ext_choice_idem:
  "P [+] P =F[M,M] P"
apply (simp add: cspF_cspT_semantics)
apply (simp add: cspT_Ext_choice_idem)
apply (rule order_antisym)
 apply (rule, simp add: in_traces in_failures)
 apply (elim conjE disjE)
 apply (simp_all)
 apply (rule proc_F2_F4)
 apply (simp_all)
 apply (rule, simp add: in_traces in_failures)
done

lemma cspF_Int_choice_idem:
  "P |~| P =F[M,M] P"
apply (simp add: cspF_cspT_semantics)
apply (simp add: cspT_Int_choice_idem)
apply (rule order_antisym)
 apply (rule, simp add: in_failures)+
done

(*------------------*
 |      csp law     |
 *------------------*)

lemmas cspF_idem = cspF_Ext_choice_idem cspF_Int_choice_idem

(*-----------------------------------*
 |          Commutativity            |
 *-----------------------------------*)

(*********************************************************
                      Ext choice
 *********************************************************)

lemma cspF_Ext_choice_commut:
  "P [+] Q =F[M,M] Q [+] P"
apply (simp add: cspF_cspT_semantics)
apply (simp add: cspT_Ext_choice_commut)

apply (rule order_antisym)
apply (rule, simp add: in_failures, fast)+
done

(*********************************************************
                      Int choice
 *********************************************************)

lemma cspF_Int_choice_commut:
  "P |~| Q =F[M,M] Q |~| P"
apply (simp add: cspF_cspT_semantics)
apply (simp add: cspT_Int_choice_commut)
apply (rule order_antisym)
apply (rule, simp add: in_failures, fast)+
done

(*********************************************************
                      Parallel
 *********************************************************)

lemma cspF_Parallel_commut:
  "P |[X]| Q =F[M,M] Q |[X]| P"
apply (simp add: cspF_cspT_semantics)
apply (simp add: cspT_Parallel_commut)
apply (rule order_antisym)

apply (rule, simp add: in_failures)
apply (elim conjE exE)
apply (rule_tac x="Z" in exI)
apply (rule_tac x="Y" in exI, simp)
apply (rule conjI, fast)
apply (rule_tac x="t" in exI)
apply (rule_tac x="sa" in exI)
apply (simp add: par_tr_sym)

apply (rule, simp add: in_failures)
apply (elim conjE exE)
apply (rule_tac x="Z" in exI)
apply (rule_tac x="Y" in exI, simp)
apply (rule conjI, fast)
apply (rule_tac x="t" in exI)
apply (rule_tac x="sa" in exI)
apply (simp add: par_tr_sym)
done

(*------------------*
 |      csp law     |
 *------------------*)

lemmas cspF_commut = cspF_Ext_choice_commut cspF_Int_choice_commut cspF_Parallel_commut

(*-----------------------------------*
 |          Associativity            |
 *-----------------------------------*)

lemma cspF_Ext_choice_assoc:
  "P [+] (Q [+] R) =F[M,M] (P [+] Q) [+] R"
apply (simp add: cspF_cspT_semantics)
apply (simp add: cspT_Ext_choice_assoc)
apply (rule order_antisym)
apply (rule, simp add: in_failures in_traces)
apply (force)
apply (rule, simp add: in_failures in_traces)
apply (force)
done

lemma cspF_Ext_choice_assoc_sym:
  "(P [+] Q) [+] R =F[M,M] P [+] (Q [+] R)"
apply (rule cspF_sym)
apply (simp add: cspF_Ext_choice_assoc)
done

lemma cspF_Int_choice_assoc:
  "P |~| (Q |~| R) =F[M,M] (P |~| Q) |~| R"
apply (simp add: cspF_cspT_semantics)
apply (simp add: cspT_Int_choice_assoc)
apply (rule order_antisym)
apply (rule, simp add: in_failures)+
done

lemma cspF_Int_choice_assoc_sym:
  "(P |~| Q) |~| R =F[M,M] P |~| (Q |~| R)"
apply (rule cspF_sym)
apply (simp add: cspF_Int_choice_assoc)
done

(*------------------*
 |      csp law     |
 *------------------*)

lemmas cspF_assoc = cspF_Ext_choice_assoc cspF_Int_choice_assoc
lemmas cspF_assoc_sym = cspF_Ext_choice_assoc_sym cspF_Int_choice_assoc_sym

(*-----------------------------------*
 |        Left Commutativity         |
 *-----------------------------------*)

lemma cspF_Ext_choice_left_commut:
  "P [+] (Q [+] R) =F[M,M] Q [+] (P [+] R)"
apply (simp add: cspF_cspT_semantics)
apply (simp add: cspT_Ext_choice_left_commut)
apply (rule order_antisym)
apply (rule, simp add: in_failures in_traces)
apply (force)
apply (rule, simp add: in_failures in_traces)
apply (force)
done

lemma cspF_Int_choice_left_commut:
  "P |~| (Q |~| R) =F[M,M] Q |~| (P |~| R)"
apply (simp add: cspF_cspT_semantics)
apply (simp add: cspT_Int_choice_left_commut)
apply (rule order_antisym)
 apply (rule, simp add: in_failures)+
done

lemmas cspF_left_commut =
       cspF_Ext_choice_left_commut cspF_Int_choice_left_commut

(*-----------------------------------*
 |              Unit                 |
 *-----------------------------------*)

(*** STOP [+] P ***)

lemma cspF_Ext_choice_unit_l:
  "STOP [+] P =F[M,M] P"
apply (simp add: cspF_cspT_semantics)
apply (simp add: cspT_Ext_choice_unit_l)
apply (rule order_antisym)
 apply (rule, simp add: in_traces in_failures)
 apply (elim conjE disjE)
 apply (simp_all)
 apply (rule proc_F2_F4)
 apply (simp_all)

 apply (rule, simp add: in_failures)
done

lemma cspF_Ext_choice_unit_r:
  "P [+] STOP =F[M,M] P"
apply (rule cspF_rw_left)
apply (rule cspF_Ext_choice_commut)
apply (simp add: cspF_Ext_choice_unit_l)
done

lemmas cspF_Ext_choice_unit =
       cspF_Ext_choice_unit_l cspF_Ext_choice_unit_r

lemma cspF_Int_choice_unit_l:
  "DIV |~| P =F[M,M] P"
apply (simp add: cspF_cspT_semantics)
apply (simp add: cspT_Int_choice_unit_l)
apply (rule order_antisym)
 apply (rule, simp add: in_failures)
 apply (rule, simp add: in_failures)
done

lemma cspF_Int_choice_unit_r:
  "P |~| DIV =F[M,M] P"
apply (rule cspF_rw_left)
apply (rule cspF_Int_choice_commut)
apply (simp add: cspF_Int_choice_unit_l)
done

lemmas cspF_Int_choice_unit =
       cspF_Int_choice_unit_l cspF_Int_choice_unit_r

lemmas cspF_unit = cspF_Ext_choice_unit cspF_Int_choice_unit

(*-----------------------------------*
 |           !!-empty                |
 *-----------------------------------*)

lemma cspF_Rep_int_choice_sum_DIV:
   "sumset C = {} ==> !! : C .. Pf =F[M1,M2] DIV"
apply (simp add: cspF_cspT_semantics)
apply (simp add: cspT_Rep_int_choice_DIV)
apply (simp add: failures_iff)
apply (simp add: empF_def)
done

lemma cspF_Rep_int_choice_nat_DIV:
   "!nat :{} .. Pf =F[M1,M2] DIV"
by (simp add: Rep_int_choice_ss_def cspF_Rep_int_choice_sum_DIV)

lemma cspF_Rep_int_choice_set_DIV:
   "!set :{} .. Pf =F[M1,M2] DIV"
by (simp add: Rep_int_choice_ss_def cspF_Rep_int_choice_sum_DIV)

lemma cspF_Rep_int_choice_com_DIV:
   "! :{} .. Pf =F[M1,M2] DIV"
by (simp add: Rep_int_choice_com_def cspF_Rep_int_choice_set_DIV)

lemma cspF_Rep_int_choice_f_DIV:
   "inj f ==> !<f> :{} .. Pf =F[M1,M2] DIV"
by (simp add: Rep_int_choice_f_def cspF_Rep_int_choice_com_DIV)

lemmas cspF_Rep_int_choice_DIV = cspF_Rep_int_choice_sum_DIV
                                 cspF_Rep_int_choice_nat_DIV
                                 cspF_Rep_int_choice_set_DIV
                                 cspF_Rep_int_choice_com_DIV
                                 cspF_Rep_int_choice_f_DIV

lemmas cspF_Rep_int_choice_DIV_sym = cspF_Rep_int_choice_DIV[THEN cspF_sym]
lemmas cspF_Rep_int_choice_empty = cspF_Rep_int_choice_DIV

lemma cspF_DIV_top: "P <=F DIV"
apply (simp add: cspF_semantics)
apply (simp add: traces_iff failures_iff)
done

(*-----------------------------------*
 |             !!-unit               |
 *-----------------------------------*)

lemma cspF_Rep_int_choice_sum_unit:
  "sumset C ~= {} ==> !! c:C .. P =F[M,M] P"
apply (simp add: cspF_cspT_semantics)
apply (simp add: cspT_Rep_int_choice_unit)
apply (rule order_antisym)
 apply (rule, simp add: in_failures)
 apply (rule, simp add: in_failures)
 apply (force)
done

lemma cspF_Rep_int_choice_nat_unit:
  "N ~= {} ==> !nat n:N .. P =F[M,M] P"
by (simp add: Rep_int_choice_ss_def cspF_Rep_int_choice_sum_unit)

lemma cspF_Rep_int_choice_set_unit:
  "Xs ~= {} ==> !set X:Xs .. P =F[M,M] P"
by (simp add: Rep_int_choice_ss_def cspF_Rep_int_choice_sum_unit)

lemma cspF_Rep_int_choice_com_unit:
  "X ~= {} ==> ! a:X .. P =F[M,M] P"
by (simp add: Rep_int_choice_com_def cspF_Rep_int_choice_set_unit)

lemma cspF_Rep_int_choice_f_unit:
  "X ~= {} ==> !<f> a:X .. P =F[M,M] P"
by (simp add: Rep_int_choice_f_def cspF_Rep_int_choice_com_unit)

lemmas cspF_Rep_int_choice_unit =
       cspF_Rep_int_choice_sum_unit
       cspF_Rep_int_choice_nat_unit
       cspF_Rep_int_choice_set_unit
       cspF_Rep_int_choice_com_unit
       cspF_Rep_int_choice_f_unit

(*-----------------------------------*
 |             !!-const              |
 *-----------------------------------*)

(* const *)

lemma cspF_Rep_int_choice_sum_const:
  "[| sumset C ~= {} ; ALL c: sumset C. Pf c = P |] ==> !! :C .. Pf =F[M,M] P"
apply (simp add: cspF_cspT_semantics)
apply (simp add: cspT_Rep_int_choice_const)
apply (rule order_antisym)
 apply (rule, simp add: in_failures)
 apply (rule, simp add: in_failures)
 apply (force)
done

lemma cspF_Rep_int_choice_nat_const:
  "[| N ~= {} ; ALL n:N. Pf n = P |] ==> !nat :N .. Pf =F[M,M] P"
apply (simp add: Rep_int_choice_ss_def)
by (rule cspF_Rep_int_choice_sum_const, auto)

lemma cspF_Rep_int_choice_set_const:
  "[| Xs ~= {} ; ALL X:Xs. Pf X = P |] ==> !set :Xs .. Pf =F[M,M] P"
apply (simp add: Rep_int_choice_ss_def)
by (rule cspF_Rep_int_choice_sum_const, auto)

lemma cspF_Rep_int_choice_com_const:
  "[| X ~= {} ; ALL a:X. Pf a = P |] ==> ! :X .. Pf =F[M,M] P"
apply (simp add: Rep_int_choice_com_def)
by (rule cspF_Rep_int_choice_set_const, auto)

lemma cspF_Rep_int_choice_f_const:
  "[| inj f ; X ~= {} ; ALL a:X. Pf a = P |] ==> !<f> :X .. Pf =F[M,M] P"
apply (simp add: Rep_int_choice_f_def)
by (rule cspF_Rep_int_choice_com_const, auto)

lemmas cspF_Rep_int_choice_const =
       cspF_Rep_int_choice_sum_const
       cspF_Rep_int_choice_nat_const
       cspF_Rep_int_choice_set_const
       cspF_Rep_int_choice_com_const
       cspF_Rep_int_choice_f_const

(*-----------------------------------*
 |           |~|-!!-union            |
 *-----------------------------------*)

lemma cspF_Int_Rep_int_choice_sum_union:
  "C1 =type= C2 ==>
   (!! :C1 .. P1f) |~| (!! :C2 .. P2f)
   =F[M,M] (!! c:(C1 Uns C2) ..
          IF (c : sumset C1 & c : sumset C2) THEN (P1f c |~| P2f c)
          ELSE IF (c : sumset C1) THEN P1f c ELSE P2f c)"
apply (simp add: cspF_cspT_semantics)
apply (simp add: cspT_Int_Rep_int_choice_union)
apply (rule order_antisym)

 apply (rule)
 apply (simp add: in_failures)
 apply (elim conjE bexE disjE)
  apply (rule_tac x="c" in bexI)
  apply (simp)
  apply (simp)
  apply (rule_tac x="c" in bexI)
  apply (simp)
  apply (simp)

(* => *)
 apply (rule)
 apply (simp add: in_failures)
 apply (elim conjE exE bexE)
 apply (simp_all)
 apply (elim disjE)
 apply (simp_all)
 apply (case_tac "c : sumset C2")
 apply (simp add: in_failures)
 apply (force)
 apply (simp add: in_failures)
 apply (force)
 apply (case_tac "c : sumset C1")
 apply (simp add: in_failures)
 apply (force)
 apply (simp add: in_failures)
 apply (force)
done

lemma cspF_Int_Rep_int_choice_nat_union:
  "(!nat :N1 .. P1f) |~| (!nat :N2 .. P2f)
   =F[M,M] (!nat n:(N1 Un N2) ..
          IF (n : N1 & n : N2) THEN (P1f n |~| P2f n)
          ELSE IF (n : N1) THEN P1f n ELSE P2f n)"
apply (simp add: Rep_int_choice_ss_def)
apply (rule cspF_rw_left)
apply (rule cspF_Int_Rep_int_choice_sum_union)
apply (simp_all)
apply (rule cspF_decompo)
by (auto)

lemma cspF_Int_Rep_int_choice_set_union:
  "(!set :Xs1 .. P1f) |~| (!set :Xs2 .. P2f)
   =F[M,M] (!set X:(Xs1 Un Xs2) ..
          IF (X : Xs1 & X : Xs2) THEN (P1f X |~| P2f X)
          ELSE IF (X : Xs1) THEN P1f X ELSE P2f X)"
apply (simp add: Rep_int_choice_ss_def)
apply (rule cspF_rw_left)
apply (rule cspF_Int_Rep_int_choice_sum_union)
apply (simp_all)
apply (rule cspF_decompo)
by (auto)

lemma cspF_Int_Rep_int_choice_com_union:
  "(! :X1 .. P1f) |~| (! :X2 .. P2f)
   =F[M,M] (! a:(X1 Un X2) ..
          IF (a : X1 & a : X2) THEN (P1f a |~| P2f a)
          ELSE IF (a : X1) THEN P1f a ELSE P2f a)"
apply (simp add: Rep_int_choice_com_def)
apply (rule cspF_rw_left)
apply (rule cspF_Int_Rep_int_choice_set_union)
apply (simp_all)
apply (rule cspF_decompo)
by (auto)

lemma cspF_Int_Rep_int_choice_f_union:
  "inj f ==>
  (!<f> :X1 .. P1f) |~| (!<f> :X2 .. P2f)
   =F[M,M] (!<f> a:(X1 Un X2) ..
          IF (a : X1 & a : X2) THEN (P1f a |~| P2f a)
          ELSE IF (a : X1) THEN P1f a ELSE P2f a)"
apply (simp add: Rep_int_choice_f_def)
apply (rule cspF_rw_left)
apply (rule cspF_Int_Rep_int_choice_com_union)
apply (rule cspF_decompo)
apply (auto simp add: inj_image_mem_iff)
done

lemmas cspF_Int_Rep_int_choice_union =
       cspF_Int_Rep_int_choice_sum_union
       cspF_Int_Rep_int_choice_nat_union
       cspF_Int_Rep_int_choice_set_union
       cspF_Int_Rep_int_choice_com_union
       cspF_Int_Rep_int_choice_f_union

(*-----------------------------------*
 |           !!-union-|~|            |
 *-----------------------------------*)

lemma cspF_Rep_int_choice_sum_union_Int:
  "C1 =type= C2 ==>
  (!! :(C1 Uns C2) .. Pf)
   =F[M,M] (!! c:C1 .. Pf c) |~| (!! c:C2 .. Pf c)"
apply (rule cspF_rw_right)
apply (rule cspF_Int_Rep_int_choice_union)
apply (simp)
apply (rule cspF_decompo)
apply (simp)
apply (rule cspF_rw_right)
apply (rule cspF_IF_split)
apply (simp)
apply (simp add: cspF_idem[THEN cspF_sym])
apply (intro impI)
apply (rule cspF_rw_right)
apply (rule cspF_IF_split)
apply (simp)
done

lemma cspF_Rep_int_choice_nat_union_Int:
  "(!nat :(N1 Un N2) .. Pf)
   =F[M,M] (!nat n:N1 .. Pf n) |~| (!nat n:N2 .. Pf n)"
apply (simp add: Rep_int_choice_ss_def)
apply (rule cspF_rw_right)
apply (rule cspF_Rep_int_choice_sum_union_Int[THEN cspF_sym])
apply (simp_all)
done

lemma cspF_Rep_int_choice_set_union_Int:
  "(!set :(Xs1 Un Xs2) .. Pf)
   =F[M,M] (!set X:Xs1 .. Pf X) |~| (!set X:Xs2 .. Pf X)"
apply (simp add: Rep_int_choice_ss_def)
apply (rule cspF_rw_right)
apply (rule cspF_Rep_int_choice_sum_union_Int[THEN cspF_sym])
apply (simp_all)
done

lemma cspF_Rep_int_choice_com_union_Int:
  "(! :(X1 Un X2) .. Pf)
   =F[M,M] (! a:X1 .. Pf a) |~| (! a:X2 .. Pf a)"
apply (simp add: Rep_int_choice_com_def)
apply (rule cspF_rw_right)
apply (rule cspF_Rep_int_choice_set_union_Int[THEN cspF_sym])
apply (rule cspF_decompo)
apply (auto)
done

lemma cspF_Rep_int_choice_f_union_Int:
  "(!<f> :(X1 Un X2) .. Pf)
   =F[M,M] (!<f> x:X1 .. Pf x) |~| (!<f> x:X2 .. Pf x)"
apply (simp add: Rep_int_choice_f_def)
apply (rule cspF_rw_right)
apply (rule cspF_Rep_int_choice_com_union_Int[THEN cspF_sym])
apply (rule cspF_decompo)
apply (auto)
done

lemmas cspF_Rep_int_choice_union_Int =
       cspF_Rep_int_choice_sum_union_Int
       cspF_Rep_int_choice_nat_union_Int
       cspF_Rep_int_choice_set_union_Int
       cspF_Rep_int_choice_com_union_Int
       cspF_Rep_int_choice_f_union_Int

(*********************************************************
                     Depth_rest
 *********************************************************)

(*------------------*
 |      csp law     |
 *------------------*)

lemma cspF_Depth_rest_Zero:
  "P |. 0 =F[M1,M2] DIV"
apply (simp add: cspF_cspT_semantics)
apply (simp add: cspT_Depth_rest_Zero)
apply (rule order_antisym)

(* => *)
 apply (rule)
 apply (simp add: in_failures)
 apply (force)

(* <= *)
 apply (rule)
 apply (simp add: in_failures)
done

lemma cspF_Depth_rest_min:
  "P |. n |. m =F[M,M] P |. min n m"
apply (simp add: cspF_cspT_semantics)
apply (simp add: cspT_Depth_rest_min)
apply (simp add: failures.simps)
apply (simp add: min_rs)
done

lemma cspF_Depth_rest_congE:
  "[| P =F[M1,M2] Q ; ALL m. P |. m =F[M1,M2] Q |. m ==> S |] ==> S"
apply (simp add: cspF_semantics)
apply (simp add: traces.simps)
apply (simp add: failures.simps)
done

lemma cspF_Depth_rest_n:
  "P |. n |. n =F[M,M] P |. n"
apply (rule cspF_rw_left)
apply (rule cspF_Depth_rest_min)
apply (simp)
done

(*------------------*
 |     !nat-rest    |
 *------------------*)

lemma cspF_nat_Depth_rest_UNIV:
  "P =F[M,M] !nat n .. (P |. n)"
apply (simp add: cspF_cspT_semantics)
apply (simp add: cspT_nat_Depth_rest_UNIV)
apply (rule order_antisym)

 (* <= *)
 apply (rule)
 apply (simp add: in_failures)
 apply (case_tac "noTick s")

  apply (rule_tac x="Suc (lengtht s)" in exI)
  apply (simp)

  apply (rule_tac x="lengtht s" in exI)
  apply (simp)
  apply (rule_tac x="(butlastt s)" in exI)
  apply (simp add: Tick_decompo)
  apply (simp add: noTick_butlast)

 (* => *)
 apply (rule)
 apply (simp add: in_failures)
done

lemma cspF_nat_Depth_rest_lengthset:
   "P =F[M,M] !nat n:(lengthset P (fstF o M)) .. (P |. n)"
apply (simp add: cspF_cspT_semantics)
apply (simp add: cspT_nat_Depth_rest_lengthset)
apply (rule order_antisym)

 (* <= *)
 apply (rule)
 apply (simp add: in_failures)
 apply (case_tac "noTick s")

  apply (rule_tac x="Suc (lengtht s)" in bexI)
  apply (simp)
  apply (simp add: lengthset_def)
  apply (rule_tac x="s" in exI)
  apply (simp add: proc_T2)

  apply (rule_tac x="lengtht s" in bexI)
  apply (simp)
  apply (rule_tac x="(butlastt s)" in exI)
  apply (simp add: Tick_decompo)
  apply (simp add: noTick_butlast)
  apply (simp add: lengthset_def)
  apply (rule_tac x="s" in exI)
  apply (simp add: proc_T2)

 (* => *)
 apply (rule)
 apply (simp add: in_failures)
done

lemmas cspF_nat_Depth_rest = cspF_nat_Depth_rest_UNIV
                             cspF_nat_Depth_rest_lengthset

(*------------------*
 |    ?-partial     |
 *------------------*)

lemma cspF_Ext_pre_choice_partial:
  "? :X -> Pf =F[M,M] ? x:X -> (IF (x:X) THEN Pf x ELSE DIV)"
apply (rule cspF_decompo)
apply (simp_all)
apply (rule cspF_rw_right)
apply (rule cspF_IF)
apply (simp)
done

(*------------------*
 |   !!-partial     |
 *------------------*)

lemma cspF_Rep_int_choice_sum_partial:
  "!! :C .. Pf =F[M,M] !! c:C .. (IF (c: sumset C) THEN Pf c ELSE DIV)"
apply (rule cspF_decompo)
apply (simp_all)
apply (rule cspF_rw_right)
apply (rule cspF_IF)
apply (simp)
done

lemma cspF_Rep_int_choice_nat_partial:
  "!nat :N .. Pf =F[M,M] !nat n:N .. (IF (n:N) THEN Pf n ELSE DIV)"
apply (rule cspF_decompo)
apply (simp_all)
apply (rule cspF_rw_right)
apply (rule cspF_IF)
apply (simp)
done

lemma cspF_Rep_int_choice_set_partial:
  "!set :Xs .. Pf =F[M,M] !set X:Xs .. (IF (X:Xs) THEN Pf X ELSE DIV)"
apply (rule cspF_decompo)
apply (simp_all)
apply (rule cspF_rw_right)
apply (rule cspF_IF)
apply (simp)
done

lemma cspF_Rep_int_choice_com_partial:
  "! :X .. Pf =F[M,M] ! a:X .. (IF (a:X) THEN Pf a ELSE DIV)"
apply (rule cspF_decompo)
apply (simp_all)
apply (rule cspF_rw_right)
apply (rule cspF_IF)
apply (simp)
done

lemma cspF_Rep_int_choice_f_partial:
  "inj f ==> !<f> :X .. Pf =F[M,M] !<f> a:X .. (IF (a:X) THEN Pf a ELSE DIV)"
apply (rule cspF_decompo)
apply (simp_all)
apply (rule cspF_rw_right)
apply (rule cspF_IF)
apply (simp)
done

lemmas cspF_Rep_int_choice_partial =
       cspF_Rep_int_choice_sum_partial
       cspF_Rep_int_choice_nat_partial
       cspF_Rep_int_choice_set_partial
       cspF_Rep_int_choice_com_partial
       cspF_Rep_int_choice_f_partial

(* =================================================== *
 |             addition for CSP-Prover 5               |
 * =================================================== *)

(* --------------------------------------------------- *
       unfold only the first Sending and Receiving
 * --------------------------------------------------- *)

lemma cspF_first_Send_prefix:
  "a ! v -> P =F[M,M] a v -> P"
by (simp add: csp_prefix_ss_def)

lemma cspF_first_Rec_prefix:
  "a ? x:X -> Pf x =F[M,M] ? : (a ` X) -> (%x. (Pf ((inv a) x)))"
by (simp add: csp_prefix_ss_def)

lemma cspF_first_Int_pre_choice:
  "! :X -> Pf =F[M,M]  ! :X .. (%x. x -> (Pf x))"
by (simp add: csp_prefix_ss_def)

lemma cspF_first_Nondet_send_prefix:
  "a !? x:X -> Pf x =F[M,M] ! :(a ` X) -> (%x. (Pf ((inv a) x)))"
by (simp add: csp_prefix_ss_def)

lemmas cspF_first_prefix_ss =
       cspF_first_Send_prefix
       cspF_first_Rec_prefix
       cspF_first_Int_pre_choice
       cspF_first_Nondet_send_prefix

(* --------------------------------------------------- *
      Associativity of Sequential composition
 * --------------------------------------------------- *)

lemma cspF_Seq_compo_assoc:
  "(P ;; Q) ;; R =F[M,M] P ;; (Q ;; R)"
apply (simp add: cspF_cspT_semantics)
apply (simp add: cspT_Seq_compo_assoc)
apply (rule order_antisym)

 apply (rule)
 apply (simp add: in_traces in_failures)
 apply (elim disjE conjE exE)
  apply (force)

  apply (rule disjI2)
  apply (simp)
  apply (rule_tac x="sa" in exI)
  apply (rule_tac x="t" in exI)
  apply (simp)

  apply (subgoal_tac "noTick (sa ^^^ <Tick>)")
  apply (rotate_tac 3)
  apply (erule rem_asmE)
  apply (simp)
  apply (simp)

  apply (simp)
  apply (rule disjI2)
  apply (simp add: appt_decompo)
  apply (elim disjE conjE exE)

   apply (simp)
   apply (elim disjE conjE exE)
   apply (simp)
   apply (simp)
   apply (rule_tac x="sb" in exI)
   apply (rule_tac x="t" in exI)
   apply (simp)
   apply (rule disjI2)
   apply (rule_tac x="<>" in exI)
   apply (rule_tac x="t" in exI)
   apply (simp)

   apply (simp)
   apply (rotate_tac -2)
   apply (drule sym)
   apply (simp)
   apply (rotate_tac -2)
   apply (drule sym)
   apply (simp)

   apply (simp)
   apply (rule_tac x="sb" in exI)
   apply (rule_tac x="u ^^^ t" in exI)
   apply (simp add: appt_assoc)
   apply (rule disjI2)
   apply (rule_tac x="u" in exI)
   apply (rule_tac x="t" in exI)
   apply (simp)

(* => *)
 apply (rule)
 apply (simp add: in_traces in_failures)
 apply (elim disjE conjE exE)

  apply (simp)

  apply (rule disjI1)
  apply (simp)
  apply (rule disjI2)
  apply (rule_tac x="sa" in exI)
  apply (rule_tac x="t" in exI)
  apply (simp)

  apply (rule disjI2)
  apply (rule_tac x="sa ^^^ sb" in exI)
  apply (rule_tac x="ta" in exI)
  apply (simp add: appt_assoc)
  apply (rule disjI2)
  apply (rule_tac x="sa" in exI)
  apply (rule_tac x="sb ^^^ <Tick>" in exI)
  apply (simp)
done

lemma cspF_Seq_compo_assoc_sym:
  "P ;; (Q ;; R) =F[M,M] (P ;; Q) ;; R"
apply (rule cspF_sym)
apply (simp add: cspF_Seq_compo_assoc)
done

(* ---------------------------------------------- *
         decompose right internal choice
 * ---------------------------------------------- *)

lemma cspF_Int_choice_eq_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_eq_right)
apply (rule order_antisym)
apply (rule)
apply (simp add: in_failures)
apply (rule)
apply (simp add: in_failures)
done

(* -------- right -------- *)

lemma cspF_Rep_int_choice_sum_eq_right_ALL:
  "[| sumset C ~= {} ; ALL c : (sumset C). P =F[M1,M2] Qf c |]
               ==> P =F[M1,M2] !! :C .. Qf"
apply (simp add: cspF_cspT_semantics)
apply (simp add: cspT_Rep_int_choice_sum_eq_right_ALL)
apply (rule order_antisym)
apply (rule)
apply (simp add: in_failures)
apply (subgoal_tac "EX c. c: sumset C")
apply (erule exE)
apply (drule_tac x="c" in bspec, simp)
apply (erule conjE)
apply (erule order_antisymE)
apply (erule subsetFE_ALL)
apply (drule_tac x="s" in spec)
apply (drule_tac x="X" in spec)
apply (simp)
apply (fast)
apply (fast)

apply (rule)
apply (simp add: in_failures)
apply (erule bexE)
apply (drule_tac x="c" in bspec, simp)
apply (erule conjE)
apply (erule order_antisymE)
apply (rotate_tac -1)
apply (erule subsetFE_ALL)
apply (drule_tac x="s" in spec)
apply (drule_tac x="X" in spec)
apply (simp)
done

lemma cspF_Rep_int_choice_sum_eq_right:
  "[| sumset C ~= {} ; !! c. c : (sumset C) ==> P =F[M1,M2] Qf c |]
               ==> P =F[M1,M2] !! :C .. Qf"
by (simp add: cspF_Rep_int_choice_sum_eq_right_ALL)

(* nat *)

lemma cspF_Rep_int_choice_nat_eq_right:
  "[| N ~= {} ; !! n. n : N ==> P =F[M1,M2] Qf n |]
               ==> P =F[M1,M2] !nat :N .. Qf"
apply (simp add: Rep_int_choice_ss_def)
by (rule cspF_Rep_int_choice_sum_eq_right, auto)

lemma cspF_Rep_int_choice_set_eq_right:
  "[| Xs ~= {} ; !! X. X : Xs ==> P =F[M1,M2] Qf X |]
               ==> P =F[M1,M2] !set :Xs .. Qf"
apply (simp add: Rep_int_choice_ss_def)
by (rule cspF_Rep_int_choice_sum_eq_right, auto)

lemma cspF_Rep_int_choice_com_eq_right:
  "[| X ~= {} ; !! a. a:X ==> P =F[M1,M2] Qf a |]
               ==> P =F[M1,M2] ! :X .. Qf"
apply (simp add: Rep_int_choice_ss_def)
by (rule cspF_Rep_int_choice_sum_eq_right, auto)

lemma cspF_Rep_int_choice_f_eq_right:
  "[| inj f ; X ~= {} ; !! a. a:X ==> P =F[M1,M2] Qf a |]
               ==> P =F[M1,M2] !<f> :X .. Qf"
apply (simp add: Rep_int_choice_ss_def)
by (rule cspF_Rep_int_choice_sum_eq_right, auto)

lemmas cspF_int_eq_right =
       cspF_Rep_int_choice_sum_eq_right
       cspF_Rep_int_choice_nat_eq_right
       cspF_Rep_int_choice_set_eq_right
       cspF_Rep_int_choice_com_eq_right
       cspF_Rep_int_choice_f_eq_right
       cspF_Int_choice_eq_right

(* -------- left -------- *)

lemma cspF_Int_choice_eq_left:
  "[| Q1 =F[M1,M2] P ; Q2 =F[M1,M2] P |]
   ==> Q1 |~| Q2 =F[M1,M2] P"
apply (rule cspF_sym)
apply (rule cspF_int_eq_right)
apply (rule cspF_sym, simp)
apply (rule cspF_sym, simp)
done

lemma cspF_Rep_int_choice_sum_eq_left:
  "[| sumset C ~= {} ; !! c. c : (sumset C) ==> Qf c =F[M1,M2] P |]
               ==> !! :C .. Qf =F[M1,M2] P"
apply (rule cspF_sym, rule cspF_int_eq_right, simp)
apply (rule cspF_sym, simp)
done

lemma cspF_Rep_int_choice_nat_eq_left:
  "[| N ~= {} ; !! n. n : N ==> Qf n =F[M1,M2] P |]
               ==> !nat :N .. Qf =F[M1,M2] P"
apply (simp add: Rep_int_choice_ss_def)
by (rule cspF_Rep_int_choice_sum_eq_left, auto)

lemma cspF_Rep_int_choice_set_eq_left:
  "[| Xs ~= {} ; !! X. X : Xs ==> Qf X =F[M1,M2] P |]
               ==> !set :Xs .. Qf =F[M1,M2] P"
apply (simp add: Rep_int_choice_ss_def)
by (rule cspF_Rep_int_choice_sum_eq_left, auto)

lemma cspF_Rep_int_choice_com_eq_left:
  "[| X ~= {} ; !! a. a:X ==> Qf a =F[M1,M2] P |]
               ==> ! :X .. Qf =F[M1,M2] P"
apply (simp add: Rep_int_choice_ss_def)
by (rule cspF_Rep_int_choice_sum_eq_left, auto)

lemma cspF_Rep_int_choice_f_eq_left:
  "[| inj f ; X ~= {} ; !! a. a:X ==> Qf a =F[M1,M2] P |]
               ==> !<f> :X .. Qf =F[M1,M2] P"
apply (simp add: Rep_int_choice_ss_def)
by (rule cspF_Rep_int_choice_sum_eq_left, auto)

lemmas cspF_int_eq_left =
       cspF_Rep_int_choice_sum_eq_left
       cspF_Rep_int_choice_nat_eq_left
       cspF_Rep_int_choice_set_eq_left
       cspF_Rep_int_choice_com_eq_left
       cspF_Rep_int_choice_f_eq_left
       cspF_Int_choice_eq_left

(* ---------------------------------------------- *
      replicated internal choice -> binary ...
 * ---------------------------------------------- *)

(* ---- Un ---- *)

(* nat *)

lemma cspF_Rep_int_choice_nat_Un:
  "!nat n:(N1 Un N2) .. Pf n =F[M,M] !nat n:N1 .. Pf n |~| !nat n:N2 .. Pf n"
apply (simp add: cspF_cspT_semantics)
apply (simp add: cspT_Rep_int_choice_nat_Un)
apply (rule order_antisym)
apply (auto simp add: in_failures)
done

(* set *)

lemma cspF_Rep_int_choice_set_Un:
  "!set X:(Xs1 Un Xs2) .. Pf X =F[M,M] !set X:Xs2 .. Pf X |~| !set X:Xs1 .. Pf X"
apply (simp add: cspF_cspT_semantics)
apply (simp add: cspT_Rep_int_choice_set_Un)
apply (rule order_antisym)
apply (auto simp add: in_failures)
done

(* com *)

lemma cspF_Rep_int_choice_com_Un:
  "! x:(X1 Un X2) .. Pf x =F[M,M] ! x:X1 .. Pf x |~| ! x:X2 .. Pf x"
apply (simp add: cspF_cspT_semantics)
apply (simp add: cspT_Rep_int_choice_com_Un)
apply (rule order_antisym)
apply (auto simp add: in_failures)
done

(* f *)

lemma cspF_Rep_int_choice_f_Un:
  "inj f ==>
   !<f> x:(X1 Un X2) .. Pf x =F[M,M] !<f> x:X1 .. Pf x |~| !<f> x:X2 .. Pf x"
apply (simp add: cspF_cspT_semantics)
apply (simp add: cspT_Rep_int_choice_f_Un)
apply (rule order_antisym)
apply (auto simp add: in_failures)
done

lemmas cspF_Rep_int_choice_Un =
       cspF_Rep_int_choice_nat_Un
       cspF_Rep_int_choice_set_Un
       cspF_Rep_int_choice_com_Un
       cspF_Rep_int_choice_f_Un

(* ---- insert ---- *)

(* nat *)

lemma cspF_Rep_int_choice_nat_insert:
  "!nat n:(insert m N) .. Pf n =F[M,M] Pf m |~| !nat n:N .. Pf n"
apply (simp add: cspF_cspT_semantics)
apply (simp add: cspT_Rep_int_choice_nat_insert)
apply (rule order_antisym)
apply (auto simp add: in_failures)
done

(* set *)

lemma cspF_Rep_int_choice_set_insert:
  "!set X:(insert Y Xs) .. Pf X =F[M,M] Pf Y |~| !set X:Xs .. Pf X"
apply (simp add: cspF_cspT_semantics)
apply (simp add: cspT_Rep_int_choice_set_insert)
apply (rule order_antisym)
apply (auto simp add: in_failures)
done

(* com *)

lemma cspF_Rep_int_choice_com_insert:
  "! x:(insert a X) .. Pf x =F[M,M] Pf a |~| ! x:X .. Pf x"
apply (simp add: cspF_cspT_semantics)
apply (simp add: cspT_Rep_int_choice_com_insert)
apply (rule order_antisym)
apply (auto simp add: in_failures)
done

(* f *)

lemma cspF_Rep_int_choice_f_insert:
  "inj f ==> !<f> x:(insert a X) .. Pf x =F[M,M] Pf a |~| !<f> x:X .. Pf x"
apply (simp add: cspF_cspT_semantics)
apply (simp add: cspT_Rep_int_choice_f_insert)
apply (rule order_antisym)
apply (auto simp add: in_failures)
done

lemmas cspF_Rep_int_choice_insert =
       cspF_Rep_int_choice_nat_insert
       cspF_Rep_int_choice_set_insert
       cspF_Rep_int_choice_com_insert
       cspF_Rep_int_choice_f_insert

lemmas cspF_Rep_int_choice_sepa =
       cspF_Rep_int_choice_insert
       cspF_Rep_int_choice_Un

(* ---------------------------------------------- *
       simplify replicated internal choice
 * ---------------------------------------------- *)

lemma cspF_Rep_int_choice_com_map_f:
  "inj f ==> ! x:(f ` X) .. Pf x =F[M,M] !<f> x:X .. Pf (f x)"
apply (simp add: cspF_cspT_semantics)
apply (simp add: cspT_Rep_int_choice_com_map_f)
apply (rule order_antisym)
apply (auto simp add: in_failures)
done

lemma cspF_Rep_int_choice_f_map_f:
  "[| inj f ; inj g |] ==> !<f> x:(g ` X) .. Pf x =F[M,M] !<f o g> x:X .. Pf (g x)"
apply (subgoal_tac "inj (f o g)")
apply (simp add: cspF_cspT_semantics)
apply (simp add: cspT_Rep_int_choice_f_map_f)
apply (rule order_antisym)
apply (auto simp add: in_failures)
apply (auto simp add: inj_on_def)
done

lemmas cspF_Rep_int_choice_f_map =
       cspF_Rep_int_choice_com_map_f
       cspF_Rep_int_choice_f_map_f

end


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

section \<open>The Strict Function Type\<close>

theory Sfun
imports Cfun
begin

pcpodef ('a, 'b) sfun (infixr "\<rightarrow>!" 0)
  = "{f :: 'a \<rightarrow> 'b. f\<cdot>\<bottom> = \<bottom>}"
by simp_all

type_notation (ASCII)
  sfun  (infixr "->!" 0)

text \<open>TODO: Define nice syntax for abstraction, application.\<close>

definition
  sfun_abs :: "('a \<rightarrow> 'b) \<rightarrow> ('a \<rightarrow>! 'b)"
where
  "sfun_abs = (\<Lambda> f. Abs_sfun (strictify\<cdot>f))"

definition
  sfun_rep :: "('a \<rightarrow>! 'b) \<rightarrow> 'a \<rightarrow> 'b"
where
  "sfun_rep = (\<Lambda> f. Rep_sfun f)"

lemma sfun_rep_beta: "sfun_rep\<cdot>f = Rep_sfun f"
  unfolding sfun_rep_def by (simp add: cont_Rep_sfun)

lemma sfun_rep_strict1 [simp]: "sfun_rep\<cdot>\<bottom> = \<bottom>"
  unfolding sfun_rep_beta by (rule Rep_sfun_strict)

lemma sfun_rep_strict2 [simp]: "sfun_rep\<cdot>f\<cdot>\<bottom> = \<bottom>"
  unfolding sfun_rep_beta by (rule Rep_sfun [simplified])

lemma strictify_cancel: "f\<cdot>\<bottom> = \<bottom> \<Longrightarrow> strictify\<cdot>f = f"
  by (simp add: cfun_eq_iff strictify_conv_if)

lemma sfun_abs_sfun_rep [simp]: "sfun_abs\<cdot>(sfun_rep\<cdot>f) = f"
  unfolding sfun_abs_def sfun_rep_def
  apply (simp add: cont_Abs_sfun cont_Rep_sfun)
  apply (simp add: Rep_sfun_inject [symmetric] Abs_sfun_inverse)
  apply (simp add: cfun_eq_iff strictify_conv_if)
  apply (simp add: Rep_sfun [simplified])
  done

lemma sfun_rep_sfun_abs [simp]: "sfun_rep\<cdot>(sfun_abs\<cdot>f) = strictify\<cdot>f"
  unfolding sfun_abs_def sfun_rep_def
  apply (simp add: cont_Abs_sfun cont_Rep_sfun)
  apply (simp add: Abs_sfun_inverse)
  done

lemma sfun_eq_iff: "f = g \<longleftrightarrow> sfun_rep\<cdot>f = sfun_rep\<cdot>g"
by (simp add: sfun_rep_def cont_Rep_sfun Rep_sfun_inject)

lemma sfun_below_iff: "f \<sqsubseteq> g \<longleftrightarrow> sfun_rep\<cdot>f \<sqsubseteq> sfun_rep\<cdot>g"
by (simp add: sfun_rep_def cont_Rep_sfun below_sfun_def)

end