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

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

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

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

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

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

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

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

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

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

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

subsection\<open>Basic definitions\<close>

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

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

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

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

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

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

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

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

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

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

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

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

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

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

subsection\<open>Type system\<close>

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

subsection\<open>Soundness results\<close>

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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


(* Author: Peter Lammich *)

theory DiffArray_Base
imports
  Main
  "HOL-Library.Code_Target_Numeral"

begin

subsection \<open>Additional List Operations\<close>

definition "tabulate n f = map f [0..<n]"

context
  notes [simp] = tabulate_def
begin

lemma tabulate0[simp]: "tabulate 0 f = []" by simp

lemma tabulate_Suc: "tabulate (Suc n) f = tabulate n f @ [f n]" by simp

lemma tabulate_Suc': "tabulate (Suc n) f = f 0 # tabulate n (f o Suc)"
  by (simp add: map_upt_Suc del: upt_Suc)

lemma tabulate_const[simp]: "tabulate n (\<lambda>_. c) = replicate n c" by (auto simp: map_replicate_trivial)

lemma length_tabulate[simp]: "length (tabulate n f) = n" by simp
lemma nth_tabulate[simp]: "i<n \<Longrightarrow> tabulate n f ! i = f i" by simp

lemma upd_tabulate: "(tabulate n f)[i:=x] = tabulate n (f(i:=x))"
  apply (induction n)
  by (auto simp: list_update_append split: nat.split)

lemma take_tabulate: "take n (tabulate m f) = tabulate (min n m) f"
  by (simp add: min_def take_map)

lemma hd_tabulate[simp]: "n\<noteq>0 \<Longrightarrow> hd (tabulate n f) = f 0"
  by (cases n) (simp add: map_upt_Suc del: upt_Suc)+

lemma tl_tabulate: "tl (tabulate n f) = tabulate (n-1) (f o Suc)"
  apply (simp add: map_upt_Suc map_Suc_upt del: upt_Suc flip: map_tl map_map)
  by (cases n; simp)

lemma tabulate_cong[fundef_cong]: "n=n' \<Longrightarrow> (\<And>i. i<n \<Longrightarrow> f i = f' i) \<Longrightarrow> tabulate n f = tabulate n' f'"
  by simp

lemma tabulate_nth_take: "n \<le> length xs \<Longrightarrow> tabulate n ((!) xs) = take n xs"
  by (rule nth_equalityI, auto)

end

lemma drop_tabulate: "drop n (tabulate m f) = tabulate (m-n) (f o (+)n)"
  apply (induction n arbitrary: m f)
  apply (auto simp: drop_Suc drop_tl tl_tabulate comp_def)
  done

subsection \<open>Primitive Operations\<close>

typedef 'a array = "UNIV :: 'a list set"
  morphisms array_\<alpha> Array
  by blast
setup_lifting type_definition_array

lift_definition array_new :: "nat \<Rightarrow> 'a \<Rightarrow> 'a array" is "\<lambda>n a. replicate n a" .

lift_definition array_tabulate :: "nat \<Rightarrow> (nat \<Rightarrow> 'a) \<Rightarrow> 'a array" is "\<lambda>n f. Array (tabulate n f)" .

lift_definition array_length :: "'a array \<Rightarrow> nat" is length .

lift_definition array_get :: "'a array \<Rightarrow> nat \<Rightarrow> 'a" is nth .

lift_definition array_set :: "'a array \<Rightarrow> nat \<Rightarrow> 'a \<Rightarrow> 'a array" is list_update .

lift_definition array_of_list :: "'a list \<Rightarrow> 'a array" is \<open>\<lambda>x. x\<close> .

subsubsection \<open>Refinement Lemmas\<close>

named_theorems array_refine
context
  notes [simp] = Array_inverse
begin

  lemma array_\<alpha>_inj: "array_\<alpha> a = array_\<alpha> b \<Longrightarrow> a=b" by transfer auto

  lemma array_eq_iff: "a=b \<longleftrightarrow> array_\<alpha> a = array_\<alpha> b" by transfer auto

  lemma array_new_refine[simp,array_refine]: "array_\<alpha> (array_new n a) = replicate n a" by transfer auto

  lemma array_tabulate_refine[simp,array_refine]: "array_\<alpha> (array_tabulate n f) = tabulate n f" by transfer auto

  lemma array_length_refine[simp,array_refine]: "array_length a = length (array_\<alpha> a)" by transfer auto

  lemma array_get_refine[simp,array_refine]: "array_get a i = array_\<alpha> a ! i" by transfer auto

  lemma array_set_refine[simp,array_refine]: "array_\<alpha> (array_set a i x) = (array_\<alpha> a)[i := x]" by transfer auto

  lemma array_of_list_refine[simp,array_refine]: "array_\<alpha> (array_of_list xs) = xs" by transfer auto

end

lifting_update array.lifting
lifting_forget array.lifting

subsection \<open>Basic Derived Operations\<close>
text \<open>These operations may have direct implementations in target language\<close>

definition "array_grow a n dflt = (
  let la = array_length a in
  array_tabulate n (\<lambda>i. if i<la then array_get a i else dflt)
)"

lemma tabulate_grow: "tabulate n (\<lambda>i. if i < length xs then xs!i else d) = take n xs @ (replicate (n-length xs) d)"
  apply (induction n)
  apply (auto simp: tabulate_Suc take_Suc_conv_app_nth replicate_append_same Suc_diff_le)
  done

lemma array_grow_refine[simp,array_refine]:
  "array_\<alpha> (array_grow a n d) = take n (array_\<alpha> a) @ replicate (n-length (array_\<alpha> a)) d"
  by (auto simp: array_grow_def tabulate_grow cong: if_cong)

