header {* BD Security *}

(*<*)
theory BD_Security
imports IO_Automaton
begin
(*>*)

subsection{* Definition *}

declare Let_def[simp]

no_notation relcomp (infixr "O" 75)

abbreviation never :: "('a \<Rightarrow> bool) \<Rightarrow> 'a list \<Rightarrow> bool" where "never U \<equiv> list_all (\<lambda> a. \<not> U a)"

function filtermap ::
"(('state,'act,'out) trans \<Rightarrow> bool) \<Rightarrow> (('state,'act,'out) trans \<Rightarrow> 'a) \<Rightarrow> ('state,'act,'out) trace \<Rightarrow> 'a list"
where
"filtermap pred func [] = []"
|
"\<not> pred trn \<Longrightarrow> filtermap pred func (trn # tr) = filtermap pred func tr"
|
"pred trn \<Longrightarrow> filtermap pred func (trn # tr) = func trn # filtermap pred func tr"
by auto (metis list.exhaust)
termination by lexicographic_order

locale BD_Security = IO_Automaton istate step
 for istate :: 'state and step :: "'state \<Rightarrow> 'act \<Rightarrow> 'out \<times> 'state"
+
fixes (* value filtering and production:  *)
   \<phi> :: "('state,'act,'out) trans => bool" and f :: "('state,'act,'out) trans \<Rightarrow> 'value"
 and (* observation filtering and production: *)
   \<gamma> :: "('state,'act,'out) trans => bool" and g :: "('state,'act,'out) trans \<Rightarrow> 'obs"
 and (* declassification trigger:  *)
   T :: "('state,'act,'out) trans \<Rightarrow> bool"
 and (* declassification bound: *)
   B :: "'value list \<Rightarrow> 'value list \<Rightarrow> bool"
begin

(* The value function: *)
definition V :: "('state,'act,'out) trace \<Rightarrow> 'value list" where "V \<equiv> filtermap \<phi> f"
(* The observation function: *)
definition O :: "('state,'act,'out) trace \<Rightarrow> 'obs list" where "O \<equiv> filtermap \<gamma> g"

lemma V_simps[simp]:
"V [] = []"  "\<not> \<phi> trn \<Longrightarrow> V (trn # tr) = V tr"  "\<phi> trn \<Longrightarrow> V (trn # tr) = f trn # V tr"
unfolding V_def by auto

lemma O_simps[simp]:
"O [] = []"  "\<not> \<gamma> trn \<Longrightarrow> O (trn # tr) = O tr"  "\<gamma> trn \<Longrightarrow> O (trn # tr) = g trn # O tr"
unfolding O_def by auto

(* Reachable states by transitions satisfying T: *)
inductive reachNT:: "'state \<Rightarrow> bool" where
Istate: "reachNT istate"
|
Step:
"\<lbrakk>reachNT (srcOf trn); step (srcOf trn) (actOf trn) = (outOf trn, tgtOf trn); \<not> T trn\<rbrakk>
 \<Longrightarrow> reachNT (tgtOf trn)"

lemma reachNT_PairI:
assumes "reachNT s" and "step s a = (ou, s')" and "\<not> T (Trans s a ou s')"
shows "reachNT s'"
by (metis BD_Security.reachNT.simps assms trans.sel)

lemma reachNT_reach: assumes "reachNT s"  shows "reach s"
using assms by induct (auto intro: reach.intros, metis reach.Step snd_conv validTrans)

lemma reachNT_stateO_aux:
assumes "reachNT s"
shows "s = istate \<or> (\<exists>sh a ou. reach sh \<and> step sh a = (ou,s) \<and> \<not>T (Trans sh a ou s))"
using assms by induct (clarsimp, metis BD_Security.reachNT_reach trans.exhaust_sel)

lemma reachNT_state_cases[cases set,consumes 1, case_names init step]:
assumes "reachNT s"
obtains "s = istate"
| sh a ou where "reach sh" "step sh a = (ou,s)" "\<not>T (Trans sh a ou s)"
by (metis reachNT_stateO_aux[OF assms])

(* This is assumed to be an invariant only modulo non T  *)
definition invarNT where
"invarNT Inv \<equiv> \<forall> s a ou s'. reachNT s \<and> Inv s \<and> \<not> T (Trans s a ou s') \<and> step s a = (ou,s') \<longrightarrow> Inv s'"

lemma invarNT_disj:
assumes "invarNT Inv1" and "invarNT Inv2"
shows "invarNT (\<lambda> s. Inv1 s \<or> Inv2 s)"
using assms unfolding invarNT_def by blast

lemma invarNT_conj:
assumes "invarNT Inv1" and "invarNT Inv2"
shows "invarNT (\<lambda> s. Inv1 s \<and> Inv2 s)"
using assms unfolding invarNT_def by blast

lemma holdsIstate_invarNT:
assumes h: "holdsIstate Inv" and i: "invarNT Inv" and a: "reachNT s"
shows "Inv s"
using a using h i unfolding holdsIstate_def invarNT_def
by (induct rule: reachNT.induct) (metis i invarNT_def trans.exhaust_sel)+

(* BD security: *)
definition secure :: bool where
"secure \<equiv>
 \<forall> tr vl vl1.
   validFrom istate tr \<and> never T tr \<and> B vl vl1 \<and> V tr = vl \<longrightarrow>
   (\<exists> tr1. validFrom istate tr1 \<and> O tr1 = O tr \<and> V tr1 = vl1)"

lemma V_iff_non_\<phi>[simp]: "V (trn # tr) = V tr \<longleftrightarrow> \<not> \<phi> trn"
by (cases "\<phi> trn") auto

lemma V_imp_\<phi>: "V (trn # tr) = v # V tr \<Longrightarrow> \<phi> trn"
by (cases "\<phi> trn") auto

lemma V_imp_Nil: "V (trn # tr) = [] \<Longrightarrow> V tr = []"
by (metis V_simps list.distinct trans.exhaust)

lemma V_iff_Nil[simp]: "V (trn # tr) = [] \<longleftrightarrow> \<not> \<phi> trn \<and> V tr = []"
by (metis V_iff_non_\<phi> V_imp_Nil)

end (* context BD_Security *)

subsection{* Unwinding proof method *}

context BD_Security
begin

definition consume :: "('state,'act,'out) trans \<Rightarrow> 'value list \<Rightarrow> 'value list \<Rightarrow> bool" where
"consume trn vl vl' \<equiv>
 if \<phi> trn then vl \<noteq> [] \<and> f trn = hd vl \<and> vl' = tl vl
 else vl' = vl"

lemma length_consume[simp]:
"consume trn vl vl' \<Longrightarrow> length vl' < Suc (length vl)"
unfolding consume_def by (auto split: if_splits)

lemma ex_consume_\<phi>:
assumes "\<not> \<phi> trn"
obtains vl' where "consume trn vl vl'"
using assms unfolding consume_def by auto

lemma ex_consume_NO:
assumes "vl \<noteq> []" and "f trn = hd vl"
obtains vl' where "consume trn vl vl'"
using assms unfolding consume_def by (cases "\<phi> trn") auto

(* independent action: *)
definition iaction where
"iaction \<Delta> s vl s1 vl1 \<equiv>
 \<exists> a1 ou1 s1' vl1'.
   let trn1 = Trans s1 a1 ou1 s1' in
   validTrans trn1 \<and>
   \<phi> trn1 \<and> consume trn1 vl1 vl1' \<and>
   \<not> \<gamma> trn1
   \<and>
   \<Delta> s vl s1' vl1'"

lemma iactionI[intro?]:
assumes "step s1 a1 = (ou1, s1')" and "\<phi> (Trans s1 a1 ou1 s1')"
and "consume (Trans s1 a1 ou1 s1') vl1 vl1'"
and "\<not> \<gamma> (Trans s1 a1 ou1 s1')" and "\<Delta> s vl s1' vl1'"
shows "iaction \<Delta> s vl s1 vl1"
unfolding iaction_def using assms by auto

definition match where
"match \<Delta> s s1 vl1 a ou s' vl' \<equiv>
 \<exists> a1 ou1 s1' vl1'.
    let trn = Trans s a ou s'; trn1 = Trans s1 a1 ou1 s1' in
    validTrans trn1 \<and>
    consume trn1 vl1 vl1' \<and>
    \<gamma> trn = \<gamma> trn1 \<and> (\<gamma> trn \<longrightarrow> g trn = g trn1) \<and>
    \<Delta> s' vl' s1' vl1'"

lemma matchI[intro?]:
assumes "validTrans (Trans s1 a1 ou1 s1')"
and "consume (Trans s1 a1 ou1 s1') vl1 vl1'" and "\<gamma> (Trans s a ou s') = \<gamma> (Trans s1 a1 ou1 s1')"
and "\<gamma> (Trans s a ou s') \<Longrightarrow> g (Trans s a ou s') = g (Trans s1 a1 ou1 s1')"
and "\<Delta> s' vl' s1' vl1'"
shows "match \<Delta> s s1 vl1 a ou s' vl'"
unfolding match_def using assms by auto

