section {* Abstract syntax for Hybrid CSP. *}

theory HHL1
  imports  HCSP_Com
begin

consts
spec :: "fform => proc => fform => fform => prop"   ("{_}_{_;_}" 80)
specP2 :: "fform => fform => proc => fform => fform => fform  => fform => prop"   ("{_, _}_{_, _ ; _, _}" 80)
specP3 :: "fform => fform => fform => proc => fform => fform => fform => fform => fform => fform => prop"("{_,_,_}_{_,_,_; _,_,_}" 80)
specP4 :: "fform => fform => fform => fform => proc => fform => fform => fform => fform => fform  => fform => fform  => fform => prop"   ("{_,_,_,_}_{_,_,_,_ ; _,_,_,_}" 80)
specP5 :: "fform => fform => fform => fform => fform => proc => fform => fform => fform => fform => fform => fform  => fform => fform  => fform => fform  => prop"   ("{_,_,_,_,_}_{_,_,_,_,_ ; _,_,_,_,_}" 80)
specP6 :: "fform => fform => fform => fform => fform => fform => proc => fform => fform => fform => fform => fform => fform => fform  => fform => fform => fform => fform => fform  => prop"   ("{_,_,_,_,_,_}_{_,_,_,_,_,_ ; _,_,_,_,_,_}" 80)

(*List rules, p do not have exp1. If p have exp1, it must be eliminated by consequence rule firstly.*)
axiomatization where
ListEmpty : "{p} empty(exp1) {exp1[=](List [])[&]p; (l [=] (Real 0))}" and
ListAdd : "{exp1[=](List ls)[&]p} (addL exp1 exp2) {(exp1[=](List (exp2#ls)))[&]p; (l [=] (Real 0))}" and
ListDel : "|- exp1[=](List (tl(ls)))[&]p [-->] post
  ==> {exp1[=](List ls)[&]p} (delL(exp1)) {post; (l [=] (Real 0))}" and
ListEmptya : "{p} empty(exp1) {p; (l [=] (Real 0))}" and
ListAdda : "{p} (addL exp1 exp2) {p; (l [=] (Real 0))}" and
ListDela : "{p} (delL(exp1)) {p; (l [=] (Real 0))}"
axiomatization where
Empty: "EL [=] List [] |- isEmpty(EL)"

(*Skip rule*)
axiomatization where
Skip : "|- ((l [=] (Real 0)) [-->] G) ==> {p} Skip {p; G}"

(*Assignment rule*)
axiomatization where
Assign  :" [| ~inPairForm ([(e, f)], q); |-(p [-->] (substF ([(e, f)]) (q)))
        [&]   ((l [=] (Real 0)) [-->] G)|] ==>
       {p} (e := f) {q; G}"

(*Example*)
lemma "{WTrue} (RVar ''x'') := (Real 2) {((RVar ''x'') [=] (Real 2)); (l [=] (Real 0))}"
apply (cut_tac p = "WTrue" and e = "(RVar ''x'')" and f = "(Real 2)" and
                q = "((RVar ''x'') [=] (Real 2))" and G = "(l [=] (Real 0))" in Assign, auto)
apply (rule Trans,auto)
done

(*Continuous rule*)
axiomatization where
Continue : "|- (Init [-->] FF)
           [&] ((p [&] close(FF) [&] close([~]b)) [-->] q)
           [&] ((((l [=] Real 0) [|] (high (close(FF) [&] p [&] close(b)))) [&] Rg) [-->] G)
           ==> {Init [&] p} <FF&&b> : Rg {q; G}" and
ContinueT : "|- (Init[&]p [-->]FF[&]b)
           [&] ((p [&] close(FF) [&] close(b) [&] close([~]b)) [-->] q)
           [&] ((((l [=] Real 0) [|] (high (close(FF) [&] p [&] close(b)))) [&] Rg) [-->] G)
           ==> {Init [&] p} <FF&&(b)> : Rg {q; G}" and
ContinueF : "|- (p[-->][~]b) [&] (p[-->]q) [&] ((l[=](Real 0))[-->]G)
           ==> {p} <FF&&b> : Rg {q; G}"

(*Continuous rule 2*)
axiomatization where
Continue2 : "|- (Init [-->] FF)
           [&] ((p [&] close(FF) [&] close([~]b)) [-->] q)
           [&] ((((l [=] Real 0) [|] (high (close(FF) [&] p [&] close(b)))) [&] Rg) [-->] G)
[&] (exeFlow (D,b,F1) [-->]FF)
           ==> {Init [&] p} <D&&FF&&b> : Rg {q; G}"  and
Continue2T : "|- (Init[&]p [-->] FF[&]b)
           [&] ((p [&] close(FF) [&] close(b) [&] close([~]b)) [-->] q)
           [&] ((((l [=] Real 0) [|] (high (close(FF) [&] p [&] close(b)))) [&] Rg) [-->] G)
[&](exeFlow (D,b,FF) [-->]FF)
           ==> {Init [&] p} <D&&FF&&(b)> : Rg {q; G}" and
Continue2F : "|- (p[-->][~]b) [&] (p[-->]q) [&] ((l[=](Real 0))[-->]G)
           ==> {p} <D&&FF&&b> : Rg {q; G}"

(*Sequential rule*)
axiomatization where
Sequence : "[| {p} P {m; H}; {m} Q {q; G} |] ==>
             {p} P; (m, H); Q {q; H [^] G}"
axiomatization where
Sequence1 : "[| {p} P {m; H}; {m} Q {q; G} |] ==>
             {p} P; M; Q {q; H [^] G}"

(*Case rule*)
axiomatization where
Case : "[| {p [&] b} P {q; G}; {p [&] ([~]b)} P {q; G}|]
             ==> {p} P {q; G}"

(*Conditional rule*)
axiomatization where
ConditionF : " [| |-(p [-->] [~] b); |- (p [-->] q); |- ((l [=] Real 0) [-->] G) |]
             ==> {p} IF b P {q; G}"
and
ConditionT :  "[| |-(p [-->] b); {p} P {q; G} |]
             ==> {p} IF b P {q; G}"
and
Condition : "[| {p [&] b} IF b P {q; G}; {p [&] ([~]b)} IF b P {q; G}|]
             ==> {p} IF b P {q; G}"
axiomatization where
ConditionT2 :  "[| |-(pn [-->] b); {pm,pn} (Pm||Pn) {qm,qn; Gm,Gn} |]
  ==> {pm,pn} (Pm||(IF b Pn)) {qm,qn; Gm,Gn}" and
ConditionT2a :  "[| |-(pm [-->] b); {pm,pn} (Pm||Pn) {qm,qn; Gm,Gn} |]
  ==> {pm,pn} ((IF b Pm)||Pn) {qm,qn; Gm,Gn}"

(*Nondeterministic rule*)
axiomatization where
Nondeterministic :
"{p [&] b} P {q;G}
  ==> {p} NON i x : b P {q; G}"

(*Communication rule*)
(*H in the rule denotes the common interval range.*)
axiomatization where
Communication : "[| ~inPairForm ([(x, e)], ry);
                    {px, py} (Px || Py) {qx, qy; Hx, Hy};
                    |- (qx [-->] rx) [&] (qy [-->] (substF ([(x, e)]) (ry)));
                    |- ((Hx [^] (high (qx))) [-->] Gx) [&] ((Hy [^] (high (qy))) [-->] Gy);
                    |- ((((Hx [^] (high (qx))) [&] Hy) [|]((Hy [^] (high (qy))) [&] Hx)) [-->] H)
                 |]
              ==>   {px, py} ((Px; (qx, Hx); ch !! e) || (Py; (qy, Hy); ch ?? x)) {rx, ry;
                    Gx [&] H, Gy [&] H}"
axiomatization where
Communication1 : "[| ~inPairForm ([(x, e)], ry);
                    {px, py} (Px || Py) {qx, qy; Hx, Hy};
                    |- (qx [-->] rx) [&] (qx[&]qy [-->] (substF ([(x, e)]) (ry)));
                    |- ((Hx [^] (high (qx))) [-->] Gx) [&] ((Hy [^] (high (qy))) [-->] Gy);
                    |- ((((Hx [^] (high (qx))) [&] Hy) [|]((Hy [^] (high (qy))) [&] Hx)) [-->] H)
                 |]
              ==>   {px, py} ((Px; (qx, Hx); ch !! e) || (Py; (qy, Hy); ch ?? x)) {rx, ry;
                    Gx [&] H, Gy [&] H}"
axiomatization where
CommunicationSim : "[| ~inPairForm ([(x, e)], ry);
  |- (px [-->] rx) [&] (px[&]py [-->] (substF ([(x, e)]) (ry))) |]
  ==>  {px, py} ((ch !! e) || (ch ?? x)) {rx, ry;(l[=](Real 0)), (l[=](Real 0))}"
axiomatization where
CommunicationC : "[| ~inPairForm ([(x, e)], ry);
                    {qx} (Px) {rx; (l[=](Real 0))};
                    |- (px [&] py) [-->] (substF ([(x, e)]) (qx));
                    |- py [-->] ry;
                    |- (l[=](Real 0)) [-->] Hx;
                    |- (l[=](Real 0)) [-->] My;
                    |- (l[=](Real 0)) [-->] My;
                   contain(Pm,(ch ?? x))|]
              ==>   {px, py} (( Pm; (qx, Hx); Px) || (ch !! e))
                    {rx, ry; Mx, My}"

(*Communication interrupt rule*)
primrec contain :: "proc => proc => bool" where
"contain (Skip,p) = False" |
"contain (Stop,p) = False" |
"contain (x:=e,p) = False" |
"contain ((Ch!!e),p) = ((Ch!!e)=p)" |
"contain ((Ch??x),p) = ((Ch??x)=p)" |
"contain ((q;m;r),p) = False" |
"contain ((IF b q),p) = False" |
"contain ((NON i x : b q),p) = False" |
"contain ((q [[ r),p) = (if contain(q,p) then True else contain(r,p))" |
"contain ((q << r),p) = False" |
"contain ((q || r),p) = False" |
"contain ((q*),p) = False" |
"contain ((q**n),p) = False" |
"contain ((<FF && b> : g),p) = False" |
"contain ((q |> b r),p) = False" |
"contain ((q [[> r),p) = False"

(**)
axiomatization where
CommunicationI1 : "[| ~inPairForm ([(x, e)], ry);
                    |- Hy [-->] H;
                    |- rg [-->] H[^]WTrue;
                    {px, py} (Px || Py) {qx, qy; Hx, Hy};
                    |- Init [&] pre [<->] qx;
                    |- pre [&] Init [&] b [-->] FF;
                    |- (pre [&] close(FF) [&] close(b)) [-->] rx;
                    |- (qy [&] pre [&] close(FF) [&] close(b)) [-->] (substF ([(x, e)]) (ry));
                    |- (Hx [^] ((((l [=] Real 0) [|] (high (close(FF) [&] pre [&] close(b)))) [&] H)) [-->] Gx);
                    |- Hy [-->] Gy;
                    |- Hx [-->] Hxm;
                    |- Hy [-->] Hym;
                    contain(P,(ch !! e))
                 |]
              ==>   {px, py} (( Px; (qx, Hxm); (<FF && b> :rg) [[> P) || (Py; (qy, Hym); ch ?? x))
                    {rx, ry; Gx, Gy}"
axiomatization where
CommunicationI2 : "[| ~inPairForm ([(x, e)], ry);
                    |- Hy [-->] H;
                    |- rg [-->] H[^]WTrue;
                    {px, py} (Px || Py) {qx, qy; Hx, Hy};
                    |- Init [&] pre [<->] qx;
                    |- pre [&] Init [&] b [-->] FF;
                    |- (qy [&] pre [&] close(FF) [&] close(b)) [-->] (substF ([(x, e)]) (rx));
                    |- qy [-->] ry;
                    |- Hx [^] ((((l [=] Real 0) [|] (high (close(FF) [&] pre [&] close(b)))) [&] H)) [-->] Gx;
                    |- Hy [-->] Gy;
                    |- Hx [-->] Hxm;
                    |- Hy [-->] Hym;
                    contain(P,(ch ?? x))
                 |]
              ==>   {px, py} (( Px; (qx, Hxm); (<FF && b> :rg) [[> P) || (Py; (qy, Hym); ch !! e))
                    {rx, ry; Gx, Gy}"

(*Parallel rule*)
(*It is valid only when there are not communications occurring in P3 and P4.*)
axiomatization where
Parallel1: "[| {px, py} (Px || Py) {qx, qy; Hx, Hy}; {qx} Qx {rx; Gx}; {qy} Qy {ry; Gy} |]
           ==>  {px, py} ((Px; (qx, Hx); Qx) || (Py; (qy, Hy); Qy)) {rx, ry; Hx [^] Gx, Hy [^] Gy}"

(*It is valid only when there are no communications occurring in P1 and P2.*)
axiomatization where
Parallel2: "[| {px} Px {qx; Hx}; {py} Py {qy; Hy}|]
           ==> {px, py} (Px || Py) {qx, qy; Hx, Hy}"
(*It is valid in any case*)
axiomatization where
Parallel3: "[| {px, py} (Px || Py) {qx, qy; Hx[&](l[=](Real m)), Hy[&](l[=](Real m))};
               {qx, qy} (Qx || Qy) {rx, ry; Mx, My};
               |- (Hx[&](l[=](Real m))) [-->] HL;
               |- (Hy[&](l[=](Real m))) [-->] HR;
               |- ((Hx[&](l[=](Real m))) [^] Mx) [-->] Gx;
               |- ((Hy[&](l[=](Real m))) [^] My) [-->] Gy
            |]
           ==> {px, py} (Px;(qx,HL);Qx) || (Py;(qy,HR);Qy) {rx, ry; Gx, Gy}"

(*Repetition rule*)
axiomatization where
Rep : "[| {px} (Px) {px; Hx}; |- Hx [^] Hx [-->] Hx|]
           ==>  {px} (Px*) {px; Hx} "
axiomatization where
Repetition : "[| {px, py} (Px || Py) {px, py; Hx, Hy};
                 |- Hx [^] Hx [-->] Hx; |- Hy [^] Hy [-->] Hy|]
           ==>  {px, py} ((Px*) || (Py*)) {px, py; Hx, Hy} "

axiomatization where
Repetition0 : "(Pm**(0)) == Skip" and
Repetition1 : "(Pm**(Suc(0))) == Pm" and
RepetitionN : "(Pm**(am+1)) == (Pm; M; Pm**am)"

axiomatization where
RepetitionA2 : "{p1,p2} ((Pm**(am+1))||(Pn**(an+1))) {p1,p2; Ha,Hb}
==> {p1,p2} ((Pm***)||(Pn***)) {p1,p2; Ha,Hb}"

axiomatization where
RepetitionG2 : "[| {p1,p2} ((Pm***)||(Pn***)) {p1,p2; Ha,Hb}; |- Ha [^] Ha [-->] Ha; |- Hb [^] Hb [-->] Hb|]
==> {p1,p2} (Pm*||Pn*) {p1,p2; Ha,Hb}"

axiomatization where
RepetitionA6 : "{p1,p2,p3,p4,p5,p6} ((Pm**(am+1))||(Pn**(an+1))||(Po**(ao+1))||(Pp**(ap+1))||(Pq**(aq+1))||(Pr**(ar+1))) {p1,p2,p3,p4,p5,p6; Ha,Hb,Hc,Hd,He,Hf}
==> {p1,p2,p3,p4,p5,p6} ((Pm***)||(Pn***)||(Po***)||(Pp***)||(Pq***)||(Pr***)) {p1,p2,p3,p4,p5,p6; Ha,Hb,Hc,Hd,He,Hf}"

axiomatization where
RepetitionG6 : "[| {p1,p2,p3,p4,p5,p6} ((Pm***)||(Pn***)||(Po***)||(Pp***)||(Pq***)||(Pr***)) {p1,p2,p3,p4,p5,p6; Ha,Hb,Hc,Hd,He,Hf}; |- Ha [^] Ha [-->] Ha; |- Hb [^] Hb [-->] Hb; |- Hc [^] Hc [-->] Hc; |- Hd [^] Hd [-->] Hd; |- He [^] He [-->] He; |- Hf [^] Hf [-->] Hf|]
==> {p1,p2,p3,p4,p5,p6} (Pm*||Pn*||Po*||Pp*||Pq*||Pr*) {p1,p2,p3,p4,p5,p6; Ha,Hb,Hc,Hd,He,Hf}"

(*N times repetition request post and history holds for any middle state to ensure RepetitionG holds.*)
axiomatization where
RepetitionT1a : "{px, py} ((Px;M;Pz) || Py) {qx, qy; Hx, Hy}
           ==>  {px, py} (((Px**1);M;Pz) || Py) {qx, qy; Hx, Hy}" and
RepetitionTna : "[| {px, py} (((Px**m);(qx,H);Px;M;P) || Py) {qx, qy; Hx, Hy};
                 |- Hx [^] Hx [-->] Hx;
                 |- H [-->] Hx|]
           ==>  {px, py} (((Px**(m+1));M;P) || Py) {qx, qy; Hx, Hy}" and