definition "array_take a n = (
  let n = min (array_length a) n in
  array_tabulate n (array_get a)
)"

lemma tabulate_take: "tabulate (min (length xs) n) ((!) xs) = take n xs"
  by (auto simp: min_def tabulate_nth_take)

lemma array_take_refine[simp,array_refine]: "array_\<alpha> (array_take a n) = take n (array_\<alpha> a)"
  by (auto simp: array_take_def tabulate_take cong: tabulate_cong)

text \<open>The following is a total version of
  \<open>array_get\<close>, which returns a default
  value in case the index is out of bounds.
  This can be efficiently implemented in the target language by catching
  exceptions.
\<close>
definition "array_get_oo x a i \<equiv>
  if i<array_length a then array_get a i else x"

lemma array_get_oo_refine[simp,array_refine]: "array_get_oo x a i = (if i<length (array_\<alpha> a) then array_\<alpha> a!i else x)"
  by (simp add: array_get_oo_def)

definition "array_set_oo f a i x \<equiv>
  if i<array_length a then array_set a i x else f()"

lemma array_set_oo_refine[simp,array_refine]: "array_\<alpha> (array_set_oo f a i x)
  = (if i<length (array_\<alpha> a) then (array_\<alpha> a)[i:=x] else array_\<alpha> (f ()))"
  by (simp add: array_set_oo_def)

text \<open>
  Map array. No old versions for intermediate results need to be tracked,
  which allows more efficient in-place implementation in case access to old
  versions is forbidden.
\<close>
definition "array_map f a \<equiv> array_tabulate (array_length a) (f o array_get a)"

lemma array_map_refine[simp,array_refine]: "array_\<alpha> (array_map f a) = map f (array_\<alpha> a)"
  unfolding array_map_def
  apply (auto simp: tabulate_def simp flip: map_map cong: map_cong)
  by (smt (z3) atLeastLessThan_iff length_map map_eq_conv map_nth nth_map set_upt)

lemma array_map_cong[fundef_cong]: "a=a' \<Longrightarrow> (\<And>x. x\<in>set (array_\<alpha> a) \<Longrightarrow> f x = f' x) \<Longrightarrow> array_map f a = array_map f' a'"
  by (simp add: array_eq_iff)

context
  fixes f :: "'a \<Rightarrow> 's \<Rightarrow> 's" and xs :: "'a list"
begin
function foldl_idx where
  "foldl_idx i s = (if i<length xs then foldl_idx (i+1) (f (xs!i) s) else s)"
  by pat_completeness auto
termination
  apply (relation "measure (\<lambda>(i,_). length xs - i)")
  apply auto
  done

lemmas [simp del] = foldl_idx.simps

lemma foldl_idx_eq: "foldl_idx i s = fold f (drop i xs) s"
  apply (induction i s rule: foldl_idx.induct)
  apply (subst foldl_idx.simps)
  apply (auto simp flip: Cons_nth_drop_Suc)
  done

lemma fold_by_idx: "fold f xs s = foldl_idx 0 s" using foldl_idx_eq by simp

end

fun foldr_idx where
  "foldr_idx f xs 0 s = s"
| "foldr_idx f xs (Suc i) s = foldr_idx f xs i (f (xs!i) s)"

lemma foldr_idx_eq: "i\<le>length xs \<Longrightarrow> foldr_idx f xs i s = foldr f (take i xs) s"
  apply (induction i arbitrary: s)
  apply (auto simp: take_Suc_conv_app_nth)
  done

lemma foldr_by_idx: "foldr f xs s = foldr_idx f xs (length xs) s" apply (subst foldr_idx_eq) by auto

context
  fixes f :: "'a \<Rightarrow> 's \<Rightarrow> 's" and a :: "'a array"
begin

function array_foldl_idx where
  "array_foldl_idx i s = (if i<array_length a then array_foldl_idx (i+1) (f (array_get a i) s) else s)"
  by pat_completeness auto
termination
  apply (relation "measure (\<lambda>(i,_). array_length a - i)")
  apply auto
  done

lemmas [simp del] = array_foldl_idx.simps

end

lemma array_foldl_idx_refine[simp, array_refine]: "array_foldl_idx f a i s = foldl_idx f (array_\<alpha> a) i s"
  apply (induction i s rule: foldl_idx.induct)
  apply (subst array_foldl_idx.simps)
  apply (subst foldl_idx.simps)
  by fastforce

definition "array_fold f a s \<equiv> array_foldl_idx f a 0 s"
lemma array_fold_refine[simp, array_refine]: "array_fold f a s = fold f (array_\<alpha> a) s"
  unfolding array_fold_def
  by (simp add: fold_by_idx)

fun array_foldr_idx where
  "array_foldr_idx f xs 0 s = s"
| "array_foldr_idx f xs (Suc i) s = array_foldr_idx f xs i (f (array_get xs i) s)"

lemma array_foldr_idx_refine[simp, array_refine]: "array_foldr_idx f xs i s = foldr_idx f (array_\<alpha> xs) i s"
  apply (induction i arbitrary: s)
  by auto

definition "array_foldr f xs s \<equiv> array_foldr_idx f xs (array_length xs) s"

lemma array_foldr_refine[simp, array_refine]: "array_foldr f xs s = foldr f (array_\<alpha> xs) s"
  by (simp add: array_foldr_def foldr_by_idx)

subsection \<open>Code Generator Setup\<close>

subsubsection \<open>Code-Numeral Preparation\<close>

definition [code del]: "array_new' == array_new o nat_of_integer"
definition [code del]: "array_tabulate' n f \<equiv> array_tabulate (nat_of_integer n) (f o integer_of_nat)"

