(*File: Language.thy
  Author: L Beringer & M Hofmann, LMU Munich
  Date: 05/12/2008
  Purpose: Syntax and operational semantics of subset of JVML
*)
(*<*)
theory Language imports AssocLists begin
(*>*)

section\<open>Language \label{sec:language}\<close>
subsection\<open>Syntax\<close>

text\<open>We have syntactic classes of (local) variables, class names,
field names, and method names. Naming restrictions, namespaces, long
Java names etc.~are not modelled.\<close>

typedecl Var
typedecl Class
typedecl Field
typedecl Method

text\<open>Since arithmetic operations are modelled as unimplemented
functions, we introduce the type of values in this section. The domain
of heap locations is arbitrary.\<close>

typedecl Addr

text\<open>A reference is either null or an address.\<close>

datatype Ref = Nullref | Loc Addr

text\<open>Values are either integer numbers or references.\<close>

datatype Val = RVal Ref | IVal int

text\<open>The type of (instruction) labels is fixed, since the operational
semantics increments the program counter after each instruction.\<close>

type_synonym Label = int

text\<open>Regarding the instructions, we support basic operand-stack
manipulations, object creation, field modifications, casts, static
method invocations, conditional and unconditional jumps, and a return
instruction.

For every (Isabelle) function \<open>f : Val\<Rightarrow>Val\<Rightarrow>Val\<close> we have an
instruction \<open>binop f\<close> whose semantics is to invoke \<open>f\<close>
on the two topmost values on the operand stack and replace them with
the result.  Similarly for \<open>unop f\<close>.\<close>

datatype Instr =
  const Val
| dup
| pop
| swap
| load Var
| store Var
| binop "Val \<Rightarrow> Val \<Rightarrow> Val"
| unop "Val \<Rightarrow> Val"
| new Class
| getfield Class Field
| putfield Class Field
| checkcast Class
| invokeS Class Method
| goto Label
| iftrue Label
| vreturn

text\<open>Method body declarations contain a list of formal parameters, a
mapping from instruction labels to instructions, and a start
label. The operational semantics assumes that instructions are
labelled consecutively\footnote{In the paper, we slightly abstract
from this by including a successor functions on labels}.\<close>

type_synonym Mbody = "Var list \<times> (Label, Instr) AssList \<times> Label"

text\<open>A class definition associates method bodies to method names.\<close>
type_synonym Classdef = "(Method, Mbody) AssList"

text\<open>Finally, a program consists of classes.\<close>
type_synonym Prog = "(Class, Classdef) AssList"

text\<open>Taken together, the three types \<open>Prog\<close>, \<open>Classdef\<close>,
and \<open>Mbody\<close> represent an abstract model of the virtual machine
environment. In our opinion, it would be desirable to avoid modelling
this environment at a finer level, at least for the purpose of the
program logic. For example, we prefer not to consider in detail the
representation of the constant pool.\<close>

subsection\<open>Dynamic semantics\<close>
subsubsection\<open>Semantic components\<close>

text\<open>An object consists of the identifier of its dynamic class and a
map from field names to values. Currently, we do not model
type-correctness, nor do we require that all (or indeed any) of the
fields stem from the static definition of the class, or a super-class.
Note, however, that type correctness can be expressed in the logic.\<close>

type_synonym Object = "Class \<times> (Field, Val) AssList"

text\<open>The heap is represented as a map from addresses to values.  The
JVM specification does not prescribe any particular object layout. The
proposed type reflects this indeterminacy, but allows one to calculate
the byte-correct size of a heap only after a layout scheme has been
supplied. Alternative heap models would be the store-less semantics in
the sense of Jonkers~\cite{Jonkers1981} and
Deutsch~\cite{Deutsch1992}, (where the heap is modelled as a partial
equivalence relation on access paths), or object-based semantics in
the sense of Reddy~\cite{Reddy1996}, where the heap is represented as
a history of update operations.  H\"ahnle et al.~use a variant of the
latter in their dynamic logic for a {\sc
JavaCard}~~\cite{HaehnleM:Cassis2005}.\<close>

type_synonym Heap = "(Addr, Object) AssList"

text\<open>Later, one might extend heaps by a component for static fields.\<close>

text\<open>The types of the (register) store and the operand stack are as
expected.\<close>

type_synonym Store = "(Var, Val) AssList"
type_synonym OpStack = "Val list"

text\<open>States contain an operand stack, a store, and a heap.\<close>
type_synonym State = "OpStack \<times> Store \<times> Heap"

definition heap::"State \<Rightarrow> Heap"
where "heap s = snd(snd s)"

text\<open>The operational semantics and the program logic are defined
relative to a fixed program \<open>P\<close>.  Alternatively, the type of the
operational semantics (and proof judgements) could be extended by a
program component.  We also define the constant value \<open>TRUE\<close>,
the representation of which does not matter for the current
formalisation.\<close>

axiomatization P::Prog and TRUE::Val

text\<open>In order to obtain more readable rules, we define operations
for extracting method bodies and instructions from the program.\<close>

definition mbody_is::"Class \<Rightarrow> Method \<Rightarrow> Mbody \<Rightarrow> bool"
where "mbody_is C m M = (\<exists> CD . P\<down>C = Some CD \<and> CD\<down>m = Some M)"

definition get_ins::"Mbody \<Rightarrow> Label \<Rightarrow> Instr option"
where "get_ins M l = (fst(snd M))\<down>l"

definition ins_is::"Class \<Rightarrow> Method \<Rightarrow> Label \<Rightarrow> Instr \<Rightarrow> bool"
where "ins_is C m l ins = (\<exists> M . mbody_is C m M \<and> get_ins M l = Some ins)"

text\<open>The transfer of method arguments from the caller's operand stack
to the formal parameters of an invoked method is modelled by the
predicate\<close>