RepetitionG : "[| {px, py} (Px**(m+1) || Py**(n+1)) {px, py; Hx, Hy};
                 |- Hx [^] Hx [-->] Hx; |- Hy [^] Hy [-->] Hy|]
           ==>  {px, py} ((Px* ) || (Py* )) {px, py; Hx, Hy} " and
RepetitionE : "[| {px, py} (((P;M;(Px**(n+1)));(qx,Hx);(Px* )) || Py) {qx, qy; Hx, Hy}|]
           ==>  {px, py} ((P;M;(Px* )) || Py) {qx, qy; Hx, Hy} "

(*Structure rule*)
axiomatization where
Structure : "{px, py} (Px || Py) {qx, qy; Hx, Hy}
           ==> {py, px} (Py || Px) {qy, qx; Hy, Hx}" and
structR : "{px, py} Q||((Px;Mx;Py);My;Pz) {qx, qy; Hx, Hy}
           ==> {px, py} Q||(Px;Mx;Py;My;Pz){qx, qy; Hx, Hy}" and
structL : "{px, py} ((Px;Mx;Py);My;Pz)||Q {qx, qy; Hx, Hy}
           ==> {px, py} (Px;Mx;Py;My;Pz)||Q{qx, qy; Hx, Hy}" and
structSkipL : "{px, py} (Skip;(px,l[=](Real 0));P)||Q {qx, qy; Hx, Hy}
           == {px, py} P||Q{qx, qy; Hx, Hy}" and
structSkipR : "{px, py} (P;(qx,Hx);Skip)||Q {qx, qy; Hx, Hy}
           == {px, py} P||Q{qx, qy; Hx, Hy}" and
Equality2: "[| Pm==Qm; Pn==Qn; {p1,p2} (Qm||Qn) {p1,p2; Ha,Hb}|]
==> {p1,p2} (Pm||Pn) {p1,p2; Ha,Hb}" and
Equality6: "[| Pm==Qm; Pn==Qn; Po==Qo; Pp==Qp; Pq==Qq; Pr==Qr; {p1,p2,p3,p4,p5,p6} (Qm||Qn||Qo||Qp||Qq||Qr) {p1,p2,p3,p4,p5,p6; Ha,Hb,Hc,Hd,He,Hf}|]
==> {p1,p2,p3,p4,p5,p6} (Pm||Pn||Po||Pp||Pq||Pr) {p1,p2,p3,p4,p5,p6; Ha,Hb,Hc,Hd,He,Hf}"

(*Consequence rule*)
axiomatization where
ConsequenceS : "[| {px} P {qx; Hx}; |- ((p [-->] px) [&] (qx [-->] q) [&] (Hx [-->] H))|]
            ==> {p} P {q; H}"
and
ConsequenceP : "[| {px, py} (Px || Py) {qx, qy; Hx, Hy};
                   |- ((p [-->] px) [&] (r [-->] py) [&] (qx [-->] q) [&] (qy [-->] s)
                       [&] (Hx [-->] H) [&] (Hy [-->] G))|]
            ==> {p, r} (Px || Py) {q, s; H, G}"
and
Consequence6 : "[|{qa,qb,qc,qd,qe,qf} (Pm||Pn||Po||Pp||Pq||Pr) {ra,rb,rc,rd,re,rf; Ha,Hb,Hc,Hd,He,Hf}; |- (q1[-->]qa) [&] (q2[-->]qb) [&] (q3[-->]qc) [&] (q4[-->]qd)  [&] (q5[-->]qe) [&] (q6[-->]qf); |- (ra[-->]r1) [&] (rb[-->]r2) [&] (rc[-->]r3) [&] (rd[-->]r4)  [&] (re[-->]r5) [&] (rf[-->]r6); |- (Ha[-->]H1) [&] (Hb[-->]H2) [&] (Hc[-->]H3) [&] (Hd[-->]H4) [&] (He[-->]H5) [&] (Hf[-->]H6)|]
==> {q1,q2,q3,q4,q5,q6} (Pm||Pn||Po||Pp||Pq||Pr) {r1,r2,r3,r4,r5,r6; H1,H2,H3,H4,H5,H6}"

(*added rules for parallel with more entities*)
axiomatization where
Parallel23: "[| {p1,p2} (Pm||Pn) {q1,q2; H1,H2};
                {p3} Po {q3; H3}|]
       ==> {p1,p2,p3} (Pm||Pn||Po) {q1,q2,q3; H1,H2,H3}" and
Parallel24: "[| {p1,p2,p3} (Pm||Pn||Po) {q1,q2,q3; H1,H2,H3};
                {p4} Pp {q4; H4}|]
       ==> {p1,p2,p3,p4} (Pm||Pn||Po||Pp) {q1,q2,q3,q4; H1,H2,H3,H4}" and
Parallel25: "[| {p1,p2,p3,p4} (Pm||Pn||Po||Pp) {q1,q2,q3,q4; H1,H2,H3,H4};
                {p5} Pq {q5; H5}|]
       ==> {p1,p2,p3,p4,p5} (Pm||Pn||Po||Pp||Pq) {q1,q2,q3,q4,q5; H1,H2,H3,H4,H5}" and
Parallel26: "[| {p1,p2,p3,p4,p5} (Pm||Pn||Po||Pp||Pq) {q1,q2,q3,q4,q5; H1,H2,H3,H4,H5};
                {p6} Pr {q6; H6}|]
       ==> {p1,p2,p3,p4,p5,p6} (Pm||Pn||Po||Pp||Pq||Pr) {q1,q2,q3,q4,q5,q6; H1,H2,H3,H4,H5,H6}"
axiomatization where
ParallelSeq6: "[| {p1,p2,p3,p4,p5,p6} (Pm||Pn||Po||Pp||Pq||Pr) {q1,q2,q3,q4,q5,q6; Ha,Hb,Hc,Hd,He,Hf}; {r1,r2,r3,r4,r5,r6} (Qm||Qn||Qo||Qp||Qq||Qr) {p1,p2,p3,p4,p5,p6; G1,G2,G3,G4,G5,G6}; |- (G1[^]Ha) [-->] M1; |- (G2[^]Hb) [-->] M2; |- (G3[^]Hc) [-->] M3; |- (G4[^]Hd) [-->] M4; |- (G5[^]He) [-->] M5; |- (G6[^]Hf) [-->] M6|]
           ==> {r1,r2,r3,r4,r5,r6} ((Qm;(p1,G1);Pm)||(Qn;(p2,G2);Pn)||(Qo;(p3,G3);Po)||(Qp;(p4,G4);Pp)||(Qq;(p5,G5);Pq)||(Qr;(p6,G6);Pr)) {q1,q2,q3,q4,q5,q6; M1,M2,M3,M4,M5,M6}"

axiomatization where
ParallelSeq6a: "[|{p1}Pm{q1; Ha}; {p2}Pn{q2; Hb}; {p3}Po{q3; Hc}; {p4}Pp{q4; Hd}; {p5}Pq{q5; He}; {p6}Pr{q6; Hf}|]
==>  {p1,p2,p3,p4,p5,p6} (Pm||Pn||Po||Pp||Pq||Pr) {q1,q2,q3,q4,q5,q6; Ha,Hb,Hc,Hd,He,Hf}"

axiomatization where
ParallelSeq12a: "[| {p1,p2,p3,p4,p5,p6} (Pm||Pn||Po||Pp||Pq||Pr) {q1,q2,q3,q4,q5,q6; Ha,Hb,Hc,Hd,He,Hf}; {r1,r2} (Qm||Qn) {p1,p2; G1,G2}; |- (G1[^]Ha) [-->] M1; |- (G2[^]Hb) [-->] M2|]
           ==> {r1,r2,p3,p4,p5,p6} ((Qm;(p1,G1);Pm)||(Qn;(p2,G2);Pn)||(Po)||(Pp)||(Pq)||(Pr)) {q1,q2,q3,q4,q5,q6; M1,M2,Hc,Hd,He,Hf}" and
ParallelSeq25a: "[| {p1,p2,p3,p4,p6} (Pm||Pn||Po||Pp||Pr) {q1,q2,q3,q4,q6; Ha,Hb,Hc,Hd,Hf}; {r2,r5} (Qn||Qq) {p2,p5; G2,G5}; |- (G2[^]Hb) [-->] M2|]
           ==> {p1,r2,p3,p4,r5,p6} ((Pm)||(Qn;(p2,G2);Pn)||(Po)||(Pp)||(Qq)||(Pr)) {q1,q2,q3,q4,p5,q6; Ha,M2,Hc,Hd,G5,Hf}" and
ParallelSeq23a: "[| {p1,p2,p4,p6} (Pm||Pn||Pp||Pr) {q1,q2,q4,q6; Ha,Hb,Hd,Hf}; {r2,r3} (Qn||Qo) {p2,p3; G2,G3}; |- (G2[^]Hb) [-->] M2|]
           ==> {p1,r2,r3,p4,p6} ((Pm)||(Qn;(p2,G2);Pn)||(Qo)||(Pp)||(Pr)) {q1,q2,p3,q4,q6; Ha,M2,G3,Hd,Hf}" and
ParallelSeq23b: "[| {p1,p2,p6} (Pm||Pn||Pr) {q1,q2,q6; Ha,Hb,Hf}; {r2,r4} (Qn||Qp) {p2,p4; G2,G4}; |- (G2[^]Hb) [-->] M2|]
           ==> {p1,r2,r4,p6} ((Pm)||(Qn;(p2,G2);Pn)||(Qp)||(Pr)) {q1,q2,p4,q6; Ha,M2,G4,Hf}" and
ParallelSeq23c: "[| {p1,p2} (Pm||Pn) {q1,q2; Ha,Hb}; {r2,r6} (Qn||Qr) {p2,p6; G2,G6}; |- (G2[^]Hb) [-->] M2|]
           ==> {p1,r2,r6} ((Pm)||(Qn;(p2,G2);Pn)||(Qr)) {q1,q2,p6; Ha,M2,G6}"

axiomatization where
ParallelSeq6b: "[| {p1,p2,p3,p4,p5,p6} (Pm||Pn||Po||Pp||Pq||Pr) {q1,q2,q3,q4,q5,q6; Ha,Hb,Hc,Hd,He,Hf}; {q1,q2}Qn||Rn{r1,r2; Ga,Gb}; |- Ha[^]Ga [-->]Ma; |- Hb[^]Gb [-->]Mb|]
           ==>  {p1,p2,p3,p4,p5,p6} ((Pm;(q1,Ha);Qn)||(Pn;(q2,Hb);Rn)||Po||Pp||Pq||Pr) {r1,r2,q3,q4,q5,q6; Ma,Mb,Hc,Hd,He,Hf}"
axiomatization where
ConsequenceP5 : "[| {pa,pb,pc,pd,pe} P {qa,qb,qc,qd,qe; Ha,Hb,Hc,Hd,He};
                   |- (p1 [-->] pa) [&] (p2 [-->] pb) [&] (p3 [-->] pc) [&] (p4 [-->] pd) [&] (p5 [-->] pe);
                   |- (qa [-->] q1) [&] (qb [-->] q2) [&] (qc [-->] q3) [&] (qd [-->] q4) [&] (qe [-->] q5);
                   |- (Ha [-->] H1) [&] (Hb [-->] H2) [&] (Hc [-->] H3) [&]
                      (Hd [-->] H4) [&] (He [-->] H5) |]
            ==> {p1,p2,p3,p4,p5} P {q1,q2,q3,q4,q5; H1,H2,H3,H4,H5}"
