(*File: Sound.thy
  Author: L Beringer & M Hofmann, LMU Munich
  Date: 05/12/2008
  Purpose: Interpretation of judgements, and soundness proof,
           of the program logic with  invariants, pre-
           and post-conditions, and local assertions, but no
           exploitation of sucessful bytecode verification.
*)
(*<*)
theory Sound imports Logic MultiStep Reachability begin
(*>*)

(*<*)
lemma MaxZero[rule_format]: "max n k = (0::nat) \<Longrightarrow> n=0 \<and> k=0"
by (simp add: max_def, case_tac "n\<le>k", clarsimp,clarsimp)
(*>*)

section\<open>Soundness\<close>
text\<open>This section contains the soundness proof of the program logic.
In the first subsection, we define our notion of validity, thus
formalising our intuitive explanation of the terms preconditions,
specifications, and invariants. The following two subsections contain
the details of the proof and can easily be skipped during a first pass
through the document.\<close>

subsection\<open>Validity\<close>

text\<open>A  judgement is valid at the program point \<open>C.m.l\<close>
(i.e.~at label \<open>l\<close> in method \<open>m\<close> of class \<open>C\<close>),
written $\mathit{valid}\; C\; m\; l\; A\; B\; I$ or, in symbols, $$\vDash\,
\lbrace A \rbrace\, C,m,l\, \lbrace B \rbrace\, I,$$ if $A$ is a
precondition for $B$ and for all local annotations following $l$ in an
execution of \<open>m\<close>, and all reachable states in the current frame
or yet-to-be created subframes satisfy $I$. More precisely,
whenever an execution of the method starting in an initial state $s_0$
reaches the label \<open>l\<close> with state \<open>s\<close>, the following
properties are implied by $A(s_0,s)$.
\begin{enumerate}

  \item If the continued execution from \<open>s\<close> reaches a final
  state \<open>t\<close> (i.e.~the method terminates), then that final state
  \<open>t\<close> satisfies $B(s_0,s,t)$.

  \item Any state $s'$ visited in the current frame during the remaining
  program execution whose label carries an annotation \<open>Q\<close> will
  satisfy $Q(s_0,s')$, even if the execution of the frame does not
  terminate.

  \item Any state $s'$ visited in the current frame or a subframe of
  the current frame will satisfy $I(s_0,s,\mathit{heap}(s'))$, again even if the
  execution does not terminate.

\end{enumerate}

Formally, this interpretation is expressed as follows.
\<close>

definition valid::"Class \<Rightarrow> Method \<Rightarrow> Label \<Rightarrow> Assn \<Rightarrow> Post \<Rightarrow> Inv \<Rightarrow> bool" where
"valid C m l A B I =
   (\<forall> M. mbody_is C m M \<longrightarrow>
   (\<forall> Mspec Minv Anno . MST\<down>(C,m) = Some(Mspec,Minv,Anno) \<longrightarrow>
   (\<forall> par code l0 . M = (par,code,l0) \<longrightarrow>
   (\<forall> s0 s . MS M l0 (mkState s0) l s \<longrightarrow> A s0 s \<longrightarrow>
    ((\<forall> h v. Opsem M l s h v \<longrightarrow> B s0 s (h,v)) \<and>
     (\<forall> ll r . (MS M l s ll r  \<longrightarrow> (\<forall> Q . Anno\<down>(ll) = Some Q \<longrightarrow>  Q s0 r)) \<and>
               (Reach M l s r \<longrightarrow> I s0 s (heap r))))))))"

abbreviation valid_syntax :: "Assn \<Rightarrow> Class \<Rightarrow> Method \<Rightarrow>
                    Label \<Rightarrow> Post \<Rightarrow> Inv \<Rightarrow> bool"
       (" \<Turnstile> \<lbrace> _ \<rbrace> _ , _ , _ \<lbrace> _ \<rbrace> _" [200,200,200,200,200,200] 200)
where "valid_syntax A C m l B I == valid C m l A B I"

text\<open>This notion of validity extends that of Bannwart-M\"uller by
allowing the post-condition to differ from method specification and to
refer to the initial state, and by including invariants.  In
the logic of Bannwart and M\"uller, the validity of a method
specification is given by a partial correctness (Hoare-style)
interpretation, while the validity of  preconditions of
individual instructions is such that a precondition at $l$ implies the
preconditions of its immediate control flow successors.\<close>

text\<open>Validity us lifted to contexts and the method specification
table. In the case of the former, we simply require that all entries
be valid.\<close>

definition G_valid::"CTXT \<Rightarrow> bool" where
"G_valid G = (\<forall> C m l A B I. G\<down>(C,m,l) = Some (A,B,I)\<longrightarrow>
                                \<Turnstile> \<lbrace>A\<rbrace> C, m, l \<lbrace>B\<rbrace> I)"

text\<open>Regarding the specification table, we require that the initial
label of each method satisfies an assertion that ties the method
precondition to the current state.\<close>

definition MST_valid ::bool where
"MST_valid = (\<forall> C m par code l0 T MI Anno.
  mbody_is C m (par,code,l0) \<longrightarrow> MST\<down>(C, m) = Some (T,MI,Anno) \<longrightarrow>
  \<Turnstile> \<lbrace>(\<lambda> s0 s. s = mkState s0)\<rbrace> C, m, l0 \<lbrace>(mkPost T)\<rbrace> (mkInv MI))"

definition Prog_valid::bool where
"Prog_valid = (\<exists> G . G_valid G \<and> MST_valid)"

text\<open>The remainder of this section contains a proof of soundness,
i.e.~of the property $$\<open>VP\<close> \Longrightarrow \<open>Prog_valid\<close>,$$ and is structured into two parts. The first step
(Section \ref{SoundnessUnderValidContexts}) establishes a soundness
result where the \<open>VP\<close> property is replaced by validity
assumptions regarding the method specification table and the
context. In the second step (Section \ref{SectionContextElimination}),
we show that these validity assumptions are satisfied by verified
programs, which implies the overall soundness theorem.\<close>

subsection\<open>Soundness under valid contexts
\label{SoundnessUnderValidContexts}\<close>

text\<open>The soundness proof proceeds by induction on the axiomatic
semantics, based on an auxiliary lemma for method invocations that is
proven by induction on the derivation height of the operational
semantics. For the latter induction, relativised notions of validity
are employed that restrict the derivation height of the program
continuations affected by an assertion. The appropriate definitions of
relativised validity for judgements, for the precondition table, and
for the method specification table are as follows.\<close>

definition validn::
  "nat \<Rightarrow> Class \<Rightarrow> Method \<Rightarrow> Label \<Rightarrow> Assn \<Rightarrow> Post \<Rightarrow> Inv \<Rightarrow> bool" where
"validn K C m l A B I =
   (\<forall> M. mbody_is C m M \<longrightarrow>
   (\<forall> Mspec Minv Anno . MST\<down>(C,m) = Some(Mspec,Minv,Anno) \<longrightarrow>
   (\<forall> par code l0 . M = (par,code,l0) \<longrightarrow>
   (\<forall> s0 s . MS M l0 (mkState s0) l s \<longrightarrow> A s0 s \<longrightarrow>
   (\<forall> k . k \<le> K \<longrightarrow>
    ((\<forall> h v. (M,l,s,k,h,v):Exec \<longrightarrow> B s0 s (h,v)) \<and>
     (\<forall> ll r . ((M,l,s,k,ll,r):MStep  \<longrightarrow>
                 (\<forall> Q . Anno\<down>(ll) = Some Q \<longrightarrow>  Q s0 r)) \<and>
               ((M,l,s,k,r):Reachable \<longrightarrow> I s0 s (heap r)))))))))"

abbreviation validn_syntax :: "nat \<Rightarrow> Assn \<Rightarrow> Class \<Rightarrow> Method \<Rightarrow>
                     Label \<Rightarrow> Post \<Rightarrow> Inv \<Rightarrow> bool"
("\<Turnstile>\<^sub>_ \<lbrace> _ \<rbrace> _ , _ , _ \<lbrace> _ \<rbrace> _ " [200,200,200,200,200,200,200] 200)
where "validn_syntax K A C m l B I == validn K C m l A B I"

definition G_validn::"nat \<Rightarrow> CTXT \<Rightarrow> bool" where
"G_validn K G = (\<forall> C m l A B I. G\<down>(C,m,l) = Some (A,B,I) \<longrightarrow>
                                \<Turnstile>\<^sub>K \<lbrace>A\<rbrace> C, m, l \<lbrace>B\<rbrace> I)"

definition MST_validn::"nat \<Rightarrow> bool" where
"MST_validn K = (\<forall> C m par code l0 T MI Anno.
   mbody_is C m (par,code,l0) \<longrightarrow> MST\<down>(C, m) = Some (T,MI,Anno) \<longrightarrow>
   \<Turnstile>\<^sub>K \<lbrace>(\<lambda> s0 s. s = mkState s0)\<rbrace> C, m, l0 \<lbrace>(mkPost T)\<rbrace> (mkInv MI))"

definition Prog_validn::"nat \<Rightarrow> bool" where
"Prog_validn K = (\<exists> G . G_validn K G \<and> MST_validn K)"

text\<open>The relativised notions are related to each other, and to the
native notions of validity as follows.\<close>

lemma valid_validn: "\<Turnstile> \<lbrace>A\<rbrace> C, m, l \<lbrace>B\<rbrace> I \<Longrightarrow> \<Turnstile>\<^sub>K \<lbrace>A\<rbrace> C, m, l \<lbrace>B\<rbrace> I"
(*<*)
apply (simp add: valid_def validn_def Opsem_def MS_def Reach_def)
apply clarsimp
apply (erule_tac x=a in allE)
apply (erule_tac x=aa in allE)
apply (erule_tac x=b in allE, clarsimp)
apply (erule_tac x=ab in allE)
apply (erule_tac x=ba in allE)
apply (erule_tac x=ac in allE)
apply (erule_tac x=ad in allE)
apply (erule_tac x=bb in allE, erule impE) apply fast
apply fastforce
done
(*>*)

lemma validn_valid: "\<lbrakk>\<forall> K . \<Turnstile>\<^sub>K \<lbrace>A\<rbrace> C, m, l \<lbrace>B\<rbrace> I\<rbrakk> \<Longrightarrow> \<Turnstile> \<lbrace>A\<rbrace> C, m, l \<lbrace>B\<rbrace> I"
(*<*)
apply (unfold valid_def validn_def)(*apply ( Opsem_def MS_def Reach_def)*)
apply (rule, rule, rule)
apply (rule, rule, rule)
apply (rule, rule, rule)
apply (rule, rule, rule)
apply (rule, rule)
apply (rule,rule,rule, rule)
    apply (unfold Opsem_def, erule exE)
    apply (erule_tac x=n in allE)
    apply (erule_tac x=M in allE, erule impE, assumption)
    apply (erule_tac x=Mspec in allE, erule_tac x=Minv in allE, erule_tac x=Anno in allE, erule impE, assumption)
    apply (erule_tac x=par in allE, erule_tac x=code in allE)
    apply (erule_tac x=l0 in allE, erule impE, assumption)
    apply (erule_tac x=s0 in allE, erule_tac x=s in allE)
    apply (erule impE, assumption)
    apply (erule impE, assumption)
    apply (erule_tac x=n in allE, erule impE, simp)
    apply fast
apply (rule, rule, rule)
apply (rule, rule, rule)
    apply (unfold MS_def, erule exE, erule exE)
    apply (erule_tac x=ka in allE)
    apply (erule_tac x=M in allE, erule impE, assumption)
    apply (erule_tac x=Mspec in allE, erule_tac x=Minv in allE, erule_tac x=Anno in allE, erule impE, assumption)
    apply (erule_tac x=par in allE, erule_tac x=code in allE)
    apply (erule_tac x=l0 in allE, erule impE, assumption)
    apply (erule_tac x=s0 in allE, erule_tac x=s in allE)
    apply (erule impE, fast)
    apply (erule impE, assumption)
    apply (erule_tac x=ka in allE, erule impE, simp)
    apply fast
apply rule
    apply (unfold Reach_def, erule exE, erule exE)
    apply (erule_tac x=ka in allE)
    apply (erule_tac x=M in allE, erule impE, assumption)
    apply (erule_tac x=Mspec in allE, erule_tac x=Minv in allE, erule_tac x=Anno in allE, erule impE, assumption)
    apply (erule_tac x=par in allE, erule_tac x=code in allE)
    apply (erule_tac x=l0 in allE, erule impE, assumption)
    apply (erule_tac x=s0 in allE, erule_tac x=s in allE)
    apply (erule impE, fast)
    apply (erule impE, assumption)
    apply (erule_tac x=ka in allE, erule impE, simp)
    apply fast
done
(*>*)

lemma validn_lower:
 "\<lbrakk>\<Turnstile>\<^sub>K \<lbrace>A\<rbrace> C, m, l \<lbrace>B\<rbrace> I; L \<le> K\<rbrakk> \<Longrightarrow> \<Turnstile>\<^sub>L \<lbrace>A\<rbrace> C, m, l \<lbrace>B\<rbrace> I"
(*<*)
apply (unfold validn_def)
apply (rule, rule, rule)
apply (rule, rule, rule)
apply (rule, rule, rule)
apply (rule, rule, rule)
apply (rule, rule, rule)
apply rule
    apply (erule_tac x=M in allE, erule impE, assumption)
    apply (erule_tac x=Mspec in allE, erule_tac x=Minv in allE, erule_tac x=Anno in allE, erule impE, assumption)
    apply (erule_tac x=par in allE)
    apply (erule_tac x=code in allE)
    apply (erule_tac x=l0 in allE, erule impE, assumption)
    apply (erule_tac x=s0 in allE)
    apply (erule_tac x=s in allE, erule impE, assumption, erule impE, assumption)
    apply (erule_tac x=k in allE, erule impE, simp)
apply assumption
done
(*>*)

lemma G_valid_validn: "G_valid G \<Longrightarrow> G_validn K G"
(*<*)
apply (simp add: G_valid_def G_validn_def, clarsimp)
apply (rule valid_validn) apply fast
done
(*>*)

lemma G_validn_valid:"\<lbrakk>\<forall> K . G_validn K G\<rbrakk> \<Longrightarrow> G_valid G"
(*<*)
apply (simp add: G_valid_def G_validn_def, clarsimp)
apply (rule validn_valid) apply clarsimp
done
(*>*)

lemma G_validn_lower: "\<lbrakk>G_validn K G; L \<le> K\<rbrakk> \<Longrightarrow> G_validn L G"
(*<*)
apply (simp add: G_validn_def, clarsimp)
apply (rule validn_lower) apply fast apply assumption
done
(*>*)