inductive_set Frame::"(OpStack \<times> (Var list) \<times> Store \<times> OpStack) set"
where
FrameNil: "\<lbrakk>oo=ops\<rbrakk> \<Longrightarrow> (ops,[],emp,oo) : Frame"
|
Frame_cons: "\<lbrakk>(oo,par,S,ops) : Frame; R =S[x\<mapsto>v]\<rbrakk>
            \<Longrightarrow> (v # oo, x # par,R,ops):Frame"

(*<*)
lemma Frame_deterministic[rule_format]:
"(ops, par, S, os) \<in> Frame \<Longrightarrow>
(\<forall> R opsa . (ops, par, R, opsa) \<in> Frame \<longrightarrow> R=S \<and> opsa = os)"
apply (erule Frame.induct, clarsimp)
apply (erule Frame.cases, clarsimp, clarsimp)
apply (erule thin_rl, clarsimp)
apply (erule Frame.cases, clarsimp, clarsimp)
done
(*>*)

text\<open>In order to obtain a deterministic semantics, we assume the
existence of a function, with the obvious freshness axiom for this
construction.\<close>

axiomatization nextLoc::"Heap \<Rightarrow> Addr"
where nextLoc_fresh: "h\<down>(nextLoc h) = None"

subsubsection\<open>Operational judgements\<close>

text\<open>Similar to Bannwart-M\"uller~\cite{BannwartMueller05}, we define
two operational judgements: a one-step relation and a relation that
represents the transitive closure of the former until the end of the
current method invocation. These relations are mutually recursive,
since the method invocation rule contracts the execution of the
invoked method to a single step. The one-step relation associates a
state to its immediate successor state, where the program counter is
interpreted with respect to the current method body. The transitive
closure ignores the bottom part of the operand stack and the store of
the final configuration. It simply returns the heap and the result of
the method invocation, where the latter is given by the topmost value
on the operand stack. In contrast to~\cite{BannwartMueller05}, we do
not use an explicit \<open>return\<close> variable. Both relations take an
additional index of type \<open>nat\<close> that monitors the derivation
height. This is useful in the proof of soundness of the program
logic.\<close>

text\<open>Intuitively, \<open>(M,l,s,n,l',s'):Step\<close> means that method
(body) \<open>M\<close> evolves in one step from state \<open>s\<close> to state
\<open>s'\<close>, while statement \<open>(M,s,n,h,v):Exec\<close> indicates that
executing from \<open>s\<close> in method \<open>M\<close> leads eventually to a
state whose final value is \<open>h\<close>, where precisely the last step in
this sequence is a \<open>vreturn\<close> instruction and the return value is
\<open>v\<close>.\<close>

text\<open>Like Bannwart and M\"uller, we define a "frame-less"
semantics. i.e.~the execution of a method body is modelled by a
transitive closure of the basic step-relation, which results in a
one-step reduction at the invocation site. Arguably, an operational
semantics with an explicit frame stack is closer to the real JVM. It
should not be difficult to verify the operational soundness of the
present system w.r.t.~such a finer model, or to modify the
semantics.\<close>

inductive_set
  Step::"(Mbody \<times> Label \<times> State \<times> nat \<times> Label \<times> State) set"
and
  Exec::"(Mbody \<times> Label \<times> State \<times> nat \<times> Heap \<times> Val) set"
where
Const:"\<lbrakk>get_ins M l = Some (const v); NEXT = (v # os,s,h); ll=l+1\<rbrakk>
       \<Longrightarrow> (M,l,(os,s,h), 1, ll, NEXT) : Step"
|
Dup:  "\<lbrakk>get_ins M l = Some dup; NEXT = (v # v # os,s,h); ll =l+1\<rbrakk>
       \<Longrightarrow> (M,l,(v # os,s,h), 1, ll, NEXT) : Step"
|
Pop:  "\<lbrakk>get_ins M l = Some pop; NEXT = (os,s,h); ll=l+1\<rbrakk>
       \<Longrightarrow> (M,l,(v # os,s,h), 1, ll, NEXT) : Step"
|
Swap: "\<lbrakk>get_ins M l = Some swap; NEXT = (w # (v # os),s,h); ll= l+1\<rbrakk>
       \<Longrightarrow> (M,l,(v # (w # os),s,h), 1, ll, NEXT) : Step"
|
Load: "\<lbrakk>get_ins M l = Some (load x); s\<down>x = Some v;
         NEXT = (v # os,s,h); ll=l+1\<rbrakk>
       \<Longrightarrow> (M,l,(os,s,h), 1, ll,NEXT) : Step"
|
Store:"\<lbrakk>get_ins M l = Some (store x); NEXT = (os,s[x\<mapsto>v],h); ll= l+1\<rbrakk>
       \<Longrightarrow> (M,l,(v # os,s,h), 1, ll, NEXT) : Step"
|
Binop:"\<lbrakk>get_ins M l = Some (binop f); NEXT = ((f v w) # os,s,h); ll=l+1\<rbrakk>
       \<Longrightarrow> (M,l,(v # (w # os),s,h), 1, ll,NEXT) : Step"
|
Unop: "\<lbrakk>get_ins M l = Some (unop f); NEXT = ((f v) # os,s,h);ll=l+1\<rbrakk>
       \<Longrightarrow> (M,l,(v # os,s,h), 1, ll, NEXT) : Step"
|
New:  "\<lbrakk>get_ins M l = Some (new d); newobj = (d, emp); a=nextLoc h;
         NEXT = ((RVal (Loc a)) # os,s,h[a\<mapsto>newobj]); ll = l+1\<rbrakk>
       \<Longrightarrow> (M,l,(os,s,h), 1, ll,NEXT) : Step"
|
Get:  "\<lbrakk>get_ins M l = Some (getfield d F); h\<down>a = Some (d, Flds);
         Flds\<down>F = Some v; NEXT = (v # os,s,h); ll=l+1\<rbrakk>
       \<Longrightarrow> (M,l,((RVal (Loc a)) # os,s,h), 1, ll,NEXT) : Step"
|
Put:  "\<lbrakk>get_ins M l = Some (putfield d F); h\<down>a = Some (d, Flds);
         newobj = (d, Flds[F\<mapsto>v]); NEXT = (os,s,h[a\<mapsto>newobj]); ll=l+1\<rbrakk>
       \<Longrightarrow> (M,l,(v # ((RVal (Loc a)) # os),s,h), 1, ll, NEXT) : Step"
|
Cast: "\<lbrakk>get_ins M l = Some (checkcast d); h\<down>a = Some (d, Flds);
         NEXT = ((RVal (Loc a)) # os,s,h); ll=l+1\<rbrakk>
       \<Longrightarrow> (M,l,((RVal (Loc a)) # os,s,h), 1, ll,NEXT) : Step"
|
Goto: "\<lbrakk>get_ins M l = Some (goto pc)\<rbrakk> \<Longrightarrow> (M,l,S, 1, pc,S) : Step"
|
IfT:  "\<lbrakk>get_ins M l = Some (iftrue pc); NEXT = (os,s,h)\<rbrakk>
       \<Longrightarrow> (M,l,(TRUE # os,s,h), 1, pc, NEXT) : Step"
|
IfF:  "\<lbrakk>get_ins M l = Some (iftrue pc); v \<noteq> TRUE; NEXT = (os,s,h); ll=l+1\<rbrakk>
       \<Longrightarrow> (M,l,(v # os,s,h), 1, ll, NEXT) : Step"
|
InvS: "\<lbrakk>get_ins M l = Some (invokeS C m); mbody_is C m (par,code,l0);
         ((par,code,l0),l0,([], S,h), n, hh, v): Exec;
         (ops,par,S,os) : Frame; NEXT = (v # os,s,hh); ll = l+1\<rbrakk>
       \<Longrightarrow> (M,l,(ops,s,h), Suc n, ll, NEXT) : Step"
|
Vret: "\<lbrakk>get_ins M l = Some vreturn\<rbrakk> \<Longrightarrow> (M,l,(v # os,s,h), 1, h, v) : Exec"
|
Run:  "\<lbrakk>(M,l,s,n,ll,t):Step; (M,ll,t,m,h,v):Exec; k = (max n m) +1 \<rbrakk>
       \<Longrightarrow> (M,l,s,k,h,v) : Exec"

text\<open>A big-step operational judgement that abstracts from the
derivation height is easily defined.\<close>

definition Opsem::"Mbody \<Rightarrow> Label \<Rightarrow> State \<Rightarrow> Heap \<Rightarrow> Val \<Rightarrow> bool"
where "Opsem M l s h v = (\<exists> n . (M,l,s,n,h,v):Exec)"

subsection \<open>Basic properties\<close>

text \<open>We provide elimination lemmas for the inductively defined
relations\<close>

inductive_cases eval_cases:
 "(M,l,s,n,ll,t) : Step"
 "(M,l,s,n,h,v) : Exec"
(*<*)
lemma no_zero_height_derivsAux[rule_format]:
"\<forall>n . ((M,l,s,n,ll,t) : Step \<longrightarrow> (n=0 \<longrightarrow> False)) \<and> ((MM,lll,ss,m,h,v):Exec \<longrightarrow> (m=0 \<longrightarrow> False))"
by (rule allI, rule Step_Exec.induct, simp_all)

lemma no_zero_height_derivsAux2: "((M,l,s,0,ll,t):Step \<longrightarrow> False) \<and> ((MM,lll,ss,0,h,v):Exec \<longrightarrow> False)"
by (insert no_zero_height_derivsAux, fast)
(*>*)
text \<open>and observe that no derivations of height 0 exist.\<close>
lemma no_zero_height_Step_derivs: "(M,l,s,0,ll,t):Step \<Longrightarrow> False"
(*<*)by (insert no_zero_height_derivsAux2, fast)(*>*)
(*<*)
lemma no_zero_height_Step_derivs1: "(M,l,(os,S,H),0,ll,t):Step \<Longrightarrow> False"
by (insert no_zero_height_derivsAux2, fast)
(*>*)

lemma no_zero_height_Exec_derivs: "(M,l,s,0,h,v):Exec \<Longrightarrow> False"
(*<*)by (insert no_zero_height_derivsAux2, fast)(*>*)
(*<*)
lemma no_zero_height_Exec_derivs1: "(M,l,(os,S,H),0,h,v):Exec \<Longrightarrow> False"
by (insert no_zero_height_derivsAux2, fast)
(*>*)

(*<*)
(*Elimination rules*)
lemma ConstElim1:"\<lbrakk>(M, l, (os, S, h), n, ll,t) \<in> Step; get_ins M l = Some (const v)\<rbrakk>
               \<Longrightarrow> n = Suc 0 \<and> t = (v # os, S, h) \<and> ll = l+1"
by (erule eval_cases, simp_all)

lemma DupElim1: "\<lbrakk>(M, l, (os, S, h), n, ll, t) \<in> Step; get_ins M l =  Some dup\<rbrakk>
               \<Longrightarrow> \<exists> v ops . os = v # ops \<and> n = Suc 0 \<and> t = (v # os, S, h) \<and> ll = l+1"
by (erule eval_cases, simp_all)

lemma PopElim1: "\<lbrakk>(M, l, (os, S, h), n, ll, t) \<in> Step; get_ins M l =  Some pop\<rbrakk>
               \<Longrightarrow> \<exists> v ops . os = v # ops \<and> n = Suc 0 \<and> t = (ops, S, h) \<and> ll = l+1"
by (erule eval_cases, simp_all)

lemma SwapElim1: "\<lbrakk>(M, l, (os, S, h), n, ll, t) \<in> Step; get_ins M l = Some swap\<rbrakk>
              \<Longrightarrow> \<exists> v w ops . os = v # w # ops \<and> n = Suc 0 \<and> t = (w # v # ops, S, h) \<and> ll = l+1"
by (erule eval_cases, simp_all)

lemma LoadElim1: "\<lbrakk>(M, l, (os, S, h), n, ll, t) \<in> Step; get_ins M l = Some (load x)\<rbrakk>
                 \<Longrightarrow> \<exists> v . S\<down>x = Some v \<and> n = Suc 0 \<and> t = (v # os, S, h) \<and> ll = l+1"
by (erule eval_cases, simp_all)

lemma StoreElim1: "\<lbrakk>(M, l, (os, S, h), n, ll, t) \<in> Step; get_ins M l = Some (store x)\<rbrakk>
                  \<Longrightarrow> \<exists> v ops . os = v # ops \<and> n = Suc 0 \<and> t = (ops, S[x\<mapsto>v], h) \<and> ll = l+1"
by (erule eval_cases, simp_all)

lemma BinopElim1: "\<lbrakk>(M, l, (os, S, h), n, ll, t) \<in> Step; get_ins M l = Some (binop f)\<rbrakk>
                  \<Longrightarrow> \<exists> v w ops . os = v # w # ops \<and> n = Suc 0 \<and> t = (f v w # ops, S, h) \<and> ll = l+1"
by (erule eval_cases, simp_all)

lemma UnopElim1: "\<lbrakk>(M, l, (os, S, h), n, ll, t) \<in> Step; get_ins M l = Some (unop f)\<rbrakk>
                 \<Longrightarrow> \<exists> v ops . os = v # ops \<and> n = Suc 0 \<and> t = (f v # ops, S, h) \<and> ll = l+1"
by (erule eval_cases, simp_all)

lemma NewElim1: "\<lbrakk>(M, l, (os, S, h), n, ll, t) \<in> Step; get_ins M l = Some (new d)\<rbrakk>
               \<Longrightarrow> \<exists> a . a = nextLoc h \<and> n = Suc 0 \<and> t = (RVal (Loc a) # os, S, h[a\<mapsto>(d, emp)]) \<and> ll = l+1"
by (erule eval_cases, simp_all)

lemma GetElim1: "\<lbrakk>(M, l, (os, S, h), n, ll, t) \<in> Step; get_ins M l = Some (getfield d F)\<rbrakk>
               \<Longrightarrow> \<exists> a Flds v ops. h\<down>a = Some (d, Flds) \<and> Flds\<down>F = Some v \<and>
                                   os = RVal (Loc a) # ops \<and> n = Suc 0 \<and> t = (v # ops, S, h) \<and> ll = l+1"
by (erule eval_cases, simp_all)

lemma PutElim1: "\<lbrakk>(M, l, (os, S, h), n, ll, t) \<in> Step; get_ins M l = Some (putfield d F)\<rbrakk>
                \<Longrightarrow> \<exists> a Flds v ops. h\<down>a = Some (d, Flds) \<and> os = v # RVal (Loc a) # ops \<and>
                                   n = Suc 0 \<and> t = (ops, S, h[a\<mapsto>(d, Flds[F\<mapsto>v])]) \<and> ll = l+1"
by (erule eval_cases, simp_all)

lemma CastElim1: "\<lbrakk>(M, l, (os, S, h), n, ll, t) \<in> Step; get_ins M l = Some (checkcast d)\<rbrakk>
                \<Longrightarrow> \<exists> a Flds ops . h\<down>a = Some (d, Flds) \<and> os = RVal (Loc a) # ops \<and> n = Suc 0 \<and>
                                   t = (RVal (Loc a) # ops, S, h) \<and> ll = l+1"
by (erule eval_cases, simp_all)

lemma GotoElim1: "\<lbrakk>(M, l, (os, S, h), n, ll, t) \<in> Step; get_ins M l = Some (goto pc)\<rbrakk>
                \<Longrightarrow> n = Suc 0 \<and> t = (os, S, h) \<and> ll = pc"
by (erule eval_cases, simp_all)

lemma IfElim1: "\<lbrakk>(M, l, (os, S, h), n, ll, t) \<in> Step; get_ins M l = Some (iftrue pc)\<rbrakk>
              \<Longrightarrow> (\<exists> ops . os = TRUE # ops \<and> n = Suc 0 \<and> t = (ops, S, h) \<and> ll = pc) \<or>
                  (\<exists> v ops . v \<noteq> TRUE \<and> os = v # ops \<and> n = Suc 0 \<and> t = (ops, S, h) \<and> ll = l+1)"
by (erule eval_cases, simp_all)

lemma InvokeElim1: "\<lbrakk>(M, l, (os, S, h), n, ll, t) \<in> Step; get_ins M l = Some (invokeS C m)\<rbrakk>
                   \<Longrightarrow> \<exists> code l0 v ops hh u k R par.
                           mbody_is C m (par,code, l0) \<and> (os,par,R,ops):Frame \<and>
                           ((par,code,l0), l0, ([], R, h), k, hh, v) \<in> Exec \<and>
                           n = Suc k \<and> t = (v # ops, S, hh) \<and> ll = l+1"
by (erule eval_cases, simp_all, fastforce)
lemma InvokeElim: "\<lbrakk>(M, l, s, n, ll, t) \<in> Step; get_ins M l = Some (invokeS C m)\<rbrakk>
                   \<Longrightarrow> \<exists> code l0 v ops hh u k R par.
                           mbody_is C m (par,code, l0) \<and> (fst s,par,R,ops):Frame \<and>
                           ((par,code,l0), l0, ([], R, snd(snd s)), k, hh, v) \<in> Exec \<and>
                           n = Suc k \<and> t = (v # ops, fst (snd s), hh) \<and> ll = l+1"
by (erule eval_cases, simp_all, fastforce)

lemma RetElim1: "\<lbrakk>(M, l, (os, S, h), n, ll, t) \<in> Step; get_ins M l = Some (vreturn)\<rbrakk> \<Longrightarrow> False"
by (erule eval_cases, simp_all)

lemma ExecElim1: "\<lbrakk>(M,l,(os,S,H),k,h,v):Exec\<rbrakk>
      \<Longrightarrow> (get_ins M l = Some vreturn \<and> (\<exists> ops . os = v # ops \<and> k = Suc 0 \<and> h=H)) \<or>
          (\<exists> n m t ll. (M, l,(os,S,H), n, ll,t) \<in> Step \<and> (M, ll, t, m, h, v) \<in> Exec \<and> k = Suc (max n m))"
apply (erule eval_cases, simp_all)
apply (rule disjI2)
  apply clarsimp
  apply (rule, rule, rule, rule) apply (rule, rule, rule) apply assumption
  apply (rule, assumption) apply simp
done

lemma InstrElimNext:
 "\<lbrakk>(M, l, s, n, ll, t) \<in> Step;
   get_ins M l = Some I;
   I = const c \<or> I = dup \<or> I = pop \<or> I = swap \<or> I = load x \<or>
   I = store x \<or> I = binop f \<or> I = unop g \<or> I = new d \<or>
   I = getfield d F \<or> I = putfield d F \<or> I = checkcast d\<rbrakk>
  \<Longrightarrow> ll = l+1"
apply (drule eval_cases, simp_all)
apply clarsimp
apply clarsimp
done
(*>*)

text\<open>By induction on the derivation system one can show
determinism.\<close>

(*<*)
lemma StepExec_determ_Aux[rule_format]:
"(\<forall> n1 l M s l1 t . n1 \<le> n \<longrightarrow> (M, l, s, n1, l1, t) \<in> Step \<longrightarrow>
       (\<forall> n2 l2 r. (M,l,s,n2,l2,r):Step \<longrightarrow> (n1=n2 \<and> t=r \<and> l1=l2))) \<and>
 (\<forall> n1 l M s h v . n1 \<le> n \<longrightarrow> (M, l, s, n1, h, v) \<in> Exec \<longrightarrow>
      (\<forall> n2 k w . (M,l,s,n2,k,w):Exec \<longrightarrow> (n1=n2 \<and> h=k \<and> v=w)))"
apply (induct n)
apply clarsimp apply rule apply clarsimp apply (drule no_zero_height_Step_derivs1, simp)
   apply clarsimp apply (drule no_zero_height_Exec_derivs1, simp)
apply clarsimp
apply rule
  apply clarsimp
apply (erule Step.cases)
  apply clarsimp apply (drule ConstElim1) apply simp apply clarsimp
  apply clarsimp apply (drule DupElim1) apply simp apply clarsimp
  apply clarsimp apply (drule PopElim1) apply simp apply clarsimp
  apply clarsimp apply (drule SwapElim1) apply simp apply clarsimp
  apply clarsimp apply (drule LoadElim1) apply simp apply clarsimp
  apply clarsimp apply (drule StoreElim1) apply simp apply clarsimp
  apply clarsimp apply (drule BinopElim1) apply simp apply clarsimp
  apply clarsimp apply (drule UnopElim1) apply simp apply clarsimp
  apply clarsimp apply (drule NewElim1) apply simp apply clarsimp
  apply clarsimp apply (drule GetElim1) apply fastforce apply clarsimp
  apply clarsimp apply (drule PutElim1) apply fastforce apply clarsimp
  apply clarsimp apply (drule CastElim1) apply simp apply clarsimp
  apply clarsimp apply (drule GotoElim1) apply simp apply clarsimp
  apply clarsimp apply (drule IfElim1) apply simp apply clarsimp
  apply clarsimp apply (drule IfElim1) apply simp apply clarsimp
  apply clarsimp apply (drule InvokeElim1) apply simp apply clarsimp
    apply (erule thin_rl)
    apply (simp add: mbody_is_def, clarsimp)
    apply (drule Frame_deterministic, assumption, clarsimp)
apply clarsimp
  apply (erule Exec.cases)
  apply clarsimp apply (erule Exec.cases)
    apply clarsimp
    apply clarsimp apply (drule RetElim1, simp, simp)
  apply clarsimp apply (drule ExecElim1)
    apply clarsimp
    apply (erule disjE, clarsimp) apply (drule RetElim1, simp, simp)
    apply clarsimp
      apply (erule_tac x=na in allE, rotate_tac -1, clarsimp)
      apply (erule_tac x=la in allE, rotate_tac -1)
      apply (erule_tac x=ad in allE, rotate_tac -1)
      apply (erule_tac x=ae in allE, rotate_tac -1)
      apply (erule_tac x=bb in allE, rotate_tac -1)
      apply (erule_tac x=af in allE, rotate_tac -1)
      apply (erule_tac x=ag in allE, rotate_tac -1)
      apply (erule_tac x=bc in allE, rotate_tac -1)
      apply (erule_tac x=ll in allE, rotate_tac -1)
      apply (erule_tac x=ah in allE, rotate_tac -1)
      apply (erule_tac x=ai in allE, rotate_tac -1)
      apply (erule_tac x=bd in allE, clarsimp)
      apply (rotate_tac -1)
      apply (erule_tac x=nb in allE, rotate_tac -1)
      apply (erule_tac x=lla in allE, rotate_tac -1)
      apply (erule_tac x=a in allE, rotate_tac -1)
      apply (erule_tac x=aa in allE, rotate_tac -1)
      apply (erule_tac x=b in allE, clarsimp)
      apply (erule_tac x=m in allE, rotate_tac -1, clarsimp)
      apply (erule_tac x=lla in allE, rotate_tac -1)
      apply (erule_tac x=ad in allE, rotate_tac -1)
      apply (erule_tac x=ae in allE, rotate_tac -1)
      apply (erule_tac x=bb in allE, rotate_tac -1)
      apply (erule_tac x=a in allE, rotate_tac -1)
      apply (erule_tac x=aa in allE, rotate_tac -1)
      apply (erule_tac x=b in allE, rotate_tac -1)
      apply (erule_tac x=ha in allE, rotate_tac -1)
      apply (erule_tac x=va in allE, rotate_tac -1, clarsimp)
done
(*>*)

lemma Step_determ:
 "\<lbrakk>(M,l,s,n,l1,t) \<in> Step; (M,l,s,m,l2,r):Step\<rbrakk> \<Longrightarrow> n=m \<and> t=r \<and> l1=l2"
(*<*)
apply (insert StepExec_determ_Aux[of n])
apply (erule conjE)
apply (rotate_tac -1, erule thin_rl)
apply fast
done
(*>*)

lemma Exec_determ:
 "\<lbrakk>(M,l,s,n,h,v) \<in> Exec; (M,l,s,m,k,w):Exec\<rbrakk> \<Longrightarrow> n=m \<and> h=k \<and> v=w"
(*<*)
apply (insert StepExec_determ_Aux[of n])
apply (erule conjE)
apply (rotate_tac -2, erule thin_rl)
apply fast
done
(*>*)

(*<*)
end
(*>*)


(*  Title:      HOL/Auth/n_mutualExDeadFree.thy
    Author:     Yongjian Li and Kaiqiang Duan, State Key Lab of Computer Science, Institute of Software, Chinese Academy of Sciences
    Copyright    2016 State Key Lab of Computer Science, Institute of Software, Chinese Academy of Sciences
*)

header{*The n_mutualExDeadFree Protocol Case Study*}

theory n_mutualExDeadFree imports n_mutualExDeadFree_lemma_invs_on_rules n_mutualExDeadFree_on_inis
begin
lemma main:
assumes a1: "s \<in> reachableSet {andList (allInitSpecs N)} (rules N)"
and a2: "0 < N"
shows "\<forall> f. f \<in> (invariants N) --> formEval f s"
proof (rule consistentLemma)
show "consistent (invariants N) {andList (allInitSpecs N)} (rules N)"
proof (cut_tac a1, unfold consistent_def, rule conjI)
show "\<forall> f ini s. f \<in> (invariants N) --> ini \<in> {andList (allInitSpecs N)} --> formEval ini s --> formEval f s"
proof ((rule allI)+, (rule impI)+)
  fix f ini s
  assume b1: "f \<in> (invariants N)" and b2: "ini \<in> {andList (allInitSpecs N)}" and b3: "formEval ini s"
  have b4: "formEval (andList (allInitSpecs N)) s"
  apply (cut_tac b2 b3, simp) done
  show "formEval f s"
  apply (rule on_inis, cut_tac b1, assumption, cut_tac b2, assumption, cut_tac b3, assumption) done
qed
next show "\<forall> f r s. f \<in> invariants N --> r \<in> rules N --> invHoldForRule s f r (invariants N)"
proof ((rule allI)+, (rule impI)+)
  fix f r s
  assume b1: "f \<in> invariants N" and b2: "r \<in> rules N"
  show "invHoldForRule s f r (invariants N)"
  apply (rule invs_on_rules, cut_tac b1, assumption, cut_tac b2, assumption) done
qed
qed
next show "s \<in> reachableSet {andList (allInitSpecs N)} (rules N)"
  apply (metis a1) done
qed
end


(*  Title:      ZF/UNITY/Mutex.thy
    Author:     Sidi O Ehmety, Computer Laboratory
    Copyright   2001  University of Cambridge

Based on "A Family of 2-Process Mutual Exclusion Algorithms" by J Misra.

Variables' types are introduced globally so that type verification
reduces to the usual ZF typechecking \<in> an ill-tyed expression will
reduce to the empty set.
*)

section{*Mutual Exclusion*}

theory Mutex
imports SubstAx
begin

text{*Based on "A Family of 2-Process Mutual Exclusion Algorithms" by J Misra

Variables' types are introduced globally so that type verification reduces to
the usual ZF typechecking: an ill-tyed expressions reduce to the empty set.
*}

abbreviation "p == Var([0])"
abbreviation "m == Var([1])"
abbreviation "n == Var([0,0])"
abbreviation "u == Var([0,1])"
abbreviation "v == Var([1,0])"

axiomatization where --{** Type declarations  **}
  p_type:  "type_of(p)=bool & default_val(p)=0" and
  m_type:  "type_of(m)=int  & default_val(m)=#0" and
  n_type:  "type_of(n)=int  & default_val(n)=#0" and
  u_type:  "type_of(u)=bool & default_val(u)=0" and
  v_type:  "type_of(v)=bool & default_val(v)=0"

definition
  (** The program for process U **)
  "U0 == {<s,t>:state*state. t = s(u:=1, m:=#1) & s`m = #0}"

definition
  "U1 == {<s,t>:state*state. t = s(p:= s`v, m:=#2) &  s`m = #1}"

definition
  "U2 == {<s,t>:state*state. t = s(m:=#3) & s`p=0 & s`m = #2}"

definition
  "U3 == {<s,t>:state*state. t=s(u:=0, m:=#4) & s`m = #3}"

definition
  "U4 == {<s,t>:state*state. t = s(p:=1, m:=#0) & s`m = #4}"

   (** The program for process V **)

definition
  "V0 == {<s,t>:state*state. t = s (v:=1, n:=#1) & s`n = #0}"

definition
  "V1 == {<s,t>:state*state. t = s(p:=not(s`u), n:=#2) & s`n = #1}"

definition
  "V2 == {<s,t>:state*state. t  = s(n:=#3) & s`p=1 & s`n = #2}"

definition
  "V3 == {<s,t>:state*state. t = s (v:=0, n:=#4) & s`n = #3}"

definition
  "V4 == {<s,t>:state*state. t  = s (p:=0, n:=#0) & s`n = #4}"

definition
  "Mutex == mk_program({s:state. s`u=0 & s`v=0 & s`m = #0 & s`n = #0},
              {U0, U1, U2, U3, U4, V0, V1, V2, V3, V4}, Pow(state*state))"

  (** The correct invariants **)

definition
  "IU == {s:state. (s`u = 1\<longleftrightarrow>(#1 $<= s`m & s`m $<= #3))
                     & (s`m = #3 \<longrightarrow> s`p=0)}"

definition
  "IV == {s:state. (s`v = 1 \<longleftrightarrow> (#1 $<= s`n & s`n $<= #3))
                      & (s`n = #3 \<longrightarrow> s`p=1)}"

  (** The faulty invariant (for U alone) **)

definition
  "bad_IU == {s:state. (s`u = 1 \<longleftrightarrow> (#1 $<= s`m & s`m  $<= #3))&
                   (#3 $<= s`m & s`m $<= #4 \<longrightarrow> s`p=0)}"

(** Variables' types **)

declare p_type [simp] u_type [simp] v_type [simp] m_type [simp] n_type [simp]

lemma u_value_type: "s \<in> state ==>s`u \<in> bool"
apply (unfold state_def)
apply (drule_tac a = u in apply_type, auto)
done

lemma v_value_type: "s \<in> state ==> s`v \<in> bool"
apply (unfold state_def)
apply (drule_tac a = v in apply_type, auto)
done

lemma p_value_type: "s \<in> state ==> s`p \<in> bool"
apply (unfold state_def)
apply (drule_tac a = p in apply_type, auto)
done

lemma m_value_type: "s \<in> state ==> s`m \<in> int"
apply (unfold state_def)
apply (drule_tac a = m in apply_type, auto)
done

lemma n_value_type: "s \<in> state ==>s`n \<in> int"
apply (unfold state_def)
apply (drule_tac a = n in apply_type, auto)
done

declare p_value_type [simp] u_value_type [simp] v_value_type [simp]
        m_value_type [simp] n_value_type [simp]

declare p_value_type [TC] u_value_type [TC] v_value_type [TC]
        m_value_type [TC] n_value_type [TC]

text{*Mutex is a program*}

lemma Mutex_in_program [simp,TC]: "Mutex \<in> program"
by (simp add: Mutex_def)

declare Mutex_def [THEN def_prg_Init, simp]
declare Mutex_def [program]

declare  U0_def [THEN def_act_simp, simp]
declare  U1_def [THEN def_act_simp, simp]
declare  U2_def [THEN def_act_simp, simp]
declare  U3_def [THEN def_act_simp, simp]
declare  U4_def [THEN def_act_simp, simp]

declare  V0_def [THEN def_act_simp, simp]
declare  V1_def [THEN def_act_simp, simp]
declare  V2_def [THEN def_act_simp, simp]
declare  V3_def [THEN def_act_simp, simp]
declare  V4_def [THEN def_act_simp, simp]

declare  U0_def [THEN def_set_simp, simp]
declare  U1_def [THEN def_set_simp, simp]
declare  U2_def [THEN def_set_simp, simp]
declare  U3_def [THEN def_set_simp, simp]
declare  U4_def [THEN def_set_simp, simp]

declare  V0_def [THEN def_set_simp, simp]
declare  V1_def [THEN def_set_simp, simp]
declare  V2_def [THEN def_set_simp, simp]
declare  V3_def [THEN def_set_simp, simp]
declare  V4_def [THEN def_set_simp, simp]

declare  IU_def [THEN def_set_simp, simp]
declare  IV_def [THEN def_set_simp, simp]
declare  bad_IU_def [THEN def_set_simp, simp]

lemma IU: "Mutex \<in> Always(IU)"
apply (rule AlwaysI, force)
apply (unfold Mutex_def, safety, auto)
done

lemma IV: "Mutex \<in> Always(IV)"
apply (rule AlwaysI, force)
apply (unfold Mutex_def, safety)
done

(*The safety property: mutual exclusion*)
lemma mutual_exclusion: "Mutex \<in> Always({s \<in> state. ~(s`m = #3 & s`n = #3)})"
apply (rule Always_weaken)
apply (rule Always_Int_I [OF IU IV], auto)
done

(*The bad invariant FAILS in V1*)

lemma less_lemma: "[| x$<#1; #3 $<= x |] ==> P"
apply (drule_tac j = "#1" and k = "#3" in zless_zle_trans)
apply (drule_tac [2] j = x in zle_zless_trans, auto)
done

lemma "Mutex \<in> Always(bad_IU)"
apply (rule AlwaysI, force)
apply (unfold Mutex_def, safety, auto)
apply (subgoal_tac "#1 $<= #3")
apply (drule_tac x = "#1" and y = "#3" in zle_trans, auto)
apply (simp (no_asm) add: not_zless_iff_zle [THEN iff_sym])
apply auto
(*Resulting state: n=1, p=false, m=4, u=false.
  Execution of V1 (the command of process v guarded by n=1) sets p:=true,
  violating the invariant!*)
oops

(*** Progress for U ***)

lemma U_F0: "Mutex \<in> {s \<in> state. s`m=#2} Unless {s \<in> state. s`m=#3}"
by (unfold op_Unless_def Mutex_def, safety)

lemma U_F1:
     "Mutex \<in> {s \<in> state. s`m=#1} LeadsTo {s \<in> state. s`p = s`v & s`m = #2}"
by (unfold Mutex_def, ensures U1)

lemma U_F2: "Mutex \<in> {s \<in> state. s`p =0 & s`m = #2} LeadsTo {s \<in> state. s`m = #3}"
apply (cut_tac IU)
apply (unfold Mutex_def, ensures U2)
done

lemma U_F3: "Mutex \<in> {s \<in> state. s`m = #3} LeadsTo {s \<in> state. s`p=1}"
apply (rule_tac B = "{s \<in> state. s`m = #4}" in LeadsTo_Trans)
 apply (unfold Mutex_def)
 apply (ensures U3)
apply (ensures U4)
done

lemma U_lemma2: "Mutex \<in> {s \<in> state. s`m = #2} LeadsTo {s \<in> state. s`p=1}"
apply (rule LeadsTo_Diff [OF LeadsTo_weaken_L
                             Int_lower2 [THEN subset_imp_LeadsTo]])
apply (rule LeadsTo_Trans [OF U_F2 U_F3], auto)
apply (auto dest!: p_value_type simp add: bool_def)
done

lemma U_lemma1: "Mutex \<in> {s \<in> state. s`m = #1} LeadsTo {s \<in> state. s`p =1}"
by (rule LeadsTo_Trans [OF U_F1 [THEN LeadsTo_weaken_R] U_lemma2], blast)

lemma eq_123: "i \<in> int ==> (#1 $<= i & i $<= #3) \<longleftrightarrow> (i=#1 | i=#2 | i=#3)"
apply auto
apply (auto simp add: neq_iff_zless)
apply (drule_tac [4] j = "#3" and i = i in zle_zless_trans)
apply (drule_tac [2] j = i and i = "#1" in zle_zless_trans)
apply (drule_tac j = i and i = "#1" in zle_zless_trans, auto)
apply (rule zle_anti_sym)
apply (simp_all (no_asm_simp) add: zless_add1_iff_zle [THEN iff_sym])
done

lemma U_lemma123: "Mutex \<in> {s \<in> state. #1 $<= s`m & s`m $<= #3} LeadsTo {s \<in> state. s`p=1}"
by (simp add: eq_123 Collect_disj_eq LeadsTo_Un_distrib U_lemma1 U_lemma2 U_F3)

(*Misra's F4*)
lemma u_Leadsto_p: "Mutex \<in> {s \<in> state. s`u = 1} LeadsTo {s \<in> state. s`p=1}"
by (rule Always_LeadsTo_weaken [OF IU U_lemma123], auto)

(*** Progress for V ***)

lemma V_F0: "Mutex \<in> {s \<in> state. s`n=#2} Unless {s \<in> state. s`n=#3}"
by (unfold op_Unless_def Mutex_def, safety)

lemma V_F1: "Mutex \<in> {s \<in> state. s`n=#1} LeadsTo {s \<in> state. s`p = not(s`u) & s`n = #2}"
by (unfold Mutex_def, ensures "V1")

lemma V_F2: "Mutex \<in> {s \<in> state. s`p=1 & s`n = #2} LeadsTo {s \<in> state. s`n = #3}"
apply (cut_tac IV)
apply (unfold Mutex_def, ensures "V2")
done

lemma V_F3: "Mutex \<in> {s \<in> state. s`n = #3} LeadsTo {s \<in> state. s`p=0}"
apply (rule_tac B = "{s \<in> state. s`n = #4}" in LeadsTo_Trans)
 apply (unfold Mutex_def)
 apply (ensures V3)
apply (ensures V4)
done

lemma V_lemma2: "Mutex \<in> {s \<in> state. s`n = #2} LeadsTo {s \<in> state. s`p=0}"
apply (rule LeadsTo_Diff [OF LeadsTo_weaken_L
                             Int_lower2 [THEN subset_imp_LeadsTo]])
apply (rule LeadsTo_Trans [OF V_F2 V_F3], auto)
apply (auto dest!: p_value_type simp add: bool_def)
done

lemma V_lemma1: "Mutex \<in> {s \<in> state. s`n = #1} LeadsTo {s \<in> state. s`p = 0}"
by (rule LeadsTo_Trans [OF V_F1 [THEN LeadsTo_weaken_R] V_lemma2], blast)

lemma V_lemma123: "Mutex \<in> {s \<in> state. #1 $<= s`n & s`n $<= #3} LeadsTo {s \<in> state. s`p = 0}"
by (simp add: eq_123 Collect_disj_eq LeadsTo_Un_distrib V_lemma1 V_lemma2 V_F3)

(*Misra's F4*)
lemma v_Leadsto_not_p: "Mutex \<in> {s \<in> state. s`v = 1} LeadsTo {s \<in> state. s`p = 0}"
by (rule Always_LeadsTo_weaken [OF IV V_lemma123], auto)

(** Absence of starvation **)

(*Misra's F6*)
lemma m1_Leadsto_3: "Mutex \<in> {s \<in> state. s`m = #1} LeadsTo {s \<in> state. s`m = #3}"
apply (rule LeadsTo_cancel2 [THEN LeadsTo_Un_duplicate])
apply (rule_tac [2] U_F2)
apply (simp add: Collect_conj_eq)
apply (subst Un_commute)
apply (rule LeadsTo_cancel2 [THEN LeadsTo_Un_duplicate])
 apply (rule_tac [2] PSP_Unless [OF v_Leadsto_not_p U_F0])
apply (rule U_F1 [THEN LeadsTo_weaken_R], auto)
apply (auto dest!: v_value_type simp add: bool_def)
done

(*The same for V*)
lemma n1_Leadsto_3: "Mutex \<in> {s \<in> state. s`n = #1} LeadsTo {s \<in> state. s`n = #3}"
apply (rule LeadsTo_cancel2 [THEN LeadsTo_Un_duplicate])
apply (rule_tac [2] V_F2)
apply (simp add: Collect_conj_eq)
apply (subst Un_commute)
apply (rule LeadsTo_cancel2 [THEN LeadsTo_Un_duplicate])
 apply (rule_tac [2] PSP_Unless [OF u_Leadsto_p V_F0])
apply (rule V_F1 [THEN LeadsTo_weaken_R], auto)
apply (auto dest!: u_value_type simp add: bool_def)
done

end


header {* \isaheader{Transfer between Domains} *}
theory RefineG_Transfer
imports "../Refine_Misc"
begin
  text {* Currently, this theory is specialized to
    transfers that include no data refinement.
    *}

definition "REFINEG_TRANSFER_POST_SIMP x y \<equiv> x=y"
definition [simp]: "REFINEG_TRANSFER_ALIGN x y == True"
lemma REFINEG_TRANSFER_ALIGNI: "REFINEG_TRANSFER_ALIGN x y" by simp

lemma START_REFINEG_TRANSFER:
  assumes "REFINEG_TRANSFER_ALIGN d c"
  assumes "c\<le>a"
  assumes "REFINEG_TRANSFER_POST_SIMP c d"
  shows "d\<le>a"
  using assms
  by (simp add: REFINEG_TRANSFER_POST_SIMP_def)

lemma STOP_REFINEG_TRANSFER: "REFINEG_TRANSFER_POST_SIMP c c"
  unfolding REFINEG_TRANSFER_POST_SIMP_def ..

ML {*
structure RefineG_Transfer = struct

  structure Post_Processors = Theory_Data (
    type T = (Proof.context -> tactic') Symtab.table
    val empty = Symtab.empty
    val extend = I
    val merge = Symtab.join (K snd)
  )

  fun add_post_processor name tac =
    Post_Processors.map (Symtab.update_new (name,tac))
  fun delete_post_processor name =
    Post_Processors.map (Symtab.delete name)
  val get_post_processors = Post_Processors.get #> Symtab.dest

  fun post_process_tac ctxt = let
    val tacs = get_post_processors (Proof_Context.theory_of ctxt)
      |> map (fn (_,tac) => tac ctxt)

    val tac = REPEAT_DETERM' (CHANGED o EVERY' (map (fn t => TRY o t) tacs))
  in
    tac
  end

  structure Post_Simp = Generic_Data (
      type T = simpset
      val empty = HOL_basic_ss
      val extend = I
      val merge = Raw_Simplifier.merge_ss
  )

  fun post_simps_op f a context = let
    val ctxt = Context.proof_of context
    fun do_it ss = simpset_of (f (put_simpset ss ctxt, a))
  in
    Post_Simp.map do_it context
  end

  val add_post_simps = post_simps_op (op addsimps)
  val del_post_simps = post_simps_op (op delsimps)

  fun get_post_ss ctxt = let
    val ss = Post_Simp.get (Context.Proof ctxt)
    val ctxt = put_simpset ss ctxt
  in
    ctxt
  end

  structure post_subst = Named_Thms
    ( val name = @{binding refine_transfer_post_subst}
      val description = "Refinement Framework: " ^
        "Transfer postprocessing substitutions" );

  fun post_subst_tac ctxt = let
    val s_thms = post_subst.get ctxt
    val dis_tac = (ALLGOALS (Tagged_Solver.solve_tac ctxt))
    val cnv = Cond_Rewr_Conv.cond_rewrs_conv dis_tac s_thms
    val ts_conv = Conv.top_sweep_conv cnv ctxt
    val ss = get_post_ss ctxt
  in
    REPEAT o CHANGED o
    (Simplifier.simp_tac ss THEN' CONVERSION ts_conv)
  end

  structure transfer = Named_Thms
    ( val name = @{binding refine_transfer}
      val description = "Refinement Framework: " ^
        "Transfer rules" );

  fun transfer_tac thms ctxt i st = let
    val thms = thms @ transfer.get ctxt;
    val ss = put_simpset HOL_basic_ss ctxt addsimps @{thms nested_prod_case_simp}
  in
    REPEAT_DETERM1 (
      COND (has_fewer_prems (nprems_of st)) no_tac (
        FIRST [
          Method.assm_tac ctxt i,
          resolve_tac thms i,
          Tagged_Solver.solve_tac ctxt i,
          CHANGED_PROP (simp_tac ss i)]
      )) st
  end

  (* Adjust right term to have same structure as left one *)
  val align_tac = IF_EXGOAL (fn i => fn st =>
    case Logic.concl_of_goal (prop_of st) i of
      @{mpat "Trueprop (REFINEG_TRANSFER_ALIGN ?c _)"} => let
        val thy = theory_of_thm st
        val c = cterm_of thy c
        val cT = ctyp_of_term c

        val rl = @{thm REFINEG_TRANSFER_ALIGNI}
          |> Thm.incr_indexes (Thm.maxidx_of st + 1)
          |> instantiate' [NONE,SOME cT] [NONE,SOME c]
        (*val _ = tracing (@{make_string} rl)*)
      in
        rtac rl i st
      end
    | _ => Seq.empty
  )

  fun post_transfer_tac thms ctxt = let open Autoref_Tacticals in
    rtac @{thm START_REFINEG_TRANSFER}
    THEN' align_tac
    THEN' IF_SOLVED (transfer_tac thms ctxt)
      (post_process_tac ctxt THEN' rtac @{thm STOP_REFINEG_TRANSFER})
      (K all_tac)

  end

  fun get_post_simp_rules context = Context.proof_of context
      |> get_post_ss
      |> simpset_of
      |> Raw_Simplifier.dest_ss
      |> #simps |> map snd

  local
    val add_ps = Thm.declaration_attribute (add_post_simps o single)
    val del_ps = Thm.declaration_attribute (del_post_simps o single)
  in
    val setup = I
      #> add_post_processor "RefineG_Transfer.post_subst" post_subst_tac
      #> post_subst.setup
      #> transfer.setup
      #> Attrib.setup @{binding refine_transfer_post_simp}
          (Attrib.add_del add_ps del_ps)
          ("declaration of transfer post simplification rules")
      #> Global_Theory.add_thms_dynamic (
           @{binding refine_transfer_post_simps}, get_post_simp_rules)

  end
end
*}

setup {* RefineG_Transfer.setup *}
method_setup refine_transfer =
  {* Scan.lift (Args.mode "post") -- Attrib.thms
  >> (fn (post,thms) => fn ctxt => SIMPLE_METHOD'
    ( if post then RefineG_Transfer.post_transfer_tac thms ctxt
      else RefineG_Transfer.transfer_tac thms ctxt))
  *} "Invoke transfer rules"

locale transfer = fixes \<alpha> :: "'c \<Rightarrow> 'a::complete_lattice"
begin

text {*
  In the following, we define some transfer lemmas for general
  HOL - constructs.
*}

lemma transfer_if[refine_transfer]:
  assumes "b \<Longrightarrow> \<alpha> s1 \<le> S1"
  assumes "\<not>b \<Longrightarrow> \<alpha> s2 \<le> S2"
  shows "\<alpha> (if b then s1 else s2) \<le> (if b then S1 else S2)"
  using assms by auto

lemma transfer_prod[refine_transfer]:
  assumes "\<And>a b. \<alpha> (f a b) \<le> F a b"
  shows "\<alpha> (case_prod f x) \<le> (case_prod F x)"
  using assms by (auto split: prod.split)

lemma transfer_Let[refine_transfer]:
  assumes "\<And>x. \<alpha> (f x) \<le> F x"
  shows "\<alpha> (Let x f) \<le> Let x F"
  using assms by auto

lemma transfer_option[refine_transfer]:
  assumes "\<alpha> fa \<le> Fa"
  assumes "\<And>x. \<alpha> (fb x) \<le> Fb x"
  shows "\<alpha> (case_option fa fb x) \<le> case_option Fa Fb x"
  using assms by (auto split: option.split)

lemma transfer_list[refine_transfer]:
  assumes "\<alpha> fn \<le> Fn"
  assumes "\<And>x xs. \<alpha> (fc x xs) \<le> Fc x xs"
  shows "\<alpha> (case_list fn fc l) \<le> case_list Fn Fc l"
  using assms by (auto split: list.split)

lemma transfer_rec_list[refine_transfer]:
  assumes FN: "\<And>s. \<alpha> (fn s) \<le> fn' s"
  assumes FC: "\<And>x l rec rec' s. \<lbrakk> \<And>s. \<alpha> (rec s) \<le> (rec' s) \<rbrakk>
    \<Longrightarrow> \<alpha> (fc x l rec s) \<le> fc' x l rec' s"
  shows "\<alpha> (rec_list fn fc l s) \<le> rec_list fn' fc' l s"
  apply (induct l arbitrary: s)
  apply (simp add: FN)
  apply (simp add: FC)
  done

end

text {* Transfer into complete lattice structure *}
locale ordered_transfer = transfer +
  constrains \<alpha> :: "'c::complete_lattice \<Rightarrow> 'a::complete_lattice"

text {* Transfer into complete lattice structure with distributive
  transfer function. *}
locale dist_transfer = ordered_transfer +
  constrains \<alpha> :: "'c::complete_lattice \<Rightarrow> 'a::complete_lattice"
  assumes \<alpha>_dist: "\<And>A. is_chain A \<Longrightarrow> \<alpha> (Sup A) = Sup (\<alpha>`A)"
begin
  lemma \<alpha>_mono[simp, intro!]: "mono \<alpha>"
    apply rule
    apply (subgoal_tac "is_chain {x,y}")
    apply (drule \<alpha>_dist)
    apply (auto simp: le_iff_sup) []
    apply (rule chainI)
    apply auto
    done

  lemma \<alpha>_strict[simp]: "\<alpha> bot = bot"
    using \<alpha>_dist[of "{}"] by simp
end

text {* Transfer into ccpo *}
locale ccpo_transfer = transfer \<alpha> for
  \<alpha> :: "'c::ccpo \<Rightarrow> 'a::complete_lattice"

text {* Transfer into ccpo with distributive
  transfer function. *}
locale dist_ccpo_transfer = ccpo_transfer \<alpha>
  for \<alpha> :: "'c::ccpo \<Rightarrow> 'a::complete_lattice" +
  assumes \<alpha>_dist: "\<And>A. is_chain A \<Longrightarrow> \<alpha> (Sup A) = Sup (\<alpha>`A)"
begin

  lemma \<alpha>_mono[simp, intro!]: "mono \<alpha>"
  proof
    fix x y :: 'c
    assume LE: "x\<le>y"
    hence C[simp, intro!]: "is_chain {x,y}" by (auto intro: chainI)
    from LE have "\<alpha> x \<le> sup (\<alpha> x) (\<alpha> y)" by simp
    also have "\<dots> = Sup (\<alpha>`{x,y})" by simp
    also have "\<dots> = \<alpha> (Sup {x,y})"
      by (rule \<alpha>_dist[symmetric]) simp
    also have "Sup {x,y} = y"
      apply (rule antisym)
      apply (rule ccpo_Sup_least[OF C]) using LE apply auto []
      apply (rule ccpo_Sup_upper[OF C]) by auto
    finally show "\<alpha> x \<le> \<alpha> y" .
  qed

  lemma \<alpha>_strict[simp]: "\<alpha> (Sup {}) = bot"
    using \<alpha>_dist[of "{}"] by simp
end

end


(*  Title:      HOL/Imperative_HOL/Ref.thy
    Author:     John Matthews, Galois Connections; Alexander Krauss, Lukas Bulwahn & Florian Haftmann, TU Muenchen
*)

section \<open>Monadic references\<close>

theory Ref
imports Array
begin

text \<open>
  Imperative reference operations; modeled after their ML counterparts.
  See \<^url>\<open>https://caml.inria.fr/pub/docs/manual-caml-light/node14.15.html\<close>
  and \<^url>\<open>https://www.smlnj.org/doc/Conversion/top-level-comparison.html\<close>.
\<close>

subsection \<open>Primitives\<close>

definition present :: "heap \<Rightarrow> 'a::heap ref \<Rightarrow> bool" where
  "present h r \<longleftrightarrow> addr_of_ref r < lim h"

definition get :: "heap \<Rightarrow> 'a::heap ref \<Rightarrow> 'a" where
  "get h = from_nat \<circ> refs h TYPEREP('a) \<circ> addr_of_ref"

definition set :: "'a::heap ref \<Rightarrow> 'a \<Rightarrow> heap \<Rightarrow> heap" where
  "set r x = refs_update
    (\<lambda>h. h(TYPEREP('a) := ((h (TYPEREP('a))) (addr_of_ref r := to_nat x))))"

definition alloc :: "'a \<Rightarrow> heap \<Rightarrow> 'a::heap ref \<times> heap" where
  "alloc x h = (let
     l = lim h;
     r = Ref l
   in (r, set r x (h\<lparr>lim := l + 1\<rparr>)))"

definition noteq :: "'a::heap ref \<Rightarrow> 'b::heap ref \<Rightarrow> bool" (infix "=!=" 70) where
  "r =!= s \<longleftrightarrow> TYPEREP('a) \<noteq> TYPEREP('b) \<or> addr_of_ref r \<noteq> addr_of_ref s"

subsection \<open>Monad operations\<close>

definition ref :: "'a::heap \<Rightarrow> 'a ref Heap" where
  [code del]: "ref v = Heap_Monad.heap (alloc v)"

definition lookup :: "'a::heap ref \<Rightarrow> 'a Heap" ("!_" 61) where
  [code del]: "lookup r = Heap_Monad.tap (\<lambda>h. get h r)"

definition update :: "'a ref \<Rightarrow> 'a::heap \<Rightarrow> unit Heap" ("_ := _" 62) where
  [code del]: "update r v = Heap_Monad.heap (\<lambda>h. ((), set r v h))"

definition change :: "('a::heap \<Rightarrow> 'a) \<Rightarrow> 'a ref \<Rightarrow> 'a Heap" where
  "change f r = do {
     x \<leftarrow> ! r;
     let y = f x;
     r := y;
     return y
   }"

subsection \<open>Properties\<close>

text \<open>Primitives\<close>

lemma noteq_sym: "r =!= s \<Longrightarrow> s =!= r"
  and unequal [simp]: "r \<noteq> r' \<longleftrightarrow> r =!= r'" \<comment> \<open>same types!\<close>
  by (auto simp add: noteq_def)

lemma noteq_irrefl: "r =!= r \<Longrightarrow> False"
  by (auto simp add: noteq_def)

lemma present_alloc_neq: "present h r \<Longrightarrow> r =!= fst (alloc v h)"
  by (simp add: present_def alloc_def noteq_def Let_def)

lemma next_fresh [simp]:
  assumes "(r, h') = alloc x h"
  shows "\<not> present h r"
  using assms by (cases h) (auto simp add: alloc_def present_def Let_def)

lemma next_present [simp]:
  assumes "(r, h') = alloc x h"
  shows "present h' r"
  using assms by (cases h) (auto simp add: alloc_def set_def present_def Let_def)

lemma get_set_eq [simp]:
  "get (set r x h) r = x"
  by (simp add: get_def set_def)

lemma get_set_neq [simp]:
  "r =!= s \<Longrightarrow> get (set s x h) r = get h r"
  by (simp add: noteq_def get_def set_def)

lemma set_same [simp]:
  "set r x (set r y h) = set r x h"
  by (simp add: set_def)

lemma not_present_alloc [simp]:
  "\<not> present h (fst (alloc v h))"
  by (simp add: present_def alloc_def Let_def)

lemma set_set_swap:
  "r =!= r' \<Longrightarrow> set r x (set r' x' h) = set r' x' (set r x h)"
  by (simp add: noteq_def set_def fun_eq_iff)

lemma alloc_set:
  "fst (alloc x (set r x' h)) = fst (alloc x h)"
  by (simp add: alloc_def set_def Let_def)

lemma get_alloc [simp]:
  "get (snd (alloc x h)) (fst (alloc x' h)) = x"
  by (simp add: alloc_def Let_def)

lemma set_alloc [simp]:
  "set (fst (alloc v h)) v' (snd (alloc v h)) = snd (alloc v' h)"
  by (simp add: alloc_def Let_def)

lemma get_alloc_neq: "r =!= fst (alloc v h) \<Longrightarrow>
  get (snd (alloc v h)) r  = get h r"
  by (simp add: get_def set_def alloc_def Let_def noteq_def)

lemma lim_set [simp]:
  "lim (set r v h) = lim h"
  by (simp add: set_def)

lemma present_alloc [simp]:
  "present h r \<Longrightarrow> present (snd (alloc v h)) r"
  by (simp add: present_def alloc_def Let_def)

lemma present_set [simp]:
  "present (set r v h) = present h"
  by (simp add: present_def fun_eq_iff)

lemma noteq_I:
  "present h r \<Longrightarrow> \<not> present h r' \<Longrightarrow> r =!= r'"
  by (auto simp add: noteq_def present_def)

text \<open>Monad operations\<close>

lemma execute_ref [execute_simps]:
  "execute (ref v) h = Some (alloc v h)"
  by (simp add: ref_def execute_simps)

lemma success_refI [success_intros]:
  "success (ref v) h"
  by (auto intro: success_intros simp add: ref_def)

lemma effect_refI [effect_intros]:
  assumes "(r, h') = alloc v h"
  shows "effect (ref v) h h' r"
  by (rule effectI) (insert assms, simp add: execute_simps)

lemma effect_refE [effect_elims]:
  assumes "effect (ref v) h h' r"
  obtains "get h' r = v" and "present h' r" and "\<not> present h r"
  using assms by (rule effectE) (simp add: execute_simps)

lemma execute_lookup [execute_simps]:
  "Heap_Monad.execute (lookup r) h = Some (get h r, h)"
  by (simp add: lookup_def execute_simps)

lemma success_lookupI [success_intros]:
  "success (lookup r) h"
  by (auto intro: success_intros  simp add: lookup_def)

lemma effect_lookupI [effect_intros]:
  assumes "h' = h" "x = get h r"
  shows "effect (!r) h h' x"
  by (rule effectI) (insert assms, simp add: execute_simps)

lemma effect_lookupE [effect_elims]:
  assumes "effect (!r) h h' x"
  obtains "h' = h" "x = get h r"
  using assms by (rule effectE) (simp add: execute_simps)

lemma execute_update [execute_simps]:
  "Heap_Monad.execute (update r v) h = Some ((), set r v h)"
  by (simp add: update_def execute_simps)

lemma success_updateI [success_intros]:
  "success (update r v) h"
  by (auto intro: success_intros  simp add: update_def)

lemma effect_updateI [effect_intros]:
  assumes "h' = set r v h"
  shows "effect (r := v) h h' x"
  by (rule effectI) (insert assms, simp add: execute_simps)

lemma effect_updateE [effect_elims]:
  assumes "effect (r' := v) h h' r"
  obtains "h' = set r' v h"
  using assms by (rule effectE) (simp add: execute_simps)

lemma execute_change [execute_simps]:
  "Heap_Monad.execute (change f r) h = Some (f (get h r), set r (f (get h r)) h)"
  by (simp add: change_def bind_def Let_def execute_simps)

lemma success_changeI [success_intros]:
  "success (change f r) h"
  by (auto intro!: success_intros effect_intros simp add: change_def)

lemma effect_changeI [effect_intros]:
  assumes "h' = set r (f (get h r)) h" "x = f (get h r)"
  shows "effect (change f r) h h' x"
  by (rule effectI) (insert assms, simp add: execute_simps)

lemma effect_changeE [effect_elims]:
  assumes "effect (change f r') h h' r"
  obtains "h' = set r' (f (get h r')) h" "r = f (get h r')"
  using assms by (rule effectE) (simp add: execute_simps)

lemma lookup_chain:
  "(!r \<then> f) = f"
  by (rule Heap_eqI) (auto simp add: lookup_def execute_simps intro: execute_bind)

lemma update_change [code]:
  "r := e = change (\<lambda>_. e) r \<then> return ()"
  by (rule Heap_eqI) (simp add: change_def lookup_chain)

text \<open>Non-interaction between imperative arrays and imperative references\<close>

lemma array_get_set [simp]:
  "Array.get (set r v h) = Array.get h"
  by (simp add: Array.get_def set_def fun_eq_iff)

lemma get_update [simp]:
  "get (Array.update a i v h) r = get h r"
  by (simp add: get_def Array.update_def Array.set_def)

lemma alloc_update:
  "fst (alloc v (Array.update a i v' h)) = fst (alloc v h)"
  by (simp add: Array.update_def Array.get_def Array.set_def alloc_def Let_def)

lemma update_set_swap:
  "Array.update a i v (set r v' h) = set r v' (Array.update a i v h)"
  by (simp add: Array.update_def Array.get_def Array.set_def set_def)

lemma length_alloc [simp]:
  "Array.length (snd (alloc v h)) a = Array.length h a"
  by (simp add: Array.length_def Array.get_def alloc_def set_def Let_def)

lemma array_get_alloc [simp]:
  "Array.get (snd (alloc v h)) = Array.get h"
  by (simp add: Array.get_def alloc_def set_def Let_def fun_eq_iff)

lemma present_update [simp]:
  "present (Array.update a i v h) = present h"
  by (simp add: Array.update_def Array.set_def fun_eq_iff present_def)

lemma array_present_set [simp]:
  "Array.present (set r v h) = Array.present h"
  by (simp add: Array.present_def set_def fun_eq_iff)

lemma array_present_alloc [simp]:
  "Array.present h a \<Longrightarrow> Array.present (snd (alloc v h)) a"
  by (simp add: Array.present_def alloc_def Let_def)

lemma set_array_set_swap:
  "Array.set a xs (set r x' h) = set r x' (Array.set a xs h)"
  by (simp add: Array.set_def set_def)

hide_const (open) present get set alloc noteq lookup update change

subsection \<open>Code generator setup\<close>

text \<open>Intermediate operation avoids invariance problem in \<open>Scala\<close> (similar to value restriction)\<close>

definition ref' where
  [code del]: "ref' = ref"

text \<open>SML / Eval\<close>

code_printing type_constructor ref \<rightharpoonup> (SML) "_/ ref"
code_printing type_constructor ref \<rightharpoonup> (Eval) "_/ Unsynchronized.ref"
code_printing constant Ref \<rightharpoonup> (SML) "raise/ (Fail/ \"bare Ref\")"
code_printing constant ref' \<rightharpoonup> (SML) "(fn/ ()/ =>/ ref/ _)"
code_printing constant ref' \<rightharpoonup> (Eval) "(fn/ ()/ =>/ Unsynchronized.ref/ _)"
code_printing constant Ref.lookup \<rightharpoonup> (SML) "(fn/ ()/ =>/ !/ _)"
code_printing constant Ref.update \<rightharpoonup> (SML) "(fn/ ()/ =>/ _/ :=/ _)"
code_printing constant "HOL.equal :: 'a ref \<Rightarrow> 'a ref \<Rightarrow> bool" \<rightharpoonup> (SML) infixl 6 "="

code_reserved Eval Unsynchronized

text \<open>OCaml\<close>

code_printing type_constructor ref \<rightharpoonup> (OCaml) "_/ ref"
code_printing constant Ref \<rightharpoonup> (OCaml) "failwith/ \"bare Ref\""
code_printing constant ref' \<rightharpoonup> (OCaml) "(fun/ ()/ ->/ ref/ _)"
code_printing constant Ref.lookup \<rightharpoonup> (OCaml) "(fun/ ()/ ->/ !/ _)"
code_printing constant Ref.update \<rightharpoonup> (OCaml) "(fun/ ()/ ->/ _/ :=/ _)"
code_printing constant "HOL.equal :: 'a ref \<Rightarrow> 'a ref \<Rightarrow> bool" \<rightharpoonup> (OCaml) infixl 4 "="

code_reserved OCaml ref

text \<open>Haskell\<close>

code_printing type_constructor ref \<rightharpoonup> (Haskell) "Heap.STRef/ Heap.RealWorld/ _"
code_printing constant Ref \<rightharpoonup> (Haskell) "error/ \"bare Ref\""
code_printing constant ref' \<rightharpoonup> (Haskell) "Heap.newSTRef"
code_printing constant Ref.lookup \<rightharpoonup> (Haskell) "Heap.readSTRef"
code_printing constant Ref.update \<rightharpoonup> (Haskell) "Heap.writeSTRef"
code_printing constant "HOL.equal :: 'a ref \<Rightarrow> 'a ref \<Rightarrow> bool" \<rightharpoonup> (Haskell) infix 4 "=="
code_printing class_instance ref :: HOL.equal \<rightharpoonup> (Haskell) -

text \<open>Scala\<close>

code_printing type_constructor ref \<rightharpoonup> (Scala) "!Ref[_]"
code_printing constant Ref \<rightharpoonup> (Scala) "!sys.error(\"bare Ref\")"
code_printing constant ref' \<rightharpoonup> (Scala) "('_: Unit)/ =>/ Ref((_))"
code_printing constant Ref.lookup \<rightharpoonup> (Scala) "('_: Unit)/ =>/ Ref.lookup((_))"
code_printing constant Ref.update \<rightharpoonup> (Scala) "('_: Unit)/ =>/ Ref.update((_), (_))"
code_printing constant "HOL.equal :: 'a ref \<Rightarrow> 'a ref \<Rightarrow> bool" \<rightharpoonup> (Scala) infixl 5 "=="

end


theory DP_CPredS
  imports "./DP_CRelVS"
begin
locale dp_pred =
  fixes cmem :: "('param \<rightharpoonup> 'result) \<Rightarrow> bool"
begin
context
  includes lifting_syntax
begin

definition cpred_s :: "('a \<Rightarrow> bool) \<Rightarrow> ('param \<rightharpoonup> 'result, 'a) state \<Rightarrow> bool" where
  "cpred_s P s \<equiv> \<forall>M. cmem M \<longrightarrow> (case runState s M of (v', M') \<Rightarrow> P v' \<and> cmem M')"

lemma cpred_s_def_alt: "cpred_s P s = pred_fun cmem (pred_prod P cmem) (runState s)"
  unfolding cpred_s_def by (fastforce split: pred_prod_split)
term 0(**)

notation pred_fun (infixr "...>" 55)

abbreviation pred_fun_lifted :: "('a \<Rightarrow> bool) \<Rightarrow> ('b \<Rightarrow> bool) \<Rightarrow> ('a ==_\<Longrightarrow> 'b) \<Rightarrow> bool" (infixr "...>\<^sub>T" 55) where
  "A ...>\<^sub>T B \<equiv> A ...> cpred_s B"

lemma cpred_s_intro:
  assumes "\<And>M v' M'. \<lbrakk>cmem M; runState v\<^sub>T M = (v', M')\<rbrakk> \<Longrightarrow> P v' \<and> cmem M'"
  shows "cpred_s P v\<^sub>T"
  unfolding cpred_s_def using assms by blast

lemma cpred_s_elim:
  assumes "cpred_s P v\<^sub>T" "cmem M"
  obtains v' M' where "runState v\<^sub>T M = (v', M')" "P v'" "cmem M'"
  using assms unfolding cpred_s_def by blast
term 0 (**)

lemma cpred_s_return:
  "P v \<Longrightarrow> cpred_s P \<langle>v\<rangle>"
  unfolding return_def by (fastforce intro: cpred_s_intro)

lemma return_transferP:
  "(P ...> cpred_s P) return"
  unfolding pred_fun_def by (metis cpred_s_return)

lemma bind_transferP:
  "(cpred_s P0 ...> (P0 ...>\<^sub>T P1) ...> cpred_s P1) (op \<bind>)"
  unfolding bind_def pred_fun_def by (fastforce intro: cpred_s_intro elim: cpred_s_elim split: prod.split)

lemma fun_app_lifted_transferP:
  "(cpred_s (R0 ...>\<^sub>T R1) ...> cpred_s P0 ...> cpred_s P1) (op .)"
  unfolding fun_app_lifted_def
  oops
end
end

end


theory Impl_List_Playground_ChairNetwork_statefulpolicy_example
imports "../TopoS_Impl"
begin

text{*An example of our chair network [simplified]*}

text{*Our access control view on the network*}
  definition ChairNetwork_empty :: "string list_graph" where
    "ChairNetwork_empty \<equiv> \<lparr> nodesL = [''WebSrv'', ''FilesSrv'', ''Printer'',
                                ''Students'',
                                ''Employees'',
                                ''Internet''],
                      edgesL = [] \<rparr>"

  lemma "wf_list_graph ChairNetwork_empty" by eval

subsection{*Our security requirements*}
  subsubsection{*We have a server with confidential data*}
    definition ConfidentialChairData::"(string SecurityInvariant)" where
      "ConfidentialChairData \<equiv> new_configured_list_SecurityInvariant SINVAR_BLPtrusted_impl.SINVAR_LIB_BLPtrusted \<lparr>
          node_properties = [''FilesSrv'' \<mapsto> \<lparr> security_level = 1, trusted = False \<rparr>,
                             ''Employees'' \<mapsto> \<lparr> security_level = 0, trusted = True \<rparr>]
          \<rparr> ''confidential data''"

  subsubsection{* accessibly by employees and students*}
    definition "PrintingACL \<equiv> new_configured_list_SecurityInvariant SINVAR_LIB_CommunicationPartners \<lparr>
          node_properties = [''Printer'' \<mapsto> Master [''Employees'', ''Students''],
                             ''Employees'' \<mapsto> Care,
                             ''Students'' \<mapsto> Care]
          \<rparr> ''printing acl''"

  subsubsection{* Printers are information sinks *}
    definition "PrintingSink \<equiv> new_configured_list_SecurityInvariant SINVAR_LIB_Sink \<lparr>
          node_properties = [''Printer'' \<mapsto> Sink]
          \<rparr> ''printing sink''"

  subsubsection{*Students and Employees may access each other but are not accessible from the outside*}
    definition "InternalSubnet \<equiv> new_configured_list_SecurityInvariant SINVAR_LIB_SubnetsInGW \<lparr>
          node_properties = [''Students'' \<mapsto> Member, ''Employees'' \<mapsto> Member]
          \<rparr> ''internal subnet''"

  subsubsection{* The files server is only accessibly by employees*}
    definition "FilesSrvACL \<equiv> new_configured_list_SecurityInvariant SINVAR_LIB_CommunicationPartners \<lparr>
          node_properties = [''FilesSrv'' \<mapsto> Master [''Employees''],
                             ''Employees'' \<mapsto> Care]
          \<rparr> ''file srv acl''"

definition "ChairSecurityRequirements = [ConfidentialChairData, PrintingACL, PrintingSink, InternalSubnet, FilesSrvACL]"

lemma "\<forall>m \<in> set ChairSecurityRequirements. implc_sinvar m ChairNetwork_empty" by eval

value "implc_get_offending_flows ChairSecurityRequirements ChairNetwork_empty"
value "generate_valid_topology ChairSecurityRequirements ChairNetwork_empty"

value "List.product (nodesL ChairNetwork_empty) (nodesL ChairNetwork_empty)"

definition "ChairNetwork = generate_valid_topology ChairSecurityRequirements
      \<lparr>nodesL = nodesL ChairNetwork_empty, edgesL = List.product (nodesL ChairNetwork_empty) (nodesL ChairNetwork_empty) \<rparr>"

value "ChairNetwork"

ML{*
visualize_graph @{context} @{term "ChairSecurityRequirements"} @{term "ChairNetwork"};
*}

definition "ChairNetwork_stateful_IFS = \<lparr> hostsL = nodesL ChairNetwork, flows_fixL = edgesL ChairNetwork, flows_stateL = filter_IFS_no_violations ChairNetwork ChairSecurityRequirements \<rparr>"
value "edgesL ChairNetwork"
value "filter_IFS_no_violations ChairNetwork ChairSecurityRequirements"
value "ChairNetwork_stateful_IFS"
lemma "set (flows_stateL ChairNetwork_stateful_IFS) \<subseteq> (set (flows_fixL ChairNetwork_stateful_IFS))" by eval (*must always hold*)
value "(set (flows_fixL ChairNetwork_stateful_IFS)) - set (flows_stateL ChairNetwork_stateful_IFS)"
(*only problems: printers!!!*)
value "stateful_list_policy_to_list_graph ChairNetwork_stateful_IFS"
lemma "set (filter_IFS_no_violations ChairNetwork [ConfidentialChairData]) = set (edgesL ChairNetwork)" by eval

definition "ChairNetwork_stateful_ACS = \<lparr> hostsL = nodesL ChairNetwork, flows_fixL = edgesL ChairNetwork, flows_stateL = filter_compliant_stateful_ACS ChairNetwork ChairSecurityRequirements \<rparr>"
value "edgesL ChairNetwork"
value "filter_compliant_stateful_ACS ChairNetwork ChairSecurityRequirements"
value "ChairNetwork_stateful_ACS"
lemma "set (flows_stateL ChairNetwork_stateful_ACS) \<subseteq> (set (flows_fixL ChairNetwork_stateful_ACS))"
  by eval (*must always hold*)
value "(set (flows_fixL ChairNetwork_stateful_ACS)) - set (flows_stateL ChairNetwork_stateful_ACS)"

(*flows that are already allowed in both directions are not marked as stateful*)
value "((set (flows_fixL ChairNetwork_stateful_ACS)) - set (flows_stateL ChairNetwork_stateful_ACS)) - set (backlinks (flows_fixL ChairNetwork_stateful_ACS))"

(*the new backflows*)
value "set (edgesL (stateful_list_policy_to_list_graph ChairNetwork_stateful_ACS)) - (set (edgesL ChairNetwork))"

(*the resulting ACS graph*)
value "stateful_list_policy_to_list_graph ChairNetwork_stateful_ACS"

value "generate_valid_stateful_policy_IFSACS ChairNetwork ChairSecurityRequirements"
value "generate_valid_stateful_policy_IFSACS_2 ChairNetwork ChairSecurityRequirements"
lemma "set (flows_fixL (generate_valid_stateful_policy_IFSACS ChairNetwork ChairSecurityRequirements)) =
       set (flows_fixL (generate_valid_stateful_policy_IFSACS_2 ChairNetwork ChairSecurityRequirements))" by eval
lemma "set (flows_stateL (generate_valid_stateful_policy_IFSACS ChairNetwork ChairSecurityRequirements)) =
       set (flows_stateL (generate_valid_stateful_policy_IFSACS_2 ChairNetwork ChairSecurityRequirements))" by eval

definition "ChairNetwork_stateful = generate_valid_stateful_policy_IFSACS ChairNetwork ChairSecurityRequirements"

ML_val{*
visualize_edges @{context} @{term "flows_fixL ChairNetwork_stateful"}
    [("edge [dir=\"arrow\", style=dashed, color=\"#FF8822\", constraint=false]", @{term "flows_stateL ChairNetwork_stateful"})] "";
*}

(*these requirements impose no restrictoins on the stateful flows*)
definition "ChairNetwork_stateful_v2 = generate_valid_stateful_policy_IFSACS ChairNetwork
    [ConfidentialChairData, PrintingACL,  InternalSubnet, FilesSrvACL]"
ML_val{*
visualize_edges @{context} @{term "flows_fixL ChairNetwork_stateful_v2"}
    [("edge [dir=\"arrow\", style=dashed, color=\"#FF8822\", constraint=false]",
     @{term "flows_stateL ChairNetwork_stateful_v2"})] "";
*}

(*The sink requirements imposes the restriction that the printer cannot answer*)
definition "ChairNetwork_stateful_v3 = generate_valid_stateful_policy_IFSACS ChairNetwork [PrintingSink]"
ML_val{*
visualize_edges @{context} @{term "flows_fixL ChairNetwork_stateful_v3"}
    [("edge [dir=\"arrow\", style=dashed, color=\"#FF8822\", constraint=false]", @{term "flows_stateL ChairNetwork_stateful_v3"})] "";
*}

subsection{*An example of bad side-effects in access control policies*}

  definition ACL_not_with::"(string SecurityInvariant)" where
    "ACL_not_with \<equiv> new_configured_list_SecurityInvariant SINVAR_ACLnotCommunicateWith_impl.SINVAR_LIB_ACLnotCommunicateWith \<lparr>
        node_properties = [''A'' \<mapsto> {''C''},
                           ''B'' \<mapsto> {},
                           ''C'' \<mapsto> {}]
        \<rparr> ''example: a must not reach C''"

  definition simple_network :: "string list_graph" where
    "simple_network \<equiv> \<lparr> nodesL = [''A'', ''B'', ''C''],
                      edgesL = [(''B'', ''A''), (''B'', ''C'')] \<rparr>"

  lemma "wf_list_graph ChairNetwork_empty" by eval
  lemma "\<forall>m \<in> set [ACL_not_with]. implc_sinvar m simple_network" by eval

  lemma "implc_get_offending_flows [ACL_not_with] simple_network = []" by eval
  lemma "implc_get_offending_flows [ACL_not_with]
    \<lparr> nodesL = [''A'', ''B'', ''C''], edgesL = [(''B'', ''A''), (''B'', ''C''), (''A'', ''B'')] \<rparr> =
      [[(''B'', ''C'')], [(''A'', ''B'')]]" by eval
  lemma "implc_get_offending_flows [ACL_not_with]
    \<lparr> nodesL = [''A'', ''B'', ''C''], edgesL = [(''B'', ''A''), (''B'', ''C''), (''C'', ''B'')] \<rparr> =
      []" by eval

value "generate_valid_stateful_policy_IFSACS simple_network [ACL_not_with]"
value "generate_valid_stateful_policy_IFSACS_2 simple_network [ACL_not_with]"

subsection{*performance test*}
(*6 minutes , about 1.8k edges in graph, most of the times, no requirements apply,
  simply added some nodes, edges to the chair network. topology is valid*)
(*value "generate_valid_stateful_policy_IFSACS biggraph ChairSecurityRequirements"*)

end


theory Smallstep
imports Events Globalenvs Integers
begin

(** Tools for small-step operational semantics *)

(** This module defines generic operations and theorems over
  the one-step transition relations that are used to specify
  operational semantics in small-step style. *)

locale smallstep =
  fixes step :: "'s \<Rightarrow> trace \<Rightarrow> 's \<Rightarrow> bool"
begin

inductive star :: "'s \<Rightarrow> trace \<Rightarrow> 's \<Rightarrow> bool" where
  star_refl: "star s E0 s"
| star_step: "step s1 t1 s2 \<Longrightarrow> star s2 t2 s3 \<Longrightarrow> t = List.append t1 t2 \<Longrightarrow>
      star s1 t s3"

lemma star_one: "step s1 t s2 \<Longrightarrow> star s1 t s2"
  by (metis (full_types) append_Nil2 star.simps)

lemma star_trans: "star s1 t1 s2 \<Longrightarrow> star s2 t2 s3 \<Longrightarrow> star s1 (List.append t1 t2) s3"
  apply (induction rule: star.induct)
  apply simp
  by (simp add: smallstep.star_step)+

lemma star_trans2: "star s1 t1 s2 \<Longrightarrow> star s2 t2 s3 \<Longrightarrow> star s3 t3 s4 \<Longrightarrow> star s1 (t1 @ t2 @ t3) s4"
  by (simp add: star_trans)

lemma star_destruct:
  assumes "star s1 t s2"
  shows "s1 \<noteq> s2 \<Longrightarrow> \<exists> s1' t1 t2. (step s1 t1 s1' \<and> star s1' t2 s2 \<and> t = t1 @ t2)"
  by (metis assms star.cases)

end

(* more lemmas for our deterministic case; CompCert doesn't have this *)
locale smallstep_determ = smallstep step
  for step :: "'s \<Rightarrow> trace \<Rightarrow> 's \<Rightarrow> bool" +
  assumes determ: "step s t1 s1' \<Longrightarrow> step s t2 s2' \<Longrightarrow> (t1 = t2 \<and> s1' = s2')"
begin

(* if there's a step from s1 to s2 and s3 \<noteq> s1,
  then reaching s3 from s1 is equivalent to reaching s3 from s2 *)
lemma star_step_subst:
  assumes "step s1 t1 s2"
  shows "s1 \<noteq> s3 \<Longrightarrow> t = List.append t1 t2 \<Longrightarrow>
      star s1 t s3 = star s2 t2 s3"
  apply standard
   apply (metis assms determ same_append_eq star_destruct)
  using assms star_step by auto
end

end


(*  Title:      Jinja/J/SmallProgress.thy

    Author:     Tobias Nipkow
    Copyright   2003 Technische Universitaet Muenchen
*)

section \<open>Progress of Small Step Semantics\<close>

theory Progress
imports Equivalence WellTypeRT DefAss "../Common/Conform"
begin

lemma final_addrE:
  "\<lbrakk> P,E,h \<turnstile> e : Class C; final e;
    \<And>a. e = addr a \<Longrightarrow> R;
    \<And>a. e = Throw a \<Longrightarrow> R \<rbrakk> \<Longrightarrow> R"
(*<*)by(auto simp:final_def)(*>*)

lemma finalRefE:
 "\<lbrakk> P,E,h \<turnstile> e : T; is_refT T; final e;
   e = null \<Longrightarrow> R;
   \<And>a C. \<lbrakk> e = addr a; T = Class C \<rbrakk> \<Longrightarrow> R;
   \<And>a. e = Throw a \<Longrightarrow> R \<rbrakk> \<Longrightarrow> R"
(*<*)by(auto simp:final_def is_refT_def)(*>*)

text\<open>Derivation of new induction scheme for well typing:\<close>

inductive
  WTrt' :: "[J_prog,heap,env,expr,ty] \<Rightarrow> bool"
  and WTrts' :: "[J_prog,heap,env,expr list, ty list] \<Rightarrow> bool"
  and WTrt2' :: "[J_prog,env,heap,expr,ty] \<Rightarrow> bool"
        ("_,_,_ \<turnstile> _ :'' _"   [51,51,51]50)
  and WTrts2' :: "[J_prog,env,heap,expr list, ty list] \<Rightarrow> bool"
        ("_,_,_ \<turnstile> _ [:''] _" [51,51,51]50)
  for P :: J_prog and h :: heap
where
  "P,E,h \<turnstile> e :' T \<equiv> WTrt' P h E e T"
| "P,E,h \<turnstile> es [:'] Ts \<equiv> WTrts' P h E es Ts"

| "is_class P C  \<Longrightarrow>  P,E,h \<turnstile> new C :' Class C"
| "\<lbrakk> P,E,h \<turnstile> e :' T; is_refT T; is_class P C \<rbrakk>
  \<Longrightarrow> P,E,h \<turnstile> Cast C e :' Class C"
| "typeof\<^bsub>h\<^esub> v = Some T \<Longrightarrow> P,E,h \<turnstile> Val v :' T"
| "E v = Some T  \<Longrightarrow>  P,E,h \<turnstile> Var v :' T"
| "\<lbrakk> P,E,h \<turnstile> e\<^sub>1 :' T\<^sub>1;  P,E,h \<turnstile> e\<^sub>2 :' T\<^sub>2 \<rbrakk>
  \<Longrightarrow> P,E,h \<turnstile> e\<^sub>1 \<guillemotleft>Eq\<guillemotright> e\<^sub>2 :' Boolean"
| "\<lbrakk> P,E,h \<turnstile> e\<^sub>1 :' Integer;  P,E,h \<turnstile> e\<^sub>2 :' Integer \<rbrakk>
  \<Longrightarrow> P,E,h \<turnstile> e\<^sub>1 \<guillemotleft>Add\<guillemotright> e\<^sub>2 :' Integer"
| "\<lbrakk> P,E,h \<turnstile> Var V :' T;  P,E,h \<turnstile> e :' T';  P \<turnstile> T' \<le> T \<^cancel>\<open>V \<noteq> This\<close> \<rbrakk>
  \<Longrightarrow> P,E,h \<turnstile> V:=e :' Void"
| "\<lbrakk> P,E,h \<turnstile> e :' Class C; P \<turnstile> C has F:T in D \<rbrakk> \<Longrightarrow> P,E,h \<turnstile> e\<bullet>F{D} :' T"
| "P,E,h \<turnstile> e :' NT \<Longrightarrow> P,E,h \<turnstile> e\<bullet>F{D} :' T"
| "\<lbrakk> P,E,h \<turnstile> e\<^sub>1 :' Class C;  P \<turnstile> C has F:T in D;
    P,E,h \<turnstile> e\<^sub>2 :' T\<^sub>2;  P \<turnstile> T\<^sub>2 \<le> T \<rbrakk>
  \<Longrightarrow> P,E,h \<turnstile> e\<^sub>1\<bullet>F{D}:=e\<^sub>2 :' Void"
| "\<lbrakk> P,E,h \<turnstile> e\<^sub>1:'NT; P,E,h \<turnstile> e\<^sub>2 :' T\<^sub>2 \<rbrakk> \<Longrightarrow> P,E,h \<turnstile> e\<^sub>1\<bullet>F{D}:=e\<^sub>2 :' Void"
| "\<lbrakk> P,E,h \<turnstile> e :' Class C; P \<turnstile> C sees M:Ts \<rightarrow> T = (pns,body) in D;
    P,E,h \<turnstile> es [:'] Ts'; P \<turnstile> Ts' [\<le>] Ts \<rbrakk>
  \<Longrightarrow> P,E,h \<turnstile> e\<bullet>M(es) :' T"
| "\<lbrakk> P,E,h \<turnstile> e :' NT; P,E,h \<turnstile> es [:'] Ts \<rbrakk> \<Longrightarrow> P,E,h \<turnstile> e\<bullet>M(es) :' T"
| "P,E,h \<turnstile> [] [:'] []"
| "\<lbrakk> P,E,h \<turnstile> e :' T;  P,E,h \<turnstile> es [:'] Ts \<rbrakk> \<Longrightarrow>  P,E,h \<turnstile> e#es [:'] T#Ts"
| "\<lbrakk> typeof\<^bsub>h\<^esub> v = Some T\<^sub>1; P \<turnstile> T\<^sub>1 \<le> T; P,E(V\<mapsto>T),h \<turnstile> e\<^sub>2 :' T\<^sub>2 \<rbrakk>
  \<Longrightarrow>  P,E,h \<turnstile> {V:T := Val v; e\<^sub>2} :' T\<^sub>2"
| "\<lbrakk> P,E(V\<mapsto>T),h \<turnstile> e :' T'; \<not> assigned V e \<rbrakk> \<Longrightarrow>  P,E,h \<turnstile> {V:T; e} :' T'"
| "\<lbrakk> P,E,h \<turnstile> e\<^sub>1:' T\<^sub>1;  P,E,h \<turnstile> e\<^sub>2:'T\<^sub>2 \<rbrakk>  \<Longrightarrow>  P,E,h \<turnstile> e\<^sub>1;;e\<^sub>2 :' T\<^sub>2"
| "\<lbrakk> P,E,h \<turnstile> e :' Boolean;  P,E,h \<turnstile> e\<^sub>1:' T\<^sub>1;  P,E,h \<turnstile> e\<^sub>2:' T\<^sub>2;
    P \<turnstile> T\<^sub>1 \<le> T\<^sub>2 \<or> P \<turnstile> T\<^sub>2 \<le> T\<^sub>1;
    P \<turnstile> T\<^sub>1 \<le> T\<^sub>2 \<longrightarrow> T = T\<^sub>2; P \<turnstile> T\<^sub>2 \<le> T\<^sub>1 \<longrightarrow> T = T\<^sub>1 \<rbrakk>
  \<Longrightarrow> P,E,h \<turnstile> if (e) e\<^sub>1 else e\<^sub>2 :' T"
(*
 "\<lbrakk> P,E,h \<turnstile> e :' Boolean;  P,E,h \<turnstile> e\<^sub>1:' T\<^sub>1;  P,E,h \<turnstile> e\<^sub>2:' T\<^sub>2; P \<turnstile> T\<^sub>1 \<le> T\<^sub>2 \<rbrakk>
  \<Longrightarrow> P,E,h \<turnstile> if (e) e\<^sub>1 else e\<^sub>2 :' T\<^sub>2"
 "\<lbrakk> P,E,h \<turnstile> e :' Boolean;  P,E,h \<turnstile> e\<^sub>1:' T\<^sub>1;  P,E,h \<turnstile> e\<^sub>2:' T\<^sub>2; P \<turnstile> T\<^sub>2 \<le> T\<^sub>1 \<rbrakk>
  \<Longrightarrow> P,E,h \<turnstile> if (e) e\<^sub>1 else e\<^sub>2 :' T\<^sub>1"
*)
| "\<lbrakk> P,E,h \<turnstile> e :' Boolean;  P,E,h \<turnstile> c:' T \<rbrakk>
  \<Longrightarrow>  P,E,h \<turnstile> while(e) c :' Void"
| "\<lbrakk> P,E,h \<turnstile> e :' T\<^sub>r; is_refT T\<^sub>r \<rbrakk>  \<Longrightarrow>  P,E,h \<turnstile> throw e :' T"
| "\<lbrakk> P,E,h \<turnstile> e\<^sub>1 :' T\<^sub>1;  P,E(V \<mapsto> Class C),h \<turnstile> e\<^sub>2 :' T\<^sub>2; P \<turnstile> T\<^sub>1 \<le> T\<^sub>2 \<rbrakk>
  \<Longrightarrow> P,E,h \<turnstile> try e\<^sub>1 catch(C V) e\<^sub>2 :' T\<^sub>2"

(*<*)
lemmas WTrt'_induct = WTrt'_WTrts'.induct [split_format (complete)]
  and WTrt'_inducts = WTrt'_WTrts'.inducts [split_format (complete)]

inductive_cases WTrt'_elim_cases[elim!]:
  "P,E,h \<turnstile> V :=e :' T"
(*>*)

lemma [iff]: "P,E,h \<turnstile> Val v :' T = (typeof\<^bsub>h\<^esub> v = Some T)"
(*<*)
apply(rule iffI)
apply (auto elim: WTrt'.cases intro!:WTrt'_WTrts'.intros)
done
(*>*)

lemma [iff]: "P,E,h \<turnstile> Var v :' T = (E v = Some T)"
(*<*)
apply(rule iffI)
apply (auto elim: WTrt'.cases intro!:WTrt'_WTrts'.intros)
done
(*>*)

lemma wt_wt': "P,E,h \<turnstile> e : T \<Longrightarrow> P,E,h \<turnstile> e :' T"
and wts_wts': "P,E,h \<turnstile> es [:] Ts \<Longrightarrow> P,E,h \<turnstile> es [:'] Ts"
(*<*)
apply (induct rule:WTrt_inducts)
prefer 14
apply(case_tac "assigned V e")
apply(clarsimp simp add:fun_upd_same assigned_def simp del:fun_upd_apply)
apply(erule (2) WTrt'_WTrts'.intros)
apply(erule (1) WTrt'_WTrts'.intros)
apply(blast intro:WTrt'_WTrts'.intros)+
done
(*>*)

lemma wt'_wt: "P,E,h \<turnstile> e :' T \<Longrightarrow> P,E,h \<turnstile> e : T"
and wts'_wts: "P,E,h \<turnstile> es [:'] Ts \<Longrightarrow> P,E,h \<turnstile> es [:] Ts"
(*<*)
apply (induct rule:WTrt'_inducts)
prefer 16
apply(rule WTrt_WTrts.intros)
apply(rule WTrt_WTrts.intros)
apply(rule WTrt_WTrts.intros)
apply simp
apply(erule (2) WTrt_WTrts.intros)
apply(blast intro:WTrt_WTrts.intros)+
done
(*>*)

corollary wt'_iff_wt: "(P,E,h \<turnstile> e :' T) = (P,E,h \<turnstile> e : T)"
(*<*)by(blast intro:wt_wt' wt'_wt)(*>*)

corollary wts'_iff_wts: "(P,E,h \<turnstile> es [:'] Ts) = (P,E,h \<turnstile> es [:] Ts)"
(*<*)by(blast intro:wts_wts' wts'_wts)(*>*)

(*<*)
lemmas WTrt_inducts2 = WTrt'_inducts [unfolded wt'_iff_wt wts'_iff_wts,
 case_names WTrtNew WTrtCast WTrtVal WTrtVar WTrtBinOpEq WTrtBinOpAdd WTrtLAss WTrtFAcc WTrtFAccNT WTrtFAss
 WTrtFAssNT WTrtCall WTrtCallNT WTrtNil WTrtCons WTrtInitBlock WTrtBlock WTrtSeq WTrtCond
 WTrtWhile WTrtThrow WTrtTry, consumes 1]
(*>*)

end