axiomatization where
Repetition5 : "[| {p1,p2,p3,p4,p5} (((Pm||Pn)||Po)||Pp)||Pq {q1,q2,q3,q4,q5; H1,H2,H3,H4,H5};
                  |- H1 [^] H1 [-->] H1; |- H2 [^] H2 [-->] H2; |- H3 [^] H3 [-->] H3;
                  |- H4 [^] H4 [-->] H4; |- H5 [^] H5 [-->] H5|]
           ==> {p1,p2,p3,p4,p5} (((Pm*||Pn*)||Po*)||Pp*)||Pq* {q1,q2,q3,q4,q5; H1,H2,H3,H4,H5}"
axiomatization where
Parallel113: "[| {p1,p2,p3} ((Pm||Pn)||Po) {q,q2,q3; H,H2,H3};
                  {q} Q {qx; Hx}; |- (H[^]Hx) [-->] Hy|]
           ==> {p1,p2,p3} (((Pm;(q,H);Q)||Pn)||Po) {qx,q2,q3; Hy,H2,H3}"
axiomatization where
Parallel115: "[| {p1,p2,p3,p4,p5} (((Pm||Pn)||Po)||Pp)||Pq {q,q2,q3,q4,q5; H,H2,H3,H4,H5};
                  {q} Q {qx; Hx}; |- (H[^]Hx) [-->] Hy|]
           ==> {p1,p2,p3,p4,p5} ((((Pm;(q,H);Q)||Pn)||Po)||Pp)||Pq {qx,q2,q3,q4,q5; Hy,H2,H3,H4,H5}"
axiomatization where
Parallel13: "[| {p1,p2,p3} (Pm||Pn)||Po {q1,q2,q3; H1,H2,H3};
                  {q3} Q {qx; Hx}; |- (H3[^]Hx) [-->] Hy|]
           ==> {p1,p2,p3} (Pm||Pn)||(Po;(q3,H3);Q) {q1,q2,qx; H1,H2,Hy}"
axiomatization where
Parallel14: "[| {p1,p2,p3,p4} ((Pm||Pn)||Po)||Pp {q1,q2,q3,q4; H1,H2,H3,H4};
                  {q4} Q {qx; Hx}; |- (H4[^]Hx) [-->] Hy|]
           ==> {p1,p2,p3,p4} ((Pm||Pn)||Po)||(Pp;(q4,H4);Q) {q1,q2,q3,qx; H1,H2,H3,Hy}"
axiomatization where
Parallel15: "[| {p1,p2,p3,p4,p5} (((Pm||Pn)||Po)||Pp)||Pq {q1,q2,q3,q4,q5; H1,H2,H3,H4,H5};
                  {q5} Q {qx; Hx}; |- (H5[^]Hx) [-->] Hy|]
           ==> {p1,p2,p3,p4,p5} (((Pm||Pn)||Po)||Pp)||(Pq;(q5,H5);Q) {q1,q2,q3,q4,qx; H1,H2,H3,H4,Hy}"
axiomatization where
Communication3 : "[| ~inPairForm ([(x, e)], qy);
                    {p1,p2,p3} (Pm||Pn)||Po {q1,q2,q3; H1,H2,H3};
                    |- (q1 [-->] qx) [&] (q3 [-->] (substF ([(x, e)]) (qy)));
                    |- ((H1 [^] (high (q1))) [-->] Hx) [&] ((H3 [^] (high (q3))) [-->] Hy);
                    |- ((((H1 [^] (high (q1))) [&] H3) [|]((H3 [^] (high (q3))) [&] H1)) [-->] H);
                    |- Hx [&] H [-->] Ha;
                    |- Hy [&] H [-->] Hb
                  |]
               ==>  {p1,p2,p3} ((Pm;(q1, H1);ch!!e)||Pn)||(Po;(q3, H3);ch??x)
                    {qx,q2,qy; Ha,H2,Hb}"
axiomatization where
Communication4 : "[| ~inPairForm ([(x, e)], qy);
                    {p1,p2,p3,p4} ((Pm||Pn)||Po)||Pp {q1,q2,q3,q4; H1,H2,H3,H4};
                    |- (q1 [-->] qx) [&] (q4 [-->] (substF ([(x, e)]) (qy)));
                    |- ((H1 [^] (high (q1))) [-->] Hx) [&] ((H4 [^] (high (q4))) [-->] Hy);
                    |- ((((H1 [^] (high (q1))) [&] H4) [|]((H4 [^] (high (q4))) [&] H1)) [-->] H);
                    |- Hx [&] H [-->] Ha;
                    |- Hy [&] H [-->] Hb
                  |]
               ==>  {p1,p2,p3,p4} (((Pm;(q1, H1);ch!!e)||Pn)||Po)||(Pp;(q4, H4);ch??x)
                    {qx,q2,q3,qy; Ha,H2,H3,Hb}"
axiomatization where
Communication5 : "[| ~inPairForm ([(x, e)], qy);
                    {p1,p2,p3,p4,p5} (((Pm||Pn)||Po)||Pp)||Pq {q1,q2,q3,q4,q5; H1,H2,H3,H4,H5};
                    |- (q1 [-->] qx) [&] (q5 [-->] (substF ([(x, e)]) (qy)));
                    |- ((H1 [^] (high (q1))) [-->] Hx) [&] ((H5 [^] (high (q5))) [-->] Hy);
                    |- ((((H1 [^] (high (q1))) [&] H5) [|]((H5 [^] (high (q5))) [&] H1)) [-->] H);
                    |- Hx [&] H [-->] Ha;
                    |- Hy [&] H [-->] Hb
                  |]
               ==>  {p1,p2,p3,p4,p5} ((((Pm;(q1, H1);ch!!e)||Pn)||Po)||Pp)||(Pq;(q5, H5);ch??x)
                    {qx,q2,q3,q4,qy; Ha,H2,H3,H4,Hb}"

(*important derived rules*)
lemma structSkipEL : "{px, py} (Skip;(px,l[=](Real 0));P)||Q {qx, qy; Hx, Hy}
           ==> {px, py} P||Q{qx, qy; Hx, Hy}"
apply (cut_tac px=px and py=py and P=P and Q=Q and qx=qx and qy=qy and Hx=Hx and Hy=Hy in structSkipL,auto)
done

lemma structSkipIL : "{px, py} P||Q{qx, qy; Hx, Hy}
           ==> {px, py} (Skip;(px,l[=](Real 0));P)||Q {qx, qy; Hx, Hy}"
apply (cut_tac px=px and py=py and P=P and Q=Q and qx=qx and qy=qy and Hx=Hx and Hy=Hy in structSkipL,auto)
done

lemma structSkipER : "{px, py} (P;(qx,Hx);Skip)||Q {qx, qy; Hx, Hy}
           ==> {px, py} P||Q{qx, qy; Hx, Hy}"
apply (cut_tac px=px and py=py and P=P and Q=Q and qx=qx and qy=qy and Hx=Hx and Hy=Hy in structSkipR,auto)
done

lemma structSkipIR : "{px, py} P||Q{qx, qy; Hx, Hy}
           ==> {px, py} (P;(qx,Hx);Skip)||Q {qx, qy; Hx, Hy}"
apply (cut_tac px=px and py=py and P=P and Q=Q and qx=qx and qy=qy and Hx=Hx and Hy=Hy in structSkipR,auto)
done

lemma RepetitionT1 : "{px, py} (Px || Py) {qx, qy; Hx, Hy}
           ==>  {px, py} (Px**1 || Py) {qx, qy; Hx, Hy}"
apply (rule structSkipER)
apply (rule RepetitionT1a)
apply (rule structSkipIR,auto)
done

lemma RepetitionTn : "[| {px, py} (((Px**m);(qx,H);Px) || Py) {qx, qy; Hx, Hy};
                 |- Hx [^] Hx [-->] Hx;
                 |- H [-->] Hx|]
           ==>  {px, py} (Px**(m+1) || Py) {qx, qy; Hx, Hy}"
apply (rule structSkipER)
apply (cut_tac H="H" in RepetitionTna,auto)
apply (rule structL)
apply (rule structSkipIR,auto)
done

lemma Parallel4: "[| {py} Py {qy; Hy[&](l[=](Real 0))};
               {qx, qy} (Qx || Qy) {rx, ry; Mx, My};
               |- (Hy[&](l[=](Real 0))) [-->] HR;
               |- ((Hy[&](l[=](Real 0))) [^] My) [-->] Gy
            |]
           ==> {qx, py} (Qx) || (Py;(qy,HR);Qy) {rx, ry; Mx, Gy}"
apply (rule structSkipEL)
apply (cut_tac m=0 and Hx="l [=] Real 0" in Parallel3,auto)
apply (rule Parallel2,auto)
apply (rule Skip)
(*1*)
apply (rule impR)
apply (rule conjR)
apply (rule basic)+
apply (rule impR)
apply (rule conjL)
apply (rule basic)
apply (rule impR)
apply (rule LC1)
apply (rule LL3a)
apply (rule basic)
done

lemma Parallel1a: "[| {px, py} (Px || Py) {qx, qy; Hx, Hy}; {qy} Qy {ry; Gy}; |- Hy [^] Gy [-->] G |]
           ==>  {px, py} ((Px) || (Py; (qy, Hy); Qy)) {qx, ry; Hx, G}"
apply (rule structSkipER)
apply (subgoal_tac "{px, py}(Px;(qx, Hx);Skip)||(Py;(qy, Hy);Qy){qx,ry; (Hx [^] l [=] Real 0), Hy [^] Gy}")
apply (cut_tac px=px and py=py and qx=qx and qy=ry and Hx="Hx [^] l [=] Real 0" and Hy="Hy [^] Gy" in ConsequenceP,auto)
apply (rule conjR)
apply (rule impR)
apply (rule basic)
apply (rule conjR)
apply (rule impR)
apply (rule basic)
apply (rule conjR)
apply (rule impR)
apply (rule basic)
apply (rule conjR)
apply (rule impR)
apply (rule basic)
apply (rule conjR)
apply (rule impR)
apply (rule LL4)
apply (rule basic)
apply assumption
(*start*)
apply (cut_tac px=px and py=py and Px=Px and qx=qx and Hx="Hx" and Qx=Skip and Py=Py and qy=qy and Hy=Hy and Qy=Qy and rx=qx and ry=ry and Gx="(l [=] Real 0)" and Gy=Gy in Parallel1,auto)
apply (rule Skip)
apply (rule impR)
apply (rule basic)
done