lemma MST_validn_valid:"\<lbrakk>\<forall> K. MST_validn K\<rbrakk> \<Longrightarrow> MST_valid"
(*<*)
apply (simp add: MST_validn_def MST_valid_def, clarsimp)
apply (rule validn_valid, clarsimp)
done
(*>*)

lemma MST_valid_validn:"MST_valid \<Longrightarrow> MST_validn K"
(*<*)
apply (unfold MST_validn_def MST_valid_def)
apply (rule, rule, rule)
apply (rule, rule, rule)
apply (rule, rule, rule)
apply rule
apply (rule valid_validn)
apply fast
done
(*>*)

lemma MST_validn_lower: "\<lbrakk>MST_validn K; L \<le> K\<rbrakk> \<Longrightarrow> MST_validn L"
(*<*)
apply (simp add: MST_validn_def, clarsimp)
apply (erule_tac x=C in allE)
apply (erule_tac x=m in allE)
apply (erule_tac x=par in allE)
apply (erule_tac x=code in allE)
apply (erule_tac x=l0 in allE, erule impE, assumption)
apply (erule_tac x=T in allE)
apply (erule_tac x=MI in allE, clarsimp)
apply (erule validn_lower) apply assumption
done
(*>*)

text\<open>We define an abbreviation for the side conditions of the rule
for static method invocations\ldots\<close>

definition INVS_SC::
  "Class \<Rightarrow> Method \<Rightarrow> Label \<Rightarrow> Class \<Rightarrow> Method \<Rightarrow>  MethSpec \<Rightarrow> MethInv \<Rightarrow>
   ANNO \<Rightarrow> ANNO \<Rightarrow> Mbody \<Rightarrow> Assn \<Rightarrow> Inv \<Rightarrow> bool" where
