theory NFAGA
imports NFASpec
begin

subsection \<open> Construction hierarchy \<close>

lemma nfa_dfa_construct_default :
assumes label_set_OK: "nfa_dfa_construct_label_sets \<alpha> invar \<alpha>_s invar_s q2_\<alpha> q2_invar (\<lambda>x. {x}) (\<lambda>_. True) construct"
shows "nfa_dfa_construct \<alpha> invar \<alpha>_s invar_s q2_\<alpha> q2_invar construct"
proof (intro nfa_dfa_construct.intro nfa_dfa_construct_axioms.intro)
  from label_set_OK show "nfa \<alpha> invar" unfolding nfa_dfa_construct_label_sets_def by simp
next
  fix \<A>::"('f, 'c) NFA_rec" and det and f::"'f \<Rightarrow> 'g" and ff I A FP and D_it::"'e \<Rightarrow> ('h \<Rightarrow> bool) \<Rightarrow> ('c \<times> 'e \<Rightarrow> 'h \<Rightarrow> 'h) \<Rightarrow> 'h \<Rightarrow> 'h"
  assume assms: "NFA \<A>" "det \<Longrightarrow> DFA \<A>" "inj_on f (\<Q> \<A>)" "\<And>q. \<lbrakk>q2_invar q; q2_\<alpha> q \<in> \<Q> \<A>\<rbrakk> \<Longrightarrow> ff q = f (q2_\<alpha> q)" "distinct (map q2_\<alpha> I)" "\<And>q. q \<in> set I \<Longrightarrow> q2_invar q"
    "q2_\<alpha> ` set I = \<I> \<A>" "invar_s A" "\<alpha>_s A = \<Sigma> \<A>" "\<And>q. \<lbrakk>q2_invar q; q2_\<alpha> q \<in> \<Q> \<A>\<rbrakk> \<Longrightarrow> FP q = (q2_\<alpha> q \<in> \<F> \<A>)"
    "\<And>q. \<lbrakk>q2_invar q; q2_\<alpha> q \<in> \<Q> \<A>\<rbrakk> \<Longrightarrow> set_iterator_abs (\<lambda>(a, q'). (a, q2_\<alpha> q')) (\<lambda>(a, q'). q2_invar q') (D_it q) {(a, q'). (q2_\<alpha> q, a, q') \<in> \<Delta> \<A>}"

  note label_set_rule = nfa_dfa_construct_label_sets.nfa_dfa_construct_label_sets_correct[OF label_set_OK,
      where DS_q = "\<lambda>q. {({a}, q') | a q'. (q, a, q') \<in> \<Delta> \<A>}"]
  note label_set_rule' = label_set_rule [of \<A> det f ff I A FP D_it, OF assms(1-9)]

  show "invar (construct det ff I A FP D_it) \<and> NFA_isomorphic_wf (\<alpha> (construct det ff I A FP D_it)) (NFA_remove_unreachable_states \<A>)"
  proof (rule label_set_rule')
    fix q
    assume pre: "q2_invar q" "q2_\<alpha> q \<in> \<Q> \<A>"

    from assms(10)[OF pre] show "FP q = (q2_\<alpha> q \<in> \<F> \<A>)" by simp

    from assms(11)[OF pre]
    obtain lc where lc_props: "\<forall>(a, y)\<in>set lc. q2_invar y"
         "distinct (map (\<lambda>(a, q'). (a, q2_\<alpha> q')) lc)"
         "{(a, q'). (q2_\<alpha> q, a, q') \<in> \<Delta> \<A>} = (\<lambda>(a, q'). (a, q2_\<alpha> q')) ` set lc"
         "D_it q = foldli lc"
      by (auto simp add: set_iterator_abs_def set_iterator_abs_genord_def)
    show "set_iterator_abs (\<lambda>(as, q). ({as}, q2_\<alpha> q))
           (\<lambda>(as, q). True \<and> q2_invar q) (D_it q)
           {({a}, q') |a q'. (q2_\<alpha> q, a, q') \<in> \<Delta> \<A>}"
      unfolding set_iterator_abs_def set_iterator_abs_genord_def
      proof (rule_tac exI [where x = lc], intro conjI)
        from lc_props(2)
        show "distinct (map (\<lambda>(as, q). ({as}, q2_\<alpha> q)) lc)"
          by (simp add: distinct_map inj_on_def Ball_def)
      next
        from lc_props(3)
        show "{({a}, q') |a q'. (q2_\<alpha> q, a, q') \<in> \<Delta> \<A>} =
              set (map (\<lambda>(as, q). ({as}, q2_\<alpha> q)) lc)"
          unfolding set_eq_iff
          apply (simp add: image_iff Bex_def del: ex_simps add: ex_simps[symmetric])
          apply metis
        done
    qed (simp_all add: lc_props)
  qed auto
qed

lemma nfa_construct_default :
assumes label_set_OK: "nfa_construct_label_sets \<alpha> invar \<alpha>_s invar_s q2_\<alpha> q2_invar (\<lambda>x. {x}) (\<lambda>_. True) construct"
shows "nfa_construct \<alpha> invar \<alpha>_s invar_s q2_\<alpha> q2_invar construct"
proof (intro nfa_construct.intro nfa_construct_axioms.intro)
  from label_set_OK show "nfa \<alpha> invar" unfolding nfa_construct_label_sets_def by simp
next
  fix \<A>::"('f, 'c) NFA_rec" and det and f::"'f \<Rightarrow> 'g" and ff I A FP and D_it::"'e \<Rightarrow> ('h \<Rightarrow> bool) \<Rightarrow> ('c \<times> 'e \<Rightarrow> 'h \<Rightarrow> 'h) \<Rightarrow> 'h \<Rightarrow> 'h"
  assume assms: "NFA \<A>" "inj_on f (\<Q> \<A>)" "\<And>q. \<lbrakk>q2_invar q; q2_\<alpha> q \<in> \<Q> \<A>\<rbrakk> \<Longrightarrow> ff q = f (q2_\<alpha> q)" "distinct (map q2_\<alpha> I)"
    "\<And>q. q \<in> set I \<Longrightarrow> q2_invar q" "q2_\<alpha> ` set I = \<I> \<A>" "invar_s A" "\<alpha>_s A = \<Sigma> \<A>"
    "\<And>q. \<lbrakk>q2_invar q; q2_\<alpha> q \<in> \<Q> \<A>\<rbrakk> \<Longrightarrow> FP q = (q2_\<alpha> q \<in> \<F> \<A>)"
    "\<And>q. \<lbrakk>q2_invar q; q2_\<alpha> q \<in> \<Q> \<A>\<rbrakk> \<Longrightarrow> set_iterator_abs (\<lambda>(a, q'). (a, q2_\<alpha> q')) (\<lambda>(a, q'). q2_invar q') (D_it q) {(a, q'). (q2_\<alpha> q, a, q') \<in> \<Delta> \<A>}"
  note label_set_rule = nfa_construct_label_sets.nfa_construct_label_sets_correct[OF label_set_OK,
     where DS_q = "\<lambda>q. {({a}, q') | a q'. (q, a, q') \<in> \<Delta> \<A>}"]
  note label_set_rule' = label_set_rule [of \<A> f ff I A FP D_it, OF assms(1-9)]

  show "invar (construct ff I A FP D_it) \<and> NFA_isomorphic_wf (\<alpha> (construct ff I A FP D_it)) (NFA_remove_unreachable_states \<A>)"
  proof (rule label_set_rule')
    fix q
    assume "q2_invar q" "q2_\<alpha> q \<in> \<Q> \<A>"

    from assms(10)[OF this]
    obtain lc where lc_props: "\<forall>(a, y)\<in>set lc. q2_invar y"
         "distinct (map (\<lambda>(a, q'). (a, q2_\<alpha> q')) lc)"
         "{(a, q'). (q2_\<alpha> q, a, q') \<in> \<Delta> \<A>} = (\<lambda>(a, q'). (a, q2_\<alpha> q')) ` set lc"
         "D_it q = foldli lc"
      by (auto simp add: set_iterator_abs_def set_iterator_abs_genord_def)
    show "set_iterator_abs (\<lambda>(as, q). ({as}, q2_\<alpha> q))
           (\<lambda>(as, q). True \<and> q2_invar q) (D_it q)
           {({a}, q') |a q'. (q2_\<alpha> q, a, q') \<in> \<Delta> \<A>}"
      unfolding set_iterator_abs_def set_iterator_abs_genord_def
      proof (rule_tac exI [where x = lc], intro conjI)
        from lc_props(2)
        show "distinct (map (\<lambda>(as, q). ({as}, q2_\<alpha> q)) lc)"
          by (simp add: distinct_map inj_on_def Ball_def)
      next
        from lc_props(3)
        show "{({a}, q') |a q'. (q2_\<alpha> q, a, q') \<in> \<Delta> \<A>} =
              set (map (\<lambda>(as, q). ({as}, q2_\<alpha> q)) lc)"
          unfolding set_eq_iff
          apply (simp add: image_iff Bex_def del: ex_simps add: ex_simps[symmetric])
          apply metis
        done
    qed (simp_all add: lc_props)
  qed auto
qed

lemma dfa_construct_default :
assumes label_set_OK: "dfa_construct_label_sets \<alpha> invar \<alpha>_s invar_s q2_\<alpha> q2_invar (\<lambda>x. {x}) (\<lambda>_. True) construct"
shows "dfa_construct \<alpha> invar \<alpha>_s invar_s q2_\<alpha> q2_invar construct"
proof (intro dfa_construct.intro dfa_construct_axioms.intro)
  from label_set_OK show "nfa \<alpha> invar" unfolding dfa_construct_label_sets_def by simp
next
  fix \<A>::"('f, 'c) NFA_rec" and det and f::"'f \<Rightarrow> 'g" and ff I A FP and D_it::"'e \<Rightarrow> ('h \<Rightarrow> bool) \<Rightarrow> ('c \<times> 'e \<Rightarrow> 'h \<Rightarrow> 'h) \<Rightarrow> 'h \<Rightarrow> 'h"
  assume assms: "DFA \<A>" "inj_on f (\<Q> \<A>)" "\<And>q. \<lbrakk>q2_invar q; q2_\<alpha> q \<in> \<Q> \<A>\<rbrakk> \<Longrightarrow> ff q = f (q2_\<alpha> q)"
    "distinct (map q2_\<alpha> I)" "\<And>q. q \<in> set I \<Longrightarrow> q2_invar q" "q2_\<alpha> ` set I = \<I> \<A>" "invar_s A" "\<alpha>_s A = \<Sigma> \<A>"
    "\<And>q. \<lbrakk>q2_invar q; q2_\<alpha> q \<in> \<Q> \<A>\<rbrakk> \<Longrightarrow> FP q = (q2_\<alpha> q \<in> \<F> \<A>)"
    "\<And>q. \<lbrakk>q2_invar q; q2_\<alpha> q \<in> \<Q> \<A>\<rbrakk> \<Longrightarrow> set_iterator_abs (\<lambda>(a, q'). (a, q2_\<alpha> q')) (\<lambda>(a, q'). q2_invar q') (D_it q) {(a, q'). (q2_\<alpha> q, a, q') \<in> \<Delta> \<A>}"
  note label_set_rule = dfa_construct_label_sets.dfa_construct_label_sets_correct[OF label_set_OK,
     where DS_q = "\<lambda>q. {({a}, q') | a q'. (q, a, q') \<in> \<Delta> \<A>}"]
  note label_set_rule' = label_set_rule [of \<A> f ff I A FP D_it, OF assms(1-9)]

  show "invar (construct ff I A FP D_it) \<and> NFA_isomorphic_wf (\<alpha> (construct ff I A FP D_it)) (NFA_remove_unreachable_states \<A>)"
  proof (rule label_set_rule')
    fix q
    assume "q2_invar q" "q2_\<alpha> q \<in> \<Q> \<A>"

    from assms(10)[OF this]
    obtain lc where lc_props: "\<forall>(a, y)\<in>set lc. q2_invar y"
         "distinct (map (\<lambda>(a, q'). (a, q2_\<alpha> q')) lc)"
         "{(a, q'). (q2_\<alpha> q, a, q') \<in> \<Delta> \<A>} = (\<lambda>(a, q'). (a, q2_\<alpha> q')) ` set lc"
         "D_it q = foldli lc"
      by (auto simp add: set_iterator_abs_def set_iterator_abs_genord_def)
    show "set_iterator_abs (\<lambda>(as, q). ({as}, q2_\<alpha> q))
           (\<lambda>(as, q). True \<and> q2_invar q) (D_it q)
           {({a}, q') |a q'. (q2_\<alpha> q, a, q') \<in> \<Delta> \<A>}"
      unfolding set_iterator_abs_def set_iterator_abs_genord_def
      proof (rule_tac exI [where x = lc], intro conjI)
        from lc_props(2)
        show "distinct (map (\<lambda>(as, q). ({as}, q2_\<alpha> q)) lc)"
          by (simp add: distinct_map inj_on_def Ball_def)
      next
        from lc_props(3)
        show "{({a}, q') |a q'. (q2_\<alpha> q, a, q') \<in> \<Delta> \<A>} =
              set (map (\<lambda>(as, q). ({as}, q2_\<alpha> q)) lc)"
          unfolding set_eq_iff
          apply (simp add: image_iff Bex_def del: ex_simps add: ex_simps[symmetric])
          apply metis
        done
    qed (simp_all add: lc_props)
  qed auto
qed

lemma nfa_dfa_construct_no_enc_default :
  "nfa_dfa_construct \<alpha> invar \<alpha>_s invar_s id (\<lambda>_. True) construct \<Longrightarrow>
   nfa_dfa_construct_no_enc \<alpha> invar \<alpha>_s invar_s construct"
by (simp add: nfa_dfa_construct_def nfa_dfa_construct_no_enc_def nfa_dfa_construct_no_enc_axioms_def
                nfa_dfa_construct_axioms_def)

lemma nfa_construct_no_enc_default :
  "nfa_construct \<alpha> invar \<alpha>_s invar_s id (\<lambda>_. True) construct \<Longrightarrow>
   nfa_construct_no_enc \<alpha> invar \<alpha>_s invar_s construct"
by (simp add: nfa_construct_def nfa_construct_no_enc_def nfa_construct_no_enc_axioms_def
                nfa_construct_axioms_def)

lemma dfa_construct_no_enc_default :
  "dfa_construct \<alpha> invar \<alpha>_s invar_s id (\<lambda>_. True) construct \<Longrightarrow>
   dfa_construct_no_enc \<alpha> invar \<alpha>_s invar_s construct"
 by (simp add: dfa_construct_def dfa_construct_no_enc_def dfa_construct_no_enc_axioms_def
               dfa_construct_axioms_def)

lemma dfa_construct_no_enc_fun_default :
  "dfa_construct_fun \<alpha> invar \<alpha>_s invar_s id (\<lambda>_. True) construct \<Longrightarrow>
   dfa_construct_no_enc_fun \<alpha> invar \<alpha>_s invar_s construct"
  by (simp add: dfa_construct_fun_def dfa_construct_no_enc_fun_def
                dfa_construct_no_enc_fun_axioms_def
                dfa_construct_fun_axioms_def)

subsection \<open> Construct with functions \<close>

definition construct_by_fun ::
  "('q2_rep,'i,'a,'a_set,'\<sigma>,'nfa) nfa_construct \<Rightarrow>
   ('a_set \<Rightarrow> ('a,'\<sigma>) set_iterator) \<Rightarrow>
   ('q2_rep,'i,'a,'a_set,'nfa) nfa_construct_fun" where
  "construct_by_fun const it_A ff I A FP D_fun =
   const ff [I] A FP
   (\<lambda>q. set_iterator_image (\<lambda>a. (a, D_fun q a)) (it_A A))"

lemma construct_by_fun_alt_def :
  "construct_by_fun const it_A ff I A FP D_fun =
   const ff [I] A FP (\<lambda>q c f. it_A A c (\<lambda>x. f (x, D_fun q x)))"
   unfolding construct_by_fun_def[abs_def] set_iterator_image_alt_def
   by simp

 term "poly_set_iteratei \<alpha> invar_s it_A"
 term "poly_set_iteratei_defs.iteratei"

lemma construct_by_fun_correct :
fixes const :: "('q2_rep,'i,'a,'a_set,'a list,'nfa) nfa_construct"
  and \<alpha> :: "'nfa \<Rightarrow> ('q, 'a) NFA_rec"
  and q2_\<alpha> :: "'q2_rep \<Rightarrow> 'q2"
assumes const_OK: "dfa_construct \<alpha> invar \<alpha>_s invar_s q2_\<alpha> q2_invar const"
    and it_A: "poly_set_iteratei \<alpha>_s invar_s it_A"
shows "dfa_construct_fun \<alpha> invar \<alpha>_s invar_s q2_\<alpha> q2_invar (construct_by_fun const it_A)"
proof (intro dfa_construct_fun.intro dfa_construct_fun_axioms.intro)
  from const_OK show "nfa \<alpha> invar" unfolding dfa_construct_def by simp

  fix \<A> :: "('q2, 'a) NFA_rec" and
      f :: "'q2 \<Rightarrow> 'i" and ff I A FP D_fun
  assume wf_A: "DFA \<A>"
     and inj_f: "inj_on f (\<Q> \<A>)"
     and ff_OK: "\<And>q. q2_invar q \<Longrightarrow> q2_\<alpha> q \<in> \<Q> \<A> \<Longrightarrow> ff q = f (q2_\<alpha> q)"
     and invar_I: "q2_invar I"
     and I_in: "q2_\<alpha> I \<in> \<I> \<A>"
     and invar_A: "invar_s A"
     and A_OK: "\<alpha>_s A = \<Sigma> \<A>"
     and FP_OK: "\<And>q. q2_invar q \<Longrightarrow> q2_\<alpha> q \<in> \<Q> \<A> \<Longrightarrow> FP q = (q2_\<alpha> q \<in> \<F> \<A>)"
     and D_fun_OK: "\<And>q a. q2_invar q \<Longrightarrow> q2_\<alpha> q \<in> \<Q> \<A> \<Longrightarrow> a \<in> \<Sigma> \<A> \<Longrightarrow>
                (q2_\<alpha> q, a, q2_\<alpha> (D_fun q a)) \<in> \<Delta> \<A> \<and> q2_invar (D_fun q a)"

  interpret DFA \<A> by fact
  note const_rule = dfa_construct.dfa_construct_correct [OF const_OK wf_A inj_f, of ff "[I]",
        OF ff_OK _ _ _ invar_A A_OK FP_OK]

  show "invar (construct_by_fun const it_A ff I A FP D_fun) \<and>
       NFA_isomorphic_wf (\<alpha> (construct_by_fun const it_A ff I A FP D_fun)) (NFA_remove_unreachable_states \<A>)"
    unfolding construct_by_fun_def
  proof (rule const_rule)
    from I_in \<I>_is_set_\<i> show "q2_\<alpha> ` set [I] = \<I> \<A>" by auto
  next
    fix q
    assume invar_q: "q2_invar q" and q_in_Q: "q2_\<alpha> q \<in> \<Q> \<A>"

    with D_fun_OK[of q] have
      D_fun_in_D: "\<And>a. a \<in> \<Sigma> \<A> \<Longrightarrow> (q2_\<alpha> q, a, q2_\<alpha> (D_fun q a)) \<in> \<Delta> \<A>" and
      D_fun_invar: "\<And>a. a \<in> \<Sigma> \<A> \<Longrightarrow> q2_invar (D_fun q a)" by simp_all

    let ?DS_q = "{(a,  D_fun q a) |a. a \<in> \<Sigma> \<A>}"

    from poly_set_iteratei.list_it_correct[OF it_A, OF invar_A] have
      it_A_OK': "set_iterator (it_A A) (\<alpha>_s A)" .

    from set_iterator_image_correct [OF it_A_OK', of "\<lambda>a. (a, D_fun q a)"]
    have "set_iterator (set_iterator_image (\<lambda>a. (a, D_fun q a)) (it_A A))
           ((\<lambda>a. (a, D_fun q a)) ` \<alpha>_s A)" by (simp add: inj_on_def)
    moreover have "((\<lambda>a. (a, D_fun q a)) ` \<alpha>_s A) = {(a,  D_fun q a) |a. a \<in> \<Sigma> \<A>}"
      unfolding A_OK by auto
    ultimately have it_OK:
        "set_iterator (set_iterator_image (\<lambda>a. (a, D_fun q a)) (it_A A)) ?DS_q"
        by simp

    show "set_iterator_abs (\<lambda>(a, q'). (a, q2_\<alpha> q'))
         (\<lambda>(a, q'). q2_invar q')
         (set_iterator_image (\<lambda>a. (a, D_fun q a)) (it_A A))
         {(a, q'). (q2_\<alpha> q, a, q') \<in> \<Delta> \<A>}"
      apply (rule set_iterator_abs_I2)
      apply (rule it_OK)
      apply (auto simp add: it_OK D_fun_invar image_iff D_fun_in_D \<Delta>_consistent)
      apply (metis D_fun_in_D \<Delta>_consistent LTS_is_deterministic_def deterministic_LTS)
    done
  qed (simp_all add: invar_I)
qed

subsection\<open> Brzozowski \<close>

definition Brzozowski_impl :: "('nfa \<Rightarrow> 'nfa) \<Rightarrow> ('nfa \<Rightarrow> 'nfa) \<Rightarrow> 'nfa \<Rightarrow> 'nfa" where
  "Brzozowski_impl r d A = d (r (d (r A)))"

lemma Brzozowski_impl_correct :
assumes r_OK: "nfa_reverse \<alpha> invar \<alpha> invar r"
    and d_OK: "nfa_determinise \<alpha> invar \<alpha> invar d"
shows "nfa_minimise \<alpha> invar \<alpha> invar (Brzozowski_impl r d)"
unfolding Brzozowski_impl_def[abs_def]
proof (intro nfa_minimise.intro nfa_minimise_axioms.intro conjI)
  from r_OK show nfa_OK: "nfa \<alpha> invar" and "nfa \<alpha> invar" unfolding nfa_reverse_def by simp_all

  note nfa_correct = nfa.nfa_is_wellformed [OF nfa_OK]
  note r_correct = nfa_reverse.reverse_correct___isomorphic [OF r_OK]
  note d_correct = nfa_determinise.determinise_correct___isomorphic [OF d_OK]

  fix n
  assume invar_n: "invar n"
  hence wf_n: "NFA (\<alpha> n)" by (simp add: nfa_correct)

  show "invar (d (r (d (r n))))"
    by (intro d_correct(1) r_correct(1) invar_n)

  have "NFA_isomorphic_wf (\<alpha> (d (r (d (r n))))) (Brzozowski (\<alpha> n))"
    unfolding Brzozowski_def Brzozowski_halfway_def
    by (intro d_correct r_correct invar_n NFA_isomorphic_wf_refl wf_n)
  with Brzozowski___minimise[OF wf_n]
  show "NFA_isomorphic_wf (\<alpha> (d (r (d (r n))))) (NFA_minimise (\<alpha> n))"
    by (metis NFA_isomorphic_wf_trans)
qed

subsection\<open> Minimisation combined with determinisation \<close>

lemma NFAGA_minimisation_with_determinisation :
fixes \<alpha>1::"'nfa1 \<Rightarrow> ('q1::{automaton_states}, 'a) NFA_rec"
  and \<alpha>2::"'nfa2 \<Rightarrow> ('q2::{automaton_states}, 'a) NFA_rec"
  and \<alpha>3::"'nfa3 \<Rightarrow> ('q3, 'a) NFA_rec"
assumes d_OK: "nfa_determinise \<alpha>1 invar1 \<alpha>2 invar2 d"
    and m_OK: "dfa_minimise \<alpha>2 invar2 \<alpha>3 invar3 m"
shows "nfa_minimise \<alpha>1 invar1 \<alpha>3 invar3 (m \<circ> d)"
proof (intro nfa_minimise.intro nfa_minimise_axioms.intro conjI)
  from d_OK show nfa1_OK: "nfa \<alpha>1 invar1" unfolding nfa_determinise_def by simp
  from m_OK show "nfa \<alpha>3 invar3" unfolding dfa_minimise_def by simp

  fix a
  assume invar_a: "invar1 a"

  from nfa1_OK invar_a have NFA_a: "NFA (\<alpha>1 a)" unfolding nfa_def by simp

  let ?da = "NFA_determinise (\<alpha>1 a)"

  from nfa_determinise.determinise_correct___same [OF d_OK, OF invar_a]
  have invar_da: "invar2 (d a)" and
       iso_da: "NFA_isomorphic_wf (\<alpha>2 (d a)) ?da"
    by (simp_all add: NFA_isomorphic_wf___NFA_normalise_states_cong)

  have DFA_da : "DFA ?da" by (simp add: NFA_determinise_is_DFA NFA_a)
  have con_da: "SemiAutomaton_is_initially_connected ?da"
    unfolding NFA_determinise_def
    by (intro SemiAutomaton_is_initially_connected___normalise_states
              efficient_determinise_NFA___is_initially_connected)

  from dfa_minimise.dfa_minimise_correct___isomorphic
         [OF m_OK, OF invar_da, OF DFA_da con_da iso_da]
  have invar_mda: "invar3 ((m \<circ> d) a)" and
       iso_mda: "NFA_isomorphic_wf (\<alpha>3 ((m \<circ> d) a)) (NFA_minimise ?da)"
    by simp_all

  from invar_mda show "invar3 ((m \<circ> d) a)" .

  from iso_mda NFA_a DFA_da DFA_implies_NFA[OF DFA_da]
  show "NFA_isomorphic_wf (\<alpha>3 ((m \<circ> d) a)) (NFA_minimise (\<alpha>1 a))"
    by (simp add: NFA_isomorphic_wf___minimise DFA_alt_def
                  NFA_determinise_\<L>)
qed

subsection\<open> Language Operations \<close>

definition NFAGA_language_is_univ :: "('nfa \<Rightarrow> 'nfa) \<Rightarrow> ('nfa \<Rightarrow> 'nfa) \<Rightarrow> ('nfa \<Rightarrow> bool) \<Rightarrow> 'nfa \<Rightarrow> bool" where
  "NFAGA_language_is_univ d c is_emp A =  is_emp (c (d A))"

lemma NFAGA_language_is_univ_correct :
assumes c_OK: "nfa_complement \<alpha> invar c"
    and d_OK: "nfa_determinise \<alpha> invar \<alpha> invar d"
    and is_emp_OK: "nfa_language_is_empty \<alpha> invar is_emp"
shows "nfa_language_is_univ \<alpha> invar (NFAGA_language_is_univ d c is_emp)"
proof (intro nfa_language_is_univ.intro nfa_language_is_univ_axioms.intro)
  from c_OK show nfa_OK: "nfa \<alpha> invar" unfolding nfa_complement_def by simp_all

  fix n
  assume invar_n: "invar n"

  from invar_n nfa_OK have NFA_n: "NFA (\<alpha> n)"
    unfolding nfa_def by simp

  from nfa_determinise.determinise_correct___same[OF d_OK, OF invar_n]
  have invar_dn: "invar (d n)" and
       iso_dn: "NFA_isomorphic_wf (\<alpha> (d n)) (NFA_determinise (\<alpha> n))" by simp_all

  from nfa_complement.complement_correct___isomorphic[OF c_OK, OF invar_dn] iso_dn
  have invar_cdn: "invar (c (d n))" and
       iso_cdn: "NFA_isomorphic_wf (\<alpha> (c (d n))) (DFA_complement (NFA_determinise (\<alpha> n)))" by simp_all

  from nfa_language_is_empty.language_is_empty_correct [OF is_emp_OK, OF invar_cdn]
  have emp_eq: "is_emp (c (d n)) = (\<L> (\<alpha> (c (d n))) = {})" by simp

  from iso_cdn have "\<L> (\<alpha> (c (d n))) = \<L> (DFA_complement (NFA_determinise (\<alpha> n)))"
    by (metis NFA_isomorphic_wf_\<L>)
  hence L_cdn_eq: "\<L> (\<alpha> (c (d n))) = lists (\<Sigma> (\<alpha> n)) - \<L> (\<alpha> n)"
    using  DFA.DFA_complement_\<L>[OF NFA_determinise_is_DFA[OF NFA_n]]
           NFA_determinise_\<L>[OF NFA_n]
    by simp

   have L_n_subset: "\<L> (\<alpha> n) \<subseteq> lists (\<Sigma> (\<alpha> n))"
     using NFA.NFA_\<L>___lists_\<Sigma>[OF NFA_n] by simp

  show "NFAGA_language_is_univ d c is_emp n =
        (\<L> (\<alpha> n) = lists (\<Sigma> (\<alpha> n)))"
    unfolding NFAGA_language_is_univ_def emp_eq L_cdn_eq
    using L_n_subset by auto
qed

definition NFAGA_language_is_subset :: "('nfa \<Rightarrow> 'nfa) \<Rightarrow> ('nfa \<Rightarrow> 'nfa) \<Rightarrow> ('nfa \<Rightarrow> 'nfa \<Rightarrow> 'nfa) \<Rightarrow> ('nfa \<Rightarrow> bool) \<Rightarrow> 'nfa \<Rightarrow> 'nfa \<Rightarrow> bool" where
  "NFAGA_language_is_subset d c p is_emp A1 A2 =
   is_emp (p A1 (c (d A2)))"

lemma NFAGA_language_is_subset_correct :
assumes c_OK: "nfa_complement \<alpha> invar c"
    and d_OK: "nfa_determinise \<alpha> invar \<alpha> invar d"
    and bc_OK: "nfa_bool_comb_same \<alpha> invar bc"
    and is_emp_OK: "nfa_language_is_empty \<alpha> invar is_emp"
shows "nfa_language_is_subset \<alpha> invar (NFAGA_language_is_subset d c (bc (\<and>)) is_emp)"
proof (intro nfa_language_is_subset.intro nfa_language_is_subset_axioms.intro)
  from c_OK show nfa_OK: "nfa \<alpha> invar" unfolding nfa_complement_def by simp_all

  fix n1 n2
  assume invar_n1: "invar n1"
     and invar_n2: "invar n2"
     and \<Sigma>_eq: "\<Sigma> (\<alpha> n1) = \<Sigma> (\<alpha> n2)"

  from invar_n1 nfa_OK have NFA_n1: "NFA (\<alpha> n1)"
    unfolding nfa_def by simp

  from invar_n2 nfa_OK have NFA_n2: "NFA (\<alpha> n2)"
    unfolding nfa_def by simp

  from nfa_determinise.determinise_correct___same[OF d_OK, OF invar_n2]
  have invar_dn2: "invar (d n2)" and
       iso_dn: "NFA_isomorphic_wf (\<alpha> (d n2)) (NFA_determinise (\<alpha> n2))" by simp_all

  from nfa_complement.complement_correct___isomorphic[OF c_OK, OF invar_dn2] iso_dn
  have invar_cdn2: "invar (c (d n2))" and
       iso_cdn2: "NFA_isomorphic_wf (\<alpha> (c (d n2))) (DFA_complement (NFA_determinise (\<alpha> n2)))" by simp_all

  have \<Sigma>_eq': "\<Sigma> (\<alpha> n1) = \<Sigma> (\<alpha> (c (d n2)))"
    using NFA_isomorphic_wf_\<Sigma>[OF iso_cdn2] \<Sigma>_eq
    by simp

  note bc_props_aux = nfa_bool_comb_same.bool_comb_correct___same_isomorphic[OF bc_OK, OF invar_n1 invar_cdn2 \<Sigma>_eq',
    where ?bc = "(\<and>)"]

  from bc_props_aux(1) bc_props_aux(2)[OF NFA_isomorphic_wf_refl[OF NFA_n1] iso_cdn2]
  have invar_res: "invar (bc (\<and>) n1 (c (d n2)))"
   and iso_res: "NFA_isomorphic_wf (\<alpha> (bc (\<and>) n1 (c (d n2))))
     (NFA_product (\<alpha> n1) (DFA_complement (NFA_determinise (\<alpha> n2))))"
        unfolding NFA_product_def by simp_all

  have L_cdn2_eq: "\<L> (DFA_complement (NFA_determinise (\<alpha> n2))) = lists (\<Sigma> (\<alpha> n2)) - \<L> (\<alpha> n2)"
    using  DFA.DFA_complement_\<L>[OF NFA_determinise_is_DFA[OF NFA_n2]]
           NFA_determinise_\<L>[OF NFA_n2]
    by simp

  from iso_cdn2 have NFA_cdn2: "NFA (DFA_complement (NFA_determinise (\<alpha> n2)))"
    unfolding NFA_isomorphic_wf_alt_def by simp

  have "\<L> (\<alpha> (bc (\<and>) n1 (c (d n2)))) = \<L> (NFA_product (\<alpha> n1) (DFA_complement (NFA_determinise (\<alpha> n2))))"
    using NFA_isomorphic_wf_\<L>[OF iso_res] .
  with NFA_product_\<L> [OF NFA_n1 NFA_cdn2] L_cdn2_eq
  have L_res_eq: "\<L> (\<alpha> (bc (\<and>) n1 (c (d n2)))) = \<L> (\<alpha> n1) \<inter> (lists (\<Sigma> (\<alpha> n2)) - \<L> (\<alpha> n2))" by simp

  from nfa_language_is_empty.language_is_empty_correct [OF is_emp_OK, OF invar_res]
  have emp_eq: "is_emp (bc (\<and>) n1 (c (d n2))) = (\<L> (\<alpha> (bc (\<and>) n1 (c (d n2)))) = {})" by simp

  have L_n1_subset: "\<L> (\<alpha> n1) \<subseteq> lists (\<Sigma> (\<alpha> n1))"
     using NFA.NFA_\<L>___lists_\<Sigma>[OF NFA_n1] by simp
  have L_n2_subset: "\<L> (\<alpha> n2) \<subseteq> lists (\<Sigma> (\<alpha> n2))"
     using NFA.NFA_\<L>___lists_\<Sigma>[OF NFA_n2] by simp

  show "NFAGA_language_is_subset d c (bc (\<and>)) is_emp n1 n2 =
       (\<L> (\<alpha> n1) \<subseteq> \<L> (\<alpha> n2))"
    using L_n2_subset L_n1_subset
    unfolding NFAGA_language_is_subset_def emp_eq L_res_eq \<Sigma>_eq
    by auto
qed

definition NFAGA_language_is_eq :: "('nfa \<Rightarrow> 'nfa \<Rightarrow> bool) \<Rightarrow> 'nfa \<Rightarrow> 'nfa \<Rightarrow> bool" where
  "NFAGA_language_is_eq is_sub A1 A2 = (is_sub A1 A2 \<and> is_sub A2 A1)"

lemma NFAGA_language_is_eq_correct :
assumes is_sub_OK: "nfa_language_is_subset \<alpha> invar is_sub"
shows "nfa_language_is_eq \<alpha> invar (NFAGA_language_is_eq is_sub)"
using assms
unfolding nfa_language_is_subset_def nfa_language_is_subset_axioms_def
          nfa_language_is_eq_def nfa_language_is_eq_axioms_def
          NFAGA_language_is_eq_def by auto

end


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

imports "Strengthen"

begin

text \<open>Here's a complicated predicate transformer. You don't need
to understand this, it just makes it easy to set up some complicated
example goals below.\<close>
definition
  "predt f g h P x y = (\<exists>x'. (\<exists>y' \<in> f y. x' \<in> g y' ` h y) \<and> P x x')"

text \<open>Strengthen performs the same kinds of steps as
intro/elim rules, but it can perform them within complex
conclusions. Here's an example where we replace Q with P
(strengthening the goal) deep within some quantifiers.\<close>

lemma predt_double_mono:
  assumes PQ: "\<And>x y. P x y \<longrightarrow> Q x y"
  assumes P: "predt f g h (predt f g h' P) x y"
  shows "predt f g h (predt f g h' Q) x y"
  using P
  apply (simp add: predt_def)
  apply (strengthen PQ)
  apply assumption
  done

text \<open>Here's a more conventional monotonicity proof.
Once the clarsimp has finished, the goal becomes a bit
difficult to prove. Let's use some fancy strengthen
features to address this. The rest of this demo will
explain what the attribute and fancy features are doing,
and thus how this proof works.\<close>

lemma predt_double_mono2:
  assumes PQ: "\<And>x y. P x y \<longrightarrow> Q x y"
  assumes P: "predt f g h (predt f g' h P) x y"
  shows "predt f g h (predt f g' h Q) x y"
  using P
  apply (clarsimp simp: predt_def)
  apply (strengthen bexI[mk_strg I _ A])
  apply (strengthen image_eqI[mk_strg I _ A])
  apply simp
  apply (strengthen bexI[mk_strg I _ O], assumption)
  apply (strengthen image_eqI[mk_strg I _ E])
  apply simp
  apply (simp add: PQ)
  done

text \<open>The @{attribute mk_strg} controls the way that
strengthen applies a rule. By default, strengthen will
use a rule as an introduction rule, trying to replace
the rule's conclusion with its premises.

Once the @{attribute mk_strg} attribute has applied, the
rule is formatted showing how strengthen will try to
transform components of a goal. The syntax of the
second theorem is reversed, showing that strengthen will
attempt to replace instances of the subset predicate
with instances of the proper subset predicate.
\<close>
thm psubset_imp_subset psubset_imp_subset[mk_strg]

text \<open>Rules can have any number of premises, or none,
and still be used as strengthen rules.\<close>
thm subset_UNIV subset_UNIV[mk_strg]
    equalityI equalityI[mk_strg]

text \<open>Rules which would introduce schematics are
adjusted by @{attribute mk_strg} to introduce quantifiers
instead. The argument I to mk_strg prevents this step.
\<close>
thm subsetD subsetD[mk_strg I] subsetD[mk_strg]

text \<open>The first argument to mk_strg controls the way
the rule will be applied.
  I: use rule in introduction style, matching its conclusion.
  D: use rule in destruction (forward) style, matching its first premise.
  I': like I, replace new schematics with existential quantifiers.
  D': like D, replace new schematics with universal quantifiers.

The default is I'.
\<close>
thm subsetD subsetD[mk_strg I] subsetD[mk_strg I']
  subsetD[mk_strg D] subsetD[mk_strg D']

text \<open>Note that I and D rules will be applicable at different
sites.\<close>
lemma
  assumes PQ: "P \<Longrightarrow> Q"
  shows "{x. Suc 0 < x \<and> P} \<subseteq> {x. Suc 0 < x \<and> Q}"
  (* adjust Q into P on rhs *)
  apply (strengthen PQ[mk_strg I])
  (* adjust P into Q on lhs *)
  apply (strengthen PQ[mk_strg D])
  (* oops, overdid it *)
  oops

text \<open>Subsequent arguments to mk_strg capture premises for
special treatment. The 'A' argument (synonym 'E') specifies that
a premise should be solved by assumption. Our fancy proof above
used a strengthen rule bexI[mk_strg I _ A], which tells strengthen
to do approximately the same thing as
\<open>apply (rule bexI) prefer 2 apply assumption\<close>

This is a useful way to apply a rule, picking the premise which
will cause unknowns to be instantiated correctly.
\<close>
thm eq_mem_trans eq_mem_trans[mk_strg I _ _] eq_mem_trans[mk_strg I A _]
    eq_mem_trans[mk_strg I _ A] eq_mem_trans[mk_strg I A A]

text \<open>The 'O' argument ("obligation") picks out premises of
a rule for immediate attention as new subgoals.

The step
\<open>apply (strengthen bexI[mk_strg I _ O], assumption)\<close>
in our proof above had the same effect as strengthening with
@{thm bexI[mk_strg I _ A]}.

This option suits special cases where a particular premise is best
handled by a specialised method.
\<close>
thm eq_mem_trans eq_mem_trans[mk_strg I _ _] eq_mem_trans[mk_strg I O _]
    eq_mem_trans[mk_strg I _ O] eq_mem_trans[mk_strg I O O]

end


theory Proof_5_2
  imports Requirements VCTheoryLemmas
begin

abbreviation s where "s s0 requestButton_value \<equiv> (toEnv
          (setPstate (setVarBool (setVarAny s0 requestButton_value) redAfterMinimalRed PRESSED) Ctrl
            redAfterMinimalRed))"

lemma VC2_R5_aux1: "toEnvP s2 \<and> toEnvP s0 \<and> substate s2 s0 \<and> toEnvNum s2 s3 < T1 \<and> s3 = s s0 requestButton_value \<Longrightarrow>
toEnvNum s2 s0 < T1"
  apply auto
  apply(simp split: if_splits)
  using substate_refl substate_asym[of s0 "s s0 requestButton_value"] by  auto

lemma VC2_R5: " (toEnvP s0 \<and>
        (\<forall>s1 s2 s3.
            substate s1 s2 \<and>
            substate s2 s3 \<and>
            substate s3 s0 \<and>
            toEnvP s1 \<and>
            toEnvP s2 \<and>
            toEnvP s3 \<and>
            toEnvNum s1 s2 = Ctrl \<and>
            toEnvNum s2 s3 < T1 \<and> getVarBool s1 minimalRed \<noteq> NOT_PRESSED \<and> getVarBool s2 minimalRed = NOT_PRESSED \<longrightarrow>
            getVarBool s3 minimalRed = NOT_PRESSED)) \<and>
       env (setVarAny s0 requestButton_value) requestButton_value \<and>
       getPstate (setVarAny s0 requestButton_value) Ctrl = minimalRed \<and>
       getVarBool (setVarAny s0 requestButton_value) Ctrl \<and>
       MINIMAL_RED_TIME_LIMIT
       \<le> ltimeEnv (setVarBool (setVarAny s0 requestButton_value) redAfterMinimalRed PRESSED) Ctrl \<Longrightarrow>
       substate s1 s2 \<and>
       substate s2 s3 \<and>
       substate s3 (s s0 requestButton_value) \<and>
       toEnvP s1 \<and>
       toEnvP s2 \<and>
       toEnvP s3 \<and>
       toEnvNum s1 s2 = Ctrl \<and>
       toEnvNum s2 s3 < T1 \<and> getVarBool s1 minimalRed \<noteq> NOT_PRESSED \<and> getVarBool s2 minimalRed = NOT_PRESSED \<Longrightarrow>
       getVarBool s3 minimalRed = NOT_PRESSED"
  apply(cases "s3 = s s0 requestButton_value")
   apply(cases "s2 = s s0 requestButton_value")
    apply blast
   apply(rule cut_rl[of "substate s2 s0"])
    apply(rule cut_rl[of "getVarBool s0 trafficLight = RED"])
  apply (metis getVarBool.simps(2) getVarBool.simps(4) getVarBool.simps(6) getVarBool.simps(7) numeral_eq_iff one_eq_numeral_iff semiring_norm(85) semiring_norm(89))
    apply(drule conjE)
     prefer 2
     apply assumption
apply(drule conjE)
     prefer 2
     apply assumption
apply(drule conjE)
     prefer 2
     apply assumption
apply(drule allE[of _ s1])
     prefer 2
  apply assumption
   apply(drule allE[of _ s2])
     prefer 2
     apply assumption
apply(drule allE[of _ s0])
     prefer 2
     apply assumption
    apply(rule cut_rl[of "toEnvNum s2 s0 < T1"])
  using substate_refl apply fast
    apply((rule VC2_R5_aux1);fast)
  apply (metis substate.simps(2) substate.simps(4) substate.simps(6) substate.simps(7) toEnvP.simps(4) toEnvP.simps(6) toEnvP.simps(7))
  apply(rule cut_rl [of "substate s3 s0"])
   apply blast
  by (metis substate.simps(2) substate.simps(4) substate.simps(6) substate.simps(7) toEnvP.simps(4) toEnvP.simps(6) toEnvP.simps(7))

theorem proof_5_2: "VC2 R5 s0 requestButton_value"
  apply(simp only: VC2_def R5_def)
  apply(rule impI)
  apply(rule conjI)
   apply simp
  apply((rule allI);(rule allI);(rule allI))
  apply(rule impI)
  by ((rule VC2_R5);assumption)


(*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>\<open>"HuntSands:POPL2006"\<close> 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>\<open>"BeringerHofmann:CSF2007"\<close>, 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>\<open>"HuntSands:POPL2006"\<close>. 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>\<open>"BeringerHofmann:CSF2007"\<close>.\<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>\<open>"HuntSands:POPL2006"\<close>.\<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