lemma CommunicationI1b : "[| ~inPairForm ([(x, e)], ry);
                    |- Hy [-->] H;
                    |- rg [-->] H[^]WTrue;
                    {py} ( Py) {qy; Hy};
                    |- Init [&] pre [<->] qx;
                    |- pre [&] Init [&] b [-->] FF;
                    |- (pre [&] close(FF) [&] close(b)) [-->] rx;
                    |- (qy [&] pre [&] close(FF) [&] close(b) [-->] (substF ([(x, e)]) (ry)));
                    |- ((((l [=] Real 0) [|] (high (close(FF) [&] pre [&] close(b)))) [&] H) [-->] Gx);
                    |- Hy [-->] Gy;
                    |- Hy [-->] Hym;
                    contain(P,(ch !! e))
                 |]
              ==>   {qx, py} (((<FF && b> :rg) [[> P) || (Py; (qy, Hym); ch ?? x))
                    {rx, ry; Gx, Gy}"
apply (rule structSkipEL)
apply (cut_tac Hx="l [=] Real 0" and Init=Init in CommunicationI1,auto)
apply (rule Parallel2,auto)
apply (rule Skip)
apply (rule impR)
apply (rule basic)
apply (cut_tac P="((l [=] Real 0 [|] high (close(FF) [&] pre [&] close(b))) [&] H) [-->] Gx" in cut,auto)
apply (rule thinR,auto)
apply (rule impR)
apply (rule LL3a)
apply (rule impL)
apply (rule basic)+
apply (rule impR)
apply (rule basic)
done

lemma structSkipELR : "{px, py} Q||(Skip;(py,l[=](Real 0));P) {qx, qy; Hx, Hy}
           ==> {px, py} Q||P{qx, qy; Hx, Hy}"
apply (rule Structure)
apply (rule structSkipEL)
apply (rule Structure)
apply assumption
done

lemma CommunicationI1a : "[| ~inPairForm ([(x, e)], ry);
                       |- Init [&] pre [<->] px;
                       |- pre [&] Init [&] b [-->] FF;
                       |- (pre [&] close(FF) [&] close(b)) [-->] rx;
                       (*|- px [-->] rx;*)
                       |- py [&] pre [&] close(FF) [&] close(b) [-->] (substF ([(x, e)]) (ry));
                       |- (l[=]Real 0) [-->] Gx;
                       |- (l[=]Real 0) [-->] Gy;
                       contain(Px,(ch !! e))|]
              ==>   {px, py} (((<FF && b> :rg) [[> Px) || (ch ?? x)) {rx, ry; Gx, Gy}"
apply (rule structSkipEL)
apply (rule structSkipELR)
apply (cut_tac H="l [=] Real 0" and Hx="l [=] Real 0" in CommunicationI1,auto)
apply (rule impR)
apply (rule basic)
apply (rule impR)
apply (rule RL3a)
apply (simp add: True_def)
apply (rule impR)
apply (rule basic)
apply (rule Parallel2)
apply (rule Skip)
apply (rule impR)
apply (rule basic)
apply (rule Skip)
apply (rule impR)
apply (rule basic)
apply (rule impR)
apply (rule LL3a)
apply (rule conjL)
apply (rule thinL)
apply (cut_tac P="l [=] Real 0 [-->] Gx" in cut,auto)
apply (rule thinL)
apply (rule thinR,auto)
apply (rule impL)
apply (rule basic)+
apply (rule impR)
apply (rule basic)
apply (rule impR)
apply (rule basic)
done

lemma CommunicationI2a : "[| ~inPairForm ([(x, e)], ry);
                       |- Init [&] pre [<->] px;
                       |- pre [&] Init [&] b [-->] FF;
                       |- py [&] pre [&] close(FF) [&] close(b) [-->] (substF ([(x, e)]) (rx));
                       |- py [-->] ry;
                       |- (l[=]Real 0) [-->] Gx;
                       |- (l[=]Real 0) [-->] Gy;
                       contain(Px,(ch ?? x))|]
              ==>   {px, py} (( (<FF && b> :rg) [[> Px) || (ch !! e)) {rx, ry; Gx, Gy}"
apply (rule structSkipEL)
apply (rule structSkipELR)
apply (cut_tac H="l [=] Real 0" and Hx="l [=] Real 0" in CommunicationI2,auto)
apply (rule impR)
apply (rule basic)
apply (rule impR)
apply (rule RL3a)
apply (simp add: True_def)
apply (rule impR)
apply (rule basic)
apply (rule Parallel2)
apply (rule Skip)
apply (rule impR)
apply (rule basic)
apply (rule Skip)
apply (rule impR)
apply (rule basic)
apply (rule impR)
apply (rule LL3a)
apply (rule conjL)
apply (rule thinL)
apply (cut_tac P="l [=] Real 0 [-->] Gx" in cut,auto)
apply (rule thinL)
apply (rule thinR,auto)
apply (rule impL)
apply (rule basic)+
apply (rule impR)
apply (rule basic)
apply (rule impR)
apply (rule basic)
done

end


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

(* Title:   Confinement_S
 * Description: confinement proof of the security model
 *)

theory Confine_S
imports System_S
begin

(* These translate Create into all_rights *)
definition
  extra_rights :: "cap \<Rightarrow> cap" where
  "extra_rights c \<equiv>
  if (Create \<in> rights c)
  then c\<lparr>rights := all_rights\<rparr>
  else c"

lemma extra_rights_idem [simp]:
  "(extra_rights (extra_rights c)) = (extra_rights c)"
  apply (clarsimp simp add: extra_rights_def)
  done

lemma extra_rights_image_idem [simp]:
  "(extra_rights ` (extra_rights ` S)) = (extra_rights ` S)"
  by (rule set_eqI) (simp add: image_iff)

lemma extra_rights_empty_rights_ident [simp]:
   "extra_rights \<lparr> target = e, rights = {} \<rparr> = \<lparr> target = e, rights = {} \<rparr>"
  by (simp add: extra_rights_def)

lemma entity_extra_rights [simp]:
  "target (extra_rights c) = target c"
  by (simp add: extra_rights_def)

lemma rights_extra_rights:
  "rights (extra_rights c) =
   (if Create \<in> (rights c)
    then all_rights
    else rights c)"
  by (simp add: extra_rights_def)

(* The following two definitions both translate Create into all_rights *)

(* A cap is in a set, or a cap with more access is. *)
definition
  cap_in_caps :: "cap \<Rightarrow> cap set \<Rightarrow> bool" (infix "\<in>cap" 50) where
  "c \<in>cap C \<equiv> \<exists>c' \<in> C. target c = target c' \<and> rights (extra_rights c) \<subseteq> rights (extra_rights c')"

abbreviation not_cap_in_caps where
  "not_cap_in_caps x A \<equiv> ~ (x \<in>cap A)" \<comment> \<open>non-membership\<close>

notation (input) cap_in_caps (infix ":cap" 50)
notation (latex output)  cap_in_caps (infix "\<in>\<^sub>c\<^sub>a\<^sub>p" 50)

notation
  not_cap_in_caps  ("(\<notin>cap)") and
  not_cap_in_caps  ("(_/ \<notin>cap _)" [51, 51] 50)

notation (latex output)
  not_cap_in_caps  ("(\<notin>\<^sub>c\<^sub>a\<^sub>p)") and
  not_cap_in_caps  (infix "\<notin>\<^sub>c\<^sub>a\<^sub>p" 50)

(* A set of caps "caps" have less (or equal) access to an entity as "cap" does. *)
definition
  caps_dominated_by :: "cap set \<Rightarrow> cap \<Rightarrow> bool" (infix "\<le>cap" 50) where
  "caps \<le>cap cap \<equiv> \<forall>cap' \<in> caps. target cap' = target cap \<longrightarrow> rights (extra_rights cap') \<subseteq> rights (extra_rights cap)"

notation (input) caps_dominated_by (infix "<=cap" 50)
notation (latex output) caps_dominated_by (infix "\<unlhd>\<^sub>c\<^sub>a\<^sub>p" 50)

definition
  shares_caps :: "state \<Rightarrow> entity_id \<Rightarrow> entity_id \<Rightarrow> bool" where
  "shares_caps s e\<^sub>x e\<^sub>y \<equiv> \<exists>e\<^sub>i . (e\<^sub>x, e\<^sub>i) \<in> store_connected s \<and> (e\<^sub>y, e\<^sub>i) \<in> store_connected s"

definition
  leak :: "state \<Rightarrow> entity_id \<Rightarrow> entity_id \<Rightarrow> bool" ("_ \<turnstile> _ \<rightarrow> _") where
  "leak s e\<^sub>x e\<^sub>y \<equiv> take_cap e\<^sub>x \<in>cap caps_of s e\<^sub>y \<or> grant_cap e\<^sub>y \<in>cap caps_of s e\<^sub>x \<or> shares_caps s e\<^sub>x e\<^sub>y"

definition
  directly_tgs_connected :: "state \<Rightarrow> (entity_id \<times> entity_id) set" where
  "directly_tgs_connected s \<equiv> {(e\<^sub>x, e\<^sub>y). leak s e\<^sub>x e\<^sub>y \<or> leak s e\<^sub>y e\<^sub>x}"

lemma directly_tgs_connected_def2:
  "(e\<^sub>x, e\<^sub>y) \<in> directly_tgs_connected s = (leak s e\<^sub>x e\<^sub>y \<or> leak s e\<^sub>y e\<^sub>x)"
  by (simp add: directly_tgs_connected_def)

abbreviation
  in_directly_tgs_connected :: "state \<Rightarrow> entity_id \<Rightarrow> entity_id \<Rightarrow> bool" ("_ \<turnstile> _ \<leftrightarrow> _" [60,0,60] 61)
where
  "s \<turnstile> x \<leftrightarrow> y \<equiv> (x,y) \<in> directly_tgs_connected s"

definition
  tgs_connected :: "state \<Rightarrow> (entity_id \<times> entity_id) set" where
  "tgs_connected s \<equiv> (directly_tgs_connected s)\<^sup>*"

abbreviation
  in_tgs_connected :: "state \<Rightarrow> entity_id \<Rightarrow> entity_id \<Rightarrow> bool" ("_ \<turnstile> _ \<leftrightarrow>* _" [60,0,60] 61)
where
  "s \<turnstile> x \<leftrightarrow>* y == (x,y) \<in> tgs_connected s"

notation (latex output)
  in_tgs_connected ("_ \<turnstile> _ \<leftrightarrow>\<^sup>* _" [60,0,60] 61)

translations
  "\<not> (s \<turnstile> x \<leftrightarrow> y)" <= "(x,y) \<notin> CONST directly_tgs_connected s"
  "\<not> (s \<turnstile> x \<leftrightarrow>* y)" <= "(x,y) \<notin> CONST tgs_connected s"

lemma shares_caps_sym [simp]:
 "shares_caps s y x = shares_caps s x y"
  by (auto simp: shares_caps_def)

lemma directly_tgs_connected_def4:
  "s \<turnstile> e\<^sub>x \<leftrightarrow> e\<^sub>y = (take_cap e\<^sub>x \<in>cap caps_of s e\<^sub>y \<or> take_cap e\<^sub>y \<in>cap caps_of s e\<^sub>x \<or>
                  grant_cap e\<^sub>y \<in>cap caps_of s e\<^sub>x \<or> grant_cap e\<^sub>x \<in>cap caps_of s e\<^sub>y \<or>
                  shares_caps s e\<^sub>x e\<^sub>y)"
  by (auto simp: directly_tgs_connected_def leak_def)

(* Note: e\<^sub>0 is unused. *)
definition
  generalOperation ::
  "entity_id \<Rightarrow> entity_id \<Rightarrow> cap \<Rightarrow> right set \<Rightarrow> modify_state" where
  "generalOperation e\<^sub>0 e\<^sub>1 c r s \<equiv>
  s (e\<^sub>1 \<mapsto> Entity ( insert (diminish r (extra_rights c)) (direct_caps_of s e\<^sub>1) ))"

lemma is_entity_general [simp]:
  "is_entity s e\<^sub>1 \<Longrightarrow> is_entity (generalOperation e\<^sub>0 e\<^sub>1 c r s) e' = is_entity s e'"
  by (simp add: is_entity_def generalOperation_def)

definition
  make_entity :: "entity_id \<Rightarrow> modify_state" where
  "make_entity n s \<equiv>
  s (n \<mapsto> null_entity)"

lemma direct_caps_of_store_connected_eq:
  "\<forall> e. direct_caps_of s e = direct_caps_of s' e
  \<Longrightarrow> store_connected s = store_connected s'"
  by (simp add: store_connected_def store_connected_direct_def
                direct_caps_of_def)

lemma direct_caps_of_caps_of_eq:
  "\<forall> e. direct_caps_of s e = direct_caps_of s' e \<Longrightarrow> caps_of s e = caps_of s' e"
  by (simp add: caps_of_def store_connected_def store_connected_direct_def
                direct_caps_of_def)

lemma direct_caps_of_caps_of_eq2:
  "\<lbrakk>\<forall> e. direct_caps_of s e = direct_caps_of s' e; c \<in>cap caps_of s e\<rbrakk> \<Longrightarrow> c \<in>cap caps_of s' e"
  apply (drule direct_caps_of_caps_of_eq)
  apply (simp add: cap_in_caps_def)
  by auto

lemma direct_caps_of_directly_tgs_connected_eq:
  "\<forall> e. direct_caps_of s e = direct_caps_of s' e \<Longrightarrow> s \<turnstile> x \<leftrightarrow> y = s' \<turnstile> x \<leftrightarrow> y"
  apply (simp add: directly_tgs_connected_def4 shares_caps_def)
  apply rule
   apply (erule disjE, drule (1) direct_caps_of_caps_of_eq2, clarsimp)+
   apply (drule direct_caps_of_store_connected_eq, clarsimp)
  apply (erule disjE, drule direct_caps_of_caps_of_eq2 [rotated, where s=s' and s'=s], simp+)+
  apply (drule direct_caps_of_store_connected_eq, simp)
  done

lemma direct_caps_of_make_entity:
  "\<not> is_entity s n \<Longrightarrow> direct_caps_of (make_entity n s) e = direct_caps_of s e"
  by (simp add: direct_caps_of_def make_entity_def is_entity_def
                null_entity_def)

lemma caps_of_make_entity:
  "\<not> is_entity s n \<Longrightarrow> caps_of (make_entity n s) e = caps_of s e"
  apply (rule direct_caps_of_caps_of_eq)
  apply clarsimp
  apply (erule direct_caps_of_make_entity)
  done

lemma caps_of_make_entity2:
  "\<lbrakk>\<not> is_entity s n; c \<in> caps_of (make_entity n s) e\<rbrakk> \<Longrightarrow> c \<in> caps_of s e"
  apply (drule caps_of_make_entity)
  apply fastforce
  done

lemma directly_tgs_connected_make_entity:
 "\<not> is_entity s n \<Longrightarrow> make_entity n s \<turnstile> x \<leftrightarrow> y = s \<turnstile> x \<leftrightarrow> y"
  apply (rule direct_caps_of_directly_tgs_connected_eq)
  apply clarsimp
  apply (drule (1) direct_caps_of_make_entity)
  done

lemma directly_tgs_connected_make_entity2:
 "\<lbrakk>\<not> is_entity s n; make_entity n s \<turnstile> x \<leftrightarrow> y\<rbrakk> \<Longrightarrow> s \<turnstile> x \<leftrightarrow> y"
  apply (drule directly_tgs_connected_make_entity)
  apply fastforce
  done

lemma diminish_extra_rights [simp]:
  "diminish (rights c) (extra_rights c) = c"
  by (simp add: diminish_def all_rights_def rights_extra_rights)

lemma diminish_extra_rights2 [simp]:
  "diminish (r \<inter> rights c) (extra_rights c) = diminish r c"
  apply (simp add: diminish_def extra_rights_def all_rights_def)
  apply (simp add: Int_commute)
  apply (subgoal_tac "rights c \<inter> (r \<inter> rights c) = r \<inter> rights c")
   apply simp
  apply fastforce
  done

lemma create_general_helper:
  "Create \<in> rights c\<^sub>2 \<Longrightarrow>
   \<lparr>target = target c\<^sub>2, rights = UNIV\<rparr> = c\<^sub>2\<lparr>rights := UNIV\<rparr>"
  by auto

lemma extra_rights_full_cap [simp]:
  "extra_rights (full_cap e) = full_cap e"
  by (simp add: extra_rights_def)

lemma create_general_alt:
  "createOperation e c\<^sub>1 c\<^sub>2 s =
   make_entity (target c\<^sub>2)
               (generalOperation  e (target c\<^sub>1) (full_cap (target c\<^sub>2)) (all_rights) s)"
  by (simp add: createOperation_def generalOperation_def make_entity_def)

lemma create_general:
  "Create \<in> rights c\<^sub>2 \<Longrightarrow> createOperation e c\<^sub>1 c\<^sub>2 s =
   make_entity (target c\<^sub>2)
               (generalOperation  e (target c\<^sub>1) c\<^sub>2 (all_rights) s)"
  by (simp add: createOperation_def generalOperation_def make_entity_def
                full_cap_def all_rights_def diminish_def
                extra_rights_def create_general_helper null_entity_def)

lemma take_general:
  "takeOperation e c\<^sub>1 c\<^sub>2 r s =
   generalOperation (target c\<^sub>1) e c\<^sub>2 (r \<inter> rights c\<^sub>2) s"
  by (simp add: takeOperation_def generalOperation_def)

lemma grant_general:
  "grantOperation e c\<^sub>1 c\<^sub>2 r s =
   generalOperation e (target c\<^sub>1) c\<^sub>2 (r \<inter> rights c\<^sub>2) s"
  by (simp add: grantOperation_def generalOperation_def)

lemma copy_general:
  "copyOperation e c\<^sub>1 c\<^sub>2 r s =
   generalOperation e (target c\<^sub>1) c\<^sub>2 (r \<inter> rights c\<^sub>2) s"
  by (simp add: copyOperation_def generalOperation_def)

(* Lemmas on the directly_tgs_connected predicate *)
lemma directly_tgs_connected_comm:
  "s \<turnstile> x \<leftrightarrow> y \<Longrightarrow> s \<turnstile> y \<leftrightarrow> x"
  by(auto simp: directly_tgs_connected_def)

lemma tgs_connected_refl [simp]:
  "s \<turnstile> x \<leftrightarrow>* x"
  by (metis tgs_connected_def rtrancl.rtrancl_refl)

lemma tgs_connected_comm:
  "s \<turnstile> x \<leftrightarrow>* y \<Longrightarrow> s \<turnstile> y \<leftrightarrow>* x"
  apply(simp add: tgs_connected_def)
  apply(erule rtrancl_induct, simp)
  apply(case_tac "s \<turnstile> z \<leftrightarrow> y")
   apply(simp add: directly_tgs_connected_comm)
  apply(simp add: directly_tgs_connected_comm)
  done

lemma tgs_connected_comm_eq:
  "s \<turnstile> x \<leftrightarrow>* y = s \<turnstile> y \<leftrightarrow>* x"
  by (metis tgs_connected_comm)

lemmas tgs_connected_trans =
       rtrancl_trans [where r="directly_tgs_connected s"  for s, simplified tgs_connected_def[symmetric]]

lemmas directly_tgs_connected_rtrancl_into_rtrancl =
       rtrancl_into_rtrancl [where r="directly_tgs_connected s" for s, simplified tgs_connected_def[symmetric]]

lemma take_caps_directly_tgs_connected:
  "\<lbrakk>c \<in> caps_of s e; Take \<in> rights c\<rbrakk> \<Longrightarrow> s \<turnstile> e \<leftrightarrow> target c"
  by (auto simp: directly_tgs_connected_def leak_def take_cap_def cap_in_caps_def extra_rights_def all_rights_def)

lemma grant_caps_directly_tgs_connected:
  "\<lbrakk>c \<in> caps_of s e; Grant \<in> rights c\<rbrakk> \<Longrightarrow> s \<turnstile> e \<leftrightarrow> target c"
  by (auto simp: directly_tgs_connected_def leak_def grant_cap_def cap_in_caps_def extra_rights_def all_rights_def)

lemma create_caps_directly_tgs_connected:
  "\<lbrakk>c \<in> caps_of s e; Create \<in> rights c\<rbrakk> \<Longrightarrow> s \<turnstile> e \<leftrightarrow> target c"
  by (auto simp: directly_tgs_connected_def leak_def cap_in_caps_def rights_extra_rights all_rights_def)

lemma store_connected_directly_tgs_connected:
  "(x, y) \<in> store_connected s \<Longrightarrow> s \<turnstile> x \<leftrightarrow> y"
  by (auto simp: directly_tgs_connected_def leak_def shares_caps_def store_connected_def)

(* Lemmas on caps *)

lemma cap_in_caps_insert [simp]:
  "c \<in>cap insert c' S = (target c = target c' \<and>
  rights (extra_rights c) \<subseteq> rights (extra_rights c') \<or> c \<in>cap S)"
  by (simp add: cap_in_caps_def)

lemma cap_in_caps_singleton [simp]:
  "c \<in>cap {c'} = (target c = target c' \<and> rights (extra_rights c) \<subseteq> rights (extra_rights c'))"
  by (simp add: cap_in_caps_def)

lemma not_in [simp]:
  "{} \<le>cap c"
  by(simp add: caps_dominated_by_def)

lemma extra_rights_diminish:
  "x \<in> rights (extra_rights (diminish r c))
   \<Longrightarrow> x \<in> rights (extra_rights c)"
  by (auto simp: rights_extra_rights all_rights_def split:if_split_asm)

(* Lemmas on system operations *)

definition
  in_store_connected :: "state \<Rightarrow> entity_id \<Rightarrow> entity_id \<Rightarrow> bool" where
  "in_store_connected s x y \<equiv> (x, y) \<in> store_connected s"

(* Lemmas about the general operation *)

lemma direct_caps_of_generalOp:
  "direct_caps_of (generalOperation e\<^sub>0 e\<^sub>1 c r s) e =
  (if e = e\<^sub>1
   then insert (diminish r (extra_rights c)) (direct_caps_of s (e\<^sub>1))
   else direct_caps_of s e)"
  by (clarsimp simp: generalOperation_def direct_caps_of_def split:option.splits)

lemma direct_caps_of_generalOp2:
  "\<lbrakk>c' \<in> direct_caps_of (generalOperation e\<^sub>0 e\<^sub>1 c r s) x\<rbrakk> \<Longrightarrow>
   c' \<in> direct_caps_of s x \<or> (c' \<in>cap {c} \<and> x = e\<^sub>1)"
  apply (clarsimp simp: direct_caps_of_generalOp extra_rights_diminish
           split:if_split_asm)
  apply (drule extra_rights_diminish)
  by simp

lemma store_connected_direct_generalOp:
  "\<lbrakk>(x, y) \<in> store_connected_direct (generalOperation e\<^sub>0 e\<^sub>1 c r s)\<rbrakk> \<Longrightarrow>
   (x, y) \<in> store_connected_direct s \<or>
   (x = e\<^sub>1 \<and> y = target c \<and> Store \<in> rights (extra_rights c))"
  by (auto simp: store_connected_direct_def direct_caps_of_generalOp all_rights_def
          split: if_split_asm)

lemma store_connected_generalOp:
  "\<lbrakk>(x, y) \<in> store_connected (generalOperation e\<^sub>0 e\<^sub>1 c r s)\<rbrakk> \<Longrightarrow>
   (x, y) \<in> store_connected s \<or>
   ((x, e\<^sub>1) \<in> store_connected s \<and>
   (e\<^sub>1, target c) \<in> store_connected_direct (generalOperation e\<^sub>0 e\<^sub>1 c r s) \<and>
   (target c, y) \<in> store_connected s)"
  apply (unfold store_connected_def)
  apply (erule rtrancl_induct)
   apply clarsimp
  apply (clarsimp)
  apply (fold store_connected_def)
  apply (subgoal_tac "(y, z) \<in> store_connected_direct s")
   apply (clarsimp simp: store_connected_def)
   apply (erule disjE)
    apply fastforce
   apply clarsimp
   apply (erule notE)
   apply fastforce
  apply (frule store_connected_direct_generalOp)
  apply (clarsimp simp: store_connected_def)
  done

lemma store_connected_generalOp_not_new:
  "\<lbrakk>(e\<^sub>1, target c) \<in> store_connected_direct (generalOperation e\<^sub>0 e\<^sub>1 c r s);
   c \<in> caps_of s e\<^sub>0\<rbrakk> \<Longrightarrow>
   (e\<^sub>1, target c) \<in> store_connected_direct s \<or>
   (e\<^sub>0, target c) \<in> store_connected s \<or>
   Create \<in> rights c"
  apply (drule store_connected_direct_generalOp)
  apply (clarsimp simp: rights_extra_rights split:if_split_asm)
   apply (drule (1) store_caps_store_connected, simp)
  done

lemma store_connected_generalOp2:
  "\<lbrakk>(x, y) \<in> store_connected (generalOperation e\<^sub>0 e\<^sub>1 c r s);
   c \<in> caps_of s e\<^sub>0; s \<turnstile> e\<^sub>0 \<leftrightarrow> e\<^sub>1\<rbrakk> \<Longrightarrow>
   s \<turnstile> x \<leftrightarrow>* y"
  apply (drule store_connected_generalOp)
  apply (erule disjE)
   apply (simp add: tgs_connected_def)
   apply (drule store_connected_directly_tgs_connected, simp)
  apply clarsimp
  apply (drule store_connected_directly_tgs_connected [where x=x and y=e\<^sub>1])
  apply (drule store_connected_directly_tgs_connected [where x="target c" and y=y])
  apply (drule (1) store_connected_generalOp_not_new)
  apply (erule disjE)
   apply (drule store_connected_direct_in_store_connected)
   apply (drule store_connected_directly_tgs_connected [where x=e\<^sub>1 and y="target c"])
   apply (simp add: tgs_connected_def)
  apply (drule directly_tgs_connected_comm [where x="e\<^sub>0" and y="e\<^sub>1"])
  apply (erule disjE)
   apply (drule store_connected_directly_tgs_connected [where x=e\<^sub>0 and y="target c"])
   apply (simp add: tgs_connected_def)
  apply (drule (1) create_caps_directly_tgs_connected)
  apply (simp add: tgs_connected_def)
  done

lemma shares_caps_of_generalOp:
  "\<lbrakk>shares_caps (generalOperation e\<^sub>0 e\<^sub>1 c r s) x y;
   c \<in> caps_of s e\<^sub>0; s \<turnstile> e\<^sub>0 \<leftrightarrow> e\<^sub>1\<rbrakk>
  \<Longrightarrow> s \<turnstile> x \<leftrightarrow>* y"
  apply (clarsimp simp: shares_caps_def)
  apply (frule (2) store_connected_generalOp2 [where x=x])
  apply (drule (2) store_connected_generalOp2 [where x=y])
  apply (drule tgs_connected_comm [where x=y])
  apply (simp add: tgs_connected_def)
  done

lemma caps_of_generalOp:
  "\<lbrakk>c' \<in> caps_of (generalOperation e\<^sub>0 e\<^sub>1 c r s) x;
   c \<in> caps_of s e\<^sub>0; s \<turnstile> e\<^sub>0 \<leftrightarrow> e\<^sub>1\<rbrakk>
  \<Longrightarrow> \<exists>z. (x,z) \<in> tgs_connected s \<and> c' \<in>cap caps_of s z"
  apply (simp add: caps_of_def[where e=x])
  apply clarsimp
  apply (frule (2) store_connected_generalOp2)
  apply (drule direct_caps_of_generalOp2)
  apply (erule disjE)
   apply (drule direct_cap_in_cap)
   apply (fastforce simp: cap_in_caps_def)
  apply (subgoal_tac "s \<turnstile> x \<leftrightarrow>* e\<^sub>0")
   apply (subgoal_tac "c' \<in>cap caps_of s e\<^sub>0")
    apply fastforce
   apply (fastforce simp: cap_in_caps_def)
  apply clarsimp
  apply (drule directly_tgs_connected_comm [where x="e\<^sub>0" and y="e\<^sub>1"])
  apply (simp add: tgs_connected_def)
  done

lemma take_cap_generalOp:
  "\<lbrakk>take_cap y \<in>cap caps_of (generalOperation e\<^sub>0 e\<^sub>1 c r s) x;
   c \<in> caps_of s e\<^sub>0; s \<turnstile> e\<^sub>0 \<leftrightarrow> e\<^sub>1\<rbrakk>
  \<Longrightarrow> \<exists>z.  s \<turnstile> x \<leftrightarrow>* z \<and> take_cap y \<in>cap caps_of s z"
  apply (simp add: cap_in_caps_def)
  apply clarsimp
  apply (drule (2) caps_of_generalOp)
  apply (fastforce simp: cap_in_caps_def)
  done

lemma grant_cap_generalOp:
  "\<lbrakk>grant_cap y \<in>cap caps_of (generalOperation e\<^sub>0 e\<^sub>1 c r s) x;
   c \<in> caps_of s e\<^sub>0; s \<turnstile> e\<^sub>0 \<leftrightarrow> e\<^sub>1\<rbrakk>
  \<Longrightarrow> \<exists>z.  s \<turnstile> x \<leftrightarrow>* z \<and> grant_cap y \<in>cap caps_of s z"
  apply (simp add: cap_in_caps_def)
  apply clarsimp
  apply (drule (2) caps_of_generalOp)
  apply (fastforce simp: cap_in_caps_def)
  done

lemma take_cap_generalOp2:
  "\<lbrakk>take_cap y \<in>cap caps_of (generalOperation e\<^sub>0 e\<^sub>1 c r s) x;
   c \<in> caps_of s e\<^sub>0; s \<turnstile> e\<^sub>0 \<leftrightarrow> e\<^sub>1\<rbrakk>
  \<Longrightarrow> (x, y) \<in> tgs_connected s"
  apply (drule (2) take_cap_generalOp)
  apply clarsimp
  apply (subgoal_tac "s \<turnstile> z \<leftrightarrow> y")
   apply (simp add: tgs_connected_def)
  apply (simp add: directly_tgs_connected_def leak_def)
  done

lemma grant_cap_generalOp2:
  "\<lbrakk>grant_cap y \<in>cap caps_of (generalOperation e\<^sub>0 e\<^sub>1 c r s) x;
   c \<in> caps_of s e\<^sub>0; s \<turnstile> e\<^sub>0 \<leftrightarrow> e\<^sub>1\<rbrakk>
  \<Longrightarrow> (x, y) \<in> tgs_connected s"
  apply (drule (2) grant_cap_generalOp)
  apply clarsimp
  apply (subgoal_tac "s \<turnstile> z \<leftrightarrow> y")
   apply (simp add: tgs_connected_def)
  apply (simp add: directly_tgs_connected_def leak_def)
  done

lemma generalOp_directly_tgs_connected:
 "\<lbrakk>generalOperation e\<^sub>0 e\<^sub>1 c r s \<turnstile> x \<leftrightarrow> y;
   c \<in> caps_of s e\<^sub>0; s \<turnstile> e\<^sub>0 \<leftrightarrow> e\<^sub>1\<rbrakk>
  \<Longrightarrow> s \<turnstile> x \<leftrightarrow>* y"
  apply (simp add: directly_tgs_connected_def [where s="generalOperation e\<^sub>0 e\<^sub>1 c r s"] leak_def)
  apply safe
       apply (rule tgs_connected_comm)
       apply (drule (3) take_cap_generalOp2)
      apply (drule (3) grant_cap_generalOp2)
     apply (erule (2) shares_caps_of_generalOp)
    apply (drule (3) take_cap_generalOp2)
   apply (rule tgs_connected_comm)
   apply (drule (3) grant_cap_generalOp2)
  apply (erule (2) shares_caps_of_generalOp)
  done

(* results from general operation *)

lemma create_legal_directly_tgs_connected:
  "legal (SysCreate e c\<^sub>1 c\<^sub>2) s \<Longrightarrow> s  \<turnstile> target c\<^sub>1 \<leftrightarrow> e"
  apply clarsimp
  apply (rule directly_tgs_connected_comm)
  apply (drule (1) create_caps_directly_tgs_connected)
  apply (drule (1) store_caps_store_connected)
  apply (drule (1) store_connected_directly_tgs_connected)
  done

lemma take_legal_directly_tgs_connected:
  "legal (SysTake e c\<^sub>1 c\<^sub>2 r) s \<Longrightarrow> s  \<turnstile> target c\<^sub>1 \<leftrightarrow> e"
  apply clarsimp
  apply (rule directly_tgs_connected_comm)
  apply (drule (2) take_caps_directly_tgs_connected)
  done

lemma grant_legal_directly_tgs_connected:
  "legal (SysGrant e c\<^sub>1 c\<^sub>2 r) s \<Longrightarrow> s \<turnstile> e \<leftrightarrow> target c\<^sub>1"
  apply clarsimp
  apply (drule (2) grant_caps_directly_tgs_connected)
  done

lemma copy_legal_directly_tgs_connected:
  "legal (SysCopy e c\<^sub>1 c\<^sub>2 r) s \<Longrightarrow> s \<turnstile> e \<leftrightarrow> target c\<^sub>1"
  apply clarsimp
  apply (drule (1) store_caps_store_connected)
  apply (drule (1) store_connected_directly_tgs_connected)
  done

lemma caps_of_create:
  "\<lbrakk>c' \<in> caps_of (createOperation e c\<^sub>1 c\<^sub>2 s) x; legal (SysCreate e c\<^sub>1 c\<^sub>2) s\<rbrakk>
  \<Longrightarrow> \<exists>z. (x,z) \<in> tgs_connected s \<and> c' \<in>cap caps_of s z"
  apply (frule create_legal_directly_tgs_connected)
  apply (clarsimp simp: create_general)
  apply (drule caps_of_make_entity2 [rotated], clarsimp)
  apply (drule (1) caps_of_generalOp)
   apply (drule (2) directly_tgs_connected_comm)
  done

lemma caps_of_take:
  "\<lbrakk>c' \<in> caps_of (takeOperation e c\<^sub>1 c\<^sub>2 r s) x; legal (SysTake e c\<^sub>1 c\<^sub>2 r) s\<rbrakk>
  \<Longrightarrow> \<exists>z. (x,z) \<in> tgs_connected s \<and> c' \<in>cap caps_of s z"
  apply (frule take_legal_directly_tgs_connected)
  apply (clarsimp simp: take_general)
  apply (drule (2) caps_of_generalOp)
   apply (drule (1) directly_tgs_connected_comm)
  done

lemma caps_of_grant:
  "\<lbrakk>c' \<in> caps_of (grantOperation e c\<^sub>1 c\<^sub>2 r s) x; legal (SysGrant e c\<^sub>1 c\<^sub>2 r) s\<rbrakk>
  \<Longrightarrow> \<exists>z. (x,z) \<in> tgs_connected s \<and> c' \<in>cap caps_of s z"
  apply (frule grant_legal_directly_tgs_connected)
  apply (clarsimp simp: grant_general)
  apply (drule (2) caps_of_generalOp)
   apply (drule (1) directly_tgs_connected_comm)
  done

lemma caps_of_copy:
  "\<lbrakk>c' \<in> caps_of (copyOperation e c\<^sub>1 c\<^sub>2 r s) x; legal (SysCopy e c\<^sub>1 c\<^sub>2 r) s\<rbrakk>
  \<Longrightarrow> \<exists>z. (x,z) \<in> tgs_connected s \<and> c' \<in>cap caps_of s z"
  apply (frule copy_legal_directly_tgs_connected)
  apply (clarsimp simp: copy_general)
  apply (drule (2) caps_of_generalOp)
   apply (drule (1) directly_tgs_connected_comm)
  done

lemma create_directly_tgs_connected:
 "\<lbrakk>createOperation e c\<^sub>1 c\<^sub>2 s \<turnstile> x \<leftrightarrow> y; legal (SysCreate e c\<^sub>1 c\<^sub>2) s\<rbrakk>
  \<Longrightarrow> s \<turnstile> x \<leftrightarrow>* y"
  apply (frule create_legal_directly_tgs_connected)
  apply (clarsimp simp: create_general)
  apply (drule directly_tgs_connected_make_entity2 [rotated], clarsimp)
  apply (drule (1) generalOp_directly_tgs_connected)
   apply (drule (2) directly_tgs_connected_comm)
  done

lemma take_directly_tgs_connected:
 "\<lbrakk>takeOperation e c\<^sub>1 c\<^sub>2 r s \<turnstile> x \<leftrightarrow> y; legal (SysTake e c\<^sub>1 c\<^sub>2 r) s\<rbrakk>
  \<Longrightarrow> s \<turnstile> x \<leftrightarrow>* y"
  apply (frule take_legal_directly_tgs_connected)
  apply (clarsimp simp: take_general)
  apply (drule (3) generalOp_directly_tgs_connected)
  done

lemma grant_directly_tgs_connected:
 "\<lbrakk>grantOperation e c\<^sub>1 c\<^sub>2 r s \<turnstile> x \<leftrightarrow> y; legal (SysGrant e c\<^sub>1 c\<^sub>2 r) s\<rbrakk>
  \<Longrightarrow> s \<turnstile> x \<leftrightarrow>* y"
  apply (frule grant_legal_directly_tgs_connected)
  apply (clarsimp simp: grant_general)
  apply (drule (3) generalOp_directly_tgs_connected)
  done

lemma copy_directly_tgs_connected:
 "\<lbrakk>copyOperation e c\<^sub>1 c\<^sub>2 r s \<turnstile> x \<leftrightarrow> y; legal (SysCopy e c\<^sub>1 c\<^sub>2 r) s\<rbrakk>
  \<Longrightarrow> s \<turnstile> x \<leftrightarrow>* y"
  apply (frule copy_legal_directly_tgs_connected)
  apply (clarsimp simp: copy_general)
  apply (drule (3) generalOp_directly_tgs_connected)
  done

lemma create_conTrans:
  "\<lbrakk>s' \<in> step cmd s; (x, y) \<in> directly_tgs_connected s'; cmd = (SysCreate e c\<^sub>1 c\<^sub>2)\<rbrakk>
  \<Longrightarrow> (x, y) \<in> tgs_connected s"
  apply(clarsimp simp: step_def split: if_split_asm)
   apply (erule disjE, fastforce simp: tgs_connected_def, clarsimp)
   apply (drule create_directly_tgs_connected, clarsimp, assumption)
  apply (simp add: tgs_connected_def)
  done

lemma take_conTrans:
  "\<lbrakk>s' \<in> step cmd s; (x, y) \<in> directly_tgs_connected s'; cmd = (SysTake e c\<^sub>1 c\<^sub>2 r)\<rbrakk>
  \<Longrightarrow> (x, y) \<in> tgs_connected s"
  apply(clarsimp simp: step_def split: if_split_asm)
   apply (erule disjE, fastforce simp: tgs_connected_def, clarsimp)
   apply (drule take_directly_tgs_connected, clarsimp, assumption)
  apply (simp add: tgs_connected_def)
  done

lemma grant_conTrans:
  "\<lbrakk>s' \<in> step cmd s; (x, y) \<in> directly_tgs_connected s'; cmd = (SysGrant e c\<^sub>1 c\<^sub>2 r)\<rbrakk>
  \<Longrightarrow> (x, y) \<in> tgs_connected s"
  apply(clarsimp simp: step_def split: if_split_asm)
   apply (erule disjE, fastforce simp: tgs_connected_def, clarsimp)
   apply (drule grant_directly_tgs_connected, clarsimp, assumption)
  apply (simp add: tgs_connected_def)
  done

lemma copy_conTrans:
  "\<lbrakk>s' \<in> step cmd s; (x, y) \<in> directly_tgs_connected s'; cmd = (SysCopy e c\<^sub>1 c\<^sub>2 r)\<rbrakk>
  \<Longrightarrow> (x, y) \<in> tgs_connected s"
  apply(clarsimp simp: step_def split: if_split_asm)
   apply (erule disjE, fastforce simp: tgs_connected_def, clarsimp)
   apply (drule copy_directly_tgs_connected, clarsimp, assumption)
  apply (simp add: tgs_connected_def)
  done

(* Lemmas about destroy *)

lemma direct_caps_of_destroy:
  "c \<in> direct_caps_of (s(e := None)) x \<Longrightarrow> c \<in> direct_caps_of s x"
  by (simp add: direct_caps_of_def split: option.splits split: if_split_asm)

lemma store_connected_destroy:
 "(x, y) \<in> store_connected (s(e := None)) \<Longrightarrow> (x, y) \<in> store_connected s"
  apply (simp add: store_connected_def)
  apply (erule rtrancl_induct)
   apply simp
  apply (fold store_connected_def)
  apply (subgoal_tac "(y,z) \<in> store_connected_direct s")
   apply (fastforce simp: store_connected_def)
  apply (simp add: store_connected_direct_def)
  apply clarsimp
  by (metis direct_caps_of_destroy)

lemma shares_caps_destroy:
  "shares_caps (destroyOperation e c s) x y
  \<Longrightarrow> shares_caps s x y"
  apply (clarsimp simp: shares_caps_def destroyOperation_def)
  apply (frule store_connected_destroy [where x=x])
  apply (drule store_connected_destroy [where x=y])
  by auto

lemma caps_of_destroy:
  "c \<in> caps_of (destroyOperation e' c' s) e \<Longrightarrow>
  c \<in> caps_of s e"
  apply (clarsimp simp add: destroyOperation_def caps_of_def)
  apply (rule_tac x=x in exI)
  apply (drule direct_caps_of_destroy)
  apply simp
  apply (erule store_connected_destroy)
  done

lemma destroy_directly_tgs_connected:
  "\<lbrakk>s' \<in> step (SysDestroy e c) s; (x, y) \<in> directly_tgs_connected s'\<rbrakk> \<Longrightarrow>
  (x, y) \<in> directly_tgs_connected s"
  apply(clarsimp simp: step_def split: if_split_asm)
  apply(erule disjE, simp)
  apply(simp add: directly_tgs_connected_def leak_def)
  apply (erule disjE)
   apply(fastforce simp add: cap_in_caps_def dest!: caps_of_destroy)
  apply (erule disjE)
   apply(fastforce simp add: cap_in_caps_def dest!: caps_of_destroy)
  apply (erule disjE)
   apply (drule shares_caps_destroy, simp)
  apply (erule disjE)
   apply(fastforce simp add: cap_in_caps_def dest!: caps_of_destroy)
  apply (erule disjE)
   apply(fastforce simp add: cap_in_caps_def dest!: caps_of_destroy)
  apply (drule shares_caps_destroy, simp)
  done

lemma destroy_conTrans:
  "\<lbrakk>s' \<in> step cmd s; (x, y) \<in> directly_tgs_connected s'; cmd = (SysDestroy e c)\<rbrakk>
  \<Longrightarrow> (x, y) \<in>  directly_tgs_connected s"
  by(auto dest!: destroy_directly_tgs_connected)

(* lemmas about remove *)

lemma direct_caps_of_remove:
  "c \<in> direct_caps_of (removeOperation e c\<^sub>1 c\<^sub>2 s) x \<Longrightarrow>
  c \<in> direct_caps_of s x"
  by (clarsimp simp: removeOperation_simpler direct_caps_of_def
              split: option.splits if_split_asm)

lemma direct_caps_of_remove_eq:
  "direct_caps_of (removeOperation e c\<^sub>1 c\<^sub>2 s) x =
  ( if   is_entity s (target c\<^sub>1) \<and> x = target c\<^sub>1
   then  direct_caps_of s (target c\<^sub>1) - {c\<^sub>2}
   else  direct_caps_of s x )"
  by(simp add: direct_caps_of_def is_entity_def removeOperation_def)

lemma store_connected_remove [rule_format]:
  "(x, y) \<in> store_connected (s(e \<mapsto> Entity C')) \<Longrightarrow>
  s e = Some (Entity C) \<longrightarrow> C' \<subseteq> C \<longrightarrow> (x, y) \<in> store_connected s"
  apply (unfold store_connected_def)
  apply (erule rtrancl_induct)
   apply simp
  apply clarsimp
  apply (subgoal_tac "(y,z) \<in> store_connected_direct s")
   apply (erule rtrancl_trans)
   apply fastforce
  apply (fold store_connected_def)
  apply (clarsimp simp add: store_connected_direct_def)
  apply (fastforce simp: direct_caps_of_def
                  split: option.splits if_split_asm)
  done

lemma caps_of_remove:
  "c \<in> caps_of (removeOperation e c\<^sub>1 c\<^sub>2 s) x \<Longrightarrow>
  c \<in> caps_of s x"
  apply (clarsimp simp: caps_of_def)
  apply (rule_tac x=xa in exI)
  apply (drule direct_caps_of_remove)
  apply (simp add: removeOperation_simpler
            split: option.splits)
  apply (erule (1) store_connected_remove)
  apply blast
  done

(* Might equal either  "caps s (target c\<^sub>1) - {c\<^sub>2}" or "caps s x" depending if the caps are duplicated.*)
lemma caps_of_remove2:
  "caps_of (removeOperation e c\<^sub>1 c\<^sub>2 s) x \<subseteq> caps_of s x"
  apply(simp add: caps_of_def is_entity_def removeOperation_def direct_caps_of_def)
  apply (clarsimp split: if_split_asm)
   apply (auto dest!: store_connected_remove)
  done

lemma shares_caps_remove:
  "shares_caps (removeOperation e c\<^sub>1 c\<^sub>2 s) x y
  \<Longrightarrow> shares_caps s x y"
  apply (clarsimp simp: shares_caps_def removeOperation_simpler
                 split:option.splits)
  apply (frule (1) store_connected_remove [where x=x], clarsimp)
  apply (drule (1) store_connected_remove [where x=y], clarsimp)
  by auto

lemma remove_directly_tgs_connected:
  "\<lbrakk>s' \<in> step (SysRemove e c\<^sub>1 c\<^sub>2) s; (x, y) \<in> directly_tgs_connected s'\<rbrakk> \<Longrightarrow>
  (x, y) \<in> directly_tgs_connected s"
  apply(simp add: step_def split: if_split_asm)
  apply(erule disjE, simp)
  apply(simp add: directly_tgs_connected_def leak_def)
  apply(simp add: cap_in_caps_def)
  apply(clarsimp)
  apply safe
     prefer 3
     apply (drule shares_caps_remove, simp)
    prefer 5
    apply (drule shares_caps_remove, simp)
   apply(auto dest!: caps_of_remove)
  done

lemma remove_conTrans:
  "\<lbrakk>s' \<in> step cmd s; (x, y) \<in> directly_tgs_connected s'; cmd = (SysRemove e c\<^sub>1 c\<^sub>2)\<rbrakk>
  \<Longrightarrow> (x, y) \<in>  directly_tgs_connected s"
  by(auto dest!: remove_directly_tgs_connected)

lemma direct_caps_of_removeSet:
  "c' \<in> direct_caps_of (removeSetOperation e c C s) x \<Longrightarrow>
  c' \<in> direct_caps_of s x"
  by (clarsimp simp: removeSetOperation_simpler direct_caps_of_def
              split: option.splits if_split_asm)

lemma caps_of_removeSet:
  "c' \<in> caps_of (removeSetOperation e c C s) x \<Longrightarrow>
  c' \<in> caps_of s x"
  apply (clarsimp simp: caps_of_def)
  apply (rule_tac x=xa in exI)
  apply (drule direct_caps_of_removeSet)
  apply (simp add: removeSetOperation_simpler split: option.splits)
  apply (erule (1) store_connected_remove)
  apply blast
  done

lemma shares_caps_removeSet:
  "shares_caps (removeSetOperation e c C s) x y
  \<Longrightarrow> shares_caps s x y"
  apply (clarsimp simp: shares_caps_def removeSetOperation_simpler split:option.splits)
  apply (frule (1) store_connected_remove [where x=x], clarsimp)
  apply (drule (1) store_connected_remove [where x=y], clarsimp)
  by auto

lemma removeSet_connected:
  " \<lbrakk>s' \<in> step (SysRemoveSet e c C) s; s' \<turnstile> x \<leftrightarrow> y\<rbrakk> \<Longrightarrow> s \<turnstile> x \<leftrightarrow> y"
  apply(simp add: step_def split: if_split_asm)
  apply(erule disjE, simp)
  apply(simp add: directly_tgs_connected_def leak_def)
  apply(simp add: cap_in_caps_def)
  apply(clarsimp)
  apply safe
     prefer 3
     apply (drule shares_caps_removeSet, simp)
    prefer 5
    apply (drule shares_caps_removeSet, simp)
   apply (auto dest!: caps_of_removeSet)
  done

lemma removeSet_conTrans:
  "\<lbrakk>s' \<in> step cmd s; s' \<turnstile> x \<leftrightarrow> y; cmd = (SysRemoveSet n c C)\<rbrakk>
  \<Longrightarrow> s \<turnstile> x \<leftrightarrow> y"
  by(auto dest!: removeSet_connected)

(* lemmas about revoke *)
lemma direct_caps_of_removeSetOfCaps:
  "c' \<in> direct_caps_of (removeSetOfCaps cap_map s) x \<Longrightarrow>
  c' \<in> direct_caps_of s x"
  by (clarsimp simp: removeSetOfCaps_def direct_caps_of_def
              split: option.splits if_split_asm)
thm store_connected_remove

lemma store_connected_removeSetOfCaps:
  "(x, y) \<in> store_connected (\<lambda>e. if is_entity s e
                                 then Some (Entity (direct_caps_of s e - cap_map e))
                                 else None) \<Longrightarrow>
    (x, y) \<in> store_connected s"
  apply (unfold store_connected_def)
  apply (erule rtrancl_induct)
   apply simp
  apply (subgoal_tac "(y,z) \<in> store_connected_direct s")
   apply (erule rtrancl_trans)
   apply fastforce
  apply (fold store_connected_def)
  apply (clarsimp simp add: store_connected_direct_def)
  apply (fastforce simp: direct_caps_of_def
                  split: option.splits if_split_asm)
  done

lemma caps_of_removeSetOfCaps:
  "c' \<in> caps_of (removeSetOfCaps cap_map s) x \<Longrightarrow>
  c' \<in> caps_of s x"
  apply (clarsimp simp: caps_of_def)
  apply (rule_tac x=xa in exI)
  apply (drule direct_caps_of_removeSetOfCaps)
  apply (simp add: removeSetOfCaps_def split: option.splits)
  apply (erule store_connected_removeSetOfCaps)
  done

lemma caps_of_revoke:
  "\<lbrakk>s' \<in> revokeOperation sub c\<^sub>1 s ;  c \<in> caps_of s' e \<rbrakk>
  \<Longrightarrow> c \<in> caps_of s e"
  apply (clarsimp simp: revokeOperation_def
                 split: if_split_asm)
  apply (drule (1) caps_of_removeSetOfCaps)
  done

lemma direct_caps_of_revoke:
  "\<lbrakk>s' \<in> revokeOperation e c s; c' \<in> direct_caps_of s' x\<rbrakk>
   \<Longrightarrow> c' \<in> direct_caps_of s x"
  apply (clarsimp simp: revokeOperation_def
                 split: if_split_asm)
  apply (drule (1) direct_caps_of_removeSetOfCaps)
  done

lemma store_connected_revoke:
 "\<lbrakk>(x, y) \<in> store_connected s'; s' \<in> revokeOperation e c s\<rbrakk>
  \<Longrightarrow> (x, y) \<in> store_connected s"
  apply (simp add: store_connected_def)
  apply (erule rtrancl_induct)
   apply simp
  apply (fold store_connected_def)
  apply (subgoal_tac "(y,z) \<in> store_connected_direct s")
   apply (fastforce simp: store_connected_def)
  apply (clarsimp simp: store_connected_direct_def)
  apply (metis direct_caps_of_revoke)
  done

lemma shares_caps_revoke:
  "\<lbrakk>shares_caps s' x y; s' \<in> revokeOperation e c s\<rbrakk>
  \<Longrightarrow> shares_caps s x y"
  apply (clarsimp simp: shares_caps_def)
  apply (frule (1) store_connected_revoke [where x=x])
  apply (drule (1) store_connected_revoke [where x=y])
  by auto

lemma removeOperation_entity_ids [simp]:
  "is_entity (removeOperation e c c' s) e' = is_entity s e'"
  by (simp add: is_entity_def removeOperation_def)

lemma removeSetOfCaps_entity_ids [simp]:
  "is_entity (removeSetOfCaps cap_map s) e' = is_entity s e'"
  by (simp add: is_entity_def removeSetOfCaps_def)

lemma revoke_entities:
  "s' \<in> revokeOperation sub c\<^sub>1 s \<Longrightarrow> is_entity s' e = is_entity s e"
  by (clarsimp simp: revokeOperation_def split: if_split_asm)

lemma revoke_directly_tgs_connected:
  "\<lbrakk>s' \<in> step (SysRevoke n c\<^sub>1) s; (x, y) \<in> directly_tgs_connected s'\<rbrakk>
  \<Longrightarrow> (x, y) \<in>  directly_tgs_connected s"
  apply (simp add: step_def split: if_split_asm)
  apply (erule disjE, simp)
  apply (simp add: directly_tgs_connected_def leak_def)
  apply (erule disjE)
   apply(auto simp add: cap_in_caps_def dest!: caps_of_revoke)[1]
  apply (erule disjE)
   apply(auto simp add: cap_in_caps_def dest!: caps_of_revoke)[1]
  apply (erule disjE)
   apply (drule (1) shares_caps_revoke, simp)
  apply (erule disjE)
   apply(auto simp add: cap_in_caps_def dest!: caps_of_revoke)[1]
  apply (erule disjE)
   apply(auto simp add: cap_in_caps_def dest!: caps_of_revoke)[1]
  apply (drule (1) shares_caps_revoke, simp)
  done

lemma revoke_conTrans:
  "\<lbrakk>s' \<in> step cmd s; (x, y) \<in> directly_tgs_connected s'; cmd = (SysRevoke n c\<^sub>1)\<rbrakk>
  \<Longrightarrow> (x, y) \<in>  directly_tgs_connected s"
  by(auto dest!: revoke_directly_tgs_connected)

(* lemmas about grant *)

lemma is_entity_grant [simp]:
  "is_entity s (target c\<^sub>1) \<Longrightarrow>
  is_entity (grantOperation e c\<^sub>1 c\<^sub>2 r s) e' = is_entity s e'"
  by (simp add: is_entity_def grantOperation_def)

lemma is_entity_destroy:
  "is_entity (destroyOperation e' c s) e \<Longrightarrow> is_entity s e"
  by (simp add: destroyOperation_def is_entity_def split: if_split_asm)

(********************************************
 ********************************************
 ***** Connected transitively preserved *****
 ********************************************
 ********************************************)

lemma connected_tgs_connected:
  "\<lbrakk>s' \<in> step cmd s; (e\<^sub>x, e\<^sub>y) \<in> directly_tgs_connected s'\<rbrakk> \<Longrightarrow>
  (e\<^sub>x, e\<^sub>y) \<in> tgs_connected s"
  apply(case_tac "(e\<^sub>x, e\<^sub>y) \<in> directly_tgs_connected s")
   apply(simp add: tgs_connected_def)
   apply(case_tac cmd)
         apply(rule create_conTrans, fastforce+)
        apply(rule take_conTrans, fastforce+)
       apply(rule grant_conTrans, fastforce+)
      apply(frule copy_conTrans, fastforce+)
     apply(frule remove_conTrans, fastforce+)
    apply(frule removeSet_conTrans, fastforce+)
   apply(frule revoke_conTrans, fastforce+)
  apply(frule destroy_conTrans, fastforce+)
  done

lemma tgs_connected_preserved_step:
  "\<lbrakk>s' \<in> step cmd s; s' \<turnstile> x \<leftrightarrow>* z\<rbrakk> \<Longrightarrow> s \<turnstile> x \<leftrightarrow>* z"
  thm rtrancl_induct [where r="directly_tgs_connected s'" and a=x and b=z and P="\<lambda>z. (x, z) \<in> (directly_tgs_connected s)\<^sup>*", simplified,
                      simplified tgs_connected_def [symmetric]]
  apply(erule rtrancl_induct [where r="directly_tgs_connected s'",
                              simplified tgs_connected_def [symmetric]], simp)
  apply(case_tac "s \<turnstile> y \<leftrightarrow>* z")
   apply (erule (1) tgs_connected_trans)
  apply (simp add: connected_tgs_connected)
  done

lemma leakImplyConnected:
  "leak s\<^sub>i e\<^sub>x e\<^sub>i \<Longrightarrow> (e\<^sub>x, e\<^sub>i) \<in> directly_tgs_connected s\<^sub>i"
 by(simp add: directly_tgs_connected_def)

lemma leakImplyConnectedTrans:
  "leak s\<^sub>i e\<^sub>x e\<^sub>i \<Longrightarrow> (e\<^sub>x, e\<^sub>i) \<in> tgs_connected s\<^sub>i"
  by(simp add: tgs_connected_def, frule leakImplyConnected, auto)

lemma tgs_connected_preserved [rule_format]:
  "\<forall>s'. s' \<in> execute cmds s \<longrightarrow>
    s' \<turnstile> x \<leftrightarrow>* y \<longrightarrow>
    s \<turnstile> x \<leftrightarrow>* y"
  apply(induct_tac cmds, simp)
  apply clarsimp
  apply(rename_tac cmd cmds s'' s')
  apply(erule_tac x=s' in allE)
  apply(simp add: tgs_connected_preserved_step)
  done

lemma leak_conTrans [rule_format]:
  "\<lbrakk>s \<in> execute cmds s\<^sub>0; leak s x y\<rbrakk>
  \<Longrightarrow> (x, y) \<in> tgs_connected s\<^sub>0"
  by (auto intro: leakImplyConnectedTrans tgs_connected_preserved)

lemma leakage_rule:
  "\<lbrakk>s' \<in> execute cmds s; \<not> s \<turnstile> x \<leftrightarrow>* y\<rbrakk> \<Longrightarrow> \<not> (s' \<turnstile> x \<rightarrow> y)"
  by(auto simp add: leak_conTrans)

(*******************************************
 *******************************************
 *****      Authority confinement     *****
 *******************************************
 *******************************************)

lemma caps_of_op:
  "\<lbrakk>s' \<in> step cmd s; c' \<in> caps_of s' x\<rbrakk>
  \<Longrightarrow> \<exists>z. s \<turnstile> x \<leftrightarrow>* z \<and> c' \<in>cap caps_of s z"
  apply (simp add: step_def split:if_split_asm)
   prefer 2
   apply (fastforce simp: cap_in_caps_def tgs_connected_def rights_extra_rights)
  apply (erule disjE)
   apply (fastforce simp: cap_in_caps_def tgs_connected_def rights_extra_rights)
  apply (case_tac cmd)
         apply (simp add: caps_of_create)
        apply (simp add: caps_of_take)
       apply (simp add: caps_of_grant)
      apply (simp add: caps_of_copy)
     apply (clarsimp, drule caps_of_remove)
     apply (fastforce simp: cap_in_caps_def tgs_connected_def rights_extra_rights)
    apply (clarsimp, drule caps_of_removeSet)
    apply (fastforce simp: cap_in_caps_def tgs_connected_def rights_extra_rights)
   apply (clarsimp, drule (1) caps_of_revoke)
   apply (fastforce simp: cap_in_caps_def tgs_connected_def rights_extra_rights)
  apply (clarsimp, drule caps_of_destroy)
  apply (fastforce simp: cap_in_caps_def tgs_connected_def rights_extra_rights)
  done

lemma authority_confinement_induct_step:
  "\<lbrakk>s' \<in> step cmd s;
    \<forall>e\<^sub>i. s \<turnstile> e\<^sub>x \<leftrightarrow>* e\<^sub>i \<longrightarrow> caps_of s e\<^sub>i \<le>cap c\<rbrakk>
  \<Longrightarrow> caps_of s' e\<^sub>x \<le>cap c"
  apply (clarsimp simp: caps_dominated_by_def)
  apply (drule (1) caps_of_op)
  apply (fastforce simp: cap_in_caps_def)
  done

lemma authority_confinement_helper:
  "s' \<in> execute cmds s \<longrightarrow>
   (\<forall>e\<^sub>i. s \<turnstile> e\<^sub>x \<leftrightarrow>* e\<^sub>i \<longrightarrow> caps_of s e\<^sub>i \<le>cap c) \<longrightarrow>
   (\<forall>e\<^sub>i. s' \<turnstile> e\<^sub>x \<leftrightarrow>* e\<^sub>i \<longrightarrow> caps_of s' e\<^sub>i \<le>cap c)"
proof (induct cmds arbitrary: s')
case Nil
  show ?case by clarsimp
next
case (Cons cmd cmds s')
show ?case
  apply clarsimp
  apply (rule authority_confinement_induct_step, assumption)
  apply clarsimp
  apply (rule Cons.hyps[rule_format], simp_all)
  apply (drule(1) tgs_connected_preserved_step)
  apply (simp add: tgs_connected_def)
  done
qed

lemma authority_confinement:
  "\<lbrakk>s' \<in> execute cmds s;
    \<forall>e\<^sub>i. s \<turnstile> e\<^sub>x \<leftrightarrow>* e\<^sub>i \<longrightarrow> caps_of s e\<^sub>i \<le>cap c\<rbrakk>
  \<Longrightarrow> caps_of s' e\<^sub>x \<le>cap c"
  by (erule authority_confinement_helper [rule_format, where e\<^sub>x=e\<^sub>x], simp_all)

end


(* @TAG(OTHER_LGPL) *)

(*
    Author:      Norbert Schirmer
    Maintainer:  Norbert Schirmer, norbert.schirmer at web de
    License:     LGPL
*)

(*  Title:      ClosureEx.thy
    Author:     Norbert Schirmer, TU Muenchen

Copyright (C) 2006-2008 Norbert Schirmer
Some rights reserved, TU Muenchen

This library is free software; you can redistribute it and/or modify
it under the terms of the GNU Lesser General Public License as
published by the Free Software Foundation; either version 2.1 of the
License, or (at your option) any later version.

This library is distributed in the hope that it will be useful, but
WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
Lesser General Public License for more details.

You should have received a copy of the GNU Lesser General Public
License along with this library; if not, write to the Free Software
Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307
USA
*)

theory ClosureEx
imports "../Vcg" "../Simpl_Heap" Closure
begin

record globals =
 cnt_' :: "ref \<Rightarrow> nat"
 alloc_' :: "ref list"
 free_' :: "nat"
record 'g vars = "'g state" +
 p_':: ref
 r_':: nat
 n_':: nat
 m_':: nat
 c_':: "(string \<times> ref) list \<times> string"
 d_':: "(string \<times> ref) list \<times> string"
 e_':: "(string \<times> nat) list \<times> string"

definition "var\<^sub>n = [''n''\<mapsto> (\<lambda>x. n_'_update (\<lambda>_. x)),
                    ''m''\<mapsto> (\<lambda>x. m_'_update (\<lambda>_. x))]"
definition "upd\<^sub>n = gen_upd var\<^sub>n"

lemma upd\<^sub>n_ap: "upd\<^sub>n (fst (ap es (es',p))) = upd\<^sub>n es' \<circ> upd\<^sub>n es"
  by (simp add: upd\<^sub>n_def gen_upd_ap)

lemma
"\<Gamma>\<turnstile>\<lbrace>\<acute>n=n\<^sub>0 \<and> (\<forall>i j. \<Gamma>\<turnstile> \<lbrace>\<acute>n=i \<and> \<acute>m=j\<rbrace> callClosure upd\<^sub>n \<acute>e \<lbrace>\<acute>r=i + j\<rbrace>)\<rbrace>
      \<acute>e :== (ap [(''n'',\<acute>n)] \<acute>e)
   \<lbrace>\<forall>j. \<Gamma>\<turnstile> \<lbrace>\<acute>m=j\<rbrace> callClosure upd\<^sub>n \<acute>e \<lbrace>\<acute>r=n\<^sub>0 + j\<rbrace>\<rbrace>"
apply vcg_step
apply clarify
apply (rule ap_closure [where var=var\<^sub>n, folded upd\<^sub>n_def])
apply clarsimp
apply (rename_tac s s')
apply (erule_tac x="n_' s" in allE)
apply (erule_tac x="m_' s'" in allE)
apply (rule exI)
apply (rule exI)
apply (rule conjI)
apply (assumption)
apply (simp add: upd\<^sub>n_def gen_upd_def var\<^sub>n_def)
done

definition "var = [''p''\<mapsto> (\<lambda>x. p_'_update (\<lambda>_. x))]"
definition "upd = gen_upd var"

procedures Inc(p|r) =
 "\<acute>p\<rightarrow>\<acute>cnt :== \<acute>p\<rightarrow>\<acute>cnt + 1;;
  \<acute>r :== \<acute>p\<rightarrow>\<acute>cnt"

lemma (in Inc_impl)
 "\<forall>i p. \<Gamma>\<turnstile> \<lbrace>\<acute>p\<rightarrow>\<acute>cnt = i\<rbrace> \<acute>r :== PROC Inc(\<acute>p) \<lbrace>\<acute>r=i+1 \<and> \<acute>p\<rightarrow>\<acute>cnt = i+1\<rbrace>"
  apply vcg
  apply simp
  done

procedures (imports Inc_signature) NewCounter(|c) =
"\<acute>p :== NEW 1 [\<acute>cnt :== 0];;
 \<acute>c :== ([(''p'',\<acute>p)],Inc_'proc)"

locale NewCounter_impl' = NewCounter_impl + Inc_impl
lemma (in NewCounter_impl')
shows
  "\<forall>alloc. \<Gamma>\<turnstile> \<lbrace>1 \<le> \<acute>free\<rbrace> \<acute>c :== PROC NewCounter()
          \<lbrace>\<exists>p. p\<rightarrow>\<acute>cnt = 0 \<and>
               (\<forall>i. \<Gamma>\<turnstile> \<lbrace>p\<rightarrow>\<acute>cnt = i\<rbrace> callClosure upd \<acute>c \<lbrace>\<acute>r=i+1 \<and> p\<rightarrow>\<acute>cnt = i+1\<rbrace>)\<rbrace>"
apply vcg
apply simp
apply (rule_tac x="new (set alloc)" in exI)
apply simp
apply (simp add: callClosure_def)
apply vcg_step
apply vcg_step
apply vcg_step
apply vcg_step
apply (simp add: upd_def var_def gen_upd_def)
done

lemma (in NewCounter_impl')

shows
  "\<forall>alloc. \<Gamma>\<turnstile> \<lbrace>1 \<le> \<acute>free\<rbrace> \<acute>c :== PROC NewCounter()
          \<lbrace>\<exists>p. p\<rightarrow>\<acute>cnt = 0 \<and>
               (\<forall>i. \<Gamma>\<turnstile> \<lbrace>p\<rightarrow>\<acute>cnt = i\<rbrace> callClosure upd \<acute>c \<lbrace>\<acute>r=i+1 \<and> p\<rightarrow>\<acute>cnt = i+1\<rbrace>)\<rbrace>"
apply vcg
apply simp
apply (rule_tac x="new (set alloc)" in exI)
apply simp
apply (simp add: callClosure_def)
apply vcg_step
apply vcg_step
apply vcg_step
apply vcg_step
apply (simp add: upd_def var_def gen_upd_def)
done

lemma (in NewCounter_impl')
shows NewCounter_spec:
  "\<forall>alloc. \<Gamma>\<turnstile> \<lbrace>1 \<le> \<acute>free \<and> \<acute>alloc=alloc\<rbrace> \<acute>c :== PROC NewCounter()
          \<lbrace>\<exists>p. p \<notin> set alloc \<and> p \<in> set \<acute>alloc \<and> p \<noteq> Null \<and> p\<rightarrow>\<acute>cnt = 0 \<and>
               (\<forall>i. \<Gamma>\<turnstile> \<lbrace>p\<rightarrow>\<acute>cnt = i\<rbrace> callClosure upd \<acute>c \<lbrace>\<acute>r=i+1 \<and> p\<rightarrow>\<acute>cnt = i+1\<rbrace>)\<rbrace>"
apply vcg
apply clarsimp
apply (rule_tac x="new (set alloc)" in exI)
apply simp
apply (simp add: callClosure_def)
apply vcg_step
apply vcg_step
apply vcg_step
apply vcg_step
apply (simp add: upd_def var_def gen_upd_def)
done

lemma "\<Gamma>\<turnstile>\<lbrace>\<exists>p. p \<noteq> Null \<and> p\<rightarrow>\<acute>cnt = i \<and>
              (\<forall>i. \<Gamma>\<turnstile> \<lbrace>p\<rightarrow>\<acute>cnt = i\<rbrace> callClosure upd \<acute>c \<lbrace>\<acute>r=i+1 \<and> p\<rightarrow>\<acute>cnt = i+1\<rbrace>)\<rbrace>
           dynCallClosure (\<lambda>s. s) upd c_' (\<lambda>s t. s\<lparr>globals := globals t\<rparr>)
                         (\<lambda>s t. Basic (\<lambda>u. u\<lparr>r_' := r_' t\<rparr>))
           \<lbrace>\<acute>r=i+1\<rbrace>"
apply (rule conseq_extract_pre)
apply clarify
apply (rule dynCallClosureFix)
apply (simp only: Ball_def)
prefer 3
apply (assumption)
prefer 2
apply vcg_step
apply vcg_step
apply (simp only: simp_thms)
apply clarsimp
done

lemma (in NewCounter_impl')
 shows "\<Gamma>\<turnstile> \<lbrace>1 \<le> \<acute>free\<rbrace>
             \<acute>c :== CALL NewCounter ();;
             dynCallClosure (\<lambda>s. s) upd c_' (\<lambda>s t. s\<lparr>globals := globals t\<rparr>)
                         (\<lambda>s t. Basic (\<lambda>u. u\<lparr>r_' := r_' t\<rparr>))
           \<lbrace>\<acute>r=1\<rbrace>"
apply vcg_step
apply (rule dynCallClosure)
prefer 2
apply vcg_step
apply vcg_step
apply vcg_step
apply clarsimp
apply (erule_tac x=0 in allE)
apply (rule exI)
apply (rule exI)
apply (rule conjI)
apply (assumption)
apply simp
done

lemma (in NewCounter_impl')
 shows "\<Gamma>\<turnstile> \<lbrace>1 \<le> \<acute>free\<rbrace>
             \<acute>c :== CALL NewCounter ();;
             dynCallClosure (\<lambda>s. s) upd c_' (\<lambda>s t. s\<lparr>globals := globals t\<rparr>)
                         (\<lambda>s t. Basic (\<lambda>u. u\<lparr>r_' := r_' t\<rparr>));;
             dynCallClosure (\<lambda>s. s) upd c_' (\<lambda>s t. s\<lparr>globals := globals t\<rparr>)
                         (\<lambda>s t. Basic (\<lambda>u. u\<lparr>r_' := r_' t\<rparr>))
           \<lbrace>\<acute>r=2\<rbrace>"
apply vcg_step
apply (rule dynCallClosure)
prefer 2
apply vcg_step
apply vcg_step
apply vcg_step
apply (rule dynCallClosure)
apply vcg_step
apply vcg_step
apply vcg_step

apply clarsimp
apply (subgoal_tac "\<Gamma>\<turnstile> \<lbrace>p\<rightarrow>\<acute>cnt = 0\<rbrace> callClosure upd (c_' t) \<lbrace>\<acute>r = Suc 0 \<and> p\<rightarrow>\<acute>cnt = Suc 0\<rbrace>")
apply (rule exI)
apply (rule exI)
apply (rule conjI)
apply assumption
apply clarsimp
apply (erule_tac x=1 in allE)
apply (rule exI)
apply (rule exI)
apply (rule conjI)
apply assumption
apply clarsimp
apply (erule allE)
apply assumption
done

lemma (in NewCounter_impl')
 shows "\<Gamma>\<turnstile> \<lbrace>1 \<le> \<acute>free\<rbrace>
             \<acute>c :== CALL NewCounter ();;
             \<acute>d :== \<acute>c;;
             dynCallClosure (\<lambda>s. s) upd c_' (\<lambda>s t. s\<lparr>globals := globals t\<rparr>)
                         (\<lambda>s t. Basic (\<lambda>u. u\<lparr>n_' := r_' t\<rparr>));;
             dynCallClosure (\<lambda>s. s) upd d_' (\<lambda>s t. s\<lparr>globals := globals t\<rparr>)
                         (\<lambda>s t. Basic (\<lambda>u. u\<lparr>m_' := r_' t\<rparr>));;
             \<acute>r :== \<acute>n + \<acute>m
           \<lbrace>\<acute>r=3\<rbrace>"

apply vcg_step
apply vcg_step
apply (rule dynCallClosure)
prefer 2
apply vcg_step
apply vcg_step
apply vcg_step
apply (rule dynCallClosure)
apply vcg_step
apply vcg_step
apply vcg_step
apply vcg_step
apply clarsimp
apply (subgoal_tac "\<Gamma>\<turnstile> \<lbrace>p\<rightarrow>\<acute>cnt = 0\<rbrace> callClosure upd (c_' t) \<lbrace>\<acute>r = Suc 0 \<and> p\<rightarrow>\<acute>cnt = Suc 0\<rbrace>")
apply (rule exI)
apply (rule exI)
apply (rule conjI)
apply assumption
apply clarsimp
apply (erule_tac x=1 in allE)
apply (rule exI)
apply (rule exI)
apply (rule conjI)
apply assumption
apply clarsimp
apply (erule allE)
apply assumption
done

end


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

theory CustomWordAbs
imports "AutoCorres.AutoCorres"
begin

external_file "custom_word_abs.c"
install_C_file "custom_word_abs.c"

lemma [word_abs]:
  "\<lbrakk> abstract_val P x sint x'; abstract_val Q y sint y' \<rbrakk> \<Longrightarrow>
        abstract_val (P \<and> Q) (max x y)
          sint (x' xor (x' xor y') && - (if x' <s y' then (1 :: sword32) else 0))"
  apply (clarsimp simp: max_def word_sless_def word_sle_def)
  done

lemma [word_abs]:
  "\<lbrakk> abstract_val P x unat x'; abstract_val Q y unat y' \<rbrakk> \<Longrightarrow>
         abstract_val (P \<and> Q \<and> y < 32) (x mod (2 ^ y)) unat (x' && 2 ^ unat y' - (1 :: word32))"
  apply (clarsimp simp del: shiftl_1 simp: shiftl_1 [symmetric])
  apply (fold mask_def)
  apply (subst word_mod_2p_is_mask [symmetric])
  apply (subst p2_gt_0)
  by (auto simp: unat_mod)

lemma [word_abs]:
  "\<lbrakk> abstract_val P x unat (x' :: word32);
     abstract_val Q y unat y' \<rbrakk> \<Longrightarrow>
      abstract_val (P \<and> Q) (x + y > UINT_MAX) id (x' + y' < x')"
  apply (subst not_le [symmetric], subst no_plus_overflow_unat_size)
  apply (clarsimp simp: not_less UINT_MAX_def word_size)
  apply arith
  done

autocorres [unsigned_word_abs = b c] "custom_word_abs.c"

context custom_word_abs begin

lemma "a' x y = max x y"
  by (unfold a'_def, rule refl)

lemma "b' x 4 s = Some (x mod 16)"
  by (unfold b'_def, simp)

lemma "c' x y = (if UINT_MAX < x + y then 1 else 0)"
  by (unfold c'_def, simp)

end

end