"INVS_SC C m l D m' T MI Anno Anno2 M' A I = (\<exists> M par code l0 T1 MI1.
    mbody_is C m M \<and> get_ins M l = Some (invokeS D m') \<and>
    MST\<down>(C,m) = Some (T1,MI1,Anno) \<and>
    MST\<down>(D,m') = Some (T,MI,Anno2) \<and>
    mbody_is D m' M' \<and> M'=(par,code,l0) \<and>
    (\<forall> Q . Anno\<down>(l) = Some Q \<longrightarrow> (\<forall> s0 s . A s0 s \<longrightarrow> Q s0 s)) \<and>
    (\<forall> s0 s . A s0 s \<longrightarrow> I s0 s (heap s)) \<and>
    (\<forall> s0 ops1 ops2 S R h t . (ops1,par,R,ops2) : Frame \<longrightarrow>
          A s0 (ops1,S,h) \<longrightarrow> MI (R,h) t \<longrightarrow> I s0 (ops1,S,h) t))"

text\<open>\ldots and another abbreviation for the soundness property of
the same rule.\<close>

definition INVS_soundK::
  "nat \<Rightarrow> CTXT \<Rightarrow> Class \<Rightarrow> Method \<Rightarrow> Label \<Rightarrow> Class \<Rightarrow> Method \<Rightarrow>
   MethSpec \<Rightarrow> MethInv \<Rightarrow> ANNO \<Rightarrow> ANNO \<Rightarrow> Mbody \<Rightarrow> Assn \<Rightarrow>
   Post \<Rightarrow> Inv \<Rightarrow> bool" where
"INVS_soundK K G C m l D m' T MI Anno Anno2 M' A B I =
  (INVS_SC C m l D m' T MI Anno Anno2 M' A I \<longrightarrow>
    G_validn K G \<longrightarrow> MST_validn K \<longrightarrow>
    \<Turnstile>\<^sub>K \<lbrace>(SINV_pre (fst M') T A)\<rbrace> C,m,(l+1)
        \<lbrace>(SINV_post (fst M') T B)\<rbrace> (SINV_inv (fst M') T I)
   \<longrightarrow> \<Turnstile>\<^sub>(K+1) \<lbrace> A \<rbrace> C,m,l \<lbrace> B \<rbrace> I)"

text\<open>The proof that this property holds for all $K$ proceeds by
induction on $K$.\<close>

lemma INVS_soundK_all:
  "INVS_soundK K G C m l D m' T MI Anno Anno2 M' A B I"
(*<*)
apply (induct K)
(*K=0*)
apply (simp add: INVS_soundK_def , clarsimp)
  apply (unfold validn_def)
  apply (rule, rule) apply (erule_tac x=M in allE, erule impE, assumption)
  apply (rule, rule, rule, rule)
  apply (erule_tac x=Mspec in allE, erule_tac x=Minv in allE, erule_tac x=Annoa in allE, erule impE, assumption)
  apply (rule, rule, rule, rule)
  apply (erule_tac x=par in allE, erule_tac x=code in allE, erule_tac x=l0 in allE, erule impE, assumption)
  apply (rule, rule, rule)
  apply (rule, rule, rule)
  apply rule
    apply (rule, rule, rule) apply (case_tac k, clarsimp)  apply (drule no_zero_height_Exec_derivs, simp) apply clarsimp
       apply (erule eval_cases) apply (simp add: INVS_SC_def mbody_is_def,clarsimp) apply clarsimp apply (drule MaxZero, clarsimp)
       apply (drule no_zero_height_Exec_derivs, simp)
   apply (rule, rule, rule, rule)
     apply clarsimp
           apply (case_tac k, clarsimp) apply (drule ZeroHeightMultiElim, clarsimp)
             apply (simp add: INVS_SC_def mbody_is_def,clarsimp)
           apply clarsimp
               apply (drule MultiSplit, simp, clarsimp) apply (drule no_zero_height_Step_derivs, simp)
   apply rule apply (case_tac k, clarsimp) apply (drule ZeroHeightReachableElim, clarsimp)
          apply (simp add: INVS_SC_def mbody_is_def,clarsimp)
         apply clarsimp apply (drule ReachableSplit, simp, clarsimp)
        apply (erule disjE)
         apply clarsimp  apply (drule no_zero_height_Step_derivs, simp)
         apply clarsimp  apply (drule ZeroHeightReachableElim, clarsimp)
         apply (rotate_tac 5, erule thin_rl)
          apply (simp add: INVS_SC_def mbody_is_def,clarsimp)
             apply (simp add: MST_validn_def)
             apply (erule_tac x=D in allE, rotate_tac -1)
             apply (erule_tac x=m' in allE, rotate_tac -1)
             apply (erule_tac x=para in allE, rotate_tac -1)
             apply (erule_tac x=codea in allE, rotate_tac -1)
             apply (erule_tac x=l0a in allE, rotate_tac -1,erule impE) apply (simp add: mbody_is_def)
             apply (rotate_tac -1, erule_tac x=T in allE)
             apply (rotate_tac -1, erule_tac x=MI in allE, clarsimp)
             apply (simp add: validn_def)
             apply (simp add: mbody_is_def)
             apply (simp add: heap_def)
(*k>0*)
apply (simp add: INVS_soundK_def , clarsimp)
apply (rotate_tac -1, erule thin_rl)
apply (unfold validn_def)
apply (rule, rule) apply (erule_tac x=M in allE, erule impE, assumption)
apply (rule, rule) apply (rule, rule) apply (rule, rule) apply (rule, rule) apply (rule, rule)
  apply (erule_tac x=Mspec in allE, erule_tac x=Minv in allE, erule_tac x=Annoa in allE, erule impE, assumption)
  apply (erule_tac x=par in allE, erule_tac x=code in allE)
  apply (erule_tac x=l0 in allE, erule impE, assumption)
apply (rule, rule)
apply (rule, rule)
apply (erule_tac x=s0 in allE)
apply rule
(*Exec*)
  apply (rule, rule, rule)
   apply (erule eval_cases) apply clarsimp apply (simp add: INVS_SC_def mbody_is_def) apply clarsimp
   apply (erule_tac x=t in allE, erule impE)
     apply (frule InvokeElim)  apply (simp add: INVS_SC_def mbody_is_def) apply clarsimp apply fastforce
     apply (simp add: MS_def, erule exE, rule) apply clarsimp apply (erule MultiApp) apply assumption
   apply (erule impE, drule InvokeElim, simp add: INVS_SC_def mbody_is_def) apply clarsimp apply fastforce
     apply clarsimp apply (simp add: INVS_SC_def mbody_is_def SINV_pre_def) apply clarsimp apply (rule, rule)
        apply (rule, rule, rule, assumption) apply (rule, rule) prefer 2 apply (rule, assumption) apply simp
        apply (simp add: MST_validn_def) apply (erule_tac x=D in allE, erule_tac x=m' in allE)
          apply (erule_tac x=parb in allE, erule_tac x=codeb in allE)
          apply (erule_tac x=l0b in allE, simp add: mbody_is_def)
          apply (simp add: validn_def)
          apply (erule_tac x=parb in allE, erule_tac x=codeb in allE)
          apply (erule_tac x=l0b in allE, simp add: mbody_is_def)
          apply (rotate_tac -1, erule_tac x=R in allE, erule_tac x=bb in allE)
          apply (rotate_tac -1, erule_tac x="[]" in allE, rotate_tac -1, erule_tac x=R in allE, erule_tac x=bb in allE)
          apply (simp add: mkState_def)
          apply (erule impE) apply (simp add: MS_def, rule) apply (rule MS_zero) apply simp apply simp apply simp
          apply (erule_tac x=ka in allE, erule impE, simp)
          apply (simp add: mkPost_def, erule conjE)
          apply (erule_tac x=hh in allE, erule_tac x=va in allE, simp add: mkState_def)
        apply (erule_tac x=ma in allE, erule impE) apply (simp add: max_def) apply (case_tac "n \<le> ma") apply clarsimp apply clarsimp
         apply (erule conjE) apply (erule_tac x=h in allE, erule_tac x=v in allE, erule impE)
         apply (drule InvokeElim) apply (simp add: INVS_SC_def mbody_is_def) apply clarsimp apply fastforce
           apply clarsimp
         apply (simp add: SINV_post_def) apply (simp add: INVS_SC_def mbody_is_def, clarsimp)
           apply (drule InvokeElim, clarsimp) apply fastforce apply clarsimp
           apply (simp add: mbody_is_def, clarsimp)
           apply (erule_tac x=ac in allE, erule_tac x=ops in allE, rotate_tac -1)
           apply (erule_tac x=ad in allE, erule_tac x=R in allE, rotate_tac -1, erule impE, assumption)
           apply (erule_tac x=bb in allE, simp, erule mp)
           apply (simp add: MST_validn_def)
           apply (erule_tac x=D in allE, erule_tac x=m' in allE, rotate_tac -1)
           apply (erule_tac x=par in allE, erule_tac x=code in allE,  erule_tac x=l0 in allE, simp add: mbody_is_def)
           apply (simp add: validn_def)
           apply (rotate_tac -1) apply (erule thin_rl) apply (rotate_tac -1)
           apply (simp add: mbody_is_def)
           apply (erule_tac x=R in allE, rotate_tac -1, erule_tac x=bb in allE, rotate_tac -1)
           apply (erule_tac x="[]" in allE, rotate_tac -1, erule_tac x=R in allE, rotate_tac -1)
           apply (erule_tac x=bb in allE, erule impE)
             apply (simp add: MS_def, rule, rule MS_zero) apply (simp, simp add: mkState_def, simp)
           apply (simp add: mkState_def)
           apply (erule_tac x=k in allE, clarsimp)
           apply (erule_tac x=bc in allE, erule_tac x=va in allE, simp add: mkPost_def mkState_def)
(*MStep*)
apply (rule, rule)
apply (rule, rule)
apply (rule, rule)
   apply (case_tac k, clarsimp) apply (drule ZeroHeightMultiElim, clarsimp) apply (simp add: INVS_SC_def) apply clarsimp
   apply clarsimp
   apply (frule MultiSplit) apply clarsimp apply clarsimp
     apply (frule InvokeElim)  apply (simp add: INVS_SC_def mbody_is_def) apply clarsimp apply fastforce
     apply clarsimp
     apply (erule_tac x="v # ops" in allE, erule_tac x=ad in allE, erule_tac x=b in allE, erule impE)
     apply (simp add: MS_def, erule exE, rule)  apply (erule MultiApp) apply assumption
       apply (erule impE, simp add: SINV_pre_def INVS_SC_def mbody_is_def) apply clarsimp
        apply (rule, rule, rule, rule, rule, assumption) apply (rule, rule)
          prefer 2 apply (rule, assumption) apply simp
        apply (simp add: MST_validn_def) apply (erule_tac x=D in allE, erule_tac x=m' in allE)
          apply (erule_tac x=parb in allE, erule_tac x=codeb in allE)
          apply (erule_tac x=l0b in allE, simp add: mbody_is_def)
          apply (simp add: validn_def)
          apply (erule_tac x=parb in allE, erule_tac x=codeb in allE)
          apply (erule_tac x=l0b in allE, simp add: mbody_is_def)
          apply (rotate_tac -1, erule_tac x=R in allE, erule_tac x=bb in allE)
          apply (rotate_tac -1, erule_tac x="[]" in allE, rotate_tac -1, erule_tac x=R in allE, erule_tac x=bb in allE)
          apply (simp add: mkState_def)
          apply (erule impE) apply (simp add: MS_def, rule) apply (rule MS_zero) apply simp apply simp apply simp
          apply (erule_tac x=k in allE, erule impE, simp)
          apply (simp add: mkPost_def, erule conjE)
          apply (erule_tac x=hh in allE, erule_tac x=va in allE, simp add: mkState_def)
        apply (erule_tac x=ma in allE, erule impE) apply simp
         apply (erule conjE) apply (erule_tac x=ll in allE, erule_tac x=ae in allE)
           apply (erule_tac x=af in allE, rotate_tac -1, erule_tac x=bc in allE, clarsimp)
(*Reach*)
apply rule
  apply (case_tac k, clarsimp) apply (drule ZeroHeightReachableElim, clarsimp)
       apply (simp add: INVS_SC_def mbody_is_def, clarsimp)
  apply clarsimp
  apply (drule ReachableSplit) apply simp apply clarsimp
  apply (erule disjE)
    apply clarsimp
         apply (frule InvokeElim) apply (simp add: INVS_SC_def mbody_is_def) apply clarsimp apply fastforce
           apply clarsimp
           apply (erule_tac x="v#ops" in allE, erule_tac x=ad in allE, erule_tac x=b in allE, erule impE)
           apply (simp add: MS_def, clarsimp, rule) apply (erule MultiApp) apply assumption
         apply (erule impE) apply (simp add: SINV_pre_def) apply (simp add: INVS_SC_def mbody_is_def, clarsimp)
            apply (rule, rule, rule, rule, rule) apply assumption
            apply (rule, rule) prefer 2 apply (rule, assumption, simp)
           apply (simp add: MST_validn_def)
           apply (erule_tac x=D in allE, erule_tac x=m' in allE, rotate_tac -1)
           apply (erule_tac x=parb in allE, erule_tac x=codeb in allE,  erule_tac x=l0b in allE, simp add: mbody_is_def)
           apply (simp add: validn_def)
           apply (simp add: mbody_is_def) apply (rotate_tac -1)
           apply (erule_tac x=R in allE, rotate_tac -1, erule_tac x=bb in allE, rotate_tac -1)
           apply (erule_tac x="[]" in allE, rotate_tac -1, erule_tac x=R in allE, rotate_tac -1)
           apply (erule_tac x=bb in allE, erule impE)
             apply (simp add: MS_def, rule, rule MS_zero) apply (simp, simp add: mkState_def, simp)
           apply (simp add: mkState_def)
           apply (erule_tac x=k in allE, clarsimp)
           apply (erule_tac x=b in allE, erule_tac x=v in allE, simp add: mkPost_def mkState_def)
        apply (erule_tac x=ma in allE, clarsimp)
        apply (rotate_tac -1)
        apply (simp add: SINV_inv_def)
        apply (erule_tac x="l+1" in allE, erule_tac x=ae in allE)
        apply (erule_tac x=af in allE, rotate_tac -1, erule_tac x=bc in allE, clarsimp)
        apply (rotate_tac -2, erule thin_rl)
        apply (simp add: SINV_inv_def INVS_SC_def mbody_is_def) apply clarsimp
        apply (rotate_tac -1, erule_tac x=ac in allE)
        apply (rotate_tac -1, erule_tac x=ops in allE)
        apply (rotate_tac -1, erule_tac x=ad in allE)
        apply (rotate_tac -1, erule_tac x=R in allE, clarsimp)
        apply (rotate_tac -1, erule_tac x=bb in allE, erule mp)
        apply (erule thin_rl)
           apply (simp add: MST_validn_def)
           apply (erule_tac x=D in allE, erule_tac x=m' in allE, rotate_tac -1)
           apply (erule_tac x=parb in allE, erule_tac x=codeb in allE,  erule_tac x=l0b in allE, simp add: mbody_is_def)
           apply (simp add: validn_def)
           apply (simp add: mbody_is_def) apply (rotate_tac -1)
           apply (erule_tac x=R in allE, rotate_tac -1, erule_tac x=bb in allE, rotate_tac -1)
           apply (erule_tac x="[]" in allE, rotate_tac -1, erule_tac x=R in allE, rotate_tac -1)
           apply (erule_tac x=bb in allE, erule impE)
             apply (simp add: MS_def, rule, rule MS_zero) apply (simp, simp add: mkState_def, simp)
           apply (simp add: mkState_def)
           apply (erule_tac x=k in allE, clarsimp)
           apply (erule_tac x=b in allE, erule_tac x=v in allE, simp add: mkPost_def mkState_def)
  apply clarsimp
  apply (simp add: INVS_SC_def mbody_is_def, clarsimp)
  apply (rotate_tac -1, erule_tac x=ab in allE)
  apply (rotate_tac -1, erule_tac x=ba in allE)
  apply (rotate_tac -1, erule_tac x=ac in allE)
  apply (rotate_tac -1, erule_tac x=ops1 in allE)
  apply (rotate_tac -1, erule_tac x=ad in allE)
  apply (rotate_tac -1, erule_tac x=R in allE, clarsimp)
  apply (rotate_tac -1, erule_tac x=bb in allE, clarsimp)
  apply (rotate_tac -1, erule_tac x="heap (ae,af,bc)" in allE, erule mp)
  apply (rotate_tac 6) apply (erule thin_rl)
  apply (simp add: MST_validn_def)
  apply (erule_tac x=D in allE, erule_tac x=m' in allE)
  apply (simp add: mbody_is_def)
  apply (simp add: validn_def)
  apply (simp add: mbody_is_def mkInv_def)
  apply (rotate_tac -1)
  apply (erule_tac x=R in allE, erule_tac x=bb in allE)
  apply (rotate_tac -1) apply (erule_tac x="[]" in allE)
  apply (rotate_tac -1)
  apply (erule_tac x=R in allE, erule_tac x=bb in allE, simp add: mkState_def, erule impE)
  apply (simp add: MS_def, rule, rule MS_zero) apply (simp, simp, simp)
  apply (erule_tac x=nat in allE, simp)
done
(*>*)

text\<open>The heart of the soundness proof - the induction on the
axiomatic semantics.\<close>

lemma SOUND_Aux[rule_format]:
"(b,G,C,m,l,A,B,I):SP_Judgement \<Longrightarrow> G_validn K G \<longrightarrow> MST_validn K \<longrightarrow>
  ((b \<longrightarrow> \<Turnstile>\<^sub>K \<lbrace>A\<rbrace> C, m, l \<lbrace>B\<rbrace> I) \<and>
   ((\<not> b) \<longrightarrow> \<Turnstile>\<^sub>(Suc K) \<lbrace>A\<rbrace> C, m, l \<lbrace>B\<rbrace> I))"
(*<*)
apply (erule SP_Judgement.induct)
(*INSTR*)
apply clarsimp
apply (rotate_tac -4) apply (erule thin_rl)
apply (simp add: mbody_is_def validn_def Opsem_def MS_def Reach_def, clarsimp)
apply rule
  apply clarsimp apply (erule eval_cases) apply simp
    apply clarsimp apply (frule InstrElimNext, simp, assumption, clarsimp)
    apply (erule_tac x=ad in allE)
    apply (erule_tac x=bb in allE)
    apply (erule_tac x=a in allE, rotate_tac -1)
    apply (erule_tac x=aa in allE)
    apply (erule_tac x=b in allE, erule impE)
      apply rule
        apply (erule MultiApp)
        apply assumption
      apply (erule impE, simp add: SP_pre_def) apply (rule, rule, rule, rule, assumption)
         apply (rule, rule,assumption)
      apply (erule_tac x=ma in allE, clarsimp)
      apply (erule_tac x=h in allE, erule_tac x=v in allE, clarsimp)
      apply (simp add: SP_post_def)
       apply (rotate_tac -1)
       apply (erule_tac x=ae in allE, rotate_tac -1)
       apply (erule_tac x=af in allE, rotate_tac -1)
       apply (erule_tac x=bc in allE, erule mp)
         apply (rule, rule, assumption)
apply clarsimp
apply rule
  apply clarsimp
    apply (case_tac ka) apply clarsimp apply (drule ZeroHeightMultiElim) apply clarsimp
    apply clarsimp
    apply (rotate_tac -2, drule MultiSplit) apply simp apply clarsimp
      apply (frule InstrElimNext, simp, assumption, clarsimp)
      apply (erule_tac x=ad in allE)
      apply (erule_tac x=bb in allE)
      apply (erule_tac x=ag in allE, rotate_tac -1)
      apply (erule_tac x=ah in allE)
      apply (erule_tac x=bd in allE, erule impE)
        apply rule
          apply (erule MultiApp)
          apply assumption
       apply (erule impE, simp add: SP_pre_def) apply (rule, rule, rule, rule, assumption)
         apply (rule, rule, assumption)
      apply (erule_tac x=ma in allE, clarsimp)
      apply (erule_tac x=ll 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 clarsimp
    apply (case_tac ka) apply clarsimp apply (drule ZeroHeightReachableElim) apply clarsimp
    apply clarsimp
    apply (rotate_tac -2, drule ReachableSplit) apply simp apply clarsimp
    apply (rotate_tac -1, erule disjE)
      apply clarsimp
      apply (frule InstrElimNext, simp, assumption, clarsimp)
      apply (erule_tac x=ad in allE)
      apply (erule_tac x=bb in allE)
      apply (erule_tac x=ag in allE, rotate_tac -1)
      apply (erule_tac x=ah in allE)
      apply (erule_tac x=bd in allE, erule impE)
        apply rule
          apply (erule MultiApp)
          apply assumption
       apply (erule impE, simp add: SP_pre_def) apply (rule, rule, rule, rule, assumption)
         apply (rule, rule, assumption)
       apply (erule_tac x=ma in allE, clarsimp)
         apply (rotate_tac -1, erule_tac x=ll in allE)
         apply (rotate_tac -1, erule_tac x=a in allE)
         apply (rotate_tac -1, erule_tac x=aa in allE)
         apply (rotate_tac -1, erule_tac x=b in allE, clarsimp)
         apply (simp add: SP_inv_def)
(*         apply (rotate_tac -1, erule_tac x="l+1" in allE)*)
         apply (rotate_tac -1, erule_tac x=ae in allE)
         apply (rotate_tac -1, erule_tac x=af in allE)
         apply (rotate_tac -1, erule_tac x=bc in allE, erule mp) apply (rule, rule, assumption)
    apply clarsimp
(*GOTO*)
apply clarsimp
apply (rotate_tac 5) apply (erule thin_rl)
apply (simp add: mbody_is_def validn_def Opsem_def MS_def Reach_def, clarsimp)
apply rule
  apply clarsimp apply (erule eval_cases) apply simp
    apply clarsimp apply (drule GotoElim1) apply (simp, clarsimp)
    apply (erule_tac x=ad in allE)
    apply (erule_tac x=bb in allE)
    apply (erule_tac x=ae in allE, rotate_tac- 1)
    apply (erule_tac x=af in allE)
    apply (erule_tac x=bc in allE, erule impE)
      apply rule
        apply (erule MultiApp)
          apply (erule Goto)
    apply (erule impE, simp add: SP_pre_def) apply (rule, rule, rule, rule, assumption)
         apply (rule, rule, erule Goto)
         apply (erule_tac x=ma in allE, clarsimp)
         apply (erule_tac x=h in allE, erule_tac x=v in allE, clarsimp)
         apply(simp add: SP_post_def, rotate_tac -1)
         apply (erule_tac x=ae in allE, rotate_tac -1)
         apply (erule_tac x=af in allE, rotate_tac -1)
         apply (erule_tac x=bc in allE, erule mp)
           apply (rule, rule, erule Goto)
apply clarsimp
apply rule
  apply clarsimp
    apply (case_tac ka) apply clarsimp apply (drule ZeroHeightMultiElim) apply clarsimp
    apply clarsimp
    apply (rotate_tac -2, drule MultiSplit) apply simp apply clarsimp
      apply (drule GotoElim1) apply simp apply clarsimp
      apply (erule_tac x=ad in allE)
      apply (erule_tac x=bb in allE)
      apply (erule_tac x=ae in allE,rotate_tac -1)
      apply (erule_tac x=af in allE)
      apply (erule_tac x=bc in allE, erule impE)
        apply rule
          apply (erule MultiApp)
            apply (erule Goto)
       apply (erule impE, simp add: SP_pre_def) apply (rule, rule, rule, rule, assumption)
         apply (rule, rule, erule Goto)
      apply (erule_tac x=ma in allE, clarsimp)
      apply (erule_tac x=ll in allE, rotate_tac -1)
      apply (erule_tac x=a in allE, rotate_tac -1)
      apply (erule_tac x=aa in allE)
      apply (erule_tac x=b in allE, clarsimp)
  apply clarsimp
    apply (case_tac ka) apply clarsimp apply (drule ZeroHeightReachableElim) apply clarsimp
    apply clarsimp
    apply (rotate_tac -2, drule ReachableSplit) apply simp apply clarsimp
      apply (drule GotoElim1) apply simp apply clarsimp
      apply (erule_tac x=ad in allE)
      apply (erule_tac x=bb in allE)
      apply (erule_tac x=ae in allE,rotate_tac -1)
      apply (erule_tac x=af in allE)
      apply (erule_tac x=bc in allE, erule impE)
        apply rule
          apply (erule MultiApp)
            apply (erule Goto)
       apply (erule impE, simp add: SP_pre_def) apply (rule, rule, rule, rule, assumption)
         apply (rule, rule, erule Goto)
      apply (erule_tac x=ma in allE, clarsimp)
         apply (rotate_tac -1, erule_tac x=ll in allE)
         apply (rotate_tac -1, erule_tac x=a in allE)
         apply (rotate_tac -1, erule_tac x=aa in allE)
         apply (rotate_tac -1, erule_tac x=b in allE, clarsimp)
         apply (simp add: SP_inv_def)
(*         apply (rotate_tac -1, erule_tac x=pc in allE)*)
         apply (rotate_tac -1, erule_tac x=ae in allE)
         apply (rotate_tac -1, erule_tac x=af in allE)
         apply (rotate_tac -1, erule_tac x=bc in allE, erule mp)
         apply (rule, rule)
            apply (erule Goto)
(*If*)
apply clarsimp
apply (rotate_tac 5) apply (erule thin_rl,erule thin_rl)
apply (simp add: mbody_is_def validn_def Opsem_def MS_def Reach_def, clarsimp)
apply rule
  apply clarsimp apply (erule eval_cases) apply simp
    apply clarsimp apply (drule IfElim1) apply (simp, clarsimp)
    apply (erule disjE)
    apply clarsimp
      apply (rotate_tac 3) apply (erule thin_rl)
      apply (rotate_tac -1)
      apply (erule_tac x=ad in allE)
      apply (erule_tac x=bb in allE)
      apply (erule_tac x=a in allE, rotate_tac -1)
      apply (erule_tac x=af in allE)
      apply (erule_tac x=bc in allE, erule impE)
        apply rule
          apply (erule MultiApp)
            apply (erule IfT, simp)
      apply (erule impE, simp add: SP_pre_def) apply (rule, rule, rule, rule) prefer 2
            apply (rule, rule, erule IfT, simp) apply fastforce
         apply (erule_tac x=ma in allE, clarsimp)
           apply (erule_tac x=h in allE, erule_tac x=v in allE, clarsimp)
           apply (simp add: SP_post_def)
           apply (rotate_tac -1)
           apply (erule_tac x="TRUE # a" in allE, erule_tac x=af in allE, erule_tac x=bc in allE, erule impE)
             apply (rule, rule, rule IfT, simp,simp)
           apply clarsimp
    apply clarsimp
      apply (rotate_tac 2) apply (erule thin_rl)
      apply (erule_tac x=ad in allE)
      apply (erule_tac x=bb in allE)
      apply (erule_tac x=a in allE, rotate_tac -1)
      apply (erule_tac x=af in allE)
      apply (erule_tac x=bc in allE, erule impE)
        apply rule
          apply (erule MultiApp)
            apply (rule IfF) apply (simp, assumption, simp) apply simp
      apply (erule impE, simp add: SP_pre_def) apply (rule, rule, rule, rule) prefer 2
            apply (rule, rule, rule IfF) apply (simp, assumption) apply fastforce
            apply simp
            apply clarsimp
         apply (erule_tac x=ma in allE, clarsimp)
           apply (erule_tac x=h in allE, erule_tac x=v in allE, clarsimp)
           apply (simp add: SP_post_def)
           apply (rotate_tac -1)
           apply (erule_tac x="va # a" in allE, erule_tac x=af in allE, erule_tac x=bc in allE, erule impE)
             apply (rule, rule, rule IfF) apply (simp, assumption) apply fastforce apply simp
           apply clarsimp
apply clarsimp
apply rule
  apply clarsimp
    apply (case_tac ka) apply clarsimp apply (drule ZeroHeightMultiElim) apply clarsimp
    apply clarsimp
    apply (rotate_tac -2, drule MultiSplit) apply simp apply clarsimp
      apply (drule IfElim1) apply simp apply clarsimp
      apply (erule disjE)
      apply clarsimp
        apply (rotate_tac 4) apply (erule thin_rl)
        apply (rotate_tac -1)
        apply (erule_tac x=ad in allE)
        apply (erule_tac x=bb in allE)
        apply (erule_tac x=ag in allE, rotate_tac -1)
        apply (erule_tac x=af in allE)
        apply (erule_tac x=bc in allE, erule impE)
          apply rule
            apply (erule MultiApp)
              apply (rule IfT) apply (simp, fastforce)
        apply (erule impE, simp add: SP_pre_def) apply (rule, rule, rule,rule) prefer 2
           apply (rule, rule, rule IfT) apply simp apply fastforce
           apply clarsimp
        apply (erule_tac x=ma in allE, clarsimp)
        apply (erule_tac x=ll 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, clarsimp)
      apply clarsimp
        apply (rotate_tac 3) apply (erule thin_rl)
        apply (erule_tac x=ad in allE)
        apply (erule_tac x=bb in allE)
        apply (erule_tac x=ag in allE, rotate_tac -1)
        apply (erule_tac x=af in allE)
        apply (erule_tac x=bc in allE, erule impE)
          apply rule
            apply (erule MultiApp)
              apply (rule IfF) apply (simp, assumption, simp) apply simp
        apply (erule impE, simp add: SP_pre_def) apply (rule, rule, rule, rule) prefer 2
           apply (rule, rule, rule IfF) apply (simp, assumption) apply fastforce apply simp
           apply clarsimp
        apply (erule_tac x=ma in allE, clarsimp)
        apply (erule_tac x=ll 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, clarsimp)
  apply clarsimp
    apply (case_tac ka) apply clarsimp apply (drule ZeroHeightReachableElim) apply clarsimp
    apply clarsimp
    apply (rotate_tac -2, drule ReachableSplit) apply simp apply clarsimp
      apply (drule IfElim1) apply simp apply clarsimp
      apply (erule disjE)
      apply clarsimp
        apply (rotate_tac 4) apply (erule thin_rl)
        apply (rotate_tac -1)
        apply (erule_tac x=ad in allE)
        apply (erule_tac x=bb in allE)
        apply (erule_tac x=ag in allE, rotate_tac -1)
        apply (erule_tac x=af in allE)
        apply (erule_tac x=bc in allE, erule impE)
          apply rule
            apply (erule MultiApp)
              apply (rule IfT) apply (simp, fastforce)
        apply (erule impE, simp add: SP_pre_def) apply (rule, rule, rule, rule) prefer 2
           apply (rule, rule, rule IfT) apply simp apply fastforce
           apply clarsimp
        apply (erule_tac x=ma in allE, clarsimp)
         apply (rotate_tac -1, erule_tac x=ll in allE)
         apply (rotate_tac -1, erule_tac x=a in allE)
         apply (rotate_tac -1, erule_tac x=aa in allE)
         apply (rotate_tac -1, erule_tac x=b in allE, clarsimp)
         apply (simp add: SP_inv_def)
(*         apply (rotate_tac -1, erule_tac x=pc in allE)*)
         apply (rotate_tac -1, erule_tac x="TRUE#ag" in allE)
         apply (rotate_tac -1, erule_tac x=af in allE)
         apply (rotate_tac -1, erule_tac x=bc in allE)
         apply (rotate_tac -1, erule impE)
            apply (rule, rule, erule IfT) apply simp
         apply clarsimp
      apply clarsimp
        apply (rotate_tac 3) apply (erule thin_rl)
        apply (erule_tac x=ad in allE)
        apply (erule_tac x=bb in allE)
        apply (erule_tac x=ag in allE, rotate_tac -1)
        apply (erule_tac x=af in allE)
        apply (erule_tac x=bc in allE, erule impE)
          apply rule
            apply (erule MultiApp)
              apply (erule IfF) apply (assumption, simp, simp)
        apply (erule impE, simp add: SP_pre_def) apply (rule, rule, rule, rule) prefer 2
           apply (rule, rule, erule IfF) apply (assumption, fastforce,simp)
           apply clarsimp
        apply (erule_tac x=ma in allE, clarsimp)
         apply (rotate_tac -1, erule_tac x=ll in allE)
         apply (rotate_tac -1, erule_tac x=a in allE)
         apply (rotate_tac -1, erule_tac x=aa in allE)
         apply (rotate_tac -1, erule_tac x=b in allE, clarsimp)
         apply (simp add: SP_inv_def)
(*         apply (rotate_tac -1, erule_tac x="Suc l" in allE)*)
         apply (rotate_tac -1, erule_tac x="v#ag" in allE)
         apply (rotate_tac -1, erule_tac x=af in allE)
         apply (rotate_tac -1, erule_tac x=bc in allE)
         apply (rotate_tac -1, erule impE)
         apply (rule, rule)
            apply (erule IfF) apply (assumption, simp, simp)
         apply clarsimp
(*RET*)
apply clarsimp
apply (simp add: mbody_is_def validn_def Opsem_def MS_def Reach_def, clarsimp)
apply rule
  apply clarsimp apply (erule eval_cases) apply clarsimp
    apply (drule RetElim1) apply simp apply simp
apply clarsimp
apply rule
  apply clarsimp
    apply (case_tac ka) apply clarsimp apply (drule ZeroHeightMultiElim) apply clarsimp
    apply clarsimp
    apply (rotate_tac -2, drule MultiSplit) apply simp apply clarsimp
      apply (drule RetElim1, clarsimp) apply simp
apply clarsimp
    apply (case_tac ka) apply clarsimp apply (drule ZeroHeightReachableElim) apply clarsimp
    apply clarsimp
    apply (rotate_tac -2, drule ReachableSplit) apply simp apply clarsimp
      apply (drule RetElim1, clarsimp) apply simp
(*INVS*)
apply clarsimp
  apply (subgoal_tac "INVS_soundK K G C m l D m' T MI Anno Anno2 (par,code,l0) A B I")
  apply (simp add: INVS_soundK_def)
  apply (erule impE) apply (simp add: INVS_SC_def) apply (rule, rule, rule, rule) apply assumption apply (rule, assumption)
     apply assumption
  apply assumption
  apply (rule INVS_soundK_all)
(*CONSEQ*)
apply clarsimp
apply rule
  apply clarsimp
  apply (simp add: validn_def,clarsimp)
  apply (erule thin_rl)
  apply (rotate_tac 5, erule thin_rl)
  apply (erule_tac x=a in allE, rotate_tac -1)
  apply (erule_tac x=aa in allE, rotate_tac -1)
  apply (erule_tac x=ba in allE, clarsimp, rotate_tac -1)
  apply (erule_tac x=ab in allE)
  apply (erule_tac x=bb in allE)
  apply (rotate_tac -1)
  apply (erule_tac x=ac in allE, rotate_tac -1)
  apply (erule_tac x=ad in allE, rotate_tac -1)
  apply (erule_tac x=bc in allE, clarsimp)
  apply (erule_tac x=k in allE, clarsimp)
  apply (rotate_tac -1)
    apply (erule_tac x=ll in allE, rotate_tac -1)
    apply (erule_tac x=ae in allE, rotate_tac -1)
    apply (erule_tac x=af in allE)
    apply (erule_tac x=bd in allE, clarsimp)
  apply clarsimp
  apply (simp add: validn_def,clarsimp)
  apply (erule thin_rl)
  apply (rotate_tac 5, erule thin_rl)
  apply (erule_tac x=a in allE, rotate_tac -1)
  apply (erule_tac x=aa in allE, rotate_tac -1)
  apply (erule_tac x=ba in allE, clarsimp, rotate_tac -1)
  apply (erule_tac x=ab in allE)
  apply (erule_tac x=bb in allE)
  apply (rotate_tac -1)
  apply (erule_tac x=ac in allE, rotate_tac -1)
  apply (erule_tac x=ad in allE, rotate_tac -1)
  apply (erule_tac x=bc in allE, clarsimp)
  apply (erule_tac x=k in allE, clarsimp)
  apply (rotate_tac -1)
    apply (erule_tac x=ll in allE, rotate_tac -1)
    apply (erule_tac x=ae in allE, rotate_tac -1)
    apply (erule_tac x=af in allE)
    apply (erule_tac x=bd in allE, clarsimp)
(*INJECT*)
apply clarsimp apply (rule validn_lower) apply fast apply simp
(*AX*)
apply clarsimp apply (simp add: G_validn_def)
done
(*>*)

text\<open>The statement of this lemma gives a semantic interpretation of
the two judgement forms, as \<open>SP_Assum\<close>-judgements enjoy validity
up to execution height $K$, while \<open>SP_Deriv\<close>-judgements are
valid up to level $K+1$.\<close>

(*<*)
lemma SOUND_K:
  "\<lbrakk> G \<rhd> \<lbrace>A\<rbrace> C,m,l \<lbrace>B\<rbrace> I; G_validn K G ; MST_validn K\<rbrakk>
  \<Longrightarrow> \<Turnstile>\<^sub>(Suc K) \<lbrace>A\<rbrace> C, m, l \<lbrace>B\<rbrace> I"
apply (drule SOUND_Aux)  apply assumption+ apply simp
done
(*>*)

text\<open>From this, we obtain a soundness result that still involves
context validity.\<close>

theorem SOUND_in_CTXT:
 "\<lbrakk>G \<rhd> \<lbrace>A\<rbrace> C,m,l \<lbrace>B\<rbrace> I; G_valid G; MST_valid\<rbrakk> \<Longrightarrow> \<Turnstile> \<lbrace>A\<rbrace> C, m, l \<lbrace>B\<rbrace> I"
(*<*)
apply (rule validn_valid)
apply clarsimp
apply (rule validn_lower)
apply (erule SOUND_K)
prefer 3 apply (subgoal_tac "K \<le> Suc K", assumption) apply simp
apply (erule G_valid_validn)
apply (erule MST_valid_validn)
done
(*>*)

text\<open>We will now show that the two semantic assumptions can be replaced by
the verified-program property.\<close>

subsection\<open>Soundness of verified programs \label{SectionContextElimination}\<close>

text\<open>In order to obtain a soundness result that does not require
validity assumptions of the context or the specification table,
we show that the \<open>VP\<close> property implies context validity.
First, the elimination of contexts. By induction on
\<open>k\<close> we prove\<close>

lemma VPG_MSTn_Gn[rule_format]:
"VP_G G \<longrightarrow> MST_validn k \<longrightarrow> G_validn k G"
(*<*)
apply (induct k)
(*k=0*)
  apply clarsimp
    apply (simp add: VP_G_def, clarsimp)
    apply (simp add: G_validn_def, clarsimp)
    apply (simp add: validn_def) apply clarsimp
        apply rule
          apply clarsimp apply (drule no_zero_height_Exec_derivs) apply simp
        apply clarsimp
        apply rule
          apply clarsimp apply (drule ZeroHeightMultiElim) apply clarsimp
            apply (rotate_tac 2)
            apply (erule_tac x=C in allE, erule_tac x=m in allE)
            apply (erule_tac x=a in allE, erule_tac x=aa in allE, erule_tac x=b in allE, clarsimp)
            apply (erule_tac x=C in allE, erule_tac x=m in allE)
            apply (erule_tac x=l in allE, erule_tac x=A in allE, erule_tac x=B in allE, clarsimp)
            apply (rule AssertionsImplyAnnoInvariants)
             prefer 3 apply assumption
             apply assumption+
          apply clarsimp apply (drule ZeroHeightReachableElim) apply clarsimp
            apply (rotate_tac 2)
            apply (erule_tac x=C in allE, erule_tac x=m in allE)
            apply (erule_tac x=a in allE, erule_tac x=aa in allE, erule_tac x=b in allE, clarsimp)
            apply (erule_tac x=C in allE, erule_tac x=m in allE,
                   erule_tac x=l in allE, erule_tac x=A in allE, erule_tac x=B in allE, clarsimp)
            apply (erule AssertionsImplyMethInvariants, assumption+)
(*k>0*)
 apply clarsimp apply (simp add: VP_G_def)
   apply (simp (no_asm) add: G_validn_def, clarsimp)
   apply (subgoal_tac "MST_validn k", clarsimp)
   apply (rule SOUND_K) apply fast
   apply assumption
   apply assumption
   apply (erule MST_validn_lower) apply simp
done
(*>*)

text\<open>which implies\<close>

lemma VPG_MST_G: "\<lbrakk>VP_G G; MST_valid\<rbrakk> \<Longrightarrow> G_valid G"
(*<*)
apply (rule G_validn_valid, clarsimp)
apply (erule VPG_MSTn_Gn)
apply (erule MST_valid_validn)
done
(*>*)

text\<open>Next, the elimination of \<open>MST_valid\<close>. Again by induction on
\<open>k\<close>, we prove\<close>

lemma VPG_MSTn[rule_format]: "VP_G G \<longrightarrow> MST_validn k"
(*<*)
apply (induct k)
apply (simp add: MST_validn_def, clarsimp)
  apply (simp add: validn_def, clarsimp)
  apply rule
    apply clarsimp apply (drule no_zero_height_Exec_derivs) apply simp
  apply clarsimp
  apply rule
    apply clarsimp apply (drule ZeroHeightMultiElim) apply clarsimp
    apply (simp add: VP_G_def, clarsimp, rotate_tac -1)
    apply (erule_tac x=C in allE, erule_tac x=m in allE)
    apply (erule_tac x=par in allE, erule_tac x=code in allE, erule_tac x=l0 in allE, clarsimp)
    apply (rule AssertionsImplyAnnoInvariants) apply fast apply assumption+ apply simp
  apply clarsimp apply (drule ZeroHeightReachableElim) apply clarsimp
    apply (simp add: VP_G_def, clarsimp, rotate_tac -1)
    apply (erule_tac x=C in allE, erule_tac x=m in allE)
    apply (erule_tac x=par in allE, erule_tac x=code in allE, erule_tac x=l0 in allE, clarsimp)
    apply (frule AssertionsImplyMethInvariants) apply assumption apply (simp add: mkState_def)
apply clarsimp
  apply (frule VPG_MSTn_Gn, assumption)
  apply (simp add: VP_G_def)
  apply (simp (no_asm) add: MST_validn_def, clarsimp)
  apply (rule SOUND_K)
   apply (rotate_tac 3)
   apply (erule_tac x=C in allE, erule_tac x=m in allE)
   apply (erule_tac x=par in allE, erule_tac x=code in allE, erule_tac x=l0 in allE, clarsimp) apply assumption
  apply assumption
  apply assumption
done
(*>*)

text\<open>which yields\<close>

lemma VPG_MST:"VP_G G \<Longrightarrow> MST_valid"
(*<*)
apply (rule MST_validn_valid, clarsimp)
apply (erule VPG_MSTn)
done
(*>*)

text\<open>Combining these two results, and unfolding the definition of
program validity yields the final soundness result.\<close>

theorem VP_VALID: "VP \<Longrightarrow> Prog_valid"
(*<*)
apply (simp add: VP_def Prog_valid_def, clarsimp)
apply (frule VPG_MST, simp)
apply (drule VPG_MST_G, assumption) apply fast
done
(*>*)

(*<*)

text \<open>In particular, the $\mathit{VP}$ property implies that all
method specifications are honoured by their respective method
implementations.\<close>

theorem "VP \<Longrightarrow> MST_valid"
(*<*)
by (drule VP_VALID, simp add: Prog_valid_def)
(*>*)

end
(*>*)


(* Title:     Quantum-Semantics/vars.thy
   Author:    David Sanan, Nanyang Technological University
   Copyright   2020
   License:     BSD
*)

theory vars
  imports HOL.Complex
begin

subsection \<open>Syntax\<close>

text \<open>Datatype for quantum programs\<close>

class nat_abs=
  fixes from_nat ::"nat \<Rightarrow> 'a"
  fixes to_nat ::"'a \<Rightarrow> nat"
  fixes subset_nat :: "'a set"

  assumes "a \<in> subset_nat \<Longrightarrow> from_nat (to_nat a) = a "
  assumes "to_nat (from_nat b) = b"

class real_abs= nat_abs+
  fixes from_real ::"real \<Rightarrow> 'a"
  fixes to_real ::"'a \<Rightarrow> real"
  fixes subset_real :: "'a set"

  assumes "a \<in> subset_real \<Longrightarrow> from_real (to_real a) = a "
  assumes "to_real (from_real b) = b"

locale vars =
  fixes variables :: "'v set"
  fixes v_domain :: "'v \<Rightarrow> ('b::nat_abs) set"
  fixes get_value :: "'s \<Rightarrow> 'v  \<Rightarrow> 'b"
  fixes set_value ::"'s \<Rightarrow> 'v \<Rightarrow> 'b \<Rightarrow> 's"
  fixes conv::"('v \<Rightarrow> 'b) \<Rightarrow> 'v set \<Rightarrow> 's"

  assumes "finite variables"
  assumes "v \<in> variables \<Longrightarrow> (get_value s v) \<in> v_domain v"
  assumes eq_get_set:"v \<in> variables \<Longrightarrow> x \<in> (v_domain v) \<Longrightarrow> get_value (set_value s v x) v = x"
  assumes abs_elem: "s = conv (get_value s) variables"

begin

definition not_access_v::"('s \<Rightarrow> 'n) \<Rightarrow> 'v \<Rightarrow> bool"
where "not_access_v f v \<equiv>
  \<forall>s f1 f2. f1 \<in> v_domain v \<and> f2 \<in> v_domain v \<longrightarrow>
    f (conv ((get_value s)(v:=f1)) variables) =
    f (conv ((get_value s)(v:=f2)) variables)"

definition access_v::"('s \<Rightarrow> 'n) \<Rightarrow> 'v \<Rightarrow> bool"
where "access_v f v \<equiv>
  \<exists>s f1 f2. f1 \<in> v_domain v \<and> f2 \<in> v_domain v \<and>
    f (conv ((get_value s)(v:=f1)) variables) \<noteq>
    f (conv ((get_value s)(v:=f2)) variables)"

definition not_access_locals::"('s \<Rightarrow> 'n) \<Rightarrow> bool"
where "not_access_locals f \<equiv> \<forall>v\<in>variables. not_access_v f v"

lemma access_neg:"access_v f v = (\<not> (not_access_v f v))"
  unfolding access_v_def not_access_v_def by auto

definition modify_v:: "('s \<Rightarrow> 's) \<Rightarrow> 'v \<Rightarrow> bool"
  where "modify_v f v \<equiv> \<exists>s. get_value (f s) v \<noteq> get_value s v"

definition not_modify_v::"('s \<Rightarrow> 's) \<Rightarrow> 'v \<Rightarrow> bool"
  where "not_modify_v f v \<equiv> \<forall>s. get_value (f s) v = get_value s v"

lemma modify_neg:"modify_v f v =  ( \<not> (not_modify_v f v))"
  unfolding modify_v_def not_modify_v_def by auto

end

end


(*  File:       Revision_Composition.thy
    Copyright   2021  Karlsruhe Institute of Technology (KIT)
*)
\<^marker>\<open>creator "Karsten Diekhoff, Karlsruhe Institute of Technology (KIT)"\<close>
\<^marker>\<open>contributor "Jonas Kraemer, Karlsruhe Institute of Technology (KIT)"\<close>
\<^marker>\<open>contributor "Michael Kirsten, Karlsruhe Institute of Technology (KIT)"\<close>

section \<open>Revision Composition\<close>

theory Revision_Composition
  imports "Basic_Modules/Component_Types/Electoral_Module"
begin

text \<open>
  A revised electoral module rejects all originally rejected or deferred
  alternatives, and defers the originally elected alternatives.
  It does not elect any alternatives.
\<close>

subsection \<open>Definition\<close>

fun revision_composition :: "'a Electoral_Module \<Rightarrow> 'a Electoral_Module" where
  "revision_composition m A p = ({}, A - elect m A p, elect m A p)"

abbreviation rev ::
"'a Electoral_Module \<Rightarrow> 'a Electoral_Module" ("_\<down>" 50) where
  "m\<down> == revision_composition m"

subsection \<open>Soundness\<close>

theorem rev_comp_sound[simp]:
  assumes "electoral_module m"
  shows "electoral_module (revision_composition m)"
proof -
  from assms
  have "\<forall> A p. finite_profile A p \<longrightarrow> elect m A p \<subseteq> A"
    using elect_in_alts
    by metis
  hence "\<forall> A p. finite_profile A p \<longrightarrow> (A - elect m A p) \<union> elect m A p = A"
    by blast
  hence unity:
    "\<forall> A p. finite_profile A p \<longrightarrow>
      set_equals_partition A (revision_composition m A p)"
    by simp
  have "\<forall> A p. finite_profile A p \<longrightarrow> (A - elect m A p) \<inter> elect m A p = {}"
    by blast
  hence disjoint:
    "\<forall> A p. finite_profile A p \<longrightarrow> disjoint3 (revision_composition m A p)"
    by simp
  from unity disjoint
  show ?thesis
    by (simp add: electoral_modI)
qed

subsection \<open>Composition Rules\<close>

text \<open>
  An electoral module received by revision is never electing.
\<close>

theorem rev_comp_non_electing[simp]:
  assumes "electoral_module m"
  shows "non_electing (m\<down>)"
  using assms
  unfolding non_electing_def
  by simp

text \<open>
  Revising an electing electoral module results in a
  non-blocking electoral module.
\<close>

theorem rev_comp_non_blocking[simp]:
  assumes "electing m"
  shows "non_blocking (m\<down>)"
proof (unfold non_blocking_def, safe, simp_all)
  show "electoral_module (m\<down>)"
    using assms rev_comp_sound
    unfolding electing_def
    by (metis (no_types, lifting))
next
  fix
    A :: "'a set" and
    p :: "'a Profile" and
    x :: "'a"
  assume
    fin_A: "finite A" and
    prof_A: "profile A p" and
    no_elect: "A - elect m A p = A" and
    x_in_A: "x \<in> A"
  from no_elect have non_elect:
    "non_electing m"
    using assms prof_A x_in_A fin_A empty_iff
          Diff_disjoint Int_absorb2 elect_in_alts
    unfolding electing_def
    by (metis (no_types, lifting))
  show False
    using non_elect assms empty_iff fin_A prof_A x_in_A
    unfolding electing_def non_electing_def
    by (metis (no_types, lifting))
qed

text \<open>
  Revising an invariant monotone electoral module results in a
  defer-invariant-monotone electoral module.
\<close>

theorem rev_comp_def_inv_mono[simp]:
  assumes "invariant_monotonicity m"
  shows "defer_invariant_monotonicity (m\<down>)"
proof (unfold defer_invariant_monotonicity_def, safe)
  show "electoral_module (m\<down>)"
    using assms rev_comp_sound
    unfolding invariant_monotonicity_def
    by simp
next
  show "non_electing (m\<down>)"
    using assms rev_comp_non_electing
    unfolding invariant_monotonicity_def
    by simp
next
  fix
    A :: "'a set" and
    p :: "'a Profile" and
    q :: "'a Profile" and
    a :: "'a" and
    x :: "'a" and
    xa :: "'a"
  assume
    rev_p_defer_a: "a \<in> defer (m\<down>) A p" and
    a_lifted: "lifted A p q a" and
    rev_q_defer_x: "x \<in> defer (m\<down>) A q" and
    x_non_eq_a: "x \<noteq> a" and
    rev_q_defer_xa: "xa \<in> defer (m\<down>) A q"
  from rev_p_defer_a
  have elect_a_in_p: "a \<in> elect m A p"
    by simp
  from rev_q_defer_x x_non_eq_a
  have elect_no_unique_a_in_q: "elect m A q \<noteq> {a}"
    by force
  from assms
  have "elect m A q = elect m A p"
    using a_lifted elect_a_in_p elect_no_unique_a_in_q
    unfolding invariant_monotonicity_def
    by (metis (no_types))
  thus "xa \<in> defer (m\<down>) A p"
    using rev_q_defer_xa
    by simp
next
  fix
    A :: "'a set" and
    p :: "'a Profile" and
    q :: "'a Profile" and
    a :: "'a" and
    x :: "'a" and
    xa :: "'a"
  assume
    rev_p_defer_a: "a \<in> defer (m\<down>) A p" and
    a_lifted: "lifted A p q a" and
    rev_q_defer_x: "x \<in> defer (m\<down>) A q" and
    x_non_eq_a: "x \<noteq> a" and
    rev_p_defer_xa: "xa \<in> defer (m\<down>) A p"
  have reject_and_defer:
    "(A - elect m A q, elect m A q) = snd ((m\<down>) A q)"
    by force
  have elect_p_eq_defer_rev_p: "elect m A p = defer (m\<down>) A p"
    by simp
  hence elect_a_in_p: "a \<in> elect m A p"
    using rev_p_defer_a
    by presburger
  have "elect m A q \<noteq> {a}"
    using rev_q_defer_x x_non_eq_a
    by force
  with assms
  show "xa \<in> defer (m\<down>) A q"
    using a_lifted rev_p_defer_xa snd_conv elect_a_in_p
          elect_p_eq_defer_rev_p reject_and_defer
    unfolding invariant_monotonicity_def
    by (metis (no_types))
next
  fix
    A :: "'a set" and
    p :: "'a Profile" and
    q :: "'a Profile" and
    a :: "'a" and
    x :: "'a" and
    xa :: "'a"
  assume
    rev_p_defer_a: "a \<in> defer (m\<down>) A p" and
    a_lifted: "lifted A p q a" and
    rev_q_defer_xa: "xa \<in> defer (m\<down>) A q"
  from assms
  show "xa \<in> defer (m\<down>) A p"
    using a_lifted empty_iff insertE rev_p_defer_a rev_q_defer_xa
          snd_conv revision_composition.elims
    unfolding invariant_monotonicity_def
    by metis
next
  fix
    A :: "'a set" and
    p :: "'a Profile" and
    q :: "'a Profile" and
    a :: "'a" and
    x :: "'a" and
    xa :: "'a"
  assume
    rev_p_defer_a: "a \<in> defer (m\<down>) A p" and
    a_lifted: "lifted A p q a" and
    rev_q_not_defer_a: "a \<notin> defer (m\<down>) A q"
  from assms
  have lifted_inv:
    "\<forall> A p q a. a \<in> elect m A p \<and> lifted A p q a \<longrightarrow>
      elect m A q = elect m A p \<or> elect m A q = {a}"
    unfolding invariant_monotonicity_def
    by (metis (no_types))
  have p_defer_rev_eq_elect: "defer (m\<down>) A p = elect m A p"
    by simp
  have q_defer_rev_eq_elect: "defer (m\<down>) A q = elect m A q"
    by simp
  thus "xa \<in> defer (m\<down>) A q"
    using p_defer_rev_eq_elect lifted_inv a_lifted rev_p_defer_a rev_q_not_defer_a
    by blast
qed

end


(*  Title:      Uint8.thy
    Author:     Andreas Lochbihler, ETH Zurich
*)

chapter \<open>Unsigned words of 8 bits\<close>

theory Uint8 imports
  Word_Type_Copies
  Code_Target_Integer_Bit
begin

text \<open>
  Restriction for OCaml code generation:
  OCaml does not provide an int8 type, so no special code generation
  for this type is set up. If the theory \<^text>\<open>Code_Target_Int_Bit\<close>
  is imported, the type \<open>uint8\<close> is emulated via \<^typ>\<open>8 word\<close>.
\<close>

section \<open>Type definition and primitive operations\<close>

typedef uint8 = \<open>UNIV :: 8 word set\<close> ..

global_interpretation uint8: word_type_copy Abs_uint8 Rep_uint8
  using type_definition_uint8 by (rule word_type_copy.intro)

setup_lifting type_definition_uint8

declare uint8.of_word_of [code abstype]

declare Quotient_uint8 [transfer_rule]

instantiation uint8 :: \<open>{comm_ring_1, semiring_modulo, equal, linorder}\<close>
begin

lift_definition zero_uint8 :: uint8 is 0 .
lift_definition one_uint8 :: uint8 is 1 .
lift_definition plus_uint8 :: \<open>uint8 \<Rightarrow> uint8 \<Rightarrow> uint8\<close> is \<open>(+)\<close> .
lift_definition uminus_uint8 :: \<open>uint8 \<Rightarrow> uint8\<close> is uminus .
lift_definition minus_uint8 :: \<open>uint8 \<Rightarrow> uint8 \<Rightarrow> uint8\<close> is \<open>(-)\<close> .
lift_definition times_uint8 :: \<open>uint8 \<Rightarrow> uint8 \<Rightarrow> uint8\<close> is \<open>(*)\<close> .
lift_definition divide_uint8 :: \<open>uint8 \<Rightarrow> uint8 \<Rightarrow> uint8\<close> is \<open>(div)\<close> .
lift_definition modulo_uint8 :: \<open>uint8 \<Rightarrow> uint8 \<Rightarrow> uint8\<close> is \<open>(mod)\<close> .
lift_definition equal_uint8 :: \<open>uint8 \<Rightarrow> uint8 \<Rightarrow> bool\<close> is \<open>HOL.equal\<close> .
lift_definition less_eq_uint8 :: \<open>uint8 \<Rightarrow> uint8 \<Rightarrow> bool\<close> is \<open>(\<le>)\<close> .
lift_definition less_uint8 :: \<open>uint8 \<Rightarrow> uint8 \<Rightarrow> bool\<close> is \<open>(<)\<close> .

global_interpretation uint8: word_type_copy_ring Abs_uint8 Rep_uint8
  by standard (fact zero_uint8.rep_eq one_uint8.rep_eq
    plus_uint8.rep_eq uminus_uint8.rep_eq minus_uint8.rep_eq
    times_uint8.rep_eq divide_uint8.rep_eq modulo_uint8.rep_eq
    equal_uint8.rep_eq less_eq_uint8.rep_eq less_uint8.rep_eq)+

instance proof -
  show \<open>OFCLASS(uint8, comm_ring_1_class)\<close>
    by (rule uint8.of_class_comm_ring_1)
  show \<open>OFCLASS(uint8, semiring_modulo_class)\<close>
    by (fact uint8.of_class_semiring_modulo)
  show \<open>OFCLASS(uint8, equal_class)\<close>
    by (fact uint8.of_class_equal)
  show \<open>OFCLASS(uint8, linorder_class)\<close>
    by (fact uint8.of_class_linorder)
qed

end

instantiation uint8 :: ring_bit_operations
begin

lift_definition bit_uint8 :: \<open>uint8 \<Rightarrow> nat \<Rightarrow> bool\<close> is bit .
lift_definition not_uint8 :: \<open>uint8 \<Rightarrow> uint8\<close> is \<open>Bit_Operations.not\<close> .
lift_definition and_uint8 :: \<open>uint8 \<Rightarrow> uint8 \<Rightarrow> uint8\<close> is \<open>Bit_Operations.and\<close> .
lift_definition or_uint8 :: \<open>uint8 \<Rightarrow> uint8 \<Rightarrow> uint8\<close> is \<open>Bit_Operations.or\<close> .
lift_definition xor_uint8 :: \<open>uint8 \<Rightarrow> uint8 \<Rightarrow> uint8\<close> is \<open>Bit_Operations.xor\<close> .
lift_definition mask_uint8 :: \<open>nat \<Rightarrow> uint8\<close> is mask .
lift_definition push_bit_uint8 :: \<open>nat \<Rightarrow> uint8 \<Rightarrow> uint8\<close> is push_bit .
lift_definition drop_bit_uint8 :: \<open>nat \<Rightarrow> uint8 \<Rightarrow> uint8\<close> is drop_bit .
lift_definition signed_drop_bit_uint8 :: \<open>nat \<Rightarrow> uint8 \<Rightarrow> uint8\<close> is signed_drop_bit .
lift_definition take_bit_uint8 :: \<open>nat \<Rightarrow> uint8 \<Rightarrow> uint8\<close> is take_bit .
lift_definition set_bit_uint8 :: \<open>nat \<Rightarrow> uint8 \<Rightarrow> uint8\<close> is Bit_Operations.set_bit .
lift_definition unset_bit_uint8 :: \<open>nat \<Rightarrow> uint8 \<Rightarrow> uint8\<close> is unset_bit .
lift_definition flip_bit_uint8 :: \<open>nat \<Rightarrow> uint8 \<Rightarrow> uint8\<close> is flip_bit .

global_interpretation uint8: word_type_copy_bits Abs_uint8 Rep_uint8 signed_drop_bit_uint8
  by standard (fact bit_uint8.rep_eq not_uint8.rep_eq and_uint8.rep_eq or_uint8.rep_eq xor_uint8.rep_eq
    mask_uint8.rep_eq push_bit_uint8.rep_eq drop_bit_uint8.rep_eq signed_drop_bit_uint8.rep_eq take_bit_uint8.rep_eq
    set_bit_uint8.rep_eq unset_bit_uint8.rep_eq flip_bit_uint8.rep_eq)+

instance
  by (fact uint8.of_class_ring_bit_operations)

end

lift_definition uint8_of_nat :: \<open>nat \<Rightarrow> uint8\<close>
  is word_of_nat .

lift_definition nat_of_uint8 :: \<open>uint8 \<Rightarrow> nat\<close>
  is unat .

lift_definition uint8_of_int :: \<open>int \<Rightarrow> uint8\<close>
  is word_of_int .

lift_definition int_of_uint8 :: \<open>uint8 \<Rightarrow> int\<close>
  is uint .

context
  includes integer.lifting
begin

lift_definition Uint8 :: \<open>integer \<Rightarrow> uint8\<close>
  is word_of_int .

lift_definition integer_of_uint8 :: \<open>uint8 \<Rightarrow> integer\<close>
  is uint .

end

global_interpretation uint8: word_type_copy_more Abs_uint8 Rep_uint8 signed_drop_bit_uint8
  uint8_of_nat nat_of_uint8 uint8_of_int int_of_uint8 Uint8 integer_of_uint8
  apply standard
       apply (simp_all add: uint8_of_nat.rep_eq nat_of_uint8.rep_eq
         uint8_of_int.rep_eq int_of_uint8.rep_eq
         Uint8.rep_eq integer_of_uint8.rep_eq integer_eq_iff)
  done

instantiation uint8 :: "{size, msb, lsb, set_bit, bit_comprehension}"
begin

lift_definition size_uint8 :: \<open>uint8 \<Rightarrow> nat\<close> is size .

lift_definition msb_uint8 :: \<open>uint8 \<Rightarrow> bool\<close> is msb .
lift_definition lsb_uint8 :: \<open>uint8 \<Rightarrow> bool\<close> is lsb .

text \<open>Workaround: avoid name space clash by spelling out \<^text>\<open>lift_definition\<close> explicitly.\<close>

definition set_bit_uint8 :: \<open>uint8 \<Rightarrow> nat \<Rightarrow> bool \<Rightarrow> uint8\<close>
  where set_bit_uint8_eq: \<open>set_bit_uint8 a n b = (if b then Bit_Operations.set_bit else unset_bit) n a\<close>

context
  includes lifting_syntax
begin

lemma set_bit_uint8_transfer [transfer_rule]:
  \<open>(cr_uint8 ===> (=) ===> (\<longleftrightarrow>) ===> cr_uint8) Generic_set_bit.set_bit Generic_set_bit.set_bit\<close>
  by (simp only: set_bit_eq [abs_def] set_bit_uint8_eq [abs_def]) transfer_prover

end

lift_definition set_bits_uint8 :: \<open>(nat \<Rightarrow> bool) \<Rightarrow> uint8\<close> is set_bits .
lift_definition set_bits_aux_uint8 :: \<open>(nat \<Rightarrow> bool) \<Rightarrow> nat \<Rightarrow> uint8 \<Rightarrow> uint8\<close> is set_bits_aux .

global_interpretation uint8: word_type_copy_misc Abs_uint8 Rep_uint8 signed_drop_bit_uint8
  uint8_of_nat nat_of_uint8 uint8_of_int int_of_uint8 Uint8 integer_of_uint8 8 set_bits_aux_uint8
  by (standard; transfer) simp_all

instance using uint8.of_class_bit_comprehension
  uint8.of_class_set_bit uint8.of_class_lsb
  by simp_all standard

end

section \<open>Code setup\<close>

code_printing code_module Uint8 \<rightharpoonup> (SML)
\<open>(* Test that words can handle numbers between 0 and 3 *)
val _ = if 3 <= Word.wordSize then () else raise (Fail ("wordSize less than 3"));

structure Uint8 : sig
  val set_bit : Word8.word -> IntInf.int -> bool -> Word8.word
  val shiftl : Word8.word -> IntInf.int -> Word8.word
  val shiftr : Word8.word -> IntInf.int -> Word8.word
  val shiftr_signed : Word8.word -> IntInf.int -> Word8.word
  val test_bit : Word8.word -> IntInf.int -> bool
end = struct

fun set_bit x n b =
  let val mask = Word8.<< (0wx1, Word.fromLargeInt (IntInf.toLarge n))
  in if b then Word8.orb (x, mask)
     else Word8.andb (x, Word8.notb mask)
  end

fun shiftl x n =
  Word8.<< (x, Word.fromLargeInt (IntInf.toLarge n))

fun shiftr x n =
  Word8.>> (x, Word.fromLargeInt (IntInf.toLarge n))

fun shiftr_signed x n =
  Word8.~>> (x, Word.fromLargeInt (IntInf.toLarge n))

fun test_bit x n =
  Word8.andb (x, Word8.<< (0wx1, Word.fromLargeInt (IntInf.toLarge n))) <> Word8.fromInt 0

end; (* struct Uint8 *)\<close>
code_reserved SML Uint8

code_printing code_module Uint8 \<rightharpoonup> (Haskell)
 \<open>module Uint8(Int8, Word8) where

  import Data.Int(Int8)
  import Data.Word(Word8)\<close>
code_reserved Haskell Uint8

text \<open>
  Scala provides only signed 8bit numbers, so we use these and
  implement sign-sensitive operations like comparisons manually.
\<close>

code_printing code_module Uint8 \<rightharpoonup> (Scala)
\<open>object Uint8 {

def less(x: Byte, y: Byte) : Boolean =
  if (x < 0) y < 0 && x < y
  else y < 0 || x < y

def less_eq(x: Byte, y: Byte) : Boolean =
  if (x < 0) y < 0 && x <= y
  else y < 0 || x <= y

def set_bit(x: Byte, n: BigInt, b: Boolean) : Byte =
  if (b)
    (x | (1 << n.intValue)).toByte
  else
    (x & (1 << n.intValue).unary_~).toByte

def shiftl(x: Byte, n: BigInt) : Byte = (x << n.intValue).toByte

def shiftr(x: Byte, n: BigInt) : Byte = ((x & 255) >>> n.intValue).toByte

def shiftr_signed(x: Byte, n: BigInt) : Byte = (x >> n.intValue).toByte

def test_bit(x: Byte, n: BigInt) : Boolean =
  (x & (1 << n.intValue)) != 0

} /* object Uint8 */\<close>
code_reserved Scala Uint8

text \<open>
  Avoid @{term Abs_uint8} in generated code, use @{term Rep_uint8'} instead.
  The symbolic implementations for code\_simp use @{term Rep_uint8}.

  The new destructor @{term Rep_uint8'} is executable.
  As the simplifier is given the [code abstract] equations literally,
  we cannot implement @{term Rep_uint8} directly, because that makes code\_simp loop.

  If code generation raises Match, some equation probably contains @{term Rep_uint8}
  ([code abstract] equations for @{typ uint8} may use @{term Rep_uint8} because
  these instances will be folded away.)

  To convert @{typ "8 word"} values into @{typ uint8}, use @{term "Abs_uint8'"}.
\<close>

definition Rep_uint8' where [simp]: "Rep_uint8' = Rep_uint8"

lemma Rep_uint8'_transfer [transfer_rule]:
  "rel_fun cr_uint8 (=) (\<lambda>x. x) Rep_uint8'"
unfolding Rep_uint8'_def by(rule uint8.rep_transfer)

lemma Rep_uint8'_code [code]: "Rep_uint8' x = (BITS n. bit x n)"
  by transfer (simp add: set_bits_bit_eq)

lift_definition Abs_uint8' :: "8 word \<Rightarrow> uint8" is "\<lambda>x :: 8 word. x" .

lemma Abs_uint8'_code [code]: "Abs_uint8' x = Uint8 (integer_of_int (uint x))"
including integer.lifting by transfer simp

declare [[code drop: "term_of_class.term_of :: uint8 \<Rightarrow> _"]]

lemma term_of_uint8_code [code]:
  defines "TR \<equiv> typerep.Typerep" and "bit0 \<equiv> STR ''Numeral_Type.bit0''" shows
  "term_of_class.term_of x =
   Code_Evaluation.App (Code_Evaluation.Const (STR ''Uint8.uint8.Abs_uint8'') (TR (STR ''fun'') [TR (STR ''Word.word'') [TR bit0 [TR bit0 [TR bit0 [TR (STR ''Numeral_Type.num1'') []]]]], TR (STR ''Uint8.uint8'') []]))
       (term_of_class.term_of (Rep_uint8' x))"
by(simp add: term_of_anything)

lemma Uin8_code [code]: "Rep_uint8 (Uint8 i) = word_of_int (int_of_integer_symbolic i)"
unfolding Uint8_def int_of_integer_symbolic_def by(simp add: Abs_uint8_inverse)

code_printing type_constructor uint8 \<rightharpoonup>
  (SML) "Word8.word" and
  (Haskell) "Uint8.Word8" and
  (Scala) "Byte"
| constant Uint8 \<rightharpoonup>
  (SML) "Word8.fromLargeInt (IntInf.toLarge _)" and
  (Haskell) "(Prelude.fromInteger _ :: Uint8.Word8)" and
  (Haskell_Quickcheck) "(Prelude.fromInteger (Prelude.toInteger _) :: Uint8.Word8)" and
  (Scala) "_.byteValue"
| constant "0 :: uint8" \<rightharpoonup>
  (SML) "(Word8.fromInt 0)" and
  (Haskell) "(0 :: Uint8.Word8)" and
  (Scala) "0.toByte"
| constant "1 :: uint8" \<rightharpoonup>
  (SML) "(Word8.fromInt 1)" and
  (Haskell) "(1 :: Uint8.Word8)" and
  (Scala) "1.toByte"
| constant "plus :: uint8 \<Rightarrow> _ \<Rightarrow> _" \<rightharpoonup>
  (SML) "Word8.+ ((_), (_))" and
  (Haskell) infixl 6 "+" and
  (Scala) "(_ +/ _).toByte"
| constant "uminus :: uint8 \<Rightarrow> _" \<rightharpoonup>
  (SML) "Word8.~" and
  (Haskell) "negate" and
  (Scala) "(- _).toByte"
| constant "minus :: uint8 \<Rightarrow> _" \<rightharpoonup>
  (SML) "Word8.- ((_), (_))" and
  (Haskell) infixl 6 "-" and
  (Scala) "(_ -/ _).toByte"
| constant "times :: uint8 \<Rightarrow> _ \<Rightarrow> _" \<rightharpoonup>
  (SML) "Word8.* ((_), (_))" and
  (Haskell) infixl 7 "*" and
  (Scala) "(_ */ _).toByte"
| constant "HOL.equal :: uint8 \<Rightarrow> _ \<Rightarrow> bool" \<rightharpoonup>
  (SML) "!((_ : Word8.word) = _)" and
  (Haskell) infix 4 "==" and
  (Scala) infixl 5 "=="
| class_instance uint8 :: equal \<rightharpoonup> (Haskell) -
| constant "less_eq :: uint8 \<Rightarrow> _ \<Rightarrow> bool" \<rightharpoonup>
  (SML) "Word8.<= ((_), (_))" and
  (Haskell) infix 4 "<=" and
  (Scala) "Uint8.less'_eq"
| constant "less :: uint8 \<Rightarrow> _ \<Rightarrow> bool" \<rightharpoonup>
  (SML) "Word8.< ((_), (_))" and
  (Haskell) infix 4 "<" and
  (Scala) "Uint8.less"
| constant "Bit_Operations.not :: uint8 \<Rightarrow> _" \<rightharpoonup>
  (SML) "Word8.notb" and
  (Haskell) "Data'_Bits.complement" and
  (Scala) "_.unary'_~.toByte"
| constant "Bit_Operations.and :: uint8 \<Rightarrow> _" \<rightharpoonup>
  (SML) "Word8.andb ((_),/ (_))" and
  (Haskell) infixl 7 "Data_Bits..&." and
  (Scala) "(_ & _).toByte"
| constant "Bit_Operations.or :: uint8 \<Rightarrow> _" \<rightharpoonup>
  (SML) "Word8.orb ((_),/ (_))" and
  (Haskell) infixl 5 "Data_Bits..|." and
  (Scala) "(_ | _).toByte"
| constant "Bit_Operations.xor :: uint8 \<Rightarrow> _" \<rightharpoonup>
  (SML) "Word8.xorb ((_),/ (_))" and
  (Haskell) "Data'_Bits.xor" and
  (Scala) "(_ ^ _).toByte"

definition uint8_divmod :: "uint8 \<Rightarrow> uint8 \<Rightarrow> uint8 \<times> uint8" where
  "uint8_divmod x y =
  (if y = 0 then (undefined ((div) :: uint8 \<Rightarrow> _) x (0 :: uint8), undefined ((mod) :: uint8 \<Rightarrow> _) x (0 :: uint8))
  else (x div y, x mod y))"

definition uint8_div :: "uint8 \<Rightarrow> uint8 \<Rightarrow> uint8"
where "uint8_div x y = fst (uint8_divmod x y)"

definition uint8_mod :: "uint8 \<Rightarrow> uint8 \<Rightarrow> uint8"
where "uint8_mod x y = snd (uint8_divmod x y)"

lemma div_uint8_code [code]: "x div y = (if y = 0 then 0 else uint8_div x y)"
  including undefined_transfer unfolding uint8_divmod_def uint8_div_def
by transfer (simp add: word_div_def)

lemma mod_uint8_code [code]: "x mod y = (if y = 0 then x else uint8_mod x y)"
including undefined_transfer unfolding uint8_mod_def uint8_divmod_def
by transfer (simp add: word_mod_def)

definition uint8_sdiv :: "uint8 \<Rightarrow> uint8 \<Rightarrow> uint8"
where
  "uint8_sdiv x y =
   (if y = 0 then undefined ((div) :: uint8 \<Rightarrow> _) x (0 :: uint8)
    else Abs_uint8 (Rep_uint8 x sdiv Rep_uint8 y))"

definition div0_uint8 :: "uint8 \<Rightarrow> uint8"
where [code del]: "div0_uint8 x = undefined ((div) :: uint8 \<Rightarrow> _) x (0 :: uint8)"
declare [[code abort: div0_uint8]]

definition mod0_uint8 :: "uint8 \<Rightarrow> uint8"
where [code del]: "mod0_uint8 x = undefined ((mod) :: uint8 \<Rightarrow> _) x (0 :: uint8)"
declare [[code abort: mod0_uint8]]

lemma uint8_divmod_code [code]:
  "uint8_divmod x y =
  (if 0x80 \<le> y then if x < y then (0, x) else (1, x - y)
   else if y = 0 then (div0_uint8 x, mod0_uint8 x)
   else let q = push_bit 1 (uint8_sdiv (drop_bit 1 x) y);
            r = x - q * y
        in if r \<ge> y then (q + 1, r - y) else (q, r))"
  including undefined_transfer unfolding uint8_divmod_def uint8_sdiv_def div0_uint8_def mod0_uint8_def
    less_eq_uint8.rep_eq
  apply transfer
  apply (simp add: divmod_via_sdivmod push_bit_eq_mult)
  done

lemma uint8_sdiv_code [code]:
  "Rep_uint8 (uint8_sdiv x y) =
   (if y = 0 then Rep_uint8 (undefined ((div) :: uint8 \<Rightarrow> _) x (0 :: uint8))
    else Rep_uint8 x sdiv Rep_uint8 y)"
unfolding uint8_sdiv_def by(simp add: Abs_uint8_inverse)

text \<open>
  Note that we only need a translation for signed division, but not for the remainder
  because @{thm uint8_divmod_code} computes both with division only.
\<close>

code_printing
  constant uint8_div \<rightharpoonup>
  (SML) "Word8.div ((_), (_))" and
  (Haskell) "Prelude.div"
| constant uint8_mod \<rightharpoonup>
  (SML) "Word8.mod ((_), (_))" and
  (Haskell) "Prelude.mod"
| constant uint8_divmod \<rightharpoonup>
  (Haskell) "divmod"
| constant uint8_sdiv \<rightharpoonup>
  (Scala) "(_ '/ _).toByte"

definition uint8_test_bit :: "uint8 \<Rightarrow> integer \<Rightarrow> bool"
where [code del]:
  "uint8_test_bit x n =
  (if n < 0 \<or> 7 < n then undefined (bit :: uint8 \<Rightarrow> _) x n
   else bit x (nat_of_integer n))"

lemma bit_uint8_code [code]:
  "bit x n \<longleftrightarrow> n < 8 \<and> uint8_test_bit x (integer_of_nat n)"
  including undefined_transfer integer.lifting unfolding uint8_test_bit_def
  by (transfer, simp, transfer, simp)

lemma uint8_test_bit_code [code]:
  "uint8_test_bit w n =
  (if n < 0 \<or> 7 < n then undefined (bit :: uint8 \<Rightarrow> _) w n else bit (Rep_uint8 w) (nat_of_integer n))"
  unfolding uint8_test_bit_def
  by (simp add: bit_uint8.rep_eq)

code_printing constant uint8_test_bit \<rightharpoonup>
  (SML) "Uint8.test'_bit" and
  (Haskell) "Data'_Bits.testBitBounded" and
  (Scala) "Uint8.test'_bit" and
  (Eval) "(fn x => fn i => if i < 0 orelse i >= 8 then raise (Fail \"argument to uint8'_test'_bit out of bounds\") else Uint8.test'_bit x i)"

definition uint8_set_bit :: "uint8 \<Rightarrow> integer \<Rightarrow> bool \<Rightarrow> uint8"
where [code del]:
  "uint8_set_bit x n b =
  (if n < 0 \<or> 7 < n then undefined (set_bit :: uint8 \<Rightarrow> _) x n b
   else set_bit x (nat_of_integer n) b)"

lemma set_bit_uint8_code [code]:
  "set_bit x n b = (if n < 8 then uint8_set_bit x (integer_of_nat n) b else x)"
including undefined_transfer integer.lifting unfolding uint8_set_bit_def
by(transfer)(auto cong: conj_cong simp add: not_less set_bit_beyond word_size)

lemma uint8_set_bit_code [code]:
  "Rep_uint8 (uint8_set_bit w n b) =
  (if n < 0 \<or> 7 < n then Rep_uint8 (undefined (set_bit :: uint8 \<Rightarrow> _) w n b)
   else set_bit (Rep_uint8 w) (nat_of_integer n) b)"
including undefined_transfer unfolding uint8_set_bit_def by transfer simp

code_printing constant uint8_set_bit \<rightharpoonup>
  (SML) "Uint8.set'_bit" and
  (Haskell) "Data'_Bits.setBitBounded" and
  (Scala) "Uint8.set'_bit" and
  (Eval) "(fn x => fn i => fn b => if i < 0 orelse i >= 8 then raise (Fail \"argument to uint8'_set'_bit out of bounds\") else Uint8.set'_bit x i b)"

definition uint8_shiftl :: "uint8 \<Rightarrow> integer \<Rightarrow> uint8"
where [code del]:
  "uint8_shiftl x n = (if n < 0 \<or> 8 \<le> n then undefined (push_bit :: nat \<Rightarrow> uint8 \<Rightarrow> _) x n else push_bit (nat_of_integer n) x)"

lemma shiftl_uint8_code [code]:
  "push_bit n x = (if n < 8 then uint8_shiftl x (integer_of_nat n) else 0)"
  including undefined_transfer integer.lifting unfolding uint8_shiftl_def
  by transfer simp

lemma uint8_shiftl_code [code]:
  "Rep_uint8 (uint8_shiftl w n) =
  (if n < 0 \<or> 8 \<le> n then Rep_uint8 (undefined (push_bit :: nat \<Rightarrow> uint8 \<Rightarrow> _) w n)
   else push_bit (nat_of_integer n) (Rep_uint8 w))"
  including undefined_transfer unfolding uint8_shiftl_def
  by transfer simp

code_printing constant uint8_shiftl \<rightharpoonup>
  (SML) "Uint8.shiftl" and
  (Haskell) "Data'_Bits.shiftlBounded" and
  (Scala) "Uint8.shiftl" and
  (Eval) "(fn x => fn i => if i < 0 orelse i >= 8 then raise (Fail \"argument to uint8'_shiftl out of bounds\") else Uint8.shiftl x i)"

definition uint8_shiftr :: "uint8 \<Rightarrow> integer \<Rightarrow> uint8"
where [code del]:
  "uint8_shiftr x n = (if n < 0 \<or> 8 \<le> n then undefined (drop_bit :: _ \<Rightarrow> _ \<Rightarrow> uint8) x n else drop_bit (nat_of_integer n) x)"

lemma shiftr_uint8_code [code]:
  "drop_bit n x = (if n < 8 then uint8_shiftr x (integer_of_nat n) else 0)"
  including undefined_transfer integer.lifting unfolding uint8_shiftr_def
  by transfer simp

lemma uint8_shiftr_code [code]:
  "Rep_uint8 (uint8_shiftr w n) =
  (if n < 0 \<or> 8 \<le> n then Rep_uint8 (undefined (drop_bit :: _ \<Rightarrow> _ \<Rightarrow> uint8) w n)
   else drop_bit (nat_of_integer n) (Rep_uint8 w))"
including undefined_transfer unfolding uint8_shiftr_def by transfer simp

code_printing constant uint8_shiftr \<rightharpoonup>
  (SML) "Uint8.shiftr" and
  (Haskell) "Data'_Bits.shiftrBounded" and
  (Scala) "Uint8.shiftr" and
  (Eval) "(fn x => fn i => if i < 0 orelse i >= 8 then raise (Fail \"argument to uint8'_shiftr out of bounds\") else Uint8.shiftr x i)"

definition uint8_sshiftr :: "uint8 \<Rightarrow> integer \<Rightarrow> uint8"
where [code del]:
  "uint8_sshiftr x n =
  (if n < 0 \<or> 8 \<le> n then undefined signed_drop_bit_uint8 n x else signed_drop_bit_uint8 (nat_of_integer n) x)"

lemma sshiftr_uint8_code [code]:
  "signed_drop_bit_uint8 n x =
  (if n < 8 then uint8_sshiftr x (integer_of_nat n) else if bit x 7 then -1 else 0)"
  including undefined_transfer integer.lifting unfolding uint8_sshiftr_def
  by transfer (simp add: not_less signed_drop_bit_beyond word_size)

lemma uint8_sshiftr_code [code]:
  "Rep_uint8 (uint8_sshiftr w n) =
  (if n < 0 \<or> 8 \<le> n then Rep_uint8 (undefined signed_drop_bit_uint8 n w)
   else signed_drop_bit (nat_of_integer n) (Rep_uint8 w))"
  including undefined_transfer unfolding uint8_sshiftr_def
  by transfer simp

code_printing constant uint8_sshiftr \<rightharpoonup>
  (SML) "Uint8.shiftr'_signed" and
  (Haskell)
    "(Prelude.fromInteger (Prelude.toInteger (Data'_Bits.shiftrBounded (Prelude.fromInteger (Prelude.toInteger _) :: Uint8.Int8) _)) :: Uint8.Word8)" and
  (Scala) "Uint8.shiftr'_signed" and
  (Eval) "(fn x => fn i => if i < 0 orelse i >= 8 then raise (Fail \"argument to uint8'_sshiftr out of bounds\") else Uint8.shiftr'_signed x i)"

context
  includes bit_operations_syntax
begin

lemma uint8_msb_test_bit: "msb x \<longleftrightarrow> bit (x :: uint8) 7"
  by transfer (simp add: msb_word_iff_bit)

lemma msb_uint16_code [code]: "msb x \<longleftrightarrow> uint8_test_bit x 7"
  by (simp add: uint8_test_bit_def uint8_msb_test_bit)

lemma uint8_of_int_code [code]:
  "uint8_of_int i = Uint8 (integer_of_int i)"
  including integer.lifting by transfer simp

lemma int_of_uint8_code [code]:
  "int_of_uint8 x = int_of_integer (integer_of_uint8 x)"
  by (simp add: int_of_uint8.rep_eq integer_of_uint8_def)

lemma uint8_of_nat_code [code]:
  "uint8_of_nat = uint8_of_int \<circ> int"
  by transfer (simp add: fun_eq_iff)

lemma nat_of_uint8_code [code]:
  "nat_of_uint8 x = nat_of_integer (integer_of_uint8 x)"
  unfolding integer_of_uint8_def including integer.lifting by transfer simp

definition integer_of_uint8_signed :: "uint8 \<Rightarrow> integer"
where
  "integer_of_uint8_signed n = (if bit n 7 then undefined integer_of_uint8 n else integer_of_uint8 n)"

lemma integer_of_uint8_signed_code [code]:
  "integer_of_uint8_signed n =
  (if bit n 7 then undefined integer_of_uint8 n else integer_of_int (uint (Rep_uint8' n)))"
  by (simp add: integer_of_uint8_signed_def integer_of_uint8_def)

end

code_printing
  constant "integer_of_uint8" \<rightharpoonup>
  (SML) "IntInf.fromLarge (Word8.toLargeInt _)" and
  (Haskell) "Prelude.toInteger"
| constant "integer_of_uint8_signed" \<rightharpoonup>
  (Scala) "BigInt"

section \<open>Quickcheck setup\<close>

definition uint8_of_natural :: "natural \<Rightarrow> uint8"
where "uint8_of_natural x \<equiv> Uint8 (integer_of_natural x)"

instantiation uint8 :: "{random, exhaustive, full_exhaustive}" begin
definition "random_uint8 \<equiv> qc_random_cnv uint8_of_natural"
definition "exhaustive_uint8 \<equiv> qc_exhaustive_cnv uint8_of_natural"
definition "full_exhaustive_uint8 \<equiv> qc_full_exhaustive_cnv uint8_of_natural"
instance ..
end

instantiation uint8 :: narrowing begin

interpretation quickcheck_narrowing_samples
  "\<lambda>i. let x = Uint8 i in (x, 0xFF - x)" "0"
  "Typerep.Typerep (STR ''Uint8.uint8'') []" .

definition "narrowing_uint8 d = qc_narrowing_drawn_from (narrowing_samples d) d"
declare [[code drop: "partial_term_of :: uint8 itself \<Rightarrow> _"]]
lemmas partial_term_of_uint8 [code] = partial_term_of_code

instance ..
end

end


theory NuInstructions
  imports NuPrime NuLLReps
begin

subsection \<open>Basic sequential instructions\<close>

(* definition op_crash :: "('x::stack) \<longmapsto> ('y::stack)" where "op_crash _ = PartialCorrect" *)

definition op_drop :: "('a::lrep) \<times> ('r::stack) \<longmapsto> 'r" where
  "op_drop x = (case x of (h,a,r) \<Rightarrow> Success (h,r))"

(* definition op_dup :: " ('r,'r,'x,'x) index \<Rightarrow> ('r::stack) \<longmapsto> ('x \<times> 'r)"
  where "op_dup idx = (\<lambda>(h,r). Success (h, get_idx idx r, r))" *)

definition op_dup :: " ('x::lrep \<times> 'r::stack) \<longmapsto> ('x \<times> 'x \<times> 'r)"
  where "op_dup = (\<lambda>(h,x,r). Success (h, x, x, r))"

definition op_pair :: "('a::lrep) \<times> ('b::lrep) \<times> ('r::stack) \<longmapsto> (('b \<times> 'a) \<times> 'r)"
  where "op_pair = (\<lambda>(h,a,b,r). Success (h,(b,a),r))"

definition op_depair :: "(('b::lrep) \<times> ('a::lrep)) \<times> ('r::stack) \<longmapsto> ('a \<times> 'b \<times> 'r)"
  where "op_depair = (\<lambda>(h,(b,a),r). Success (h,a,b,r))"

definition op_let :: " ('v::lrep \<Rightarrow> 's::stack \<longmapsto> 't::stack) \<Rightarrow> ('v \<times> 's \<longmapsto> 't)"
  where "op_let body = (\<lambda>(h,v,s). body v (h,s))"

definition op_local_value :: " 'v::lrep \<Rightarrow> 's::stack \<longmapsto> 'v \<times> 's "
  where "op_local_value v = (\<lambda>(h,s). Success (h,v,s))"

subsection \<open>Branches & Loops\<close>

definition op_sel :: " 'a itself \<Rightarrow> (1 word \<times> 'a \<times> 'a \<times> 'r) \<longmapsto> ('a \<times> 'r)"
  where "op_sel _ s = (case s of (heap,c,b,a,r) \<Rightarrow> if c = 1 then Success (heap,a,r) else Success (heap,b,r))"

definition op_if :: " 't itself \<Rightarrow> ('s::stack \<longmapsto> 't::stack) \<Rightarrow> ('s \<longmapsto> 't) \<Rightarrow> (1 word \<times> 's) \<longmapsto> 't"
  where "op_if _ brT brF s = (case s of (heap,c,r) \<Rightarrow> if c = 1 then brT (heap,r) else brF (heap,r))"

inductive SemDoWhile :: "('r \<longmapsto> 1 word \<times> 'r) \<Rightarrow> heap \<times> 'r \<Rightarrow> 'r state \<Rightarrow> bool" where
  "f s = Success (h,0,r) \<Longrightarrow> SemDoWhile f s (Success (h,r))"
| "f s = PartialCorrect \<Longrightarrow> SemDoWhile f s PartialCorrect"
| "f s = Fail \<Longrightarrow> SemDoWhile f s Fail"
| "f s = Success (h,1,r) \<Longrightarrow> SemDoWhile f (h,r) s'' \<Longrightarrow> SemDoWhile f s s''"

lemma "\<nexists> y. SemDoWhile (\<lambda>(h,r). Success (h,1,r)) (h,r) y"
  apply rule apply (elim exE) subgoal for y
    apply (induct "(\<lambda>(h, r). Success (h, (1::1 word), (r::'a)))" "(h, r)" y rule: SemDoWhile.induct)
       apply simp_all
    done done

definition op_do_while :: " 'r itself \<Rightarrow> ('r \<longmapsto> 1 word \<times> 'r) \<Rightarrow> 'r \<longmapsto> 'r" where
  "op_do_while _ f s = (if (\<exists>y. SemDoWhile f s y) then The (SemDoWhile f s) else PartialCorrect)"

inductive SemRec :: "(('x \<longmapsto> 'y) \<Rightarrow> ('x \<longmapsto> 'y)) \<Rightarrow> heap \<times> 'x \<Rightarrow> 'y state \<Rightarrow> bool" where
  SemRec_I0: "(\<And>g. F g x = y) \<Longrightarrow> SemRec F x y"
| SemRec_IS: "SemRec (F o F) x y \<Longrightarrow> SemRec F x y"

definition op_recursion :: "uniq_id \<Rightarrow> 'x::stack itself \<Rightarrow> 'y::stack itself \<Rightarrow> (('x \<longmapsto> 'y) \<Rightarrow> ('x \<longmapsto> 'y)) \<Rightarrow> 'x \<longmapsto> 'y"
  where "op_recursion _ _ _ F s = (if (\<exists>t. SemRec F s t) then The (SemRec F s) else PartialCorrect)"

section \<open>Arithmetic instructions\<close>

subsection \<open>Integer arithmetic\<close>

definition op_const_int :: "('w::len) itself \<Rightarrow> nat \<Rightarrow> ('r::stack) \<longmapsto> 'w word \<times> 'r"
  where "op_const_int _ c = (\<lambda>(heap,r). Success (heap,of_nat c,r))"

definition op_const_size_t :: " nat \<Rightarrow> ('r::stack) \<longmapsto> size_t word \<times> 'r"
  where "op_const_size_t c = (\<lambda>(heap,r).
    if c < 2 ^ addrspace_capacity then Success (heap,of_nat c,r) else PartialCorrect)"
    \<comment> \<open> `op_const_size_t` checks overflow during the compilation towards certain decided platform.  \<close>

definition op_add :: "'a itself \<Rightarrow> ('a::len) word \<times> ('a::len) word \<times> ('r::lrep) \<longmapsto> ('a::len) word \<times> 'r"
  where "op_add _ = (\<lambda>(h,a,b,r). Success (h,a+b, r))"
declare op_add_def[\<nu>instr]

definition op_sub :: "('a::len) itself \<Rightarrow> 'a word \<times> 'a word \<times> ('r::lrep) \<longmapsto> 'a word \<times> 'r"
  where "op_sub _ = (\<lambda>(h,a,b,r) \<Rightarrow> Success (h,b - a, r))"
declare op_sub_def[\<nu>instr]

definition op_udiv ::  "('a::len) itself \<Rightarrow> 'a word \<times> 'a word \<times> ('r::lrep) \<longmapsto> 'a word \<times> 'r"
  where "op_udiv _ = (\<lambda>(h,a,b,r) \<Rightarrow> Success (h,b div a, r))"
declare op_udiv_def[\<nu>instr]

definition op_lt :: " ('w::len) itself \<Rightarrow> 'w word \<times> 'w word \<times> ('r::lrep) \<longmapsto> 1 word \<times> 'r"
  where "op_lt _ = (\<lambda>(h,a,b,r).  Success (h, (if  b < a then 1 else 0), r))"
declare op_lt_def[\<nu>instr]

definition op_le :: " ('w::len) itself \<Rightarrow> 'w word \<times> 'w word \<times> ('r::lrep) \<longmapsto> 1 word \<times> 'r "
  where "op_le _ = (\<lambda>(h,a,b,r).  Success (h, (if  b \<le> a then 1 else 0), r))"

definition op_not :: "('w::len) itself \<Rightarrow> 'w word \<times> ('r::stack) \<longmapsto> 'w word \<times> 'r"
  where "op_not len = (\<lambda>(h,x,r). Success (h,not x,r))"

definition op_and :: "('w::len) itself \<Rightarrow> 'w word \<times> 'w word \<times> ('r::stack) \<longmapsto> 'w word \<times> 'r"
  where "op_and len = (\<lambda>(h,y,x,r). Success (h,and x y,r))"

definition op_or :: "('w::len) itself \<Rightarrow> 'w word \<times> 'w word \<times> ('r::stack) \<longmapsto> 'w word \<times> 'r"
  where "op_or len = (\<lambda>(h,y,x,r). Success (h,or x y,r))"

definition op_equal :: " 'a itself \<Rightarrow> ('a::{ceq,lrep}) \<times> 'a \<times> ('r::stack) \<longmapsto> 1 word \<times> 'r"
  where "op_equal _ = (\<lambda>(h,a,b,r). if ceqable h b a then Success (h,(if ceq b a then 1 else 0), r) else Fail)"

section \<open>Tuple Operations\<close>

definition cons_tup :: " 'a itself \<Rightarrow> ('a::field) \<times> ('r::stack) \<longmapsto> 'a tuple \<times> 'r"
  where "cons_tup _ = (\<lambda>(h,a,r). Success (h, Tuple a, r))"

definition op_dest_tup :: " 'a itself \<Rightarrow> ('a::field) tuple \<times> ('r::stack) \<longmapsto> 'a \<times> 'r"
  where "op_dest_tup _ s = (case s of (h,Tuple a, r) \<Rightarrow> Success (h,a,r))"

definition op_get_tuple :: "('a tuple,'a tuple,'x,'x) index \<Rightarrow> 'a itself \<Rightarrow> 'a tuple \<times> ('r::stack) \<longmapsto> ('x::lrep) \<times> 'r"
  where "op_get_tuple idx _ = (\<lambda>(h,a,r). Success (h,get_idx idx a,r))"

definition op_set_tuple ::
    "('a tuple,'b tuple,'x,'y) index \<Rightarrow> 'a itself \<Rightarrow> 'y itself \<Rightarrow> ('y::lrep) \<times> 'a tuple \<times> ('r::stack) \<longmapsto> 'b tuple \<times> 'r"
  where "op_set_tuple idx _ _ = (\<lambda>(h,y,a,r). Success (h, map_idx idx (\<lambda>_. y) a, r))"

section \<open>Field Index\<close>

definition index_tuple :: "(('a::field),('b::field),'x,'y) index \<Rightarrow> ('a tuple, 'b tuple, 'x, 'y) index"
  where "index_tuple adr = (case adr of Index g m \<Rightarrow> Index (case_tuple g) (map_tuple o m))"

section \<open>Memory & Pointer Operations\<close>

definition op_shift_pointer :: "'y::lrep itself \<Rightarrow> size_t word \<times> memptr \<times> 'r::stack \<longmapsto> memptr \<times> 'r::stack"
  where "op_shift_pointer ty s = (case s of (heap, delta, memptr (seg |+ ofs), r) \<Rightarrow>
    Success (heap, memptr (seg |+ (ofs + delta * of_nat (size_of LLTY('y)))), r))"

definition "heap_assignN n v seg heap = (\<lambda>key. case key of MemAddress (seg' |+ ofs') \<Rightarrow>
      if seg' = seg \<and> ofs' < n then v else
      if seg' = seg \<and> ofs' = n then Some DM_void else heap key | _ \<Rightarrow> heap key)"

definition op_alloc :: "('x::{zero,field}) itself \<Rightarrow> size_t word \<times> ('r::stack) \<longmapsto> memptr \<times>'r"
  where "op_alloc _ s = (case s of (heap,n,r) \<Rightarrow>  let seg = malloc heap in
  if segment_len seg = unat n \<and> segment_llty seg = LLTY('x) then
    Success (heap_assignN (unat n) (Some (deepize (0 :: 'x))) seg heap, memptr (seg |+ 0), r)
  else PartialCorrect)"

definition op_load :: " 'x itself \<Rightarrow> 'a itself \<Rightarrow> ('a::lrep,'a,'x,'x) index \<Rightarrow> memptr \<times> ('r::stack) \<longmapsto> 'x::field \<times>'r "
  where "op_load _ _ idx s = (case s of (heap, memptr adr, r) \<Rightarrow>
    (case heap (MemAddress (logical_addr_of adr)) of Some data \<Rightarrow>
       Success (heap, get_idx idx (shallowize data), r) | _ \<Rightarrow> Fail))"

definition op_store :: " 'x itself \<Rightarrow> 'a itself \<Rightarrow> ('a::lrep,'a,'x,'x) index \<Rightarrow> 'x::field \<times> memptr \<times> ('r::stack) \<longmapsto> 'r "
  where "op_store _ _ idx s = (case s of (heap, x, memptr addr, r) \<Rightarrow>
    (let key = MemAddress (logical_addr_of addr) in
    case heap key of Some data \<Rightarrow>
      Success (heap(key \<mapsto> map_deepmodel (map_idx idx (\<lambda>_. x)) data), r) | _ \<Rightarrow> Fail))"

definition op_free :: " memptr \<times> ('r::stack) \<longmapsto> 'r "
  where "op_free s = (case s of (h,memptr (base |+ ofs),r) \<Rightarrow>
    (if ofs = 0 then Success (h |` (-{MemAddress (base |+ ofs) | ofs. True}), r) else Fail))"

end