definition ignore where
"ignore \<Delta> s s1 vl1 a ou s' vl' \<equiv>
 \<not> \<gamma> (Trans s a ou s') \<and>
 \<Delta> s' vl' s1 vl1"

lemma ignoreI[intro?]:
assumes "\<not> \<gamma> (Trans s a ou s')" and "\<Delta> s' vl' s1 vl1"
shows "ignore \<Delta> s s1 vl1 a ou s' vl'"
unfolding ignore_def using assms by auto

(* reaction: *)
definition reaction where
"reaction \<Delta> s vl s1 vl1 \<equiv>
 \<forall> a ou s' vl'.
   let trn = Trans s a ou s' in
   validTrans trn \<and> \<not> T trn \<and>
   consume trn vl vl'
   \<longrightarrow>
   match \<Delta> s s1 vl1 a ou s' vl'
   \<or>
   ignore \<Delta> s s1 vl1 a ou s' vl'"

lemma reactionI[intro?]:
assumes
"\<And>a ou s' vl'.
   \<lbrakk>step s a = (ou, s'); \<not> T (Trans s a ou s');
    consume (Trans s a ou s') vl vl'\<rbrakk>
   \<Longrightarrow>
   match \<Delta> s s1 vl1 a ou s' vl' \<or> ignore \<Delta> s s1 vl1 a ou s' vl'"
shows "reaction \<Delta> s vl s1 vl1"
using assms unfolding reaction_def by auto

definition "exit" :: "'state \<Rightarrow> 'value \<Rightarrow> bool" where
"exit s v \<equiv> \<forall> tr trn. validFrom s (tr ## trn) \<and> never T (tr ## trn) \<and> \<phi> trn \<longrightarrow> f trn \<noteq> v"

lemma exit_coind:
assumes K: "K s"
and I: "\<And> trn. \<lbrakk>K (srcOf trn); validTrans trn; \<not> T trn\<rbrakk>
        \<Longrightarrow> (\<phi> trn \<longrightarrow> f trn \<noteq> v) \<and> K (tgtOf trn)"
shows "exit s v"
using K unfolding exit_def proof(intro allI conjI impI)
  fix tr trn assume "K s" and "validFrom s (tr ## trn) \<and> never T (tr ## trn) \<and> \<phi> trn"
  thus "f trn \<noteq> v"
  using I unfolding validFrom_def by (induction tr arbitrary: s trn)
  (auto, metis neq_Nil_conv rotate1.simps(2) rotate1_is_Nil_conv valid_ConsE)
qed

definition noVal where
"noVal K v \<equiv>
 \<forall> s a ou s'. reachNT s \<and> K s \<and> step s a = (ou,s') \<and> \<phi> (Trans s a ou s') \<longrightarrow> f (Trans s a ou s') \<noteq> v"

lemma noVal_disj:
assumes "noVal Inv1 v" and "noVal Inv2 v"
shows "noVal (\<lambda> s. Inv1 s \<or> Inv2 s) v"
using assms unfolding noVal_def by metis

lemma noVal_conj:
assumes "noVal Inv1 v" and "noVal Inv2 v"
shows "noVal (\<lambda> s. Inv1 s \<and> Inv2 s) v"
using assms unfolding noVal_def by blast

(* Often encountered sufficient criterion for noVal: *)
definition no\<phi> where
"no\<phi> K \<equiv> \<forall> s a ou s'. reachNT s \<and> K s \<and> step s a = (ou,s') \<longrightarrow> \<not> \<phi> (Trans s a ou s')"

lemma no\<phi>_noVal: "no\<phi> K \<Longrightarrow> noVal K v"
unfolding no\<phi>_def noVal_def by auto

(* intro rule for quick inline checks: *)
lemma exitI[consumes 2, induct pred: "exit"]:
assumes rs: "reachNT s" and K: "K s"
and I:
"\<And> s a ou s'.
   \<lbrakk>reach s; reachNT s; step s a = (ou,s'); K s\<rbrakk>
   \<Longrightarrow> (\<phi> (Trans s a ou s') \<longrightarrow> f (Trans s a ou s') \<noteq> v) \<and> K s'"
shows "exit s v"
proof-
  let ?K = "\<lambda> s. reachNT s \<and> K s"
  show ?thesis using assms by (intro exit_coind[of ?K])
  (metis BD_Security.reachNT_reach IO_Automaton.validTrans reachNT.Step trans.exhaust_sel)+
qed

(* intro rule for more elaborate checks: *)
lemma exitI2:
assumes rs: "reachNT s" and K: "K s"
and "invarNT K" and "noVal K v"
shows "exit s v"
proof-
  let ?K = "\<lambda> s. reachNT s \<and> K s"
  show ?thesis using assms unfolding invarNT_def noVal_def apply(intro exit_coind[of ?K])
  by metis (metis IO_Automaton.validTrans reachNT.Step trans.exhaust_sel)
qed

(* Binary version of the invariant: *)
definition noVal2 where
"noVal2 K v \<equiv>
 \<forall> s a ou s'. reachNT s \<and> K s v \<and> step s a = (ou,s') \<and> \<phi> (Trans s a ou s') \<longrightarrow> f (Trans s a ou s') \<noteq> v"

lemma noVal2_disj:
assumes "noVal2 Inv1 v" and "noVal2 Inv2 v"
shows "noVal2 (\<lambda> s v. Inv1 s v \<or> Inv2 s v) v"
using assms unfolding noVal2_def by metis

lemma noVal2_conj:
assumes "noVal2 Inv1 v" and "noVal2 Inv2 v"
shows "noVal2 (\<lambda> s v. Inv1 s v \<and> Inv2 s v) v"
using assms unfolding noVal2_def by blast

lemma exitI_noVal2[consumes 2, induct pred: "exit"]:
assumes rs: "reachNT s" and K: "K s v"
and I:
"\<And> s a ou s'.
   \<lbrakk>reach s; reachNT s; step s a = (ou,s'); K s v\<rbrakk>
   \<Longrightarrow> (\<phi> (Trans s a ou s') \<longrightarrow> f (Trans s a ou s') \<noteq> v) \<and> K s' v"
shows "exit s v"
proof-
  let ?K = "\<lambda> s. reachNT s \<and> K s v"
  show ?thesis using assms by (intro exit_coind[of ?K])
  (metis BD_Security.reachNT_reach IO_Automaton.validTrans reachNT.Step trans.exhaust_sel)+
qed

lemma exitI2_noVal2:
assumes rs: "reachNT s" and K: "K s v"
and "invarNT (\<lambda> s. K s v)" and "noVal2 K v"
shows "exit s v"
proof-
  let ?K = "\<lambda> s. reachNT s \<and> K s v"
  show ?thesis using assms unfolding invarNT_def noVal2_def
  by (intro exit_coind[of ?K]) (metis IO_Automaton.validTrans reachNT.Step trans.exhaust_sel)+
qed

(* end binary version *)

lemma exit_validFrom:
assumes vl: "vl \<noteq> []" and i: "exit s (hd vl)" and v: "validFrom s tr" and V: "V tr = vl"
and T: "never T tr"
shows False
using i v V T proof(induction tr arbitrary: s)
  case Nil thus ?case by (metis V_simps(1) vl)
next
  case (Cons trn tr s)
  show ?case
  proof(cases "\<phi> trn")
    case True
    hence "f trn = hd vl" using Cons by (metis V_simps(3) hd_Cons_tl list.inject vl)
    moreover have "validFrom s [trn]" using `validFrom s (trn # tr)`
    unfolding validFrom_def by auto
    ultimately show ?thesis using Cons True unfolding exit_def
    by (elim allE[of _ "[]"]) auto
  next
    case False
    hence "V tr = vl" using Cons by auto
    moreover have "never T tr" by (metis Cons.prems list_all_simps)
    moreover from `validFrom s (trn # tr)` have "validFrom (tgtOf trn) tr" and s: "s = srcOf trn"
    by (metis list.distinct(1) validFrom_def valid_ConsE Cons.prems(2)
              IO_Automaton.validFrom_def list.discI list.sel(1))+
    moreover have "exit (tgtOf trn) (hd vl)" using `exit s (hd vl)`
    unfolding exit_def s by simp
    (metis (no_types) Cons.prems(2) Cons.prems(4) append_Cons list.sel(1)
           list.distinct list_all_simps valid.Cons validFrom_def valid_ConsE)
    ultimately show ?thesis using Cons(1) by auto
  qed
qed

definition unwind where
"unwind \<Delta> \<equiv>
 \<forall> s vl s1 vl1.
   reachNT s \<and> reach s1 \<and> \<Delta> s vl s1 vl1
   \<longrightarrow>
   (vl \<noteq> [] \<and> exit s (hd vl))
   \<or>
   iaction \<Delta> s vl s1 vl1
   \<or>
   ((vl \<noteq> [] \<or> vl1 = []) \<and> reaction \<Delta> s vl s1 vl1)"

lemma unwindI[intro?]:
assumes
"\<And> s vl s1 vl1.
   \<lbrakk>reachNT s; reach s1; \<Delta> s vl s1 vl1\<rbrakk>
   \<Longrightarrow>
   (vl \<noteq> [] \<and> exit s (hd vl))
   \<or>
   iaction \<Delta> s vl s1 vl1
   \<or>
   ((vl \<noteq> [] \<or> vl1 = []) \<and> reaction \<Delta> s vl s1 vl1)"
shows "unwind \<Delta>"
using assms unfolding unwind_def by auto

lemma unwind_trace:
assumes unwind: "unwind \<Delta>" and "reachNT s" and "reach s1" and "\<Delta> s vl s1 vl1"
and "validFrom s tr" and "never T tr" and "V tr = vl"
shows "\<exists>tr1. validFrom s1 tr1 \<and> O tr1 = O tr \<and> V tr1 = vl1"
proof-
  let ?S = "\<lambda> tr vl1.
  \<forall> s vl s1. reachNT s \<and> reach s1 \<and> \<Delta> s vl s1 vl1 \<and> validFrom s tr \<and> never T tr \<and> V tr = vl \<longrightarrow>
          (\<exists>tr1. validFrom s1 tr1 \<and> O tr1 = O tr \<and> V tr1 = vl1)"
  let ?f = "\<lambda> tr vl1. length tr + length vl1"
  have "?S tr vl1"
  proof(induct rule: measure_induct2[of ?f ?S])
    case (1 tr vl1)
    show ?case
    proof(intro allI impI, elim conjE)
      fix s vl s1 assume rs: "reachNT s" and rs1: "reach s1" and \<Delta>: "\<Delta> s vl s1 vl1"
      and v: "validFrom s tr" and NT: "never T tr" and V: "V tr = vl"
      hence "(vl \<noteq> [] \<and> exit s (hd vl)) \<or>
             iaction \<Delta> s vl s1 vl1 \<or>
             (reaction \<Delta> s vl s1 vl1 \<and> \<not> iaction \<Delta> s vl s1 vl1)"
      (is "?exit \<or> ?iact \<or> ?react \<and> _")
      using unwind unfolding unwind_def by metis
      thus "\<exists>tr1. validFrom s1 tr1 \<and> O tr1 = O tr \<and> V tr1 = vl1"
      proof safe
        assume "vl \<noteq> []" and "exit s (hd vl)"
        hence False using v V exit_validFrom NT by auto
        thus ?thesis by auto
      next
        assume ?iact
        thus ?thesis  unfolding iaction_def Let_def proof safe
          fix a1 :: 'act and ou1 :: 'out and s1' :: 'state and vl1'
          let ?trn1 = "Trans s1 a1 ou1 s1'"
          assume vtrans1: "validTrans ?trn1" and \<phi>1: "\<phi> ?trn1"
          and c: "consume ?trn1 vl1 vl1'" and \<gamma>: "\<not> \<gamma> ?trn1" and \<Delta>: "\<Delta> s vl s1' vl1'"
          from \<phi>1 c obtain v1 where vl1: "vl1 = v1 # vl1'" and f1: "f ?trn1 = v1"
          unfolding consume_def by (cases vl1) auto
          have rs1': "reach s1'" using rs1 vtrans1 by (auto intro: reach_PairI)
          obtain tr1 where v1: "validFrom s1' tr1" and O: "O tr1 = O tr" and V: "V tr1 = vl1'"
          using 1[of tr vl1'] rs rs1' \<Delta> v NT V unfolding vl1 by auto
          show ?thesis
          using vtrans1 v1 O \<gamma> V \<phi>1 f1 unfolding vl1 by (intro exI[of _ "?trn1 # tr1"]) auto
        qed
      next
        assume react: ?react and iact: "\<not> ?iact"
        show ?thesis
        proof(cases tr)
          case Nil note tr = Nil
          hence vl: "vl = []" using V by simp
          show ?thesis proof(cases vl1)
            case Nil note vl1 = Nil
            show ?thesis using 1[of tr vl1] \<Delta> V NT V unfolding tr vl1 by auto
          next
            case Cons
            hence False using vl unwind rs rs1 \<Delta> iact unfolding unwind_def by auto
            thus ?thesis by auto
          qed
        next
          case (Cons trn tr') note tr = Cons
          show ?thesis
          proof(cases trn)
            case (Trans ss a ou s') note trn = Trans let ?trn = "Trans s a ou s'"
            have ss: "ss = s" using trn v unfolding tr validFrom_def by auto
            have Ta: "\<not> T ?trn" and s: "s = srcOf trn" and vtrans: "validTrans ?trn"
            and v': "validFrom s' tr'" and NT': "never T tr'"
            using v NT V unfolding tr validFrom_def trn by auto
            have rs': "reachNT s'" using rs vtrans Ta by (auto intro: reachNT_PairI)
            {assume "\<phi> ?trn" hence "vl \<noteq> [] \<and> f ?trn = hd vl" using V unfolding tr trn ss by auto
            }
            then obtain vl' where c: "consume ?trn vl vl'"
            using ex_consume_\<phi> ex_consume_NO by metis
            have V': "V tr' = vl'" using V c unfolding tr trn ss consume_def
            by (cases "\<phi> ?trn") (simp_all, metis list.sel(2-3))
            have "match \<Delta> s s1 vl1 a ou s' vl' \<or> ignore \<Delta> s s1 vl1 a ou s' vl'" (is "?match \<or> ?ignore")
            using react unfolding reaction_def using vtrans Ta c by auto
            thus ?thesis proof safe
              assume ?match
              thus ?thesis unfolding match_def Let_def proof (elim exE conjE)
                fix a1 :: 'act and ou1 :: 'out and s1' :: 'state and vl1'
                let ?trn1 = "Trans s1 a1 ou1 s1'"
                assume \<Delta>: "\<Delta> s' vl' s1' vl1'" and vtrans1: "validTrans ?trn1"
                and c1: "consume ?trn1 vl1 vl1'" and \<gamma>: "\<gamma> ?trn = \<gamma> ?trn1"
                and g: "\<gamma> ?trn \<longrightarrow> g ?trn = g ?trn1"
                have rs1': "reach s1'" using rs rs1 vtrans vtrans1 by (auto intro: reach_PairI)
                obtain tr1 where v1: "validFrom s1' tr1" and O: "O tr1 = O tr'" and V: "V tr1 = vl1'"
                using 1[of tr' vl1'] rs' rs1' \<Delta> v' NT' V' c1 unfolding tr by auto
                have "V (?trn1 # tr1) = vl1"
                using c1 V unfolding consume_def by (cases "\<phi> ?trn1") auto
                thus ?thesis
                apply(intro exI[of _ "Trans s1 a1 ou1 s1' # tr1"])
                using vtrans1 v1 O \<gamma> g V unfolding tr trn ss by auto
              qed
            next
              assume ?ignore
              thus ?thesis unfolding ignore_def Let_def proof (elim exE conjE)
                assume \<gamma>: "\<not> \<gamma> ?trn" and \<Delta>: "\<Delta> s' vl' s1 vl1"
                obtain tr1 where v1: "validFrom s1 tr1" and O: "O tr1 = O tr'" and V: "V tr1 = vl1"
                using 1[of tr' vl1] rs' rs1 \<Delta> v' NT' V' c unfolding tr by auto
                show ?thesis
                apply(intro exI[of _ tr1])
                using v1 O V \<gamma> unfolding tr trn ss by auto
              qed
            qed
          qed
        qed
      qed
    qed
  qed
  thus ?thesis using assms by auto
qed

theorem unwind_secure:
assumes init: "\<And> vl vl1. B vl vl1 \<Longrightarrow> \<Delta> istate vl istate vl1"
and unwind: "unwind \<Delta>"
shows secure
using assms unwind_trace unfolding secure_def by (blast intro: reach.Istate reachNT.Istate)

(*<*)
end (* locale BD_Security *)

end
(*>*)


chapter \<open>Gödel Formulas\<close>

(*<*)
theory Goedel_Formula imports Diagonalization Derivability_Conditions
begin
(*>*)

text \<open>Gödel formulas are defined by diagonalizing the negation of the provability predicate.\<close>

locale Goedel_Form =
\<comment> \<open>Assuming the @{term fls} (False) connective gives us negation:\<close>
Deduct2_with_False
  var trm fmla Var FvarsT substT Fvars subst
  eql cnj imp all exi
  fls
  num
  prv bprv
+
Repr_SelfSubst
  var trm fmla Var FvarsT substT Fvars subst
  num
  eql cnj imp all exi
  prv bprv
  enc
  S
+
HBL1
  var trm fmla Var FvarsT substT Fvars subst
  num
  eql cnj imp all exi
  prv bprv
  enc
  P
for
var :: "'var set" and trm :: "'trm set" and fmla :: "'fmla set"
and Var num FvarsT substT Fvars subst
and eql cnj imp all exi
and fls
and prv bprv
and enc ("\<langle>_\<rangle>")
and S
and P
begin

text \<open>The Gödel formula.
NB, we speak of "the" Gödel formula because the diagonalization function makes a choice.\<close>
definition \<phi>G :: 'fmla where "\<phi>G \<equiv> diag (neg P)"

lemma \<phi>G[simp,intro!]: "\<phi>G \<in> fmla"
and
Fvars_\<phi>G[simp]: "Fvars \<phi>G = {}"
  unfolding \<phi>G_def PP_def by auto

lemma bprv_\<phi>G_eqv:
"bprv (eqv \<phi>G (neg (PP \<langle>\<phi>G\<rangle>)))"
  unfolding \<phi>G_def PP_def using bprv_diag_eqv[of "neg P"] by simp

lemma prv_\<phi>G_eqv:
"prv (eqv \<phi>G (neg (PP \<langle>\<phi>G\<rangle>)))"
  using bprv_prv[OF _ _ bprv_\<phi>G_eqv, simplified] .

end \<comment> \<open>context @{locale Goedel_Form}\<close>

text \<open>Adding cleanly representable proofs to the assumptions
behind Gödel formulas:\<close>

locale Goedel_Form_Proofs =
Repr_SelfSubst
  var trm fmla Var FvarsT substT Fvars subst
  num
  eql cnj imp all exi
  prv bprv
  enc
  S
+
CleanRepr_Proofs
  var trm fmla Var FvarsT substT Fvars subst
  num
  eql cnj imp all exi
  prv bprv
  enc
  fls
  dsj
  "proof" prfOf
  encPf
  Pf
for
var :: "'var set" and trm :: "'trm set" and fmla :: "'fmla set"
and Var FvarsT substT Fvars subst num
and eql cnj imp all exi
and fls
and prv bprv
and enc ("\<langle>_\<rangle>")
and S
and dsj
and "proof" :: "'proof set" and prfOf encPf
and Pf

text \<open>... and extending the sublocale relationship @{locale CleanRepr_Proofs} < @{locale HBL1}:\<close>
sublocale Goedel_Form_Proofs < Goedel_Form where P = P by standard

context Goedel_Form_Proofs
begin

lemma bprv_\<phi>G_eqv_not_exi_PPf:
"bprv (eqv \<phi>G (neg (exi yy (PPf (Var yy) \<langle>\<phi>G\<rangle>))))"
proof-
  have P: "P = exi yy Pf" using P_def by (simp add: PPf_def2)
  hence "subst P \<langle>\<phi>G\<rangle> xx = subst (exi yy Pf) \<langle>\<phi>G\<rangle> xx" by auto
  hence "subst P \<langle>\<phi>G\<rangle> xx = exi yy (subst Pf \<langle>\<phi>G\<rangle> xx)" by simp
  thus ?thesis using bprv_\<phi>G_eqv by (simp add: wrepr.PP_def PPf_def2)
qed

lemma prv_\<phi>G_eqv_not_exi_PPf:
"prv (eqv \<phi>G (neg (exi yy (PPf (Var yy) \<langle>\<phi>G\<rangle>))))"
using bprv_prv[OF _ _ bprv_\<phi>G_eqv_not_exi_PPf, simplified] .

lemma prv_\<phi>G_eqv_all_not_PPf:
"prv (eqv \<phi>G (all yy (neg (PPf (Var yy) \<langle>\<phi>G\<rangle>))))"
using bprv_prv[OF _ _ bprv_\<phi>G_eqv_all_not_PPf, simplified] .

lemma bprv_eqv_all_not_PPf_imp_\<phi>G:
"bprv (imp (all yy (neg (PPf (Var yy) \<langle>\<phi>G\<rangle>))) \<phi>G)"
  using bprv_\<phi>G_eqv_all_not_PPf by (auto intro: B.prv_imp_eqvER)

lemma prv_eqv_all_not_PPf_imp_\<phi>G:
"prv (imp (all yy (neg (PPf (Var yy) \<langle>\<phi>G\<rangle>))) \<phi>G)"
using bprv_prv[OF _ _ bprv_eqv_all_not_PPf_imp_\<phi>G, simplified] .

end \<comment> \<open>context @{locale Goedel_Form_Proofs}\<close>

(*<*)
end
(*>*)


header "Abstract nonstandard semantics"

theory AbsCF
  imports HOLCF HOLCFUtils CPSScheme Utils SetMap
begin

default_sort type

text {*
After having defined the exact meaning of a control graph, we now alter the algorithm into a statically computable. We note that the contour pointer in the exact semantics is taken from an infinite set. This is unavoidable, as recursion depth is unbounded. But if this were not the case and the set were finite, the function would be calculable, having finite range and domain.

Therefore, we make the set of contour counter values finite and accept that this makes our result less exact, but calculable. We also do not work with values any more but only remember, for each variable, what possible lambdas can occur there. Because we do not have exact values any more, in a conditional expression, both branches are taken.

We want to leave the exact choice of the finite contour set open for now. Therefore, we define a type class capturing the relevant definitions and the fact that the set is finite. Isabelle expects type classes to be non-empty, so we show that the @{text unit} type is in this type class.
*}

class contour = finite +
  fixes nb_a :: "'a \<Rightarrow> label \<Rightarrow> 'a" ("\<anb>")
    and a_initial_contour :: 'a ("\<abinit>")

instantiation unit :: contour
begin
definition "\<anb> _ _ = ()"
definition "\<abinit> = ()"
instance by default auto
end

text {*
Analogous to the previous section, we define types for binding environments, closures, procedures, semantic values (which are now sets of possible procedures) and variable environment. Their types are parametrized by the chosen set of abstract contours.

The abstract variable environment is a partial map to sets in Shivers' dissertation. As he does not need to distinguish between a key not in the map and a key mapped to the empty set, this presentation is redundant. Therefore, I encoded this as a function from keys to sets of values. The theory @{theory SetMap} contains functions and lemmas to work with such maps, symbolized by an appended dot (e.g. @{text "{}."}, @{text "\<union>."}).
*}

type_synonym 'c a_benv = "label \<rightharpoonup> 'c" ("_ \<abenv>" [1000])
type_synonym 'c a_closure = "lambda \<times> 'c \<abenv>" ("_ \<aclosure>" [1000])

datatype 'c proc ("_ \<aproc>" [1000])
  = PC "'c \<aclosure>"
  | PP prim
  | AStop

type_synonym 'c a_d = "'c \<aproc> set" ("_ \<ad>" [1000])

type_synonym 'c a_venv = "var \<times> 'c \<Rightarrow> 'c \<ad>" ("_ \<avenv>" [1000])

text {*
The evaluation function now ignores constants and returns singletons for primitive operations and lambda expressions.
*}

fun evalV_a :: "val \<Rightarrow> 'c \<abenv> \<Rightarrow> 'c \<avenv> \<Rightarrow> 'c \<ad>" ("\<aA>")
  where "\<aA> (C _ i) \<beta> ve = {}"
  |     "\<aA> (P prim) \<beta> ve = {PP prim}"
  |     "\<aA> (R _ var) \<beta> ve =
           (case \<beta> (binder var) of
              Some l \<Rightarrow> ve (var,l)
            | None \<Rightarrow> {})"
  |     "\<aA> (L lam) \<beta> ve = {PC (lam, \<beta>)}"

text {*
The types of the calculated graph, the arguments to @{text \<aF>} and @{text \<aC>} resemble closely the types in the exact case, with each type replaced by its abstract counterpart.
*}

type_synonym 'c a_ccache = "((label \<times> 'c \<abenv>) \<times> 'c \<aproc>) set" ("_ \<accache>" [1000])
type_synonym 'c a_ans = "'c \<accache>" ("_ \<aans>" [1000])

type_synonym 'c a_fstate = "('c \<aproc> \<times> 'c \<ad> list \<times> 'c \<avenv> \<times> 'c)" ("_ \<afstate>" [1000])
type_synonym 'c a_cstate = "(call \<times> 'c \<abenv> \<times> 'c \<avenv> \<times> 'c)" ("_ \<acstate>" [1000])

text {*
And yet again, cont2cont results need to be shown for our custom data types.
*}

lemma cont2cont_case_lambda [simp, cont2cont]:
  assumes "\<And>a b c. cont (\<lambda>x. f x a b c)"
  shows "cont (\<lambda>x. case_lambda (f x) l)"
using assms
by (cases l) auto

lemma cont2cont_case_proc [simp, cont2cont]:
  assumes "\<And>y. cont (\<lambda>x. f1 x y)"
     and  "\<And>y. cont (\<lambda>x. f2 x y)"
     and  "cont (\<lambda>x. f3 x)"
  shows "cont (\<lambda>x. case_proc (f1 x) (f2 x) (f3 x) d)"
using assms
by (cases d) auto

lemma cont2cont_case_call [simp, cont2cont]:
  assumes "\<And>a b c. cont (\<lambda>x. f1 x a b c)"
     and  "\<And>a b c. cont (\<lambda>x. f2 x a b c)"
  shows "cont (\<lambda>x. case_call (f1 x) (f2 x) c)"
using assms
by (cases c) auto

lemma cont2cont_case_prim [simp, cont2cont]:
  assumes "\<And>y. cont (\<lambda>x. f1 x y)"
     and  "\<And>y z. cont (\<lambda>x. f2 x y z)"
  shows "cont (\<lambda>x. case_prim (f1 x) (f2 x) p)"
using assms
by (cases p) auto

text {*
We can now define the abstract nonstandard semantics, based on the equations in Figure 4.5 and 4.6 of Shivers' dissertation. In the @{text AStop} case, @{text "{}"} is returned, while for wrong arguments, @{text "\<bottom>"} is returned. Both actually represent the same value, the empty set, so this is just a aesthetic difference.
*}

fixrec   a_evalF :: "'c::contour \<afstate> discr \<rightarrow> 'c \<aans>" ("\<aF>")
     and a_evalC :: "'c::contour \<acstate> discr \<rightarrow> 'c \<aans>" ("\<aC>")
  where "\<aF>\<cdot>fstate = (case undiscr fstate of
             (PC (Lambda lab vs c, \<beta>), as, ve, b) \<Rightarrow>
               (if length vs = length as
                then let \<beta>' = \<beta> (lab \<mapsto> b);
                         ve' = ve \<union>. (\<Union>. (map (\<lambda>(v,a). {(v,b) := a}.) (zip vs as)))
                     in \<aC>\<cdot>(Discr (c,\<beta>',ve',b))
                else \<bottom>)
            | (PP (Plus c),[_,_,cnts],ve,b) \<Rightarrow>
                     let b' = \<anb> b c;
                         \<beta>  = [c \<mapsto> b]
                     in (\<Union>cnt\<in>cnts. \<aF>\<cdot>(Discr (cnt,[{}],ve,b')))
                        \<union>
                        {((c, \<beta>), cont) | cont . cont \<in> cnts}
            | (PP (prim.If ct cf),[_, cntts, cntfs],ve,b) \<Rightarrow>
                  ((   let b' = \<anb> b ct;
                            \<beta> = [ct \<mapsto> b]
                        in (\<Union>cnt\<in>cntts . \<aF>\<cdot>(Discr (cnt,[],ve,b')))
                           \<union>{((ct, \<beta>), cnt) | cnt . cnt \<in> cntts}
                   )\<union>(
                       let b' = \<anb> b cf;
                            \<beta> = [cf \<mapsto> b]
                        in (\<Union>cnt\<in>cntfs . \<aF>\<cdot>(Discr (cnt,[],ve,b')))
                           \<union>{((cf, \<beta>), cnt) | cnt . cnt \<in> cntfs}
                   ))
            | (AStop,[_],_,_) \<Rightarrow> {}
            | _ \<Rightarrow> \<bottom>
        )"
      | "\<aC>\<cdot>cstate = (case undiscr cstate of
             (App lab f vs,\<beta>,ve,b) \<Rightarrow>
                 let fs = \<aA> f \<beta> ve;
                     as = map (\<lambda>v. \<aA> v \<beta> ve) vs;
                     b' = \<anb> b lab
                  in (\<Union>f' \<in> fs. \<aF>\<cdot>(Discr (f',as,ve,b')))
                     \<union>{((lab, \<beta>),f') | f' . f'\<in> fs}
            | (Let lab ls c',\<beta>,ve,b) \<Rightarrow>
                 let b' = \<anb> b lab;
                     \<beta>' = \<beta> (lab \<mapsto> b');
                     ve' = ve \<union>. (\<Union>. (map (\<lambda>(v,l). {(v,b') := (\<aA> (L l) \<beta>' ve)}.) ls))
                 in \<aC>\<cdot>(Discr (c',\<beta>',ve',b'))
        )"

text {*
Again, we name the cases of the induction rule and build a nicer case analysis rule for arguments of type @{text \<afstate>}.
*}

lemmas a_evalF_evalC_induct = a_evalF_a_evalC.induct[case_names Admissibility Bottom Next]

fun a_evalF_cases
 where "a_evalF_cases (PC (Lambda lab vs c, \<beta>)) as ve b = undefined"
     | "a_evalF_cases (PP (Plus cp)) [a1, a2, cnt] ve b = undefined"
     | "a_evalF_cases (PP (prim.If cp1 cp2)) [v,cntt,cntf] ve b = undefined"
     | "a_evalF_cases AStop [v] ve b = undefined"

lemmas a_fstate_case_x = a_evalF_cases.cases[
  OF case_split, of _ "\<lambda>_ vs _ _ as _ _ . length vs = length as",
  case_names "Closure" "Closure_inv" "Plus" "If" "Stop"]

lemmas a_cl_cases = prod.exhaust[OF lambda.exhaust, of _ "\<lambda> a _ . a"]
lemmas a_ds_cases = list.exhaust[
  OF _ list.exhaust,  of _ _ "\<lambda>_ x. x",
  OF _ _ list.exhaust  ,of _ _ "\<lambda>_ _ _ x. x" ,
  OF _ _ _ list.exhaust,of _ _ "\<lambda>_ _ _ _ _ x. x"
  ]
lemmas a_ds_cases_stop = list.exhaust[OF _ list.exhaust, of _ _ "\<lambda>_ x. x"]
lemmas a_fstate_case = prod_cases4[OF proc.exhaust, of _ "\<lambda>x _ _ _ . x",
  OF a_cl_cases prim.exhaust, of _ "\<lambda> _ _ _ _ a . a" _ "\<lambda> _ _ _ _ a. a",
  OF case_split a_ds_cases a_ds_cases a_ds_cases_stop,
  of _ "\<lambda>_ as _ _ _ _ _ _ vs _ . length vs = length as" _ "\<lambda> _ ds _ _ _ _ . ds" "\<lambda> _ ds _ _ _ _ _. ds" "\<lambda> _ ds _ _. ds"]

text {*
Not surprisingly, the abstract semantics of a whole program is defined using @{text \<aF>} with suitably initialized arguments. The function @{text the_elem} extracts a value from a singleton set. This works because we know that @{text "\<aA>"} returns such a set when given a lambda expression.
*}

definition evalCPS_a :: "prog \<Rightarrow> ('c::contour) \<aans>" ("\<aPR>")
  where "\<aPR> l = (let ve = {}.;
                          \<beta> = empty;
                          f = \<aA> (L l) \<beta> ve
                      in  \<aF>\<cdot>(Discr (the_elem f,[{AStop}],ve,\<abinit>)))"

end


(*  Title:       An Encoding of Lambdas in Lambda-Free Higher-Order Logic
    Author:      Jasmin Blanchette <j.c.blanchette at vu.nl>, 2019
    Maintainer:  Jasmin Blanchette <j.c.blanchette at vu.nl>
*)

section \<open>An Encoding of Lambdas in Lambda-Free Higher-Order Logic\<close>

theory Lambda_Encoding
imports Lambda_Free_Term
begin

text \<open>
This theory defines an encoding of \<open>\<lambda>\<close>-expressions as \<open>\<lambda>\<close>-free higher-order terms.
\<close>

locale lambda_encoding =
  fixes
    lam :: 's and
    db :: "nat \<Rightarrow> 's"
begin

definition is_db :: "'s \<Rightarrow> bool" where
  "is_db f \<longleftrightarrow> (\<exists>i. f = db i)"

fun subst_db :: "nat \<Rightarrow> 'v \<Rightarrow> ('s, 'v) tm \<Rightarrow> ('s, 'v) tm" where
  "subst_db i x (Hd \<zeta>) = Hd (if \<zeta> = Var x then Sym (db i) else \<zeta>)"
| "subst_db i x (App s t) =
   App (subst_db i x s) (subst_db (if head s = Sym lam then i + 1 else i) x t)"

definition raw_db_subst :: "nat \<Rightarrow> 'v \<Rightarrow> 'v \<Rightarrow> ('s, 'v) tm" where
  "raw_db_subst i x = (\<lambda>y. Hd (if y = x then Sym (db i) else Var y))"

lemma head_subst_db: "head (subst_db i x s) = head (subst (raw_db_subst i x) s)"
  by (induct s arbitrary: i) (auto simp: raw_db_subst_def split: hd.split)

lemma args_subst_db:
  "args (subst_db i x s) = map (subst_db (if head s = Sym lam then i + 1 else i) x) (args s)"
  by (induct s arbitrary: i) auto

lemma var_mset_subst_db_subseteq:
  "vars_mset s \<subseteq># vars_mset t \<Longrightarrow> vars_mset (subst_db i x s) \<subseteq># vars_mset (subst_db i x t)"
  by (simp add: vars_mset_subst_db multiset_filter_mono)

end

end


theory Watertank
  imports BigStep
begin

locale watertank =
  fixes Qmax :: real and
    r :: real and
    g :: real and
    period :: real
  assumes
    Qmax_def: "Qmax = 0.007" and
    r_def: "r = 0.0254" and
    g_def: "g = 9.8" and
    period_def: "period = 0.01"
begin

definition H :: char where "H = CHR ''h''"
definition V :: char where "V = CHR ''v''"
definition T :: char where "T = CHR ''t''"

lemma vars_distinct: "H \<noteq> V" "V \<noteq> H" "H \<noteq> T" "T \<noteq> H" "V \<noteq> T" "T \<noteq> V"
  unfolding H_def V_def T_def by auto

definition plant :: proc where
  "plant = Rep (
    T ::= (\<lambda>_. 0);
    Cont (ODE ((\<lambda>_ _. 0)(H := (\<lambda>s. s V * Qmax - pi * r^2 * sqrt(2 * g * s H)), T := (\<lambda>_. 1)))) (\<lambda>s. s T < period);
    Cm (''wl''[!](\<lambda>s. s H));
    Cm (''cc''[?]V))"

definition controller :: proc where
  "controller = Rep (
    Wait period;
    Cm (''wl''[?]H);
    (IF (\<lambda>s. s H \<le> 0.31) (V ::= (\<lambda>_. 1)) Skip);
    (IF (\<lambda>s. s H \<ge> 0.59) (V ::= (\<lambda>_. 0)) Skip);
    Cm (''cc''[!](\<lambda>s. s V)))"

definition model :: pproc where
  "model = PProc [plant, controller]"

text \<open>Invariant for plant at start of loop\<close>
definition Inv1 :: "state \<Rightarrow> bool" where
  "Inv1 s \<longleftrightarrow> (s H \<ge> 0.3 \<and> s H \<le> 0.6 \<and> (s H \<le> 0.31 \<longrightarrow> s V = 1) \<and> (s H \<ge> 0.59 \<longrightarrow> s V = 0)\<and>(s V\<in>{0,1}))"

text \<open>Invariant for plant after running the ODE\<close>
definition Inv2 :: "state \<Rightarrow> bool" where
  "Inv2 s \<longleftrightarrow> (s H \<ge> 0.3 \<and> s H \<le> 0.6)"

thm contE

lemma INV:
  assumes "\<forall>t\<in>{0..d}. ((f :: real \<Rightarrow> real) has_derivative (\<lambda>s. s * f' t)) (at t within {0..d})"
    and "\<forall>t\<in>{0..d}. f t = c \<longrightarrow> f' t < 0"
    and "d>0"
    and "f 0 \<le> c"
  shows "\<forall>t\<in>{0..d}. f t \<le> c"
proof-
  assume "\<not> (\<forall>t\<in>{0..d}. f t \<le> c)"
  then obtain s where s:"f s > c" "s\<in>{0..d}"
    unfolding not_def assms(3) by force
  then have 1:"s>0 \<and> s\<le>d"
    using assms(4)
    using atLeastAtMost_iff by fastforce
  have 2:"continuous_on {0..d} f"
    using assms(1)
    using has_derivative_continuous_on by fastforce
  then have 3:"continuous_on {0..s} f"
    using 1
    using continuous_on_subset by fastforce
  then obtain D where D:"D = vimage f {..c} \<inter> {0..s}"
    by auto
  then have 4:"D \<noteq> {}" using assms(4)
    using "1" by auto
  have 5:"closed D"
    using closed_vimage_Int[of "{..c}" "{0..s}" f] D 3 by auto
  then have 6:"compact D"
    using compact_Int_closed[of "{0..s}" D] D
    by (metis compact_Icc inf.idem inf_left_commute)
  obtain i where i:"i\<in>D" "\<forall>x\<in>D. x\<le>i" "{0..i}\<subseteq>{0..s}"
         using compact_attains_sup[of "D"] D 4 6
         by (metis Int_iff atLeastAtMost_iff atLeastatMost_subset_iff less_eq_real_def)
  then have 7:"i<s" using D s
    using less_eq_real_def by auto

  then show "False"

lemma Valid_of_ODE:
  assumes "Inv1 (end_of_trace (tr)) \<and> end_of_trace (tr) T = 0"
    shows "Valid
    (\<lambda>t. t = tr)
    (Cont (ODE ((\<lambda>_ _. 0)(H := (\<lambda>s. s V * Qmax - pi * r^2 * sqrt(2 * g * s H)), T := (\<lambda>_. 1)))) (\<lambda>s. s T < period))
    (\<lambda>t. \<exists>p. t = extend_trace tr (ODEBlock period (restrict p {0..period})) \<and> (\<forall> l\<in>{0..period}. Inv2 (p l)) \<and> p 0 = end_of_trace tr)"
proof-
  have 1:"d = period"
    if cond:
    "ODEsol (ODE ((\<lambda>_ _. 0)(H := (\<lambda>s. s V * Qmax - pi * r^2 * sqrt(2 * g * s H)), T := (\<lambda>_. 1)))) p d "
    "\<forall>t. 0 \<le> t \<and> t < d \<longrightarrow> (\<lambda>s. s T < period) (p t) "
    " \<not> (\<lambda>s. s T < period) (p d) "
    "p 0 = end_of_trace tr"
    "d\<ge>0" for d and p
  proof-
    have 101:"((\<lambda>t. state2vec (p t)) has_vderiv_on
   (\<lambda>t. ODE2Vec (ODE ((\<lambda>_ _. 0)(H := \<lambda>s. s V * Qmax - pi * r\<^sup>2 * sqrt (2 * g * s H), T := \<lambda>_. 1)))
         (p t)))
   {0..d}" using cond(1) unfolding ODEsol_def by auto
    have 102:"((\<lambda>t. (p t) T) has_vderiv_on (\<lambda>t. 1)) {0..d}"
      using 101 has_vderiv_on_proj[of "(\<lambda>t. state2vec (p t))" "(\<lambda>t. ODE2Vec (ODE ((\<lambda>_ _. 0)(H := \<lambda>s. s V * Qmax - pi * r\<^sup>2 * sqrt (2 * g * s H), T := \<lambda>_. 1)))
         (p t))" "{0..d}" "T"]
      unfolding state2vec_def apply auto
      unfolding state2vec_def by auto
    have 103:"p 0 T = 0" using cond assms by auto
    interpret loc:ll_on_open_it "{-1<..}" "(\<lambda>t v. 1)" "UNIV" "0"
        apply standard
          apply auto
      by(rule local_lipschitz_constI)
    have 104: "((\<lambda>t. t) solves_ode (\<lambda>t. \<lambda>v. 1)) {0..} UNIV"
      unfolding solves_ode_def has_vderiv_on_def
      by auto
    have 105: "(loc.flow 0 0) t = (\<lambda>t. t) t" if "t \<in> {0..}" for t
        apply (rule loc.maximal_existence_flow(2)[OF 104])
      using that by (auto simp add: state2vec_def)
    have 106: "((\<lambda>t. (p t) T) solves_ode (\<lambda>t. \<lambda>v. 1)) {0..d} UNIV"
        using 102 unfolding solves_ode_def by auto
    have 107: "loc.flow 0 0 t =  ((\<lambda>t. (p t) T) t)" if "t\<in>{0..d}" for t
        apply (rule loc.maximal_existence_flow(2)[OF 106])
        using assms that 103 by auto
    have 108:"t =  (p t) T" if "t\<in>{0..d}" for t
      using 105 107 that by auto
    have 109:"\<forall>t. 0 \<le> t \<and> t < d \<longrightarrow> t<period"
      using 108 cond(2) by auto
    have 110:"d\<ge>period"
      using 108 cond by auto
    show ?thesis using 109 110 period_def cond(5)
      by (metis divide_le_0_iff divide_self_if less_divide_eq_1_pos less_eq_real_def less_numeral_extra(4) zero_less_power2 zero_neq_numeral)
  qed
  have 2:"\<forall> l\<in>{0..period}. Inv2 (p l)"
      if cond:
        "ODEsol (ODE ((\<lambda>_ _. 0)(H := (\<lambda>s. s V * Qmax - pi * r^2 * sqrt(2 * g * s H)), T := (\<lambda>_. 1)))) p d "
        "\<forall>t. 0 \<le> t \<and> t < d \<longrightarrow> (\<lambda>s. s T < period) (p t) "
        " \<not> (\<lambda>s. s T < period) (p d) "
        "p 0 = end_of_trace tr"
        "d\<ge>0" for d and p
    proof-
      have 201:"d = period"
        using 1 cond by auto
      have 202:"\<forall>x. ((\<lambda>v. (vec2state v) H) has_derivative (\<lambda>x. \<lambda>v. (vec2state v) H)(x)) (at x within UNIV)"
        unfolding vec2state_def by auto
      have 203: "\<forall>t\<in>{0 .. d}. ((\<lambda>t. (p t) H) has_derivative  (\<lambda>s. (\<lambda>x. \<lambda>v. (vec2state v) H) (state2vec(p t)) (s *\<^sub>R ODE2Vec (ODE ((\<lambda>_ _. 0)(H := (\<lambda>s. s V * Qmax - pi * r^2 * sqrt(2 * g * s H)), T := (\<lambda>_. 1)))) (p t)))) (at t within {0 .. d})"
        using chainrule[of "(\<lambda>v. v H)" "\<lambda>x. (\<lambda>x. \<lambda>v. (vec2state v) H)(state2vec x)" "(ODE ((\<lambda>_ _. 0)(H := (\<lambda>s. s V * Qmax - pi * r^2 * sqrt(2 * g * s H)), T := (\<lambda>_. 1))))" p d]
        using 202 cond(1) by auto
      have 204: "\<forall>s. (\<lambda>x. \<lambda>v. (vec2state v) H) (state2vec(p t)) (s *\<^sub>R ODE2Vec (ODE ((\<lambda>_ _. 0)(H := (\<lambda>s. s V * Qmax - pi * r^2 * sqrt(2 * g * s H)), T := (\<lambda>_. 1)))) (p t)) = s * ((\<lambda>s. s V * Qmax - pi * r^2 * sqrt(2 * g * s H)) (p t))" if "t\<in>{0 .. d}" for t
        unfolding vec2state_def apply simp unfolding state2vec_def apply auto
        using vars_distinct by auto
      have 205:"\<forall>t\<in>{0 .. d}. (((\<lambda>t. (p t) H) has_derivative (\<lambda>s. s * ((\<lambda>s. s V * Qmax - pi * r^2 * sqrt(2 * g * s H)) (p t)))) (at t within {0 .. d}))"
        using 203 204 by auto
      have 206:"\<forall>t\<in>{0 .. d}. (p 0) V  = (p t) V"
        using cond(1) unfolding ODEsol_def apply simp unfolding has_vderiv_on_def
        using mvt_vector[of d p "\<lambda>x. (\<lambda>a. (if a = T then \<lambda>_. 1
                else ((\<lambda>_ _. 0)(H := \<lambda>s. s V * Qmax - pi * r\<^sup>2 * sqrt (2 * g * s H))) a)
                (p x))" "V"]
        using vars_distinct by auto
      have 207:"\<forall>t\<in>{0 .. d}. (p t) H - 0.6 * (p t) T \<le> 0"

         show ?thesis
        sorry
    qed
show ?thesis unfolding Valid_def apply auto
  subgoal for tr2
    using contE
end

thm continuous_image_closed_interval
thm open_vimage
thm closed_vimage
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)
 *)

(*<*)
theory Chapter2_HoareHeap
imports "../../AutoCorres"
begin
(*>*)

section  {* More Complex Functions with AutoCorres *}

text {*

  In the previous section we saw how to use the C-Parser and AutoCorres
  to prove properties about some very simple C programs.

  Real life C programs tend to be far more complex however; they
  read and write to local variables, have loops and use pointers to
  access the heap. In this section we will look at some simple programs
  which use loops and access the heap to show how AutoCorres can
  allow such constructs to be reasoned about.

*}

subsection {* A simple loop: \texttt{mult\_by\_add} *}

text {*

  Our C function \texttt{mult\_by\_add} implements a multiply operation
  by successive additions:

\lstinputlisting[language=C, firstline=5]{../../mult_by_add.c}

  We start by translating the program using the C parser and AutoCorres,
  and entering the generated locale \texttt{mult\_by\_add}.
*}

install_C_file "mult_by_add.c"
autocorres [ts_rules = nondet] "mult_by_add.c"
(*<*)
context mult_by_add begin
(*>*)

text {*
  The C parser produces the SIMPL output as follows:
*}

thm mult_by_add_body_def
text {* @{thm [display] mult_by_add_body_def} *}

text {*
  Which is abstracted by AutoCorres to the following:
*}

thm mult_by_add'_def
text {* @{thm [display] mult_by_add'_def } *}

text {*

  In this case AutoCorres has abstracted \texttt{mult\_by\_add} into a
  \emph{monadic} form. Monads are a pattern frequently used in
  functional programming to represent imperative-style control-flow; an
  in-depth introduction to monads can be found elsewhere.

  The monads used by AutoCorres in this example is a
  \emph{non-deterministic state monad}; program state is implicitly
  passed between each statement, and results of computations may produce
  more than one (or possibly zero) results\footnote{Non-determinism
  becomes useful when modelling hardware, for example, where the exact
  results of the hardware cannot be determined ahead of time.}.

  (* FIXME : probably describe below in further detail. *)
  The bulk of @{term "mult_by_add'"} is wrapped inside the @{term
  "whileLoop"} \emph{monad combinator}, which is really just a fancy way
  of describing the method used by AutoCorres to encode (potentially
  non-terminating) loops using monads.

  If we want to describe the behaviour of this program, we can use
  Hoare logic as follows:

    @{term [display] "\<lbrace> P \<rbrace> mult_by_add' a b \<lbrace> Q \<rbrace>"}

  This predicate states that, assuming @{term "P"} holds on the initial
  program state, if we execute @{term "mult_by_add' a b"}, then
  @{term "Q"} will hold on the final state of the program.

  There are a few details: while @{term "P"} has type
  @{typ "'s \<Rightarrow> bool"} (i.e., takes a state and returns true if
  it satisifies the precondition), @{term "Q"} has an additional
  parameter @{typ "'r \<Rightarrow> 's \<Rightarrow> bool"}. The additional parameter
  @{typ "'r"} is the \emph{return value} of the function; so, in
  our \texttt{mult\_by\_add'} example, it will be the result of
  the multiplication.

  For example one useful property to prove on our program would
  be:

    @{term [display] "\<lbrace> \<lambda>s. True \<rbrace> mult_by_add' a b \<lbrace> \<lambda>r s. r = a * b \<rbrace>"}

  That is, for all possible input states, our \texttt{mult\_by\_add'}
  function returns the product of @{term "a"} and @{term "b"}.

  Unfortunately, this is not sufficient. As mentioned in the previous
  section, AutoCorres produces a theorem for each function it abstracts
  stating that, \emph{assuming the function does not fail}, then the
  generated function is a valid abstraction of the concrete function.
  Thus, if we wish to reason about our concrete C function, we must
  also show non-failure on the abstract program. This can be done
  using the predicate @{term "no_fail"} as follows:

    @{term [display] "\<And>a b. no_fail (\<lambda>s. True) (mult_by_add' a b)"}

  Here @{term "\<lambda>s. True"} is the precondition on the input state.

  Instead of proving our Hoare triple and @{term no_fail} separately,
  we can prove them together using the ``valid no fail'' framework
  as follows:

    @{thm [display] validNF_def}

  Our proof of @{term mult_by_add'} could then proceed as follows:

*}

lemma mult_by_add_correct:
    "\<lbrace> \<lambda>s. True \<rbrace> mult_by_add' a b \<lbrace> \<lambda>r s. r = a * b \<rbrace>!"
  txt {* Unfold abstracted definition *}
  apply (unfold mult_by_add'_def)
  txt {* Annotate the loop with an invariant and a measure. *}
  apply (subst whileLoop_add_inv
    [where I="\<lambda>(a', result) s. result = (a - a') * b"
        and M="\<lambda>((a', result), s). a'"] )
  txt {* Run the ``weakest precondition'' tool \texttt{wp}. *}
  apply wp
  txt {* Solve the program correctness goals. *}
     apply (simp add: field_simps)
    apply unat_arith
   apply (auto simp: field_simps not_less)
  done

(* FIXME: Update the following explanation. *)
text {*
  The proof is straight-forward, but uses a few different techniques:
  The first is that we annotate the loop with a loop invariant and a
  measure, using the rule @{thm whileLoop_add_inv}. We then run the
  \texttt{wp} tool which applys a large set of
  \emph{weakest precondition} rules on the program\footnote{This set of
  rules includes a rule which can handle annotated @{term whileLoop}
  terms, but will not attempt to process @{term whileLoop} terms without
  annotations.}. We finially discharge the remaining subgoals left from
  the \texttt{wp} tool using \texttt{auto}, and our proof is complete.

  In the next section, we will look at how we can use AutoCorres to
  verify a C program that reads and writes to the heap.

*}

(*<*)
end
end
(*>*)


(*  Title:      ZF/Constructible/Rec_Separation.thy
    Author:     Lawrence C Paulson, Cambridge University Computer Laboratory
*)

section {*Separation for Facts About Recursion*}

theory Rec_Separation imports Separation Internalize begin

text{*This theory proves all instances needed for locales @{text
"M_trancl"} and @{text "M_datatypes"}*}

lemma eq_succ_imp_lt: "[|i = succ(j); Ord(i)|] ==> j<i"
by simp

subsection{*The Locale @{text "M_trancl"}*}

subsubsection{*Separation for Reflexive/Transitive Closure*}

text{*First, The Defining Formula*}

(* "rtran_closure_mem(M,A,r,p) ==
      \<exists>nnat[M]. \<exists>n[M]. \<exists>n'[M].
       omega(M,nnat) & n\<in>nnat & successor(M,n,n') &
       (\<exists>f[M]. typed_function(M,n',A,f) &
        (\<exists>x[M]. \<exists>y[M]. \<exists>zero[M]. pair(M,x,y,p) & empty(M,zero) &
          fun_apply(M,f,zero,x) & fun_apply(M,f,n,y)) &
        (\<forall>j[M]. j\<in>n \<longrightarrow>
          (\<exists>fj[M]. \<exists>sj[M]. \<exists>fsj[M]. \<exists>ffp[M].
            fun_apply(M,f,j,fj) & successor(M,j,sj) &
            fun_apply(M,f,sj,fsj) & pair(M,fj,fsj,ffp) & ffp \<in> r)))"*)
definition
  rtran_closure_mem_fm :: "[i,i,i]=>i" where
 "rtran_closure_mem_fm(A,r,p) ==
   Exists(Exists(Exists(
    And(omega_fm(2),
     And(Member(1,2),
      And(succ_fm(1,0),
       Exists(And(typed_function_fm(1, A#+4, 0),
        And(Exists(Exists(Exists(
              And(pair_fm(2,1,p#+7),
               And(empty_fm(0),
                And(fun_apply_fm(3,0,2), fun_apply_fm(3,5,1))))))),
            Forall(Implies(Member(0,3),
             Exists(Exists(Exists(Exists(
              And(fun_apply_fm(5,4,3),
               And(succ_fm(4,2),
                And(fun_apply_fm(5,2,1),
                 And(pair_fm(3,1,0), Member(0,r#+9))))))))))))))))))))"

lemma rtran_closure_mem_type [TC]:
 "[| x \<in> nat; y \<in> nat; z \<in> nat |] ==> rtran_closure_mem_fm(x,y,z) \<in> formula"
by (simp add: rtran_closure_mem_fm_def)

lemma sats_rtran_closure_mem_fm [simp]:
   "[| x \<in> nat; y \<in> nat; z \<in> nat; env \<in> list(A)|]
    ==> sats(A, rtran_closure_mem_fm(x,y,z), env) \<longleftrightarrow>
        rtran_closure_mem(##A, nth(x,env), nth(y,env), nth(z,env))"
by (simp add: rtran_closure_mem_fm_def rtran_closure_mem_def)

lemma rtran_closure_mem_iff_sats:
      "[| nth(i,env) = x; nth(j,env) = y; nth(k,env) = z;
          i \<in> nat; j \<in> nat; k \<in> nat; env \<in> list(A)|]
       ==> rtran_closure_mem(##A, x, y, z) \<longleftrightarrow> sats(A, rtran_closure_mem_fm(i,j,k), env)"
by (simp add: sats_rtran_closure_mem_fm)

lemma rtran_closure_mem_reflection:
     "REFLECTS[\<lambda>x. rtran_closure_mem(L,f(x),g(x),h(x)),
               \<lambda>i x. rtran_closure_mem(##Lset(i),f(x),g(x),h(x))]"
apply (simp only: rtran_closure_mem_def)
apply (intro FOL_reflections function_reflections fun_plus_reflections)
done

text{*Separation for @{term "rtrancl(r)"}.*}
lemma rtrancl_separation:
     "[| L(r); L(A) |] ==> separation (L, rtran_closure_mem(L,A,r))"
apply (rule gen_separation_multi [OF rtran_closure_mem_reflection, of "{r,A}"],
       auto)
apply (rule_tac env="[r,A]" in DPow_LsetI)
apply (rule rtran_closure_mem_iff_sats sep_rules | simp)+
done

subsubsection{*Reflexive/Transitive Closure, Internalized*}

(*  "rtran_closure(M,r,s) ==
        \<forall>A[M]. is_field(M,r,A) \<longrightarrow>
         (\<forall>p[M]. p \<in> s \<longleftrightarrow> rtran_closure_mem(M,A,r,p))" *)
definition
  rtran_closure_fm :: "[i,i]=>i" where
  "rtran_closure_fm(r,s) ==
   Forall(Implies(field_fm(succ(r),0),
                  Forall(Iff(Member(0,succ(succ(s))),
                             rtran_closure_mem_fm(1,succ(succ(r)),0)))))"

lemma rtran_closure_type [TC]:
     "[| x \<in> nat; y \<in> nat |] ==> rtran_closure_fm(x,y) \<in> formula"
by (simp add: rtran_closure_fm_def)

lemma sats_rtran_closure_fm [simp]:
   "[| x \<in> nat; y \<in> nat; env \<in> list(A)|]
    ==> sats(A, rtran_closure_fm(x,y), env) \<longleftrightarrow>
        rtran_closure(##A, nth(x,env), nth(y,env))"
by (simp add: rtran_closure_fm_def rtran_closure_def)

lemma rtran_closure_iff_sats:
      "[| nth(i,env) = x; nth(j,env) = y;
          i \<in> nat; j \<in> nat; env \<in> list(A)|]
       ==> rtran_closure(##A, x, y) \<longleftrightarrow> sats(A, rtran_closure_fm(i,j), env)"
by simp

theorem rtran_closure_reflection:
     "REFLECTS[\<lambda>x. rtran_closure(L,f(x),g(x)),
               \<lambda>i x. rtran_closure(##Lset(i),f(x),g(x))]"
apply (simp only: rtran_closure_def)
apply (intro FOL_reflections function_reflections rtran_closure_mem_reflection)
done

subsubsection{*Transitive Closure of a Relation, Internalized*}

(*  "tran_closure(M,r,t) ==
         \<exists>s[M]. rtran_closure(M,r,s) & composition(M,r,s,t)" *)
definition
  tran_closure_fm :: "[i,i]=>i" where
  "tran_closure_fm(r,s) ==
   Exists(And(rtran_closure_fm(succ(r),0), composition_fm(succ(r),0,succ(s))))"

lemma tran_closure_type [TC]:
     "[| x \<in> nat; y \<in> nat |] ==> tran_closure_fm(x,y) \<in> formula"
by (simp add: tran_closure_fm_def)

lemma sats_tran_closure_fm [simp]:
   "[| x \<in> nat; y \<in> nat; env \<in> list(A)|]
    ==> sats(A, tran_closure_fm(x,y), env) \<longleftrightarrow>
        tran_closure(##A, nth(x,env), nth(y,env))"
by (simp add: tran_closure_fm_def tran_closure_def)

lemma tran_closure_iff_sats:
      "[| nth(i,env) = x; nth(j,env) = y;
          i \<in> nat; j \<in> nat; env \<in> list(A)|]
       ==> tran_closure(##A, x, y) \<longleftrightarrow> sats(A, tran_closure_fm(i,j), env)"
by simp

theorem tran_closure_reflection:
     "REFLECTS[\<lambda>x. tran_closure(L,f(x),g(x)),
               \<lambda>i x. tran_closure(##Lset(i),f(x),g(x))]"
apply (simp only: tran_closure_def)
apply (intro FOL_reflections function_reflections
             rtran_closure_reflection composition_reflection)
done

subsubsection{*Separation for the Proof of @{text "wellfounded_on_trancl"}*}

lemma wellfounded_trancl_reflects:
  "REFLECTS[\<lambda>x. \<exists>w[L]. \<exists>wx[L]. \<exists>rp[L].
                 w \<in> Z & pair(L,w,x,wx) & tran_closure(L,r,rp) & wx \<in> rp,
   \<lambda>i x. \<exists>w \<in> Lset(i). \<exists>wx \<in> Lset(i). \<exists>rp \<in> Lset(i).
       w \<in> Z & pair(##Lset(i),w,x,wx) & tran_closure(##Lset(i),r,rp) &
       wx \<in> rp]"
by (intro FOL_reflections function_reflections fun_plus_reflections
          tran_closure_reflection)

lemma wellfounded_trancl_separation:
         "[| L(r); L(Z) |] ==>
          separation (L, \<lambda>x.
              \<exists>w[L]. \<exists>wx[L]. \<exists>rp[L].
               w \<in> Z & pair(L,w,x,wx) & tran_closure(L,r,rp) & wx \<in> rp)"
apply (rule gen_separation_multi [OF wellfounded_trancl_reflects, of "{r,Z}"],
       auto)
apply (rule_tac env="[r,Z]" in DPow_LsetI)
apply (rule sep_rules tran_closure_iff_sats | simp)+
done

subsubsection{*Instantiating the locale @{text M_trancl}*}

lemma M_trancl_axioms_L: "M_trancl_axioms(L)"
  apply (rule M_trancl_axioms.intro)
   apply (assumption | rule rtrancl_separation wellfounded_trancl_separation)+
  done

theorem M_trancl_L: "PROP M_trancl(L)"
by (rule M_trancl.intro [OF M_basic_L M_trancl_axioms_L])

interpretation L?: M_trancl L by (rule M_trancl_L)

subsection{*@{term L} is Closed Under the Operator @{term list}*}

subsubsection{*Instances of Replacement for Lists*}

lemma list_replacement1_Reflects:
 "REFLECTS
   [\<lambda>x. \<exists>u[L]. u \<in> B \<and> (\<exists>y[L]. pair(L,u,y,x) \<and>
         is_wfrec(L, iterates_MH(L, is_list_functor(L,A), 0), memsn, u, y)),
    \<lambda>i x. \<exists>u \<in> Lset(i). u \<in> B \<and> (\<exists>y \<in> Lset(i). pair(##Lset(i), u, y, x) \<and>
         is_wfrec(##Lset(i),
                  iterates_MH(##Lset(i),
                          is_list_functor(##Lset(i), A), 0), memsn, u, y))]"
by (intro FOL_reflections function_reflections is_wfrec_reflection
          iterates_MH_reflection list_functor_reflection)

lemma list_replacement1:
   "L(A) ==> iterates_replacement(L, is_list_functor(L,A), 0)"
apply (unfold iterates_replacement_def wfrec_replacement_def, clarify)
apply (rule strong_replacementI)
apply (rule_tac u="{B,A,n,0,Memrel(succ(n))}"
         in gen_separation_multi [OF list_replacement1_Reflects],
       auto simp add: nonempty)
apply (rule_tac env="[B,A,n,0,Memrel(succ(n))]" in DPow_LsetI)
apply (rule sep_rules is_nat_case_iff_sats list_functor_iff_sats
            is_wfrec_iff_sats iterates_MH_iff_sats quasinat_iff_sats | simp)+
done

lemma list_replacement2_Reflects:
 "REFLECTS
   [\<lambda>x. \<exists>u[L]. u \<in> B & u \<in> nat &
                is_iterates(L, is_list_functor(L, A), 0, u, x),
    \<lambda>i x. \<exists>u \<in> Lset(i). u \<in> B & u \<in> nat &
               is_iterates(##Lset(i), is_list_functor(##Lset(i), A), 0, u, x)]"
by (intro FOL_reflections
          is_iterates_reflection list_functor_reflection)

lemma list_replacement2:
   "L(A) ==> strong_replacement(L,
         \<lambda>n y. n\<in>nat & is_iterates(L, is_list_functor(L,A), 0, n, y))"
apply (rule strong_replacementI)
apply (rule_tac u="{A,B,0,nat}"
         in gen_separation_multi [OF list_replacement2_Reflects],
       auto simp add: L_nat nonempty)
apply (rule_tac env="[A,B,0,nat]" in DPow_LsetI)
apply (rule sep_rules list_functor_iff_sats is_iterates_iff_sats | simp)+
done

subsection{*@{term L} is Closed Under the Operator @{term formula}*}

subsubsection{*Instances of Replacement for Formulas*}

(*FIXME: could prove a lemma iterates_replacementI to eliminate the
need to expand iterates_replacement and wfrec_replacement*)
lemma formula_replacement1_Reflects:
 "REFLECTS
   [\<lambda>x. \<exists>u[L]. u \<in> B & (\<exists>y[L]. pair(L,u,y,x) &
         is_wfrec(L, iterates_MH(L, is_formula_functor(L), 0), memsn, u, y)),
    \<lambda>i x. \<exists>u \<in> Lset(i). u \<in> B & (\<exists>y \<in> Lset(i). pair(##Lset(i), u, y, x) &
         is_wfrec(##Lset(i),
                  iterates_MH(##Lset(i),
                          is_formula_functor(##Lset(i)), 0), memsn, u, y))]"
by (intro FOL_reflections function_reflections is_wfrec_reflection
          iterates_MH_reflection formula_functor_reflection)

lemma formula_replacement1:
   "iterates_replacement(L, is_formula_functor(L), 0)"
apply (unfold iterates_replacement_def wfrec_replacement_def, clarify)
apply (rule strong_replacementI)
apply (rule_tac u="{B,n,0,Memrel(succ(n))}"
         in gen_separation_multi [OF formula_replacement1_Reflects],
       auto simp add: nonempty)
apply (rule_tac env="[n,B,0,Memrel(succ(n))]" in DPow_LsetI)
apply (rule sep_rules is_nat_case_iff_sats formula_functor_iff_sats
            is_wfrec_iff_sats iterates_MH_iff_sats quasinat_iff_sats | simp)+
done

lemma formula_replacement2_Reflects:
 "REFLECTS
   [\<lambda>x. \<exists>u[L]. u \<in> B & u \<in> nat &
                is_iterates(L, is_formula_functor(L), 0, u, x),
    \<lambda>i x. \<exists>u \<in> Lset(i). u \<in> B & u \<in> nat &
               is_iterates(##Lset(i), is_formula_functor(##Lset(i)), 0, u, x)]"
by (intro FOL_reflections
          is_iterates_reflection formula_functor_reflection)

lemma formula_replacement2:
   "strong_replacement(L,
         \<lambda>n y. n\<in>nat & is_iterates(L, is_formula_functor(L), 0, n, y))"
apply (rule strong_replacementI)
apply (rule_tac u="{B,0,nat}"
         in gen_separation_multi [OF formula_replacement2_Reflects],
       auto simp add: nonempty L_nat)
apply (rule_tac env="[B,0,nat]" in DPow_LsetI)
apply (rule sep_rules formula_functor_iff_sats is_iterates_iff_sats | simp)+
done

text{*NB The proofs for type @{term formula} are virtually identical to those
for @{term "list(A)"}.  It was a cut-and-paste job! *}

subsubsection{*The Formula @{term is_nth}, Internalized*}

(* "is_nth(M,n,l,Z) ==
      \<exists>X[M]. is_iterates(M, is_tl(M), l, n, X) & is_hd(M,X,Z)" *)
definition
  nth_fm :: "[i,i,i]=>i" where
    "nth_fm(n,l,Z) ==
       Exists(And(is_iterates_fm(tl_fm(1,0), succ(l), succ(n), 0),
              hd_fm(0,succ(Z))))"

lemma nth_fm_type [TC]:
 "[| x \<in> nat; y \<in> nat; z \<in> nat |] ==> nth_fm(x,y,z) \<in> formula"
by (simp add: nth_fm_def)

lemma sats_nth_fm [simp]:
   "[| x < length(env); y \<in> nat; z \<in> nat; env \<in> list(A)|]
    ==> sats(A, nth_fm(x,y,z), env) \<longleftrightarrow>
        is_nth(##A, nth(x,env), nth(y,env), nth(z,env))"
apply (frule lt_length_in_nat, assumption)
apply (simp add: nth_fm_def is_nth_def sats_is_iterates_fm)
done

lemma nth_iff_sats:
      "[| nth(i,env) = x; nth(j,env) = y; nth(k,env) = z;
          i < length(env); j \<in> nat; k \<in> nat; env \<in> list(A)|]
       ==> is_nth(##A, x, y, z) \<longleftrightarrow> sats(A, nth_fm(i,j,k), env)"
by (simp add: sats_nth_fm)

theorem nth_reflection:
     "REFLECTS[\<lambda>x. is_nth(L, f(x), g(x), h(x)),
               \<lambda>i x. is_nth(##Lset(i), f(x), g(x), h(x))]"
apply (simp only: is_nth_def)
apply (intro FOL_reflections is_iterates_reflection
             hd_reflection tl_reflection)
done

subsubsection{*An Instance of Replacement for @{term nth}*}

(*FIXME: could prove a lemma iterates_replacementI to eliminate the
need to expand iterates_replacement and wfrec_replacement*)
lemma nth_replacement_Reflects:
 "REFLECTS
   [\<lambda>x. \<exists>u[L]. u \<in> B & (\<exists>y[L]. pair(L,u,y,x) &
         is_wfrec(L, iterates_MH(L, is_tl(L), z), memsn, u, y)),
    \<lambda>i x. \<exists>u \<in> Lset(i). u \<in> B & (\<exists>y \<in> Lset(i). pair(##Lset(i), u, y, x) &
         is_wfrec(##Lset(i),
                  iterates_MH(##Lset(i),
                          is_tl(##Lset(i)), z), memsn, u, y))]"
by (intro FOL_reflections function_reflections is_wfrec_reflection
          iterates_MH_reflection tl_reflection)

lemma nth_replacement:
   "L(w) ==> iterates_replacement(L, is_tl(L), w)"
apply (unfold iterates_replacement_def wfrec_replacement_def, clarify)
apply (rule strong_replacementI)
apply (rule_tac u="{B,w,Memrel(succ(n))}"
         in gen_separation_multi [OF nth_replacement_Reflects],
       auto)
apply (rule_tac env="[B,w,Memrel(succ(n))]" in DPow_LsetI)
apply (rule sep_rules is_nat_case_iff_sats tl_iff_sats
            is_wfrec_iff_sats iterates_MH_iff_sats quasinat_iff_sats | simp)+
done

subsubsection{*Instantiating the locale @{text M_datatypes}*}

lemma M_datatypes_axioms_L: "M_datatypes_axioms(L)"
  apply (rule M_datatypes_axioms.intro)
      apply (assumption | rule
        list_replacement1 list_replacement2
        formula_replacement1 formula_replacement2
        nth_replacement)+
  done

theorem M_datatypes_L: "PROP M_datatypes(L)"
  apply (rule M_datatypes.intro)
   apply (rule M_trancl_L)
  apply (rule M_datatypes_axioms_L)
  done

interpretation L?: M_datatypes L by (rule M_datatypes_L)

subsection{*@{term L} is Closed Under the Operator @{term eclose}*}

subsubsection{*Instances of Replacement for @{term eclose}*}

lemma eclose_replacement1_Reflects:
 "REFLECTS
   [\<lambda>x. \<exists>u[L]. u \<in> B & (\<exists>y[L]. pair(L,u,y,x) &
         is_wfrec(L, iterates_MH(L, big_union(L), A), memsn, u, y)),
    \<lambda>i x. \<exists>u \<in> Lset(i). u \<in> B & (\<exists>y \<in> Lset(i). pair(##Lset(i), u, y, x) &
         is_wfrec(##Lset(i),
                  iterates_MH(##Lset(i), big_union(##Lset(i)), A),
                  memsn, u, y))]"
by (intro FOL_reflections function_reflections is_wfrec_reflection
          iterates_MH_reflection)

lemma eclose_replacement1:
   "L(A) ==> iterates_replacement(L, big_union(L), A)"
apply (unfold iterates_replacement_def wfrec_replacement_def, clarify)
apply (rule strong_replacementI)
apply (rule_tac u="{B,A,n,Memrel(succ(n))}"
         in gen_separation_multi [OF eclose_replacement1_Reflects], auto)
apply (rule_tac env="[B,A,n,Memrel(succ(n))]" in DPow_LsetI)
apply (rule sep_rules iterates_MH_iff_sats is_nat_case_iff_sats
             is_wfrec_iff_sats big_union_iff_sats quasinat_iff_sats | simp)+
done

lemma eclose_replacement2_Reflects:
 "REFLECTS
   [\<lambda>x. \<exists>u[L]. u \<in> B & u \<in> nat &
                is_iterates(L, big_union(L), A, u, x),
    \<lambda>i x. \<exists>u \<in> Lset(i). u \<in> B & u \<in> nat &
               is_iterates(##Lset(i), big_union(##Lset(i)), A, u, x)]"
by (intro FOL_reflections function_reflections is_iterates_reflection)

lemma eclose_replacement2:
   "L(A) ==> strong_replacement(L,
         \<lambda>n y. n\<in>nat & is_iterates(L, big_union(L), A, n, y))"
apply (rule strong_replacementI)
apply (rule_tac u="{A,B,nat}"
         in gen_separation_multi [OF eclose_replacement2_Reflects],
       auto simp add: L_nat)
apply (rule_tac env="[A,B,nat]" in DPow_LsetI)
apply (rule sep_rules is_iterates_iff_sats big_union_iff_sats | simp)+
done

subsubsection{*Instantiating the locale @{text M_eclose}*}

lemma M_eclose_axioms_L: "M_eclose_axioms(L)"
  apply (rule M_eclose_axioms.intro)
   apply (assumption | rule eclose_replacement1 eclose_replacement2)+
  done

theorem M_eclose_L: "PROP M_eclose(L)"
  apply (rule M_eclose.intro)
   apply (rule M_datatypes_L)
  apply (rule M_eclose_axioms_L)
  done

interpretation L?: M_eclose L by (rule M_eclose_L)

end


(*  Author:     Tobias Nipkow
    Copyright   1998 TUM

Is there an optimal order of arguments for `next'?
Currently we can have laws like `delta A (a#w) = delta A w o delta A a'
Otherwise we could have `acceps A == fin A o delta A (start A)'
and use foldl instead of foldl2.
*)

section "Projection functions for automata"

theory AutoProj
imports Main
begin

definition start :: "'a * 'b * 'c \<Rightarrow> 'a" where "start A = fst A"
definition "next" :: "'a * 'b * 'c \<Rightarrow> 'b" where "next A = fst(snd(A))"
definition fin :: "'a * 'b * 'c \<Rightarrow> 'c" where "fin A = snd(snd(A))"

lemma [simp]: "next(q,d,f) = d"
by(simp add:next_def)

lemma [simp]: "fin(q,d,f) = f"
by(simp add:fin_def)

end


section{*Network Security Policy Verification*}
theory Network_Security_Policy_Verification
imports
  TopoS_Interface
  TopoS_Interface_impl
  TopoS_Library
  TopoS_Composition_Theory
  TopoS_Stateful_Policy
  TopoS_Composition_Theory_impl
  TopoS_Stateful_Policy_Algorithm
  TopoS_Stateful_Policy_impl
  TopoS_Impl
begin

section{*A small Tutorial*}

text{*We demonstrate usage of the executable theory.*}
text{*Everything that is indented and starts with `Interlude:' summarizes the main correctness proofs and can be skipped if only the implementation is concerned*}

subsection{*Policy*}
text{*The secuity policy is a directed graph.*}
definition policy :: "nat list_graph" where
    "policy \<equiv> \<lparr> nodesL = [1,2,3],
                edgesL = [(1,2), (2,2), (2,3)] \<rparr>"

text{*It is syntactically well-formed *}
lemma wf_list_graph_policy: "wf_list_graph policy" by eval

text{*In contrast, this is not a syntactically well-formed graph. *}
lemma "\<not> wf_list_graph \<lparr> nodesL = [1,2]::nat list, edgesL = [(1,2), (2,2), (2,3)] \<rparr>" by eval

text{*Our @{const policy} has three rules. *}
lemma "length (edgesL policy) = 3" by eval

subsection{*Security Invariants*}
text{*We construct a security invariant. Node @{term "2::nat"} has confidential data*}

definition BLP_security_levels :: "nat \<rightharpoonup> SINVAR_BLPtrusted.node_config"where
  "BLP_security_levels \<equiv> [2 \<mapsto> \<lparr> security_level = 1, trusted = False \<rparr>]"

definition BLP_m::"(nat SecurityInvariant)" where
    "BLP_m \<equiv> new_configured_list_SecurityInvariant SINVAR_LIB_BLPtrusted \<lparr>
          node_properties = BLP_security_levels
          \<rparr> ''Two has confidential information''"

  text{*Interlude: @{const BLP_m} is a valid implementation of a SecurityInvariant*}
  definition BLP_m_spec :: "nat SecurityInvariant_configured option"where
    "BLP_m_spec \<equiv> new_configured_SecurityInvariant (
        SINVAR_BLPtrusted.sinvar,
        SINVAR_BLPtrusted.default_node_properties,
        SINVAR_BLPtrusted.receiver_violation,
        SecurityInvariant.node_props SINVAR_BLPtrusted.default_node_properties \<lparr>
          node_properties = BLP_security_levels
        \<rparr>)"
  text{*Fist, we need to show that the formal definition obeys all requirements, @{const new_configured_SecurityInvariant} verifies this. To double check, we manually give the configuration.*}
  lemma BLP_m_spec: assumes "nP = (\<lambda> v. (case BLP_security_levels v of Some c \<Rightarrow> c | None \<Rightarrow> SINVAR_BLPtrusted.default_node_properties))"
      shows "BLP_m_spec = Some \<lparr>
              c_sinvar = (\<lambda>G. SINVAR_BLPtrusted.sinvar G nP),
              c_offending_flows = (\<lambda>G. SecurityInvariant_withOffendingFlows.set_offending_flows SINVAR_BLPtrusted.sinvar G nP),
              c_isIFS = SINVAR_BLPtrusted.receiver_violation
            \<rparr>" (is "BLP_m_spec = Some ?Spec")
  proof -
    have NetModelLib: "TopoS_modelLibrary SINVAR_LIB_BLPtrusted SINVAR_BLPtrusted.sinvar"
    by(unfold_locales)
    from assms have nP: "nP = nm_node_props SINVAR_LIB_BLPtrusted \<lparr>
              node_properties = BLP_security_levels
            \<rparr>" by(simp add: fun_eq_iff SINVAR_LIB_BLPtrusted_def SINVAR_BLPtrusted_impl.NetModel_node_props_def)

    have "BLP_m_spec = new_configured_SecurityInvariant (SINVAR_BLPtrusted.sinvar, SINVAR_BLPtrusted.default_node_properties, SINVAR_BLPtrusted.receiver_violation, nP)"
    unfolding BLP_m_spec_def nP by(simp add: SINVAR_BLPtrusted_impl.NetModel_node_props_def SINVAR_LIB_BLPtrusted_def)
    also with TopoS_modelLibrary_yields_new_configured_SecurityInvariant[OF NetModelLib nP]
    have "\<dots> = Some ?Spec" by (simp add: SINVAR_LIB_BLPtrusted_def)
    finally show ?thesis by blast
  qed
  lemma valid_reqs_BLP: "valid_reqs [the BLP_m_spec]"
    by(simp add: valid_reqs_def)(metis BLP_m_spec_def BLPtrusted_impl.spec new_configured_SecurityInvariant.simps new_configured_SecurityInvariant_sound option.distinct(1) option.exhaust_sel)

  text{*Interlude: While @{const BLP_m} is executable code, we will now show that this executable code complies with its formal definition.*}
  lemma complies_BLP: "SecurityInvariant_complies_formal_def BLP_m (the BLP_m_spec)"
    unfolding BLP_m_def
    apply(rule new_configured_list_SecurityInvariant_complies)
       apply(simp_all add: BLP_m_spec_def)
     apply(unfold_locales)
    by(simp add: fun_eq_iff SINVAR_LIB_BLPtrusted_def SINVAR_BLPtrusted_impl.NetModel_node_props_def)

text{*We define the list of all security invariants of type @{typ "nat SecurityInvariant list"}.
     The type @{typ nat} is because the policy's nodes are of type @{typ nat}.*}
definition "security_invariants = [BLP_m]"

text{*We can see that the policy does not fulfill the security invariants. *}
lemma "\<not> all_security_requirements_fulfilled security_invariants policy" by eval

text{*We ask why. Obviously, node 2 leaks confidential data to node 3.*}
value "implc_get_offending_flows security_invariants policy"
lemma "implc_get_offending_flows security_invariants policy = [[(2, 3)]]" by eval

  text{*Interlude: the implementation @{const implc_get_offending_flows} corresponds to the formal definition @{const get_offending_flows}*}
  lemma "set ` set (implc_get_offending_flows (get_impl [(BLP_m, the BLP_m_spec)]) policy) = get_offending_flows (get_spec [(BLP_m, the BLP_m_spec)]) (list_graph_to_graph policy)"
  apply(rule implc_get_offending_flows_complies)
   by(simp_all add: complies_BLP wf_list_graph_policy)

text{*
Visualization of the violation (only in interactive mode)
*}
ML_val{*
visualize_graph @{context} @{term "security_invariants"} @{term "policy"};
*}

text{*Experimental: the config (only one) can be added to the end.*}
ML_val{*
visualize_graph_header @{context} @{term "security_invariants"} @{term "policy"} @{term "BLP_security_levels"};
*}

text{*
The policy has a flaw. We throw it away and generate a new one which fulfills the invariants.
*}
definition "max_policy = generate_valid_topology security_invariants \<lparr>nodesL = nodesL policy, edgesL = List.product (nodesL policy) (nodesL policy) \<rparr>"

  text{*Interlude: the implementation @{const implc_get_offending_flows} corresponds to the formal definition @{const get_offending_flows}*}
  thm generate_valid_topology_complies

  text{*Interlude: the formal definition is sound*}
  thm generate_valid_topology_sound

  text{*Here, it is also complete*}
  lemma "wf_graph G \<Longrightarrow> max_topo [the BLP_m_spec] (TopoS_Composition_Theory.generate_valid_topology [the BLP_m_spec] (fully_connected G))"
  apply(rule generate_valid_topology_max_topo[OF valid_reqs_BLP])
   apply(assumption)
  apply(simp add: BLP_m_spec)
  by blast

text{*Calculating the maximum policy*}
value "max_policy"
lemma "max_policy = \<lparr>nodesL = [1, 2, 3], edgesL = [(1, 1), (1, 2), (1, 3), (2, 2), (3, 1), (3, 2), (3, 3)]\<rparr>" by eval

text{*
Visualizing the maximum policy (only in interactive mode)
*}
ML{*
visualize_graph @{context} @{term "security_invariants"} @{term "max_policy"};
*}

text{*Of course, all security invariants hold for the maximum policy. *}
lemma "all_security_requirements_fulfilled security_invariants max_policy" by eval

subsection{*A stateful implementation*}
text{*We generate a stateful policy*}
definition "stateful_policy = generate_valid_stateful_policy_IFSACS_2 policy security_invariants"

text{*When thinking about it carefully, no flow can be stateful without introducing an information leakage here!*}
value "stateful_policy"
lemma "stateful_policy = \<lparr>hostsL = [1, 2, 3], flows_fixL = [(1, 2), (2, 2), (2, 3)], flows_stateL = []\<rparr>" by eval

  text{*Interlude: the stateful policy we are computing fulfills all the necessary properties*}
  thm generate_valid_stateful_policy_IFSACS_2_complies

  (*the individual algorithms fir IFS/ACS return a maximum policy*)
  thm filter_compliant_stateful_ACS_correct filter_compliant_stateful_ACS_maximal
  thm filter_IFS_no_violations_correct filter_IFS_no_violations_maximal

text{*
Visualizing the stateful policy (only in interactive mode)
*}
ML_val{*
visualize_edges @{context} @{term "flows_fixL stateful_policy"}
    [("edge [dir=\"arrow\", style=dashed, color=\"#FF8822\", constraint=false]", @{term "flows_stateL stateful_policy"})] "";
*}

text{*This is how it would look like if @{term "(3,1)"} were a stateful flow*}
ML_val{*
visualize_edges @{context} @{term "flows_fixL stateful_policy"}
    [("edge [dir=\"arrow\", style=dashed, color=\"#FF8822\", constraint=false]", @{term "[(3::nat,1::nat)]"})] "";
*}

hide_const policy security_invariants max_policy stateful_policy

end