definition [code del]: "array_length' == integer_of_nat o array_length"
definition [code del]: "array_get' a == array_get a o nat_of_integer"
definition [code del]: "array_set' a == array_set a o nat_of_integer"
definition [code del]:
  "array_get_oo' x a == array_get_oo x a o nat_of_integer"
definition [code del]:
  "array_set_oo' f a == array_set_oo f a o nat_of_integer"

text \<open>Fallbacks\<close>

lemmas array_get_oo'_fallback[code] = array_get_oo'_def[unfolded array_get_oo_def[abs_def]]
lemmas array_set_oo'_fallback[code] = array_set_oo'_def[unfolded array_set_oo_def[abs_def]]

lemma array_tabulate'_fallback[code]:
  "array_tabulate' n f = array_of_list (map (f o integer_of_nat) [0..<nat_of_integer n])"
  unfolding array_tabulate'_def
  by (simp add: array_eq_iff tabulate_def)

lemma array_new'_fallback[code]: "array_new' n x = array_of_list (replicate (nat_of_integer n) x)"
  by (simp add: array_new'_def array_eq_iff)

(*
  Primitive operations, to be implemented for target:

    array_of_list
    array_tabulate' (dflt via of_list)
    array_new' (dflt via of_list)

    array_length'
    array_get'
    array_set'
    array_get_oo' (dflt via array_get)

*)

subsubsection \<open>Haskell\<close>

code_printing type_constructor array \<rightharpoonup>
  (Haskell) "Array.ArrayType/ _"

code_reserved Haskell array_of_list

(*
code_printing code_module "Array" \<rightharpoonup>
  (Haskell) {*
--import qualified Data.Array.Diff as Arr;
import qualified Data.Array as Arr;
import Data.Array.IArray;
import Nat;

instance Ix Nat where {
    range (Nat a, Nat b) = map Nat (range (a, b));
    index (Nat a, Nat b) (Nat c) = index (a,b) c;
    inRange (Nat a, Nat b) (Nat c) = inRange (a, b) c;
    rangeSize (Nat a, Nat b) = rangeSize (a, b);
};

type ArrayType = Arr.DiffArray Nat;
--type ArrayType = Arr.Array Nat;

-- we need to start at 1 and not 0, because the empty array
-- is modelled by having s > e for (s,e) = bounds
-- and as we are in Nat, 0 is the smallest number

array_of_size :: Nat -> [e] -> ArrayType e;
array_of_size n = Arr.listArray (1, n);

array_new :: e -> Nat -> ArrayType e;
array_new a n = array_of_size n (repeat a);

array_length :: ArrayType e -> Nat;
array_length a = let (s, e) = bounds a in if s > e then 0 else e - s + 1;
-- the `if` is actually needed, because in Nat we have s > e --> e - s + 1 = 1

array_get :: ArrayType e -> Nat -> e;
array_get a i = a ! (i + 1);

array_set :: ArrayType e -> Nat -> e -> ArrayType e;
array_set a i e = a // [(i + 1, e)];

array_of_list :: [e] -> ArrayType e;
array_of_list xs = array_of_size (fromInteger (toInteger (length xs - 1))) xs;

array_grow :: ArrayType e -> Nat -> e -> ArrayType e;
array_grow a i x = let (s, e) = bounds a in Arr.listArray (s, e+i) (Arr.elems a ++ repeat x);

array_shrink :: ArrayType e -> Nat -> ArrayType e;
array_shrink a sz = if sz > array_length a then undefined else array_of_size sz (Arr.elems a);
*}
*)

(* TODO/FIXME: Using standard functional arrays here, as DiffArray seems
  to be discontinued in Haskell! *)
code_printing code_module "Array" \<rightharpoonup>
  (Haskell) \<open>module Array where {

--import qualified Data.Array.Diff as Arr;
import qualified Data.Array as Arr;

type ArrayType = Arr.Array Integer;

array_of_size :: Integer -> [e] -> ArrayType e;
array_of_size n = Arr.listArray (0, n-1);

array_new :: Integer -> e -> ArrayType e;
array_new n a = array_of_size n (repeat a);

array_length :: ArrayType e -> Integer;
array_length a = let (s, e) = Arr.bounds a in e;

array_get :: ArrayType e -> Integer -> e;
array_get a i = a Arr.! i;

array_set :: ArrayType e -> Integer -> e -> ArrayType e;
array_set a i e = a Arr.// [(i, e)];

array_of_list :: [e] -> ArrayType e;
array_of_list xs = array_of_size (toInteger (length xs)) xs;

}\<close>

code_printing constant Array \<rightharpoonup> (Haskell) "Array.array'_of'_list"
code_printing constant array_new' \<rightharpoonup> (Haskell) "Array.array'_new"
code_printing constant array_length' \<rightharpoonup> (Haskell) "Array.array'_length"
code_printing constant array_get' \<rightharpoonup> (Haskell) "Array.array'_get"
code_printing constant array_set' \<rightharpoonup> (Haskell) "Array.array'_set"
code_printing constant array_of_list \<rightharpoonup> (Haskell) "Array.array'_of'_list"

subsubsection \<open>SML\<close>

text \<open>
  We have the choice between single-threaded arrays, that raise an exception if an old version is accessed,
  and truly functional arrays, that update the array in place, but store undo-information to restore
  old versions.
\<close>

code_printing code_module "FArray" \<rightharpoonup>
  (SML)
\<open>
structure FArray = struct
  datatype 'a Cell = Value of 'a Array.array | Upd of (int*'a*'a Cell Unsynchronized.ref);

  type 'a array = 'a Cell Unsynchronized.ref;

  fun array (size,v) = Unsynchronized.ref (Value (Array.array (size,v)));
  fun tabulate (size, f) = Unsynchronized.ref (Value (Array.tabulate(size, f)));
  fun fromList l = Unsynchronized.ref (Value (Array.fromList l));

  fun sub (Unsynchronized.ref (Value a), idx) = Array.sub (a,idx) |
      sub (Unsynchronized.ref (Upd (i,v,cr)),idx) =
        if i=idx then v
        else sub (cr,idx);

  fun length (Unsynchronized.ref (Value a)) = Array.length a |
      length (Unsynchronized.ref (Upd (i,v,cr))) = length cr;

  fun realize_aux (aref, v) =
    case aref of
      (Unsynchronized.ref (Value a)) => (
        let
          val len = Array.length a;
          val a' = Array.array (len,v);
        in
          Array.copy {src=a, dst=a', di=0};
          Unsynchronized.ref (Value a')
        end
      ) |
      (Unsynchronized.ref (Upd (i,v,cr))) => (
        let val res=realize_aux (cr,v) in
          case res of
            (Unsynchronized.ref (Value a)) => (Array.update (a,i,v); res)
        end
      );

  fun realize aref =
    case aref of
      (Unsynchronized.ref (Value _)) => aref |
      (Unsynchronized.ref (Upd (i,v,cr))) => realize_aux(aref,v);

  fun update (aref,idx,v) =
    case aref of
      (Unsynchronized.ref (Value a)) => (
        let val nref=Unsynchronized.ref (Value a) in
          aref := Upd (idx,Array.sub(a,idx),nref);
          Array.update (a,idx,v);
          nref
        end
      ) |
      (Unsynchronized.ref (Upd _)) =>
        let val ra = realize_aux(aref,v) in
          case ra of
            (Unsynchronized.ref (Value a)) => Array.update (a,idx,v);
          ra
        end
      ;

structure IsabelleMapping = struct
type 'a ArrayType = 'a array;

fun array_new (n:IntInf.int) (a:'a) = array (IntInf.toInt n, a);
fun array_of_list (xs:'a list) = fromList xs;

fun array_tabulate (n:IntInf.int) (f:IntInf.int -> 'a) = tabulate (IntInf.toInt n, f o IntInf.fromInt)

fun array_length (a:'a ArrayType) = IntInf.fromInt (length a);

fun array_get (a:'a ArrayType) (i:IntInf.int) = sub (a, IntInf.toInt i);

fun array_set (a:'a ArrayType) (i:IntInf.int) (e:'a) = update (a, IntInf.toInt i, e);

fun array_get_oo (d:'a) (a:'a ArrayType) (i:IntInf.int) =
  sub (a,IntInf.toInt i) handle Subscript => d

fun array_set_oo (d:(unit->'a ArrayType)) (a:'a ArrayType) (i:IntInf.int) (e:'a) =
  update (a, IntInf.toInt i, e) handle Subscript => d ()

end;
end;

\<close>

code_printing
  type_constructor array \<rightharpoonup> (SML) "_/ FArray.IsabelleMapping.ArrayType"
| constant Array \<rightharpoonup> (SML) "FArray.IsabelleMapping.array'_of'_list"
| constant array_new' \<rightharpoonup> (SML) "FArray.IsabelleMapping.array'_new"
| constant array_tabulate' \<rightharpoonup> (SML) "FArray.IsabelleMapping.array'_tabulate"
| constant array_length' \<rightharpoonup> (SML) "FArray.IsabelleMapping.array'_length"
| constant array_get' \<rightharpoonup> (SML) "FArray.IsabelleMapping.array'_get"
| constant array_set' \<rightharpoonup> (SML) "FArray.IsabelleMapping.array'_set"
| constant array_of_list \<rightharpoonup> (SML) "FArray.IsabelleMapping.array'_of'_list"
| constant array_get_oo' \<rightharpoonup> (SML) "FArray.IsabelleMapping.array'_get'_oo"
| constant array_set_oo' \<rightharpoonup> (SML) "FArray.IsabelleMapping.array'_set'_oo"

subsubsection \<open>Scala\<close>
text \<open>
  We use a DiffArray-Implementation in Scala.
\<close>
code_printing code_module "DiffArray" \<rightharpoonup>
  (Scala) \<open>
object DiffArray {

  import scala.collection.mutable.ArraySeq

  protected abstract sealed class DiffArray_D[A]
  final case class Current[A] (a:ArraySeq[AnyRef]) extends DiffArray_D[A]
  final case class Upd[A] (i:Int, v:A, n:DiffArray_D[A]) extends DiffArray_D[A]

  object DiffArray_Realizer {
    def realize[A](a:DiffArray_D[A]) : ArraySeq[AnyRef] = a match {
      case Current(a) => ArraySeq.empty ++ a
      case Upd(j,v,n) => {val a = realize(n); a.update(j, v.asInstanceOf[AnyRef]); a}
    }
  }

  class T[A] (var d:DiffArray_D[A]) {

    def realize (): ArraySeq[AnyRef] = { val a=DiffArray_Realizer.realize(d); d = Current(a); a }
    override def toString() = realize().toSeq.toString

    override def equals(obj:Any) =
      if (obj.isInstanceOf[T[A]]) obj.asInstanceOf[T[A]].realize().equals(realize())
      else false

  }

  def array_of_list[A](l : List[A]) : T[A] = new T(Current(ArraySeq.empty ++ l.asInstanceOf[List[AnyRef]]))
  def array_new[A](sz : BigInt, v:A) = new T[A](Current[A](ArraySeq.fill[AnyRef](sz.intValue)(v.asInstanceOf[AnyRef])))

  private def length[A](a:DiffArray_D[A]) : BigInt = a match {
    case Current(a) => a.length
    case Upd(_,_,n) => length(n)
  }

  def length[A](a : T[A]) : BigInt = length(a.d)

  private def sub[A](a:DiffArray_D[A], i:Int) : A = a match {
    case Current(a) => a(i).asInstanceOf[A]
    case Upd(j,v,n) => if (i==j) v else sub(n,i)
  }

  def get[A](a:T[A], i:BigInt) : A = sub(a.d,i.intValue)

  private def realize[A](a:DiffArray_D[A]): ArraySeq[AnyRef] = DiffArray_Realizer.realize[A](a)

  def set[A](a:T[A], i:BigInt,v:A) : T[A] = a.d match {
    case Current(ad) => {
      val ii = i.intValue;
      a.d = Upd(ii,ad(ii).asInstanceOf[A],a.d);
      //ad.update(ii,v);
      ad(ii)=v.asInstanceOf[AnyRef]
      new T[A](Current(ad))
    }
    case Upd(_,_,_) => set(new T[A](Current(realize(a.d))), i.intValue,v)
  }

  def get_oo[A](d: => A, a:T[A], i:BigInt):A = try get(a,i) catch {
    case _:scala.IndexOutOfBoundsException => d
  }

  def set_oo[A](d: Unit => T[A], a:T[A], i:BigInt, v:A) : T[A] = try set(a,i,v) catch {
    case _:scala.IndexOutOfBoundsException => d(())
  }

}

object Test {

  def assert (b : Boolean) : Unit = if (b) () else throw new java.lang.AssertionError("Assertion Failed")

  def eql[A] (a:DiffArray.T[A], b:List[A]) = assert (a.realize.corresponds(b)((x,y) => x.equals(y)))

  def tests1(): Unit = {
    val a = DiffArray.array_of_list(1::2::3::4::Nil)
      eql(a,1::2::3::4::Nil)

    // Simple update
    val b = DiffArray.set(a,2,9)
      eql(a,1::2::3::4::Nil)
      eql(b,1::2::9::4::Nil)

    // Another update
    val c = DiffArray.set(b,3,9)
      eql(a,1::2::3::4::Nil)
      eql(b,1::2::9::4::Nil)
      eql(c,1::2::9::9::Nil)

    // Update of old version (forces realize)
    val d = DiffArray.set(b,2,8)
      eql(a,1::2::3::4::Nil)
      eql(b,1::2::9::4::Nil)
      eql(c,1::2::9::9::Nil)
      eql(d,1::2::8::4::Nil)

    }

  def tests2(): Unit = {
    val a = DiffArray.array_of_list(1::2::3::4::Nil)
      eql(a,1::2::3::4::Nil)

    // Simple update
    val b = DiffArray.set(a,2,9)
      eql(a,1::2::3::4::Nil)
      eql(b,1::2::9::4::Nil)

    // Grow of current version
/*    val c = DiffArray.grow(b,6,9)
      eql(a,1::2::3::4::Nil)
      eql(b,1::2::9::4::Nil)
      eql(c,1::2::9::4::9::9::Nil)

    // Grow of old version
    val d = DiffArray.grow(a,6,9)
      eql(a,1::2::3::4::Nil)
      eql(b,1::2::9::4::Nil)
      eql(c,1::2::9::4::9::9::Nil)
      eql(d,1::2::3::4::9::9::Nil)
*/
  }

  def tests3(): Unit = {
    val a = DiffArray.array_of_list(1::2::3::4::Nil)
      eql(a,1::2::3::4::Nil)

    // Simple update
    val b = DiffArray.set(a,2,9)
      eql(a,1::2::3::4::Nil)
      eql(b,1::2::9::4::Nil)
/*
    // Shrink of current version
    val c = DiffArray.shrink(b,3)
      eql(a,1::2::3::4::Nil)
      eql(b,1::2::9::4::Nil)
      eql(c,1::2::9::Nil)

    // Shrink of old version
    val d = DiffArray.shrink(a,3)
      eql(a,1::2::3::4::Nil)
      eql(b,1::2::9::4::Nil)
      eql(c,1::2::9::Nil)
      eql(d,1::2::3::Nil)
*/
  }

  def tests4(): Unit = {
    val a = DiffArray.array_of_list(1::2::3::4::Nil)
      eql(a,1::2::3::4::Nil)

    // Update _oo (succeeds)
    val b = DiffArray.set_oo((_) => a,a,2,9)
      eql(a,1::2::3::4::Nil)
      eql(b,1::2::9::4::Nil)

    // Update _oo (current version,fails)
    val c = DiffArray.set_oo((_) => a,b,5,9)
      eql(a,1::2::3::4::Nil)
      eql(b,1::2::9::4::Nil)
      eql(c,1::2::3::4::Nil)

    // Update _oo (old version,fails)
    val d = DiffArray.set_oo((_) => b,a,5,9)
      eql(a,1::2::3::4::Nil)
      eql(b,1::2::9::4::Nil)
      eql(c,1::2::3::4::Nil)
      eql(d,1::2::9::4::Nil)

  }

  def tests5(): Unit = {
    val a = DiffArray.array_of_list(1::2::3::4::Nil)
      eql(a,1::2::3::4::Nil)

    // Update
    val b = DiffArray.set(a,2,9)
      eql(a,1::2::3::4::Nil)
      eql(b,1::2::9::4::Nil)

    // Get_oo (current version, succeeds)
      assert (DiffArray.get_oo(0,b,2)==9)
    // Get_oo (current version, fails)
      assert (DiffArray.get_oo(0,b,5)==0)
    // Get_oo (old version, succeeds)
      assert (DiffArray.get_oo(0,a,2)==3)
    // Get_oo (old version, fails)
      assert (DiffArray.get_oo(0,a,5)==0)

  }

  def main(args: Array[String]): Unit = {
    tests1 ()
    tests2 ()
    tests3 ()
    tests4 ()
    tests5 ()

    Console.println("Tests passed")
  }

}

\<close>

code_printing
  type_constructor array \<rightharpoonup> (Scala) "DiffArray.T[_]"
| constant Array \<rightharpoonup> (Scala) "DiffArray.array'_of'_list"
| constant array_new' \<rightharpoonup> (Scala) "DiffArray.array'_new((_).toInt,(_))"
| constant array_length' \<rightharpoonup> (Scala) "DiffArray.length((_)).toInt"
| constant array_get' \<rightharpoonup> (Scala) "DiffArray.get((_),(_).toInt)"
| constant array_set' \<rightharpoonup> (Scala) "DiffArray.set((_),(_).toInt,(_))"
| constant array_of_list \<rightharpoonup> (Scala) "DiffArray.array'_of'_list"
| constant array_get_oo' \<rightharpoonup> (Scala) "DiffArray.get'_oo((_),(_),(_).toInt)"
| constant array_set_oo' \<rightharpoonup> (Scala) "DiffArray.set'_oo((_),(_),(_).toInt,(_))"

context begin
(*private*) definition "test_diffarray_setup \<equiv> (Array,array_new',array_length',array_get', array_set', array_of_list,array_get_oo',array_set_oo')"
export_code test_diffarray_setup checking SML OCaml? Haskell?
end

subsection \<open>Tests\<close>
(* TODO: Add more systematic tests! *)

definition "test1 \<equiv>
  let a=array_of_list [1,2,3,4,5,6];
      b=array_tabulate 6 (Suc);
      a'=array_set a 3 42;
      b'=array_set b 3 42;
      c=array_new 6 0
  in
    \<forall>i\<in>{0..<6}.
      array_get a i = i+1
    \<and> array_get b i = i+1
    \<and> array_get a' i = (if i=3 then 42 else i+1)
    \<and> array_get b' i = (if i=3 then 42 else i+1)
    \<and> array_get c i = (0::nat)
          "

lemma enum_rangeE:
  assumes "i\<in>{l..<h}"
  assumes "P l"
  assumes "i\<in>{Suc l..<h} \<Longrightarrow> P i"
  shows "P i"
  using assms
  by (metis atLeastLessThan_iff less_eq_Suc_le nat_less_le)

lemma "test1"
  unfolding test1_def Let_def
  apply (intro ballI conjI)
  apply (erule enum_rangeE, (simp; fail))+ apply simp
  apply (erule enum_rangeE, (simp; fail))+ apply simp
  apply (erule enum_rangeE, (simp; fail))+ apply simp
  apply (erule enum_rangeE, (simp; fail))+ apply simp
  apply (erule enum_rangeE, (simp; fail))+ apply simp
  done

ML_val \<open>
  if not @{code test1} then error "ERROR" else ()
\<close>

export_code test1 checking OCaml? Haskell? SML

hide_const test1
hide_fact test1_def

experiment
begin

fun allTrue :: "bool list \<Rightarrow> nat \<Rightarrow> bool list" where
"allTrue a 0 = a" |
"allTrue a (Suc i) = (allTrue a i)[i := True]"

lemma length_allTrue: "n \<le> length a  \<Longrightarrow> length(allTrue a n) = length a"
by(induction n) (auto)

lemma "n \<le> length a \<Longrightarrow> \<forall>i < n. (allTrue a n) ! i"
by(induction n) (auto simp: nth_list_update length_allTrue)

fun allTrue' :: "bool array \<Rightarrow> nat \<Rightarrow> bool array" where
"allTrue' a 0 = a" |
"allTrue' a (Suc i) = array_set (allTrue' a i) i True"

lemma "array_\<alpha> (allTrue' xs i) = allTrue (array_\<alpha> xs) i"
  apply (induction xs i rule: allTrue'.induct)
  apply auto
  done

end

end


(*
 * Copyright 2014, NICTA
 *
 * This software may be distributed and modified according to the terms of
 * the BSD 2-Clause license. Note that NO WARRANTY is provided.
 * See "LICENSE_BSD2.txt" for details.
 *
 * @TAG(NICTA_BSD)
 *)

(* Author: Thomas Sewell

  Instance of words in the enumeration class.
*)

header "Enumeration instances for Words"

theory WordEnum
imports Enumeration WordLib
begin

instantiation word :: (len) enum
begin

definition
  "(enum_class.enum :: ('a :: len) word list) \<equiv> map of_nat [0 ..< 2 ^ len_of TYPE('a)]"

definition
  "enum_class.enum_all (P :: ('a :: len) word \<Rightarrow> bool) \<longleftrightarrow> Ball UNIV P"

definition
  "enum_class.enum_ex (P :: ('a :: len) word \<Rightarrow> bool) \<longleftrightarrow> Bex UNIV P"

instance
  apply (intro_classes)
     apply (simp add: enum_word_def)
     apply force
    apply (simp add: distinct_map enum_word_def)
    apply (rule subset_inj_on, rule word_unat.Abs_inj_on)
    apply (clarsimp simp add: unats_def)
   apply (simp add: enum_all_word_def)
  apply (simp add: enum_ex_word_def)
  done

end

lemma fromEnum_unat[simp]: "fromEnum (x :: ('a :: len) word) = unat x"
  apply (subgoal_tac "x \<in> set enum")
   defer
   apply (simp add: enum_surj)
  apply (unfold fromEnum_def enum_word_def)
  apply (subgoal_tac "ALL n. n < 2 ^ len_of TYPE('a) --> (map of_nat [0..< 2 ^ len_of TYPE('a)] ! n) = x --> n = unat x")
   apply (subgoal_tac "(map of_nat [0..< 2 ^ len_of TYPE('a)]) ! (the_index (map of_nat [0..< 2 ^ len_of TYPE('a)]) x) = x")
    apply (subgoal_tac "the_index (map of_nat [0..< 2 ^ len_of TYPE('a)]) x < 2 ^ len_of TYPE('a)")
     apply simp
    apply (subgoal_tac "the_index (map of_nat [0..< 2 ^ len_of TYPE('a)]) x < length (map of_nat [0..< 2 ^ len_of TYPE('a)])")
     apply simp
    apply (rule the_index_bounded)
    apply (simp add: enum_word_def)
   apply (rule nth_the_index)
   apply (simp add: enum_word_def)
  apply safe
  apply (simp add: unat_of_nat)
  done

lemma length_word_enum: "length (enum :: ('a :: len) word list) = 2 ^ len_of TYPE('a)"
  apply (simp add: enum_word_def)
  done

lemma toEnum_of_nat[simp]: "n < 2 ^ len_of TYPE('a) \<Longrightarrow> ((toEnum n) :: ('a :: len) word) = of_nat n"
  apply (subst toEnum_def)
  apply (simp add: length_word_enum)
  apply (subst enum_word_def)
  apply simp
  done

declare of_nat_diff [simp]
declare word_pow_0 [simp]

lemma "(maxBound :: ('a :: len) word) = -1"
  apply (unfold maxBound_def enum_word_def)
  apply (subst last_map)
   apply simp
  apply simp
  done

lemma "(minBound :: ('a :: len) word) = 0"
  apply (unfold minBound_def enum_word_def)
  apply (simp add: hd_conv_nth)
  done

instantiation word :: (len) enumeration_both
begin

definition
  enum_alt_word_def: "enum_alt \<equiv> alt_from_ord (enum :: ('a :: len) word list)"

instance
  by (intro_classes, simp add: enum_alt_word_def)

end

definition
  upto_enum_step :: "word32 \<Rightarrow> word32 \<Rightarrow> word32 \<Rightarrow> word32 list" ("[_ , _ .e. _]")
where
  "upto_enum_step a b c \<equiv>
      if c < a then [] else map (\<lambda>x. a + x * (b - a)) [0 .e. (c - a) div (b - a)]"
  (* in the wraparound case, bad things happen. *)

end


(*  Title:      HOL/Word/Bit_Comprehension.thy
    Author:     Brian Huffman, PSU; Jeremy Dawson and Gerwin Klein, NICTA
*)

section \<open>Comprehension syntax for bit expressions\<close>

theory Bit_Comprehension
  imports Bits_Int
begin

class bit_comprehension = bit_operations +
  fixes set_bits :: "(nat \<Rightarrow> bool) \<Rightarrow> 'a"  (binder "BITS " 10)

instantiation int :: bit_comprehension
begin

definition
  "set_bits f =
    (if \<exists>n. \<forall>n'\<ge>n. \<not> f n' then
      let n = LEAST n. \<forall>n'\<ge>n. \<not> f n'
      in bl_to_bin (rev (map f [0..<n]))
     else if \<exists>n. \<forall>n'\<ge>n. f n' then
      let n = LEAST n. \<forall>n'\<ge>n. f n'
      in sbintrunc n (bl_to_bin (True # rev (map f [0..<n])))
     else 0 :: int)"

instance ..

end

lemma int_set_bits_K_False [simp]: "(BITS _. False) = (0 :: int)"
  by (simp add: set_bits_int_def)

lemma int_set_bits_K_True [simp]: "(BITS _. True) = (-1 :: int)"
  by (auto simp add: set_bits_int_def bl_to_bin_def)

end


theory Remdups
  imports
    NREST_Main
    Monadic_Operations
begin

definition "rbt_search_time_logN = undefined"
definition "rbt_insert_logN = undefined"

definition "rd_inv as \<equiv> (\<lambda>(xs,ys,S). (\<exists>zs. as = zs@xs \<and> S = set ys \<and> distinct ys \<and> set zs = set ys))"

datatype RD_curr = RBT_search | RBT_insert | REST

instantiation RD_curr :: enum
begin
definition "enum_RD_curr = [RBT_search, RBT_insert, REST]"
definition "enum_all_RD_curr P = (P RBT_search \<and> P RBT_insert \<and> P REST)"
definition "enum_ex_RD_curr P = (P RBT_search \<or> P RBT_insert \<or> P REST)"
instance apply standard apply (auto simp: enum_RD_curr_def enum_ex_RD_curr_def enum_all_RD_curr_def)
  subgoal for x apply (cases x) by auto
  subgoal for P x apply (cases x) by auto
  subgoal for P x apply (cases x) by auto
  done
end

definition body_time :: "nat \<Rightarrow> (RD_curr,enat) acost" where
  "body_time n = acostC ((\<lambda>_.0)(REST := 60, RBT_search := 1+rbt_search_time_logN (n+1), RBT_insert := rbt_insert_logN (n+1)))"
definition body_time_abs :: "(RD_curr,nat) acost" where
  "body_time_abs = acostC ((\<lambda>_.0)(REST := 60, RBT_search := 1, RBT_insert := 1))"

definition "rd_ta as = (\<lambda>(xs,ys,S). acostC (\<lambda>x. enat (length xs) * the_acost (body_time (length as)) x) )"
definition "rd_ta_abs = (\<lambda>(xs,ys,S). acostC (\<lambda>x. (length xs) * the_acost body_time_abs x) )"

definition rd_impl1 :: "('a::{linorder}) list \<Rightarrow> ('a list, _ ) nrest" where
"rd_impl1 as = do {
  ys \<leftarrow> mop_empty_list (\<lambda>_. cost REST (12::enat));
  S \<leftarrow> mop_set_empty (\<lambda>_. cost REST 1);
  zs \<leftarrow> RETURNT as;
  (zs,ys,S) \<leftarrow> whileIET (rd_inv as) (rd_ta_abs) (\<lambda>(xs,ys,S). length xs > 0) (\<lambda>(xs,ys,S). do {
    ASSERT (length xs > 0);
    ASSERT (length xs + length ys \<le> length as);
    ASSERT (card S \<le> length ys);
    x \<leftarrow> RETURNT (hd xs);
    xs \<leftarrow> RETURNT (tl xs);
    b \<leftarrow> mop_set_member (\<lambda>_. cost RBT_search 1) x S;
    if b then
      RETURNT (xs,ys,S)
    else do {
      S \<leftarrow> mop_set_insert (\<lambda>_. cost RBT_insert 1 ) x S;
      ys \<leftarrow> mop_push_list (\<lambda>_. cost REST 23 ) x ys;
      RETURNT (xs,ys,S)
    }
  }) (zs,ys,S);
  RETURNT ys
  }"

abbreviation "skalar n ac \<equiv> acostC (\<lambda>x. n * the_acost ac x)"
abbreviation "skalare n ac \<equiv> acostC (\<lambda>x. enat n * the_acost ac x)"

definition "remdups_time (n::nat) = skalare n (body_time n) + cost REST 20"
definition "remdups_time_abs (n::nat) = skalar n body_time_abs + cost REST 20"

definition "remdups_spec_abs as = SPECT (emb (\<lambda>ys. set as = set ys \<and> distinct ys)
                   ( lift_acost ( remdups_time_abs (length as)) ))"
definition "remdups_spec as = SPECT (emb (\<lambda>ys. set as = set ys \<and> distinct ys)
                   ( remdups_time (length as) ))"

fun RR where
  "RR n REST REST = (1::enat)"
| "RR n RBT_search RBT_search = 1+rbt_search_time_logN (n+1)"
| "RR n RBT_insert RBT_insert = rbt_insert_logN (n+1)"
| "RR n _ _  = 0"

abbreviation "RR' n \<equiv> (\<lambda>x. acostC (\<lambda>y. RR n x y))"

lemma timerefine_SPECT_emb':
  "timerefine F (SPECT (emb' P TT)) = SPECT (emb' P (\<lambda>r. acostC (\<lambda>cc. Sum_any (\<lambda>ac. the_acost (TT r) ac * the_acost (F ac) cc))))"
  unfolding timerefine_def  apply auto
  unfolding emb'_def apply(rule ext) by simp

lemma "acostC a = acostC b \<longleftrightarrow> a = b"
  by simp

lemma emb'_eqI: "P=P' \<Longrightarrow> X=X' \<Longrightarrow> emb' P X = emb' P' X'" unfolding emb'_def by auto
lemma finer: "remdups_spec as = timerefine (RR' (length as)) (remdups_spec_abs as)"
  unfolding remdups_spec_abs_def lift_acost_def apply(simp only: timerefine_SPECT_emb')
  unfolding remdups_spec_def apply simp
  apply(rule emb'_eqI) apply simp
  apply(rule ext)+
  apply(auto simp: remdups_time_def remdups_time_abs_def body_time_def body_time_abs_def)
  apply (simp_all add: Sum_any_to_foldr enum_RD_curr_def)
  apply (simp add: cost_def fun_eq_iff the_acost_zero_app)
  apply (auto simp: numeral_eq_enat  split: RD_curr.splits)
  subgoal for x apply (cases x) by auto
  subgoal for x apply (cases x) by auto
  subgoal for x apply (cases x) by auto
  done

(*
lemma finer: "remdups_spec as = timerefine (RR' (length as)) (remdups_spec_abs as)"
  unfolding remdups_spec_def remdups_spec_abs_def timerefine_def
      remdups_time_def remdups_time_abs_def body_time_def body_time_abs_def
  apply auto apply(rule ext)
  unfolding emb'_def apply auto
  apply(rule ext) apply auto
  apply (simp only: Sum_any_to_foldr enum_RD_curr_def) apply simp
  apply (simp only: Sum_any_to_foldr enum_RD_curr_def) apply simp
  apply (simp only: Sum_any_to_foldr enum_RD_curr_def) apply simp
  apply (simp only: Sum_any_to_foldr enum_RD_curr_def) apply auto
  subgoal for r x apply (cases x) by auto
  subgoal for r x apply (cases x) by auto
  subgoal for r x apply (cases x) by auto
  done *)

lemma enat_neq_Z_iff[simp]: "enat x \<noteq> 0 \<longleftrightarrow> x\<noteq>0"
  by (auto simp: zero_enat_def)

lemma the_acost_cost: "the_acost (cost n c) x = (if n=x then c else 0)"
  unfolding cost_def by (auto simp: zero_acost_def)

lemma rd_impl1_correct: "rd_impl1 as \<le> remdups_spec_abs as"
  unfolding remdups_spec_abs_def
  unfolding rd_impl1_def mop_empty_list_def mop_set_empty_def
      mop_set_member_def mop_set_insert_def mop_push_list_def
      rd_ta_abs_def rd_inv_def
  apply(rule gwp_specifies_I)
  apply (refine_vcg \<open>simp\<close> )
  subgoal
    by(rule wfR2_enum)
    unfolding Some_le_emb'_conv
  supply [simp] = neq_Nil_conv distinct_length_le card_length
        apply (auto simp: less_eq_acost_def the_acost_cost the_acost_plus
              Some_le_mm3_Some_conv numeral_eq_enat lift_acost_def
          body_time_abs_def one_enat_def remdups_time_abs_def plus_enat_simps intro!: le_funI)
    subgoal
      by (progress \<open>simp add: cost_def lift_acost_def less_acost_def the_acost_zero_app\<close>)
    subgoal
      by (meson list.set_cases)
    done

end