(*
 * Copyright 2014, NICTA
 *
 * This software may be distributed and modified according to the terms of
 * the GNU General Public License version 2. Note that NO WARRANTY is provided.
 * See "LICENSE_GPLv2.txt" for details.
 *
 * @TAG(NICTA_GPL)
 *)

theory Noninterference_Base_Refinement
imports Noninterference_Base
        Noninterference_Base_Alternatives
begin

(* we assume the same initial state for both systems *)
locale noninterference_refinement =
   abs?: complete_unwinding_system A s0 dom uwr policy out schedDomain +
   conc?: noninterference_system C s0 dom uwr policy out schedDomain
   for A :: "('a,'s,'e) data_type"
   and s0 :: "'s"
   and dom :: "'e \<Rightarrow> 's \<Rightarrow> 'd"
   and uwr :: "'d \<Rightarrow> ('s \<times> 's) set"
   and policy :: "('d \<times> 'd) set"
   and out :: "'d \<Rightarrow> 's \<Rightarrow> 'p"
   and schedDomain :: "'d"
   and C :: "('c,'s,'e) data_type" +
   assumes refines: "refines C A"

context noninterference_refinement begin

lemma reachable:
  "conc.reachable s \<Longrightarrow> abs.reachable s"
  apply(simp add: conc.reachable_def abs.reachable_def)
  using refines by (fastforce simp: refines_def)

lemma Step:
  "conc.Step a \<subseteq> abs.Step a"
  apply(simp add: conc.Step_def abs.Step_def)
  using refines by(fastforce simp: refines_def)

lemma confidentiality_u_refinement_closed:
  "abs.confidentiality_u \<Longrightarrow> conc.confidentiality_u"
  apply(simp add: abs.confidentiality_u_def)
  apply(subst conc.confidentiality_u_def)
  apply(blast intro: subsetD[OF Step] reachable)
  done

lemma confidentiality_u_weak_refinement_closed:
  "abs.confidentiality_u_weak \<Longrightarrow> conc.confidentiality_u_weak"
  apply(simp add: abs.confidentiality_u_weak_def)
  apply(subst conc.confidentiality_u_weak_def)
  apply(blast intro: subsetD[OF Step] reachable)
  done

lemma integrity_u_refinement_closed:
  "abs.integrity_u \<Longrightarrow> conc.integrity_u"
  apply(simp add: abs.integrity_u_def)
  apply(subst conc.integrity_u_def)
  apply(blast intro: subsetD[OF Step] reachable)
  done

lemma xources_subset:
  "abs.confidentiality_u \<Longrightarrow> abs.xources as s u \<subseteq> conc.xources as s u"
  apply(induct as arbitrary: s u)
   apply(simp add: abs.xources.xources_Nil conc.xources.xources_Nil)
  apply(simp add: abs.xources.xources_Cons conc.xources.xources_Cons)
  apply(rule conjI)
   apply(rule subsetI)
   apply(rule UnI1)
   apply(blast dest: subsetD[OF Step])
  apply(rule subsetI)
  apply(rule UnI2)
  apply(blast dest: subsetD[OF Step])
  done

lemma uwr_equiv:
  "abs.uwr_equiv s as t bs u \<Longrightarrow> conc.uwr_equiv s as t bs u"
  apply(insert refines)
  apply(fastforce simp: abs.uwr_equiv_def conc.uwr_equiv_def simp: refines_def dest: subsetD)
  done

lemma xNonleakage_gen_refinement_closed:
  "abs.xNonleakage_gen \<Longrightarrow> conc.xNonleakage_gen"
  apply(frule abs.xNonleakage_gen_confidentiality_u)
  apply(frule xources_subset)
  apply(clarsimp simp: abs.xNonleakage_gen_def conc.xNonleakage_gen_def)
  apply(drule (1) sameFor_subset_dom[OF _ xources_subset])
  apply(blast dest: reachable uwr_equiv)
  done

end

locale complete_noninterference_refinement = noninterference_refinement A s0 dom uwr policy out schedDomain C
   for A :: "('a,'s,'e) data_type"
   and s0 :: "'s"
   and dom :: "'e \<Rightarrow> 's \<Rightarrow> 'd"
   and uwr :: "'d \<Rightarrow> ('s \<times> 's) set"
   and policy :: "('d \<times> 'd) set"
   and out :: "'d \<Rightarrow> 's \<Rightarrow> 'p"
   and schedDomain :: "'d"
   and C :: "('c,'s,'e) data_type" +
   assumes Step_C: "Step_system C s0"

sublocale complete_noninterference_refinement \<subseteq> conc: complete_unwinding_system C s0 dom uwr policy out schedDomain
  apply(unfold_locales)
    using Step_C apply(fastforce simp: Step_system_def)
   using Step_C apply(fastforce simp: Step_system_def)
  apply(rule policy_refl)
  done

context complete_noninterference_refinement begin
lemma Noninfluence_strong_uwr_refinement_closed:
  "abs.Noninfluence_strong_uwr \<Longrightarrow>
    conc.Noninfluence_strong_uwr"
  apply(frule abs.Noninfluence_strong_uwr_confidentiality_u_weak)
  apply(drule abs.Noninfluence_strong_uwr_integrity_u)
  apply(drule confidentiality_u_weak_refinement_closed)
  apply(drule integrity_u_refinement_closed)
  apply(blast intro: conc.Noninfluence_strong_uwr)
  done

lemma Nonleakage_gen_refinement_closed:
  "abs.Nonleakage_gen \<Longrightarrow>
    conc.Nonleakage_gen"
  apply(simp add: abs.Nonleakage_gen_equiv_confidentiality_u conc.Nonleakage_gen_equiv_confidentiality_u)
  apply(erule confidentiality_u_refinement_closed)
  done

lemma Noninfluence_strong_quasi_refinement_closed:
  "\<lbrakk>abs.confidentiality_u_weak; abs.integrity_u;
        output_consistent\<rbrakk> \<Longrightarrow>
    conc.Noninfluence_strong"
  apply(rule conc.Noninfluence_strong)
    apply(erule confidentiality_u_weak_refinement_closed)
   apply assumption
  apply(erule integrity_u_refinement_closed)
  done

lemma Noninfluence_strong_uwr_quasi_refinement_closed:
  "\<lbrakk>abs.Noninfluence_strong_uwr;
        output_consistent\<rbrakk> \<Longrightarrow>
    conc.Noninfluence_strong"
  apply(rule conc.Noninfluence_strong)
    apply(rule confidentiality_u_weak_refinement_closed)
    apply(erule abs.Noninfluence_strong_uwr_confidentiality_u_weak)
   apply assumption
  apply(rule integrity_u_refinement_closed)
  apply(erule abs.Noninfluence_strong_uwr_integrity_u)
  done

end
end


section {* ICTAC 2016 tutorial. Taipei, 24/10/2016 *}

theory ictac16_tutorial
  imports "../theories/utp_designs"
begin

subsection {* Laws of programming *}

theorem cond_shadow: "(P \<triangleleft> b \<triangleright> (Q \<triangleleft> b \<triangleright> R)) = (P \<triangleleft> b \<triangleright> R)" oops

theorem seqr_assoc: "(P ;; (Q ;; R)) = ((P ;; Q) ;; R)" oops

theorem seqr_left_unit: "(II ;; P) = P" oops

theorem seqr_left_zero: "(false ;; P) = false" oops

theorem cond_seq_left_distr:
  assumes "out\<alpha> \<sharp> b"
  shows "((P \<triangleleft> b \<triangleright> Q) ;; R) = ((P ;; R) \<triangleleft> b \<triangleright> (Q ;; R))"
  using assms by (rel_simp, blast+)

theorem assign_twice:
  assumes "vwb_lens x" "x \<sharp> f"
  shows "(x := e ;; x := f) = (x := f)"
  using assms by rel_auto

theorem assign_commute:
  assumes "x \<bowtie> y" "x \<sharp> f" "y \<sharp> e"
  shows "(x := e ;; y := f) = (y := f ;; x := e)"
  using assms by (rel_auto, simp_all add: lens_indep_comm)

subsection {* Design laws *}

theorem design_false_pre: "(false \<turnstile> P) = true" by rel_auto

theorem design_true_left_zero: "(true ;; (P \<turnstile> Q)) = true"
proof -
  have "(true ;; (P \<turnstile> Q)) = (\<^bold>\<exists> ok\<^sub>0 \<bullet> true\<lbrakk>\<guillemotleft>ok\<^sub>0\<guillemotright>/$ok\<acute>\<rbrakk> ;; (P \<turnstile> Q)\<lbrakk>\<guillemotleft>ok\<^sub>0\<guillemotright>/$ok\<rbrakk>)"
    by (subst seqr_middle[of ok], simp_all)
  also have "... = ((true\<lbrakk>false/$ok\<acute>\<rbrakk> ;; (P \<turnstile> Q)\<lbrakk>false/$ok\<rbrakk>) \<or> (true\<lbrakk>true/$ok\<acute>\<rbrakk> ;; (P \<turnstile> Q)\<lbrakk>true/$ok\<rbrakk>))"
    by (simp add: disj_comm false_alt_def true_alt_def)
  also have "... = ((true\<lbrakk>false/$ok\<acute>\<rbrakk> ;; true\<^sub>h) \<or> (true ;; ((P \<turnstile> Q)\<lbrakk>true/$ok\<rbrakk>)))"
    by (subst_tac, rel_auto)
  also have "... = true"
    by (subst_tac, simp add: precond_right_unit unrest)
  finally show ?thesis .
qed

theorem rdesign_left_unit:
  fixes P Q :: "'\<alpha> hrel_des"
  shows "II\<^sub>D ;; (P \<turnstile>\<^sub>r Q) = (P \<turnstile>\<^sub>r Q)"
proof -
  -- {* We first expand out the definition of the design identity *}
  have "II\<^sub>D ;; (P \<turnstile>\<^sub>r Q) = (true \<turnstile>\<^sub>r II) ;; (P \<turnstile>\<^sub>r Q)"
    by (simp add: skip_d_def)
  -- {* Next, we apply the design composition law above in a subproof *}
  also have "... = (true \<and> \<not> (II ;; (\<not> P))) \<turnstile>\<^sub>r (II ;; Q)"
  proof -
    -- {* The assumption of identity is $\true$ so it is easy to discharge the proviso *}
    have "out\<alpha> \<sharp> true"
      by unrest_tac
    -- {* From this we can apply the composition law *}
    thus ?thesis
      using rdesign_composition_cond by blast
  qed
  -- {* Simplification then allows us to remove extraneous terms *}
  also have "... = (\<not> (\<not> P)) \<turnstile>\<^sub>r Q"
    by simp
  -- {* Finally, we can show the thesis *}
  finally show ?thesis by simp
qed

subsection {* Program example *}

alphabet my_state =
  x :: int
  y :: int
  z :: int

lemma "(x := 1 ;; x := (&x + 1)) = (x := 2)"
  oops

lemma "($x\<acute> >\<^sub>u $x \<and> $y\<acute> <\<^sub>u $y) \<sqsubseteq> x, y := &x + 1, &y"
  oops

lemma "(x := 1 ;; (y := 7 \<triangleleft> $x >\<^sub>u 0 \<triangleright> y := 8)) = ((x,y) := (1,7))"
  oops

(* Need following law:  *)
theorem ndesign_composition_wp: "((p1 \<turnstile>\<^sub>n Q1) ;; (p2 \<turnstile>\<^sub>n Q2)) = ((p1 \<and> Q1 wp p2) \<turnstile>\<^sub>n (Q1 ;; Q2))"
  oops

lemma violate_precond:
  "(true \<turnstile>\<^sub>n x := 1) ;; ((&x >\<^sub>u 1) \<turnstile>\<^sub>n y := 2) = \<bottom>\<^sub>D"
  apply (subst ndesign_composition_wp)
  apply (simp)
  apply (wp_tac)
  apply (subst_tac)
  apply (rel_auto)
done
end


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

theory WhileLoopRules
  imports
    Empty_Fail
    NonDetMonad_Total
    NonDetMonad_Sat
begin

section "Well-ordered measures"

(* A version of "measure" that takes any wellorder, instead of being fixed to "nat". *)
definition measure' :: "('a \<Rightarrow> 'b::wellorder) => ('a \<times> 'a) set" where
  "measure' = (\<lambda>f. {(a, b). f a < f b})"

lemma in_measure'[simp, code_unfold]:
  "((x,y) \<in> measure' f) = (f x < f y)"
  by (simp add:measure'_def)

lemma wf_measure'[iff]:
  "wf (measure' f)"
  apply (clarsimp simp: measure'_def)
  apply (insert wf_inv_image [OF wellorder_class.wf, where f=f])
  apply (clarsimp simp: inv_image_def)
  done

lemma wf_wellorder_measure:
  "wf {(a, b). (M a :: 'a :: wellorder) < M b}"
  apply (subgoal_tac "wf (inv_image ({(a, b). a < b}) M)")
   apply (clarsimp simp: inv_image_def)
  apply (rule wf_inv_image)
  apply (rule wellorder_class.wf)
  done

section "whileLoop lemmas"

text \<open>
  The following @{const whileLoop} definitions with additional
  invariant/variant annotations allow the user to annotate
  @{const whileLoop} terms with information that can be used
  by automated tools.
\<close>
definition whileLoop_inv ::
  "('a \<Rightarrow> 'b \<Rightarrow> bool) \<Rightarrow> ('a \<Rightarrow> ('b, 'a) nondet_monad) \<Rightarrow> 'a \<Rightarrow> ('a \<Rightarrow> 'b \<Rightarrow> bool) \<Rightarrow>
   (('a \<times> 'b) \<times> 'a \<times> 'b) set \<Rightarrow> ('b, 'a) nondet_monad" where
  "whileLoop_inv C B x I R \<equiv> whileLoop C B x"

definition whileLoopE_inv ::
  "('a \<Rightarrow> 'b \<Rightarrow> bool) \<Rightarrow> ('a \<Rightarrow> ('b, 'c + 'a) nondet_monad) \<Rightarrow> 'a \<Rightarrow> ('a \<Rightarrow> 'b \<Rightarrow> bool) \<Rightarrow>
   (('a \<times> 'b) \<times> 'a \<times> 'b) set \<Rightarrow> ('b, 'c + 'a) nondet_monad" where
  "whileLoopE_inv C B x I R \<equiv> whileLoopE C B x"

lemma whileLoop_add_inv:
  "whileLoop B C = (\<lambda>x. whileLoop_inv B C x I (measure' M))"
  by (clarsimp simp: whileLoop_inv_def)

lemma whileLoopE_add_inv:
  "whileLoopE B C = (\<lambda>x. whileLoopE_inv B C x I (measure' M))"
  by (clarsimp simp: whileLoopE_inv_def)

subsection "Simple base rules"

lemma whileLoop_terminates_unfold:
  "\<lbrakk> whileLoop_terminates C B r s; (r', s') \<in> fst (B r s); C r s \<rbrakk> \<Longrightarrow>
   whileLoop_terminates C B r' s'"
  by (force elim!: whileLoop_terminates.cases)

lemma snd_whileLoop_first_step: "\<lbrakk> \<not> snd (whileLoop C B r s); C r s \<rbrakk> \<Longrightarrow> \<not> snd (B r s)"
  apply (subst (asm) whileLoop_unroll)
  apply (clarsimp simp: bind_def condition_def)
  done

lemma snd_whileLoopE_first_step: "\<lbrakk> \<not> snd (whileLoopE C B r s); C r s \<rbrakk> \<Longrightarrow> \<not> snd (B r s)"
  apply (subgoal_tac "\<lbrakk> \<not> snd (whileLoopE C B r s); C r s \<rbrakk> \<Longrightarrow> \<not> snd ((lift B (Inr r)) s)")
   apply (clarsimp simp: lift_def)
  apply (unfold whileLoopE_def)
  apply (erule snd_whileLoop_first_step)
  apply clarsimp
  done

lemma snd_whileLoop_unfold:
  "\<lbrakk> \<not> snd (whileLoop C B r s); C r s; (r', s') \<in> fst (B r s) \<rbrakk> \<Longrightarrow> \<not> snd (whileLoop C B r' s')"
  apply (clarsimp simp: whileLoop_def)
  apply (auto elim: whileLoop_results.cases whileLoop_terminates.cases
              intro: whileLoop_results.intros whileLoop_terminates.intros)
  done

lemma snd_whileLoopE_unfold:
  "\<lbrakk> \<not> snd (whileLoopE C B r s); (Inr r', s') \<in> fst (B r s); C r s \<rbrakk> \<Longrightarrow> \<not> snd (whileLoopE C B r' s')"
  unfolding whileLoopE_def
  by (fastforce simp: lift_def dest: snd_whileLoop_unfold)

lemma whileLoop_results_cong [cong]:
  assumes C:  "\<And>r s. C r s = C' r s"
  and B:"\<And>(r :: 'r) (s :: 's). C' r s \<Longrightarrow> B r s = B' r s"
  shows "whileLoop_results C B = whileLoop_results C' B'"
proof -
  {
    fix x y C B C' B'
    have  "\<lbrakk> (x, y) \<in> whileLoop_results C B;
             \<And>(r :: 'r) (s :: 's). C r s = C' r s; \<And>r s. C' r s \<Longrightarrow> B r s = B' r s \<rbrakk>
           \<Longrightarrow> (x, y) \<in> whileLoop_results C' B'"
      by (induct rule: whileLoop_results.induct) (auto intro: whileLoop_results.intros)
  }

  thus ?thesis
    apply -
    apply (rule set_eqI, rule iffI; clarsimp split: prod.splits)
     apply (clarsimp simp: C B)
    apply (clarsimp simp: C [symmetric] B [symmetric])
    done
qed

lemma whileLoop_terminates_cong [cong]:
  assumes r: "r = r'"
  and s: "s = s'"
  and C: "\<And>r s. C r s = C' r s"
  and B: "\<And>r s. C' r s \<Longrightarrow> B r s = B' r s"
  shows "whileLoop_terminates C B r s = whileLoop_terminates C' B' r' s'"
proof (rule iffI)
  assume T: "whileLoop_terminates C B r s"
  show "whileLoop_terminates C' B' r' s'"
    apply (insert T r s)
    apply (induct arbitrary: r' s' rule: whileLoop_terminates.induct)
     apply (clarsimp simp: C)
     apply (erule whileLoop_terminates.intros)
    apply (clarsimp simp: C B split: prod.splits)
    apply (rule whileLoop_terminates.intros, assumption)
    apply (clarsimp simp: C B split: prod.splits)
    done
next
  assume T: "whileLoop_terminates C' B' r' s'"
  show "whileLoop_terminates C B r s"
    apply (insert T r s)
    apply (induct arbitrary: r s rule: whileLoop_terminates.induct)
     apply (rule whileLoop_terminates.intros)
     apply (clarsimp simp: C)
    apply (rule whileLoop_terminates.intros, fastforce simp: C)
    apply (clarsimp simp: C B split: prod.splits)
    done
qed

lemma whileLoop_cong[cong]:
  "\<lbrakk> \<And>r s. C r s = C' r s; \<And>r s. C r s \<Longrightarrow> B r s = B' r s \<rbrakk> \<Longrightarrow> whileLoop C B = whileLoop C' B'"
  by (clarsimp simp: whileLoop_def)

lemma whileLoopE_cong[cong]:
  "\<lbrakk> \<And>r s. C r s = C' r s ; \<And>r s. C r s \<Longrightarrow> B r s = B' r s \<rbrakk> \<Longrightarrow> whileLoopE C B = whileLoopE C' B'"
  unfolding whileLoopE_def
  by (rule whileLoop_cong[THEN arg_cong]; clarsimp simp: lift_def throwError_def split: sum.splits)

lemma whileLoop_terminates_wf:
  "wf {(x, y). C (fst y) (snd y) \<and> x \<in> fst (B (fst y) (snd y)) \<and> whileLoop_terminates C B (fst y) (snd y)}"
  apply (rule wfI[where A="UNIV" and B="{(r, s). whileLoop_terminates C B r s}"]; clarsimp)
  apply (erule whileLoop_terminates.induct; blast)
  done

subsection "Basic induction helper lemmas"

lemma whileLoop_results_induct_lemma1:
  "\<lbrakk> (a, b) \<in> whileLoop_results C B; b = Some (x, y) \<rbrakk> \<Longrightarrow> \<not> C x y"
  by (induct rule: whileLoop_results.induct) auto

lemma whileLoop_results_induct_lemma1':
  "\<lbrakk> (a, b) \<in> whileLoop_results C B; a \<noteq> b \<rbrakk> \<Longrightarrow> \<exists>x. a = Some x \<and> C (fst x) (snd x)"
  by (induct rule: whileLoop_results.induct) auto

lemma whileLoop_results_induct_lemma2 [consumes 1]:
  "\<lbrakk> (a, b) \<in> whileLoop_results C B;
     a = Some (x :: 'a \<times> 'b); b = Some y;
     P x; \<And>s t. \<lbrakk> P s; t \<in> fst (B (fst s) (snd s)); C (fst s) (snd s) \<rbrakk> \<Longrightarrow> P t \<rbrakk> \<Longrightarrow> P y"
  apply (induct arbitrary: x y rule: whileLoop_results.induct)
    apply simp
   apply simp
  apply atomize
  apply fastforce
  done

lemma whileLoop_results_induct_lemma3 [consumes 1]:
  assumes result: "(Some (r, s), Some (r', s')) \<in> whileLoop_results C B"
  and inv_start: "I r s"
  and inv_step: "\<And>r s r' s'. \<lbrakk> I r s; C r s; (r', s') \<in> fst (B r s) \<rbrakk> \<Longrightarrow> I r' s'"
  shows "I r' s'"
  apply (rule whileLoop_results_induct_lemma2 [where P="case_prod I" and y="(r', s')" and x="(r, s)",
                                               simplified case_prod_unfold, simplified])
      apply (rule result)
     apply simp
    apply simp
   apply fact
  apply (erule (1) inv_step)
  apply clarsimp
  done

subsection "Inductive reasoning about whileLoop results"

lemma in_whileLoop_induct[consumes 1]:
  assumes in_whileLoop: "(r', s') \<in> fst (whileLoop C B r s)"
  and init_I: "\<And> r s. \<not> C r s \<Longrightarrow> I r s r s"
  and step: "\<And>r s r' s' r'' s''. \<lbrakk> C r s; (r', s') \<in> fst (B r s);
                                   (r'', s'') \<in> fst (whileLoop C B r' s');
                                   I r' s' r'' s'' \<rbrakk> \<Longrightarrow> I r s r'' s''"
  shows "I r s r' s'"
proof cases
  assume "C r s"

  {
    obtain a where a_def: "a = Some (r, s)"
      by blast
    obtain b where b_def: "b = Some (r', s')"
      by blast

    have "\<lbrakk> (a, b) \<in> whileLoop_results C B; \<exists>x. a = Some x;  \<exists>x. b = Some x \<rbrakk>
          \<Longrightarrow> I (fst (the a)) (snd (the a)) (fst (the b)) (snd (the b))"
      by (induct rule: whileLoop_results.induct)
         (auto simp: init_I whileLoop_def intro: step)

    hence "(Some (r, s), Some (r', s')) \<in> whileLoop_results C B \<Longrightarrow> I r s r' s'"
      by (clarsimp simp: a_def b_def)
   }

   thus ?thesis
     using in_whileLoop
     by (clarsimp simp: whileLoop_def)
next
  assume "\<not> C r s"

  hence "r' = r \<and> s' = s"
    using in_whileLoop
    by (subst (asm) whileLoop_unroll, clarsimp simp: condition_def return_def)

  thus ?thesis
    by (metis init_I \<open>\<not> C r s\<close>)
qed

lemma snd_whileLoop_induct [consumes 1]:
  assumes induct: "snd (whileLoop C B r s)"
  and terminates: "\<not> whileLoop_terminates C B r s \<Longrightarrow> I r s"
  and init: "\<And> r s. \<lbrakk> snd (B r s); C r s \<rbrakk> \<Longrightarrow> I r s"
  and step: "\<And>r s r' s' r'' s''. \<lbrakk> C r s; (r', s') \<in> fst (B r s); snd (whileLoop C B r' s');
                                   I r' s' \<rbrakk> \<Longrightarrow> I r s"
  shows "I r s"
  apply (insert init induct)
  apply atomize
  apply (unfold whileLoop_def)
  apply clarsimp
  apply (erule disjE)
   apply (erule rev_mp)
   apply (induct "Some (r, s)" "None :: ('a \<times> 'b) option" arbitrary: r s rule: whileLoop_results.induct)
    apply clarsimp
   apply clarsimp
   apply (erule (1) step)
    apply (clarsimp simp: whileLoop_def)
   apply clarsimp
  apply (metis terminates)
  done

lemma whileLoop_terminatesE_induct [consumes 1]:
  assumes induct: "whileLoop_terminatesE C B r s"
  and init: "\<And>r s. \<not> C r s \<Longrightarrow> I r s"
  and step: "\<And>r s r' s'. \<lbrakk> C r s; \<forall>(v', s') \<in> fst (B r s). case v' of Inl _ \<Rightarrow> True | Inr r' \<Rightarrow> I r' s' \<rbrakk> \<Longrightarrow> I r s"
  shows "I r s"
  apply (insert induct)
  apply (clarsimp simp: whileLoop_terminatesE_def)
  apply (subgoal_tac "(\<lambda>r s. case (Inr r) of Inl x \<Rightarrow> True | Inr x \<Rightarrow> I x s) r s")
   apply simp
  apply (induction rule: whileLoop_terminates.induct)
   apply (clarsimp split: sum.splits elim!: init)
  apply (clarsimp split: sum.splits)
  apply (rule step)
   apply simp
  apply (force simp: lift_def split: sum.splits)
  done

subsection "Direct reasoning about whileLoop components"

lemma fst_whileLoop_cond_false:
  assumes loop_result: "(r', s') \<in> fst (whileLoop C B r s)"
  shows "\<not> C r' s'"
  using loop_result
  by (rule in_whileLoop_induct, auto)

lemma snd_whileLoop:
  assumes init_I: "I r s"
      and cond_I: "C r s"
      and non_term:  "\<And>r. \<lbrace> \<lambda>s. I r s \<and> C r s \<and> \<not> snd (B r s) \<rbrace> B r \<exists>\<lbrace> \<lambda>r' s'. C r' s' \<and> I r' s' \<rbrace>"
  shows "snd (whileLoop C B r s)"
  apply (clarsimp simp: whileLoop_def)
  apply (rotate_tac)
  apply (insert init_I cond_I)
  apply (induct rule: whileLoop_terminates.induct)
   apply clarsimp
  apply (cut_tac r=r in non_term)
  apply (clarsimp simp: exs_valid_def)
   apply (subst (asm) (2) whileLoop_results.simps)
   apply clarsimp
  apply (insert whileLoop_results.simps)
  apply fast
  done

lemma whileLoop_terminates_inv:
  assumes init_I: "I r s"
  assumes inv: "\<And>r s. \<lbrace>\<lambda>s'. I r s' \<and> C r s' \<and> s' = s \<rbrace> B r \<lbrace> \<lambda>r' s'. I r' s' \<and> ((r', s'), (r, s)) \<in> R \<rbrace>"
  assumes wf_R: "wf R"
  shows "whileLoop_terminates C B r s"
  apply (insert init_I)
  using wf_R
  apply (induction "(r, s)" arbitrary: r s)
  apply atomize
  apply (subst whileLoop_terminates_simps)
  apply clarsimp
  apply (erule use_valid)
  apply (rule hoare_strengthen_post, rule inv)
   apply force
  apply force
  done

lemma not_snd_whileLoop:
  assumes init_I: "I r s"
      and inv_holds: "\<And>r s. \<lbrace>\<lambda>s'. I r s' \<and> C r s' \<and> s' = s \<rbrace> B r \<lbrace> \<lambda>r' s'. I r' s' \<and> ((r', s'), (r, s)) \<in> R \<rbrace>!"
      and wf_R: "wf R"
  shows "\<not> snd (whileLoop C B r s)"
proof -
  {
    fix x y
    have "\<lbrakk> (x, y) \<in> whileLoop_results C B; x = Some (r, s); y = None \<rbrakk> \<Longrightarrow> False"
      apply (insert init_I)
      apply (induct arbitrary: r s rule: whileLoop_results.inducts)
        apply simp
       apply simp
       apply (insert snd_validNF [OF inv_holds])[1]
       apply blast
      apply (drule use_validNF [OF _ inv_holds])
       apply simp
      apply clarsimp
      done
  }

  also have "whileLoop_terminates C B r s"
    apply (rule whileLoop_terminates_inv [where I=I, OF init_I _ wf_R])
    apply (insert inv_holds)
    apply (clarsimp simp: validNF_def)
    done

  ultimately show ?thesis
    by (clarsimp simp: whileLoop_def, blast)
qed

lemma valid_whileLoop:
  assumes first_step: "\<And>s. P r s \<Longrightarrow> I r s"
      and inv_step: "\<And>r. \<lbrace> \<lambda>s. I r s \<and> C r s \<rbrace> B r \<lbrace> I \<rbrace>"
      and final_step: "\<And>r s. \<lbrakk> I r s; \<not> C r s \<rbrakk> \<Longrightarrow> Q r s"
  shows "\<lbrace> P r \<rbrace> whileLoop C B r \<lbrace> Q \<rbrace>"
proof -
  {
    fix r' s' s
    assume inv: "I r s"
    assume step: "(r', s') \<in> fst (whileLoop C B r s)"

    have "I r' s'"
      using step inv
      apply (induct rule: in_whileLoop_induct)
       apply simp
      apply (drule use_valid, rule inv_step, auto)
      done
  }

  thus ?thesis
    apply (clarsimp simp: valid_def)
    apply (drule first_step)
    apply (rule final_step, simp)
    apply (metis fst_whileLoop_cond_false)
    done
qed

lemma whileLoop_wp:
  "\<lbrakk> \<And>r. \<lbrace> \<lambda>s. I r s \<and> C r s \<rbrace> B r \<lbrace> I \<rbrace>;
     \<And>r s. \<lbrakk> I r s; \<not> C r s \<rbrakk> \<Longrightarrow> Q r s \<rbrakk> \<Longrightarrow>
  \<lbrace> I r \<rbrace> whileLoop C B r \<lbrace> Q \<rbrace>"
  by (rule valid_whileLoop)

lemma whileLoop_wp_inv [wp]:
  "\<lbrakk> \<And>r. \<lbrace>\<lambda>s. I r s \<and> C r s\<rbrace> B r \<lbrace>I\<rbrace>; \<And>r s. \<lbrakk>I r s; \<not> C r s\<rbrakk> \<Longrightarrow> Q r s \<rbrakk>
   \<Longrightarrow> \<lbrace> I r \<rbrace> whileLoop_inv C B r I M \<lbrace> Q \<rbrace>"
  apply (clarsimp simp: whileLoop_inv_def)
  apply (rule valid_whileLoop [where P=I and I=I], auto)
  done

lemma validE_whileLoopE:
  "\<lbrakk>\<And>s. P r s \<Longrightarrow> I r s;
    \<And>r. \<lbrace> \<lambda>s. I r s \<and> C r s \<rbrace> B r \<lbrace> I \<rbrace>,\<lbrace> A \<rbrace>;
    \<And>r s. \<lbrakk> I r s; \<not> C r s \<rbrakk> \<Longrightarrow> Q r s\<rbrakk> \<Longrightarrow>
   \<lbrace> P r \<rbrace> whileLoopE C B r \<lbrace> Q \<rbrace>,\<lbrace> A \<rbrace>"
  apply (clarsimp simp: whileLoopE_def validE_def)
  apply (rule valid_whileLoop [where I="\<lambda>r s. (case r of Inl x \<Rightarrow> A x s | Inr x \<Rightarrow> I x s)"
                                 and Q="\<lambda>r s. (case r of Inl x \<Rightarrow> A x s | Inr x \<Rightarrow> Q x s)"])
    apply atomize
    apply (clarsimp simp: valid_def lift_def split: sum.splits)
   apply (clarsimp simp: valid_def lift_def split: sum.splits)
  apply (clarsimp split: sum.splits)
  done

lemma whileLoopE_wp:
  "\<lbrakk> \<And>r. \<lbrace> \<lambda>s. I r s \<and> C r s \<rbrace> B r \<lbrace> I \<rbrace>, \<lbrace> A \<rbrace>;
     \<And>r s. \<lbrakk> I r s; \<not> C r s \<rbrakk> \<Longrightarrow> Q r s \<rbrakk> \<Longrightarrow>
  \<lbrace> I r \<rbrace> whileLoopE C B r \<lbrace> Q \<rbrace>, \<lbrace> A \<rbrace>"
  by (rule validE_whileLoopE)

lemma exs_valid_whileLoop:
 assumes init_T: "\<And>s. P s \<Longrightarrow> T r s"
    and iter_I: "\<And>r s0. \<lbrace>\<lambda>s. T r s \<and> C r s \<and> s = s0\<rbrace> B r \<exists>\<lbrace>\<lambda>r' s'. T r' s' \<and> ((r', s'),(r, s0)) \<in> R\<rbrace>"
    and wf_R: "wf R"
    and final_I: "\<And>r s. \<lbrakk> T r s; \<not> C r s  \<rbrakk> \<Longrightarrow> Q r s"
 shows "\<lbrace> P \<rbrace> whileLoop C B r \<exists>\<lbrace> Q \<rbrace>"
proof (clarsimp simp: exs_valid_def Bex_def)
  fix s
  assume "P s"

  {
    fix x
    have "T (fst x) (snd x) \<Longrightarrow> \<exists>r' s'. (r', s') \<in> fst (whileLoop C B (fst x) (snd x)) \<and> T r' s'"
      using wf_R
      apply induction
      apply atomize
      apply (case_tac "C (fst x) (snd x)")
       apply (subst whileLoop_unroll)
       apply (clarsimp simp: condition_def bind_def' split: prod.splits)
       apply (cut_tac ?s0.0=b and r=a in iter_I)
       apply (clarsimp simp: exs_valid_def)
       apply blast
      apply (subst whileLoop_unroll)
      apply (clarsimp simp: condition_def bind_def' return_def)
      done
  }

  thus "\<exists>r' s'. (r', s') \<in> fst (whileLoop C B r s) \<and> Q r' s'"
    by (metis \<open>P s\<close> fst_conv init_T snd_conv final_I fst_whileLoop_cond_false)
qed

lemma empty_fail_whileLoop[empty_fail_cond, intro!, wp]:
  assumes body_empty_fail: "\<And>r. empty_fail (B r)"
  shows "empty_fail (whileLoop C B r)"
proof -
  {
    fix s A
    assume empty: "fst (whileLoop C B r s) = {}"

    have cond_true: "\<And>x s. fst (whileLoop C B x s) = {} \<Longrightarrow> C x s"
      apply (subst (asm) whileLoop_unroll)
      apply (clarsimp simp: condition_def return_def split: if_split_asm)
      done

    have  "snd (whileLoop C B r s)"
      apply (rule snd_whileLoop [where I="\<lambda>x s. fst (whileLoop C B x s) = {}"])
        apply fact
       apply (rule cond_true, fact)
      apply (clarsimp simp: exs_valid_def)
      apply (case_tac "fst (B r s) = {}")
       apply (metis empty_failD [OF body_empty_fail])
      apply (subst (asm) whileLoop_unroll)
      apply (fastforce simp: condition_def bind_def split_def cond_true)
      done
   }

  thus ?thesis
    by (clarsimp simp: empty_fail_def)
qed

lemma empty_fail_whileLoopE[empty_fail_cond, intro!, wp]:
  assumes "\<And>r. empty_fail (B r)"
  shows "empty_fail (whileLoopE C B r)"
  by (clarsimp simp: whileLoopE_def assms)

lemma empty_fail_whileM[empty_fail_cond, intro!, wp]:
  "\<lbrakk> empty_fail C; empty_fail B \<rbrakk> \<Longrightarrow> empty_fail (whileM C B)"
  unfolding whileM_def
  by (wpsimp wp: empty_fail_whileLoop empty_fail_bind)

lemma whileLoop_results_bisim:
  assumes base: "(a, b) \<in> whileLoop_results C B"
  and vars1: "Q = (case a of Some (r, s) \<Rightarrow> Some (rt r, st s) | _ \<Rightarrow> None)"
  and vars2: "R = (case b of Some (r, s) \<Rightarrow> Some (rt r, st s) | _ \<Rightarrow> None)"
  and inv_init: "case a of Some (r, s) \<Rightarrow> I r s | _ \<Rightarrow> True"
  and inv_step: "\<And>r s r' s'. \<lbrakk> I r s; C r s; (r', s') \<in> fst (B r s) \<rbrakk> \<Longrightarrow> I r' s'"
  and cond_match: "\<And>r s. I r s \<Longrightarrow> C r s = C' (rt r) (st s)"
  and fail_step: "\<And>r s. \<lbrakk>C r s; snd (B r s); I r s\<rbrakk>
                         \<Longrightarrow> (Some (rt r, st s), None) \<in> whileLoop_results C' B'"
  and refine: "\<And>r s r' s'. \<lbrakk> I r s; C r s; (r', s') \<in>  fst (B r s) \<rbrakk>
                            \<Longrightarrow> (rt r', st s') \<in> fst (B' (rt r) (st s))"
  shows "(Q, R) \<in> whileLoop_results C' B'"
  apply (subst vars1)
  apply (subst vars2)
  apply (insert base inv_init)
  apply (induct rule: whileLoop_results.induct)
    apply clarsimp
    apply (subst (asm) cond_match)
     apply (clarsimp simp: option.splits)
    apply (clarsimp simp: option.splits)
   apply (clarsimp simp: option.splits)
   apply (metis fail_step)
  apply (case_tac z)
   apply (clarsimp simp: option.splits)
   apply (metis cond_match inv_step refine whileLoop_results.intros(3))
  apply (clarsimp simp: option.splits)
  apply (metis cond_match inv_step refine whileLoop_results.intros(3))
  done

lemma whileLoop_terminates_liftE:
  "whileLoop_terminatesE C (\<lambda>r. liftE (B r)) r s = whileLoop_terminates C B r s"
  apply (subst eq_sym_conv)
  apply (clarsimp simp: whileLoop_terminatesE_def)
  apply (rule iffI)
   apply (erule whileLoop_terminates.induct)
    apply (rule whileLoop_terminates.intros)
    apply clarsimp
   apply (clarsimp simp: split_def)
   apply (rule whileLoop_terminates.intros(2))
    apply clarsimp
   apply (clarsimp simp: liftE_def in_bind return_def lift_def[abs_def]
                          bind_def lift_def throwError_def o_def
                   split: sum.splits
                   cong: sum.case_cong)
   apply (drule (1) bspec)
   apply clarsimp
  apply (subgoal_tac
         "case Inr r of
            Inl _ \<Rightarrow> True
          | Inr r \<Rightarrow> whileLoop_terminates
                       (\<lambda>r s. (\<lambda>r s. case r of Inl _ \<Rightarrow> False | Inr v \<Rightarrow> C v s) (Inr r) s)
                       (\<lambda>r. lift (\<lambda>r. liftE (B r)) (Inr r) >>= (\<lambda>x. return (projr x))) r s")
   apply (clarsimp simp: liftE_def lift_def)
  apply (erule whileLoop_terminates.induct)
   apply (clarsimp simp: liftE_def lift_def split: sum.splits)
   apply (erule whileLoop_terminates.intros)
  apply (clarsimp simp: liftE_def split: sum.splits)
  apply (clarsimp simp: bind_def return_def split_def lift_def)
  apply (erule whileLoop_terminates.intros)
  apply force
  done

lemma snd_X_return[simp]:
  "snd ((A >>= (\<lambda>a. return (X a))) s) = snd (A s)"
  by (clarsimp simp: return_def bind_def split_def)

lemma whileLoopE_liftE:
  "whileLoopE C (\<lambda>r. liftE (B r)) r = liftE (whileLoop C B r)"
  apply (rule ext)
  apply (clarsimp simp: whileLoopE_def)
  apply (rule prod_eqI)
   apply (rule set_eqI, rule iffI)
    apply clarsimp
    apply (clarsimp simp: in_bind whileLoop_def liftE_def)
    apply (rule_tac x="b" in exI)
    apply (rule_tac x="projr a" in exI)
    apply (rule conjI)
     apply (erule whileLoop_results_bisim[where rt=projr
                                            and st="\<lambda>x. x"
                                            and I="\<lambda>r s. case r of Inr x \<Rightarrow> True | _ \<Rightarrow> False"],
            auto intro: whileLoop_results.intros simp: bind_def return_def lift_def split: sum.splits)[1]
    apply (drule whileLoop_results_induct_lemma2[where P="\<lambda>(r, s). case r of Inr x \<Rightarrow> True | _ \<Rightarrow> False"])
        apply (rule refl)
       apply (rule refl)
      apply clarsimp
     apply (clarsimp simp: return_def bind_def lift_def split: sum.splits)
    apply (clarsimp simp: return_def bind_def lift_def split: sum.splits)
   apply (clarsimp simp: in_bind whileLoop_def liftE_def)
   apply (erule whileLoop_results_bisim[where rt=Inr and st="\<lambda>x. x" and I="\<lambda>r s. True"],
          auto intro: whileLoop_results.intros intro!: bexI simp: bind_def return_def lift_def
               split: sum.splits)[1]
  apply (rule iffI)
   apply (clarsimp simp: whileLoop_def liftE_def del: notI)
   apply (erule disjE)
    apply (erule whileLoop_results_bisim[where rt=projr
                                           and st="\<lambda>x. x"
                                           and I="\<lambda>r s. case r of Inr x \<Rightarrow> True | _ \<Rightarrow> False"],
           auto intro: whileLoop_results.intros simp: bind_def return_def lift_def split: sum.splits)[1]
   apply (subst (asm) whileLoop_terminates_liftE [symmetric])
   apply (fastforce simp: whileLoop_def liftE_def whileLoop_terminatesE_def)
  apply (clarsimp simp: whileLoop_def liftE_def del: notI)
  apply (subst (asm) whileLoop_terminates_liftE [symmetric])
  apply (clarsimp simp: whileLoop_def liftE_def whileLoop_terminatesE_def)
  apply (erule disjE)
   apply (erule whileLoop_results_bisim [where rt=Inr and st="\<lambda>x. x" and I="\<lambda>r s. True"])
         apply (clarsimp split: option.splits)
        apply (clarsimp split: option.splits)
       apply (clarsimp split: option.splits)
      apply (auto intro: whileLoop_results.intros intro!: bexI simp: bind_def return_def lift_def
                  split: sum.splits)
  done

lemma validNF_whileLoop:
  assumes pre: "\<And>s. P r s \<Longrightarrow> I r s"
  and inv: "\<And>r s. \<lbrace>\<lambda>s'. I r s' \<and> C r s' \<and> s' = s \<rbrace> B r \<lbrace> \<lambda>r' s'. I r' s' \<and> ((r', s'), (r, s)) \<in> R \<rbrace>!"
  and wf: "wf R"
  and post_cond: "\<And>r s. \<lbrakk>I r s; \<not> C r s\<rbrakk> \<Longrightarrow> Q r s"
  shows "\<lbrace>P r\<rbrace> whileLoop C B r \<lbrace>Q\<rbrace>!"
  apply rule
   apply (rule valid_whileLoop)
     apply fact
    apply (insert inv, clarsimp simp: validNF_def valid_def split: prod.splits, force)[1]
   apply (metis post_cond)
  apply (unfold no_fail_def)
  apply (intro allI impI)
  apply (rule not_snd_whileLoop [where I=I and R=R])
    apply (auto intro: assms)
  done

lemma validNF_whileLoop_inv [wp]:
  assumes inv: "\<And>r s. \<lbrace>\<lambda>s'. I r s' \<and> C r s' \<and> s' = s \<rbrace> B r \<lbrace> \<lambda>r' s'. I r' s' \<and> ((r', s'), (r, s)) \<in> R \<rbrace>!"
  and wf: "wf R"
  and post_cond: "\<And>r s. \<lbrakk>I r s; \<not> C r s\<rbrakk> \<Longrightarrow> Q r s"
  shows "\<lbrace>I r\<rbrace> whileLoop_inv C B r I R \<lbrace>Q\<rbrace>!"
  apply (clarsimp simp: whileLoop_inv_def)
  apply (rule validNF_whileLoop [where I=I and R=R])
     apply simp
    apply (rule inv)
   apply (rule wf)
  apply (metis post_cond)
  done

lemma validNF_whileLoop_inv_measure [wp]:
  assumes inv: "\<And>r s. \<lbrace>\<lambda>s'. I r s' \<and> C r s' \<and> s' = s \<rbrace> B r \<lbrace> \<lambda>r' s'. I r' s' \<and> M r' s' < M r s \<rbrace>!"
  and post_cond: "\<And>r s. \<lbrakk>I r s; \<not> C r s\<rbrakk> \<Longrightarrow> Q r s"
  shows "\<lbrace>I r\<rbrace> whileLoop_inv C B r I (measure' (\<lambda>(r, s). M r s)) \<lbrace>Q\<rbrace>!"
  apply (clarsimp simp: whileLoop_inv_def)
    apply (rule validNF_whileLoop[where R="measure' (\<lambda>(r, s). M r s)" and I=I])
     apply simp
    apply clarsimp
    apply (rule inv)
   apply simp
  apply (metis post_cond)
  done

lemma validNF_whileLoop_inv_measure_twosteps:
  assumes inv: "\<And>r s. \<lbrace>\<lambda>s'. I r s' \<and> C r s' \<rbrace> B r \<lbrace> \<lambda>r' s'. I r' s' \<rbrace>!"
  assumes measure: "\<And>r m. \<lbrace>\<lambda>s. I r s \<and> C r s \<and> M r s = m \<rbrace> B r \<lbrace> \<lambda>r' s'. M r' s' < m \<rbrace>"
  and post_cond: "\<And>r s. \<lbrakk>I r s; \<not> C r s\<rbrakk> \<Longrightarrow> Q r s"
  shows "\<lbrace>I r\<rbrace> whileLoop_inv C B r I (measure' (\<lambda>(r, s). M r s)) \<lbrace>Q\<rbrace>!"
  apply (rule validNF_whileLoop_inv_measure)
   apply (rule validNF_weaken_pre)
    apply (rule validNF_post_comb_conj_L)
     apply (rule inv)
    apply (rule measure)
   apply fast
  apply (metis post_cond)
  done

lemma wf_custom_measure:
  "\<lbrakk> \<And>a b. (a, b) \<in> R \<Longrightarrow> f a < (f :: 'a \<Rightarrow> nat) b \<rbrakk> \<Longrightarrow>  wf R"
  by (metis in_measure wf_def wf_measure)

lemma validNF_whileLoopE:
  assumes pre: "\<And>s. P r s \<Longrightarrow> I r s"
  and inv: "\<And>r s. \<lbrace>\<lambda>s'. I r s' \<and> C r s' \<and> s' = s \<rbrace> B r \<lbrace> \<lambda>r' s'. I r' s' \<and> ((r', s'), (r, s)) \<in> R \<rbrace>,\<lbrace> E \<rbrace>!"
  and wf: "wf R"
  and post_cond: "\<And>r s. \<lbrakk>I r s; \<not> C r s\<rbrakk> \<Longrightarrow> Q r s"
  shows "\<lbrace> P r \<rbrace> whileLoopE C B r \<lbrace> Q \<rbrace>,\<lbrace> E \<rbrace>!"
  apply (unfold validE_NF_alt_def whileLoopE_def)
  apply (rule validNF_whileLoop [where
                I="\<lambda>r s. case r of Inl x \<Rightarrow> E x s | Inr x \<Rightarrow> I x s" and
                R="{((r', s'), (r, s)). \<exists>x x'. r' = Inl x' \<and> r = Inr x} \<union>
                   {((r', s'), (r, s)). \<exists>x x'. r' = Inr x' \<and> r = Inr x \<and> ((x', s'),(x, s)) \<in> R}"])
     apply (simp add: pre)
    apply (insert inv)[1]
    apply (fastforce simp: lift_def validNF_def valid_def validE_NF_def throwError_def no_fail_def
                           return_def validE_def
                     split: sum.splits prod.splits)
   apply (rule wf_Un)
     apply (rule wf_custom_measure [where f="\<lambda>(r, s). case r of Inl _ \<Rightarrow> 0 | _ \<Rightarrow> 1"])
     apply clarsimp
    apply (insert wf_inv_image [OF wf, where f="\<lambda>(r, s). (projr r, s)"])
    apply (drule wf_Int1 [where r'="{((r', s'),(r, s)). (\<exists>x. r = Inr x) \<and> (\<exists>x. r' = Inr x)}"])
    apply (erule wf_subset)
    apply (fastforce simp: inv_image_def split: prod.splits sum.splits)
   apply fastforce
  apply (fastforce split: sum.splits intro: post_cond)
  done

lemma validNF_whileLoopE_inv [wp]:
  assumes inv: "\<And>r s. \<lbrace>\<lambda>s'. I r s' \<and> C r s' \<and> s' = s \<rbrace> B r \<lbrace> \<lambda>r' s'. I r' s' \<and> ((r', s'), (r, s)) \<in> R \<rbrace>,\<lbrace> E \<rbrace>!"
  and wf_R: "wf R"
  and post_cond: "\<And>r s. \<lbrakk>I r s; \<not> C r s\<rbrakk> \<Longrightarrow> Q r s"
  shows "\<lbrace>I r\<rbrace> whileLoopE_inv C B r I R \<lbrace>Q\<rbrace>,\<lbrace>E\<rbrace>!"
  apply (clarsimp simp: whileLoopE_inv_def)
  apply (metis validNF_whileLoopE [OF _ inv] post_cond wf_R)
  done

lemma validNF_whileLoopE_inv_measure [wp]:
  assumes inv: "\<And>r s. \<lbrace>\<lambda>s'. I r s' \<and> C r s' \<and> s' = s \<rbrace> B r \<lbrace> \<lambda>r' s'. I r' s' \<and> M r' s' < M r s \<rbrace>, \<lbrace> E \<rbrace>!"
  and post_cond: "\<And>r s. \<lbrakk>I r s; \<not> C r s\<rbrakk> \<Longrightarrow> Q r s"
  shows "\<lbrace>I r\<rbrace> whileLoopE_inv C B r I (measure' (\<lambda>(r, s). M r s)) \<lbrace>Q\<rbrace>,\<lbrace>E\<rbrace>!"
  apply (rule validNF_whileLoopE_inv)
    apply clarsimp
    apply (rule inv)
   apply clarsimp
  apply (metis post_cond)
  done

lemma validNF_whileLoopE_inv_measure_twosteps:
  assumes inv: "\<And>r. \<lbrace>\<lambda>s'. I r s' \<and> C r s' \<rbrace> B r \<lbrace> \<lambda>r' s'. I r' s' \<rbrace>, \<lbrace> E \<rbrace>!"
  assumes measure: "\<And>r m. \<lbrace>\<lambda>s. I r s \<and> C r s \<and> M r s = m \<rbrace> B r \<lbrace> \<lambda>r' s'. M r' s' < m \<rbrace>, \<lbrace> \<lambda>_ _. True \<rbrace>"
  and post_cond: "\<And>r s. \<lbrakk>I r s; \<not> C r s\<rbrakk> \<Longrightarrow> Q r s"
  shows "\<lbrace>I r\<rbrace> whileLoopE_inv C B r I (measure' (\<lambda>(r, s). M r s)) \<lbrace>Q\<rbrace>, \<lbrace>E\<rbrace>!"
  apply (rule validNF_whileLoopE_inv_measure)
   apply (rule validE_NF_weaken_pre)
    apply (rule validE_NF_post_comb_conj_L)
     apply (rule inv)
    apply (rule measure)
   apply fast
  apply (metis post_cond)
  done

lemma whileLoopE_wp_inv [wp]:
  "\<lbrakk> \<And>r. \<lbrace>\<lambda>s. I r s \<and> C r s\<rbrace> B r \<lbrace>I\<rbrace>,\<lbrace>E\<rbrace>; \<And>r s. \<lbrakk>I r s; \<not> C r s\<rbrakk> \<Longrightarrow> Q r s \<rbrakk>
      \<Longrightarrow> \<lbrace> I r \<rbrace> whileLoopE_inv C B r I M \<lbrace> Q \<rbrace>,\<lbrace> E \<rbrace>"
  apply (clarsimp simp: whileLoopE_inv_def)
  apply (rule validE_whileLoopE [where I=I], auto)
  done

subsection "Stronger whileLoop rules"

lemma whileLoop_rule_strong:
  assumes init_U: "\<lbrace> \<lambda>s'. s' = s \<rbrace> whileLoop C B r \<lbrace> \<lambda>r s. (r, s) \<in> fst Q \<rbrace>"
  and path_exists: "\<And>r'' s''. \<lbrakk> (r'', s'') \<in> fst Q \<rbrakk> \<Longrightarrow> \<lbrace> \<lambda>s'. s' = s \<rbrace> whileLoop C B r \<exists>\<lbrace> \<lambda>r s. r = r'' \<and> s = s'' \<rbrace>"
  and loop_fail: "snd Q \<Longrightarrow> snd (whileLoop C B r s)"
  and loop_nofail: "\<not> snd Q \<Longrightarrow> \<lbrace> \<lambda>s'. s' = s \<rbrace> whileLoop C B r \<lbrace> \<lambda>_ _. True \<rbrace>!"
  shows "whileLoop C B r s = Q"
  using assms
  apply atomize
  apply (clarsimp simp: valid_def exs_valid_def validNF_def no_fail_def)
  apply rule
    apply blast
   apply blast
  apply blast
  done

lemma whileLoop_rule_strong_no_fail:
  assumes init_U: "\<lbrace> \<lambda>s'. s' = s \<rbrace> whileLoop C B r \<lbrace> \<lambda>r s. (r, s) \<in> fst Q \<rbrace>!"
  and path_exists: "\<And>r'' s''. \<lbrakk> (r'', s'') \<in> fst Q \<rbrakk> \<Longrightarrow> \<lbrace> \<lambda>s'. s' = s \<rbrace> whileLoop C B r \<exists>\<lbrace> \<lambda>r s. r = r'' \<and> s = s'' \<rbrace>"
  and loop_no_fail: "\<not> snd Q"
  shows "whileLoop C B r s = Q"
  apply (rule whileLoop_rule_strong)
     apply (metis init_U validNF_valid)
    apply (metis path_exists)
   apply (metis loop_no_fail)
  apply (metis (lifting, no_types) init_U validNF_chain)
  done

subsection "Miscellaneous rules"

(* Failure of one whileLoop implies the failure of another whileloop
 * which will only ever fail more. *)
lemma snd_whileLoop_subset:
    assumes a_fails: "snd (whileLoop C A r s)"
    and b_success_step:
        "\<And>r s r' s'. \<lbrakk> C r s; (r', s') \<in> fst (A r s); \<not> snd (B r s) \<rbrakk>
             \<Longrightarrow> (r', s') \<in> fst (B r s)"
    and b_fail_step: "\<And>r s. \<lbrakk> C r s; snd (A r s) \<rbrakk> \<Longrightarrow> snd (B r s) "
   shows "snd (whileLoop C B r s)"
  apply (insert a_fails)
  apply (induct rule: snd_whileLoop_induct)
    apply (unfold whileLoop_def snd_conv)[1]
    apply (rule disjCI, simp)
    apply rotate_tac
    apply (induct rule: whileLoop_terminates.induct)
     apply (subst (asm) whileLoop_terminates.simps)
     apply simp
    apply (subst (asm) (3) whileLoop_terminates.simps, clarsimp)
    apply (subst whileLoop_results.simps, clarsimp)
    apply (rule classical)
    apply (frule b_success_step, assumption, simp)
    apply (drule (1) bspec)
    apply clarsimp
   apply (frule (1) b_fail_step)
   apply (metis snd_whileLoop_first_step)
  apply (metis b_success_step snd_whileLoop_first_step snd_whileLoop_unfold)
  done

subsection "Some rules for whileM"

lemma whileM_wp_gen:
  assumes termin:"\<And>s. I False s \<Longrightarrow> Q s"
  assumes [wp]: "\<lbrace>I'\<rbrace> C \<lbrace>I\<rbrace>"
  assumes [wp]: "\<lbrace>I True\<rbrace> f \<lbrace>\<lambda>_. I'\<rbrace>"
  shows "\<lbrace>I'\<rbrace> whileM C f \<lbrace>\<lambda>_. Q\<rbrace>"
  unfolding whileM_def
  using termin
  by (wpsimp wp: whileLoop_wp[where I=I])

lemma whileM_inv:
  "\<lbrakk>f \<lbrace>Q\<rbrace>; P \<lbrace>Q\<rbrace>\<rbrakk> \<Longrightarrow> whileM P f \<lbrace>Q\<rbrace>"
  by (fastforce intro: whileM_wp_gen)

lemmas whileM_post_inv
  = hoare_strengthen_post[where R="\<lambda>_. Q" for Q, OF whileM_inv[where P=C for C], rotated -1]

end


header {* \isaheader{Slicing guarantees IFC Noninterference} *}

theory NonInterferenceIntra imports
  "../Slicing/StaticIntra/Slice"
  "../Slicing/Basic/CFGExit_wf"
begin

section {* Assumptions of this Approach *}

text {*
Classical IFC noninterference, a special case of a noninterference
definition using partial equivalence relations (per)
\cite{SabelfeldS:01}, partitions the variables (i.e.\ locations) into
security levels. Usually, only levels for secret or high, written
@{text H}, and public or low, written @{text L}, variables are
used. Basically, a program that is noninterferent has to fulfil one
basic property: executing the program in two different initial states
that may differ in the values of their @{text H}-variables yields two
final states that again only differ in the values of their
@{text H}-variables; thus the values of the @{text H}-variables did not
influence those of the @{text L}-variables.

Every per-based approach makes certain
assumptions: (i) all \mbox{@{text H}-variables} are defined at the
beginning of the program, (ii) all @{text L}-variables are observed (or
used in our terms) at the end and (iii) every variable is either
@{text H} or @{text L}. This security label is fixed for a variable
and can not be altered during a program run. Thus, we have to extend
the prerequisites of the slicing framework in \cite{Wasserrab:08} accordingly
in a new locale:

*}

locale NonInterferenceIntraGraph =
  BackwardSlice sourcenode targetnode kind valid_edge Entry Def Use state_val
  backward_slice +
  CFGExit_wf sourcenode targetnode kind valid_edge Entry Def Use state_val Exit
  for sourcenode :: "'edge \<Rightarrow> 'node" and targetnode :: "'edge \<Rightarrow> 'node"
  and kind :: "'edge \<Rightarrow> 'state edge_kind" and valid_edge :: "'edge \<Rightarrow> bool"
  and Entry :: "'node" ("'('_Entry'_')") and Def :: "'node \<Rightarrow> 'var set"
  and Use :: "'node \<Rightarrow> 'var set" and state_val :: "'state \<Rightarrow> 'var \<Rightarrow> 'val"
  and backward_slice :: "'node set \<Rightarrow> 'node set"
  and Exit :: "'node" ("'('_Exit'_')") +
  fixes H :: "'var set"
  fixes L :: "'var set"
  fixes High :: "'node"  ("'('_High'_')")
  fixes Low :: "'node"   ("'('_Low'_')")
  assumes Entry_edge_Exit_or_High:
  "\<lbrakk>valid_edge a; sourcenode a = (_Entry_)\<rbrakk>
    \<Longrightarrow> targetnode a = (_Exit_) \<or> targetnode a = (_High_)"
  and High_target_Entry_edge:
  "\<exists>a. valid_edge a \<and> sourcenode a = (_Entry_) \<and> targetnode a = (_High_) \<and>
       kind a = (\<lambda>s. True)\<^sub>\<surd>"
  and Entry_predecessor_of_High:
  "\<lbrakk>valid_edge a; targetnode a = (_High_)\<rbrakk> \<Longrightarrow> sourcenode a = (_Entry_)"
  and Exit_edge_Entry_or_Low: "\<lbrakk>valid_edge a; targetnode a = (_Exit_)\<rbrakk>
    \<Longrightarrow> sourcenode a = (_Entry_) \<or> sourcenode a = (_Low_)"
  and Low_source_Exit_edge:
  "\<exists>a. valid_edge a \<and> sourcenode a = (_Low_) \<and> targetnode a = (_Exit_) \<and>
       kind a = (\<lambda>s. True)\<^sub>\<surd>"
  and Exit_successor_of_Low:
  "\<lbrakk>valid_edge a; sourcenode a = (_Low_)\<rbrakk> \<Longrightarrow> targetnode a = (_Exit_)"
  and DefHigh: "Def (_High_) = H"
  and UseHigh: "Use (_High_) = H"
  and UseLow: "Use (_Low_) = L"
  and HighLowDistinct: "H \<inter> L = {}"
  and HighLowUNIV: "H \<union> L = UNIV"

begin

lemma Low_neq_Exit: assumes "L \<noteq> {}" shows "(_Low_) \<noteq> (_Exit_)"
proof
  assume "(_Low_) = (_Exit_)"
  have "Use (_Exit_) = {}" by fastforce
  with UseLow `L \<noteq> {}` `(_Low_) = (_Exit_)` show False by simp
qed

lemma Entry_path_High_path:
  assumes "(_Entry_) -as\<rightarrow>* n" and "inner_node n"
  obtains a' as' where "as = a'#as'" and "(_High_) -as'\<rightarrow>* n"
  and "kind a' = (\<lambda>s. True)\<^sub>\<surd>"
proof(atomize_elim)
  from `(_Entry_) -as\<rightarrow>* n` `inner_node n`
  show "\<exists>a' as'. as = a'#as' \<and> (_High_) -as'\<rightarrow>* n \<and> kind a' = (\<lambda>s. True)\<^sub>\<surd>"
  proof(induct n'\<equiv>"(_Entry_)" as n rule:path.induct)
    case (Cons_path n'' as n' a)
    from `n'' -as\<rightarrow>* n'` `inner_node n'` have "n'' \<noteq> (_Exit_)"
      by(fastforce simp:inner_node_def)
    with `valid_edge a` `targetnode a = n''` `sourcenode a = (_Entry_)`
    have "n'' = (_High_)" by -(drule Entry_edge_Exit_or_High,auto)
    from High_target_Entry_edge
    obtain a' where "valid_edge a'" and "sourcenode a' = (_Entry_)"
      and "targetnode a' = (_High_)" and "kind a' = (\<lambda>s. True)\<^sub>\<surd>"
      by blast
    with `valid_edge a` `sourcenode a = (_Entry_)` `targetnode a = n''`
      `n'' = (_High_)`
    have "a = a'" by(auto dest:edge_det)
    with `n'' -as\<rightarrow>* n'` `n'' = (_High_)` `kind a' = (\<lambda>s. True)\<^sub>\<surd>` show ?case by blast
  qed fastforce
qed

lemma Exit_path_Low_path:
  assumes "n -as\<rightarrow>* (_Exit_)" and "inner_node n"
  obtains a' as' where "as = as'@[a']" and "n -as'\<rightarrow>* (_Low_)"
  and "kind a' = (\<lambda>s. True)\<^sub>\<surd>"
proof(atomize_elim)
  from `n -as\<rightarrow>* (_Exit_)`
  show "\<exists>as' a'. as = as'@[a'] \<and> n -as'\<rightarrow>* (_Low_) \<and> kind a' = (\<lambda>s. True)\<^sub>\<surd>"
  proof(induct as rule:rev_induct)
    case Nil
    with `inner_node n` show ?case by fastforce
  next
    case (snoc a' as')
    from `n -as'@[a']\<rightarrow>* (_Exit_)`
    have "n -as'\<rightarrow>* sourcenode a'" and "valid_edge a'" and "targetnode a' = (_Exit_)"
      by(auto elim:path_split_snoc)
    { assume "sourcenode a' = (_Entry_)"
      with `n -as'\<rightarrow>* sourcenode a'` have "n = (_Entry_)"
        by(blast intro!:path_Entry_target)
      with `inner_node n` have False by(simp add:inner_node_def) }
    with `valid_edge a'` `targetnode a' = (_Exit_)` have "sourcenode a' = (_Low_)"
      by(blast dest!:Exit_edge_Entry_or_Low)
    from Low_source_Exit_edge
    obtain ax where "valid_edge ax" and "sourcenode ax = (_Low_)"
      and "targetnode ax = (_Exit_)" and "kind ax = (\<lambda>s. True)\<^sub>\<surd>"
      by blast
    with `valid_edge a'` `targetnode a' = (_Exit_)` `sourcenode a' = (_Low_)`
    have "a' = ax" by(fastforce intro:edge_det)
    with `n -as'\<rightarrow>* sourcenode a'` `sourcenode a' = (_Low_)` `kind ax = (\<lambda>s. True)\<^sub>\<surd>`
    show ?case by blast
  qed
qed

lemma not_Low_High: "V \<notin> L \<Longrightarrow> V \<in> H"
  using HighLowUNIV
  by fastforce

lemma not_High_Low: "V \<notin> H \<Longrightarrow> V \<in> L"
  using HighLowUNIV
  by fastforce

section {* Low Equivalence *}

text {*
In classical noninterference, an external observer can only see public values,
in our case the @{text L}-variables. If two states agree in the values of all
@{text L}-variables, these states are indistinguishable for him.
\emph{Low equivalence} groups those states in an equivalence class using
the relation @{text "\<approx>\<^sub>L"}:
*}

definition lowEquivalence :: "'state \<Rightarrow> 'state \<Rightarrow> bool" (infixl "\<approx>\<^sub>L" 50)
  where "s \<approx>\<^sub>L s' \<equiv> \<forall>V \<in> L. state_val s V = state_val s' V"

text {* The following lemmas connect low equivalent states with
relevant variables as necessary in the correctness proof for slicing. *}

lemma relevant_vars_Entry:
  assumes "V \<in> rv S (_Entry_)" and "(_High_) \<notin> backward_slice S"
  shows "V \<in> L"
proof -
  from `V \<in> rv S (_Entry_)` obtain as n' where "(_Entry_) -as\<rightarrow>* n'"
    and "n' \<in> backward_slice S" and "V \<in> Use n'"
    and "\<forall>nx \<in> set(sourcenodes as). V \<notin> Def nx" by(erule rvE)
  from `(_Entry_) -as\<rightarrow>* n'` have "valid_node n'" by(rule path_valid_node)
  thus ?thesis
  proof(cases n' rule:valid_node_cases)
    case Entry
    with `V \<in> Use n'` have False by(simp add:Entry_empty)
    thus ?thesis by simp
  next
    case Exit
    with `V \<in> Use n'` have False by(simp add:Exit_empty)
    thus ?thesis by simp
  next
    case inner
    with `(_Entry_) -as\<rightarrow>* n'` obtain a' as' where "as = a'#as'"
      and "(_High_) -as'\<rightarrow>* n'" by -(erule Entry_path_High_path)
    from `(_Entry_) -as\<rightarrow>* n'` `as = a'#as'`
    have "sourcenode a' = (_Entry_)" by(fastforce elim:path.cases)
    show ?thesis
    proof(cases "as' = []")
      case True
      with `(_High_) -as'\<rightarrow>* n'` have "n' = (_High_)" by fastforce
      with `n' \<in> backward_slice S` `(_High_) \<notin> backward_slice S`
      have False by simp
      thus ?thesis by simp
    next
      case False
      with `(_High_) -as'\<rightarrow>* n'` have "hd (sourcenodes as') = (_High_)"
        by(rule path_sourcenode)
      from False have "hd (sourcenodes as') \<in> set (sourcenodes as')"
        by(fastforce intro:hd_in_set simp:sourcenodes_def)
      with `as = a'#as'` have "hd (sourcenodes as') \<in> set (sourcenodes as)"
        by(simp add:sourcenodes_def)
      with `hd (sourcenodes as') = (_High_)` `\<forall>nx \<in> set(sourcenodes as). V \<notin> Def nx`
      have "V \<notin> Def (_High_)" by fastforce
      hence "V \<notin> H" by(simp add:DefHigh)
      thus ?thesis by(rule not_High_Low)
    qed
  qed
qed

lemma lowEquivalence_relevant_nodes_Entry:
  assumes "s \<approx>\<^sub>L s'" and "(_High_) \<notin> backward_slice S"
  shows "\<forall>V \<in> rv S (_Entry_). state_val s V = state_val s' V"
proof
  fix V assume "V \<in> rv S (_Entry_)"
  with `(_High_) \<notin> backward_slice S` have "V \<in> L" by -(rule relevant_vars_Entry)
  with `s \<approx>\<^sub>L s'` show "state_val s V = state_val s' V" by(simp add:lowEquivalence_def)
qed

lemma rv_Low_Use_Low:
  assumes "(_Low_) \<in> S"
  shows "\<lbrakk>n -as\<rightarrow>* (_Low_); n -as'\<rightarrow>* (_Low_);
    \<forall>V \<in> rv S n. state_val s V = state_val s' V;
    preds (slice_kinds S as) s; preds (slice_kinds S as') s'\<rbrakk>
  \<Longrightarrow> \<forall>V \<in> Use (_Low_). state_val (transfers (slice_kinds S as) s) V =
                       state_val (transfers (slice_kinds S as') s') V"
proof(induct n as n\<equiv>"(_Low_)" arbitrary:as' s s' rule:path.induct)
  case empty_path
  { fix V assume "V \<in> Use (_Low_)"
    moreover
    from `valid_node (_Low_)` have "(_Low_) -[]\<rightarrow>* (_Low_)"
      by(fastforce intro:path.empty_path)
    moreover
    from `valid_node (_Low_)` `(_Low_) \<in> S` have "(_Low_) \<in> backward_slice S"
      by(fastforce intro:refl)
    ultimately have "V \<in> rv S (_Low_)"
      by(fastforce intro:rvI simp:sourcenodes_def) }
  hence "\<forall>V \<in> Use (_Low_). V \<in> rv S (_Low_)" by simp
  show ?case
  proof(cases "L = {}")
    case True with UseLow show ?thesis by simp
  next
    case False
    from `(_Low_) -as'\<rightarrow>* (_Low_)` have "as' = []"
    proof(induct n\<equiv>"(_Low_)" as' n'\<equiv>"(_Low_)" rule:path.induct)
      case (Cons_path n'' as a)
      from `valid_edge a` `sourcenode a = (_Low_)`
      have "targetnode a = (_Exit_)" by -(rule Exit_successor_of_Low,simp+)
      with `targetnode a = n''` `n'' -as\<rightarrow>* (_Low_)`
      have "(_Low_) = (_Exit_)" by -(rule path_Exit_source,fastforce)
      with False have False by -(drule Low_neq_Exit,simp)
      thus ?case by simp
    qed simp
    with `\<forall>V \<in> Use (_Low_). V \<in> rv S (_Low_)`
      `\<forall>V\<in>rv S (_Low_). state_val s V = state_val s' V`
    show ?thesis by(auto simp:slice_kinds_def)
  qed
next
  case (Cons_path n'' as a n)
  note IH = `\<And>as' s s'. \<lbrakk>n'' -as'\<rightarrow>* (_Low_);
    \<forall>V\<in>rv S n''. state_val s V = state_val s' V;
   preds (slice_kinds S as) s; preds (slice_kinds S as') s'\<rbrakk>
  \<Longrightarrow> \<forall>V\<in>Use (_Low_). state_val (transfers (slice_kinds S as) s) V =
                     state_val (transfers (slice_kinds S as') s') V`
  show ?case
  proof(cases "L = {}")
    case True with UseLow show ?thesis by simp
  next
    case False
    show ?thesis
    proof(cases as')
      case Nil
      with `n -as'\<rightarrow>* (_Low_)` have "n = (_Low_)" by fastforce
      with `valid_edge a` `sourcenode a = n` have "targetnode a = (_Exit_)"
        by -(rule Exit_successor_of_Low,simp+)
      from Low_source_Exit_edge obtain ax where "valid_edge ax"
        and "sourcenode ax = (_Low_)" and "targetnode ax = (_Exit_)"
        and "kind ax = (\<lambda>s. True)\<^sub>\<surd>" by blast
      from `valid_edge a` `sourcenode a = n` `n = (_Low_)` `targetnode a = (_Exit_)`
        `valid_edge ax` `sourcenode ax = (_Low_)` `targetnode ax = (_Exit_)`
      have "a = ax" by(fastforce dest:edge_det)
      with `kind ax = (\<lambda>s. True)\<^sub>\<surd>` have "kind a = (\<lambda>s. True)\<^sub>\<surd>" by simp
      with `targetnode a = (_Exit_)` `targetnode a = n''` `n'' -as\<rightarrow>* (_Low_)`
      have "(_Low_) = (_Exit_)" by -(rule path_Exit_source,auto)
      with False have False by -(drule Low_neq_Exit,simp)
      thus ?thesis by simp
    next
      case (Cons ax asx)
      with `n -as'\<rightarrow>* (_Low_)` have "n = sourcenode ax" and "valid_edge ax"
        and "targetnode ax -asx\<rightarrow>* (_Low_)" by(auto elim:path_split_Cons)
      show ?thesis
      proof(cases "targetnode ax = n''")
        case True
        with `targetnode ax -asx\<rightarrow>* (_Low_)` have "n'' -asx\<rightarrow>* (_Low_)" by simp
        from `valid_edge ax` `valid_edge a` `n = sourcenode ax` `sourcenode a = n`
          True `targetnode a = n''` have "ax = a" by(fastforce intro:edge_det)
        from `preds (slice_kinds S (a#as)) s`
        have preds1:"preds (slice_kinds S as) (transfer (slice_kind S a) s)"
          by(simp add:slice_kinds_def)
        from `preds (slice_kinds S as') s'` Cons `ax = a`
        have preds2:"preds (slice_kinds S asx)
          (transfer (slice_kind S a) s')"
          by(simp add:slice_kinds_def)
        from `valid_edge a` `sourcenode a = n` `targetnode a = n''`
          `preds (slice_kinds S (a#as)) s` `preds (slice_kinds S as') s'`
          `ax = a` Cons `\<forall>V\<in>rv S n. state_val s V = state_val s' V`
        have "\<forall>V\<in>rv S n''. state_val (transfer (slice_kind S a) s) V =
                                 state_val (transfer (slice_kind S a) s') V"
          by -(rule rv_edge_slice_kinds,auto)
        from IH[OF `n'' -asx\<rightarrow>* (_Low_)` this preds1 preds2]
          Cons `ax = a` show ?thesis by(simp add:slice_kinds_def)
      next
        case False
        with `valid_edge a` `valid_edge ax` `sourcenode a = n` `n = sourcenode ax`
          `targetnode a = n''` `preds (slice_kinds S (a#as)) s`
          `preds (slice_kinds S as') s'` Cons
          `\<forall>V\<in>rv S n. state_val s V = state_val s' V`
        have False by -(rule rv_branching_edges_slice_kinds_False,auto)
        thus ?thesis by simp
      qed
    qed
  qed
qed

section {* The Correctness Proofs *}

text {*
In the following, we present two correctness proofs that slicing guarantees
IFC noninterference. In both theorems,
@{text "(_High_) \<notin> backward_slice S"}, where @{text "(_Low_) \<in> S"},
makes sure that no high variable (which are all defined in @{text "(_High_)"})
can influence a low variable (which are all used in @{text "(_Low_)"}).

First, a theorem regarding
@{text "(_Entry_) -as\<rightarrow>* (_Exit_)"} paths in the control flow graph (CFG),
which agree to a complete program execution: *}

lemma nonInterference_path_to_Low:
  assumes "s \<approx>\<^sub>L s'" and "(_High_) \<notin> backward_slice S" and "(_Low_) \<in> S"
  and "(_Entry_) -as\<rightarrow>* (_Low_)" and "preds (kinds as) s"
  and "(_Entry_) -as'\<rightarrow>* (_Low_)" and "preds (kinds as') s'"
  shows "transfers (kinds as) s \<approx>\<^sub>L transfers (kinds as') s'"
proof -
  from `(_Entry_) -as\<rightarrow>* (_Low_)` `preds (kinds as) s` `(_Low_) \<in> S`
  obtain asx where "preds (slice_kinds S asx) s"
    and "\<forall>V \<in> Use (_Low_). state_val(transfers (slice_kinds S asx) s) V =
                           state_val(transfers (kinds as) s) V"
    and "slice_edges S as = slice_edges S asx"
    and "(_Entry_) -asx\<rightarrow>* (_Low_)" by(erule fundamental_property_of_static_slicing)
  from `(_Entry_) -as'\<rightarrow>* (_Low_)` `preds (kinds as') s'` `(_Low_) \<in> S`
  obtain asx' where "preds (slice_kinds S asx') s'"
    and "\<forall>V \<in> Use (_Low_). state_val (transfers (slice_kinds S asx') s') V =
                           state_val (transfers (kinds as') s') V"
    and "slice_edges S as' = slice_edges S asx'"
    and "(_Entry_) -asx'\<rightarrow>* (_Low_)" by(erule fundamental_property_of_static_slicing)
  from `s \<approx>\<^sub>L s'` `(_High_) \<notin> backward_slice S`
  have "\<forall>V \<in> rv S (_Entry_). state_val s V = state_val s' V"
    by(rule lowEquivalence_relevant_nodes_Entry)
  with `(_Entry_) -asx\<rightarrow>* (_Low_)` `(_Entry_) -asx'\<rightarrow>* (_Low_)` `(_Low_) \<in> S`
    `preds (slice_kinds S asx) s` `preds (slice_kinds S asx') s'`
  have "\<forall>V \<in> Use (_Low_). state_val (transfers (slice_kinds S asx) s) V =
                          state_val (transfers (slice_kinds S asx') s') V"
    by -(rule rv_Low_Use_Low,auto)
  with `\<forall>V \<in> Use (_Low_). state_val(transfers (slice_kinds S asx) s) V =
                          state_val(transfers (kinds as) s) V`
    `\<forall>V \<in> Use (_Low_). state_val (transfers (slice_kinds S asx') s') V =
                       state_val (transfers (kinds as') s') V`
  show ?thesis by(auto simp:lowEquivalence_def UseLow)
qed

theorem nonInterference_path:
  assumes "s \<approx>\<^sub>L s'" and "(_High_) \<notin> backward_slice S" and "(_Low_) \<in> S"
  and "(_Entry_) -as\<rightarrow>* (_Exit_)" and "preds (kinds as) s"
  and "(_Entry_) -as'\<rightarrow>* (_Exit_)" and "preds (kinds as') s'"
  shows "transfers (kinds as) s \<approx>\<^sub>L transfers (kinds as') s'"
proof -
  from `(_Entry_) -as\<rightarrow>* (_Exit_)` obtain x xs where "as = x#xs"
    and "(_Entry_) = sourcenode x" and "valid_edge x"
    and "targetnode x -xs\<rightarrow>* (_Exit_)"
    apply(cases "as = []")
     apply(simp,drule empty_path_nodes,drule Entry_noteq_Exit,simp)
    by(erule path_split_Cons)
  from `valid_edge x` have "valid_node (targetnode x)" by simp
  hence "inner_node (targetnode x)"
  proof(cases rule:valid_node_cases)
    case Entry
    with `valid_edge x` have False by(rule Entry_target)
    thus ?thesis by simp
  next
    case Exit
    with `targetnode x -xs\<rightarrow>* (_Exit_)` have "xs = []"
      by -(rule path_Exit_source,simp)
    from Entry_Exit_edge obtain z where "valid_edge z"
      and "sourcenode z = (_Entry_)" and "targetnode z = (_Exit_)"
      and "kind z = (\<lambda>s. False)\<^sub>\<surd>" by blast
    from `valid_edge x` `valid_edge z` `(_Entry_) = sourcenode x`
      `sourcenode z = (_Entry_)` Exit `targetnode z = (_Exit_)`
    have "x = z" by(fastforce intro:edge_det)
    with `preds (kinds as) s` `as = x#xs` `xs = []` `kind z = (\<lambda>s. False)\<^sub>\<surd>`
    have False by(simp add:kinds_def)
    thus ?thesis by simp
  qed simp
  with `targetnode x -xs\<rightarrow>* (_Exit_)` obtain x' xs' where "xs = xs'@[x']"
    and "targetnode x -xs'\<rightarrow>* (_Low_)" and "kind x' = (\<lambda>s. True)\<^sub>\<surd>"
    by(fastforce elim:Exit_path_Low_path)
  with `(_Entry_) = sourcenode x` `valid_edge x`
  have "(_Entry_) -x#xs'\<rightarrow>* (_Low_)" by(fastforce intro:Cons_path)
  from `as = x#xs` `xs = xs'@[x']` have "as = (x#xs')@[x']" by simp
  with `preds (kinds as) s` have "preds (kinds (x#xs')) s"
    by(simp add:kinds_def preds_split)
  from `(_Entry_) -as'\<rightarrow>* (_Exit_)` obtain y ys where "as' = y#ys"
    and "(_Entry_) = sourcenode y" and "valid_edge y"
    and "targetnode y -ys\<rightarrow>* (_Exit_)"
    apply(cases "as' = []")
     apply(simp,drule empty_path_nodes,drule Entry_noteq_Exit,simp)
    by(erule path_split_Cons)
  from `valid_edge y` have "valid_node (targetnode y)" by simp
  hence "inner_node (targetnode y)"
  proof(cases rule:valid_node_cases)
    case Entry
    with `valid_edge y` have False by(rule Entry_target)
    thus ?thesis by simp
  next
    case Exit
    with `targetnode y -ys\<rightarrow>* (_Exit_)` have "ys = []"
      by -(rule path_Exit_source,simp)
    from Entry_Exit_edge obtain z where "valid_edge z"
      and "sourcenode z = (_Entry_)" and "targetnode z = (_Exit_)"
      and "kind z = (\<lambda>s. False)\<^sub>\<surd>" by blast
    from `valid_edge y` `valid_edge z` `(_Entry_) = sourcenode y`
      `sourcenode z = (_Entry_)` Exit `targetnode z = (_Exit_)`
    have "y = z" by(fastforce intro:edge_det)
    with `preds (kinds as') s'` `as' = y#ys` `ys = []` `kind z = (\<lambda>s. False)\<^sub>\<surd>`
    have False by(simp add:kinds_def)
    thus ?thesis by simp
  qed simp
  with `targetnode y -ys\<rightarrow>* (_Exit_)` obtain y' ys' where "ys = ys'@[y']"
    and "targetnode y -ys'\<rightarrow>* (_Low_)" and "kind y' = (\<lambda>s. True)\<^sub>\<surd>"
    by(fastforce elim:Exit_path_Low_path)
  with `(_Entry_) = sourcenode y` `valid_edge y`
  have "(_Entry_) -y#ys'\<rightarrow>* (_Low_)" by(fastforce intro:Cons_path)
  from `as' = y#ys` `ys = ys'@[y']` have "as' = (y#ys')@[y']" by simp
  with `preds (kinds as') s'` have "preds (kinds (y#ys')) s'"
    by(simp add:kinds_def preds_split)
  from `s \<approx>\<^sub>L s'` `(_High_) \<notin> backward_slice S` `(_Low_) \<in> S`
    `(_Entry_) -x#xs'\<rightarrow>* (_Low_)` `preds (kinds (x#xs')) s`
    `(_Entry_) -y#ys'\<rightarrow>* (_Low_)` `preds (kinds (y#ys')) s'`
  have "transfers (kinds (x#xs')) s \<approx>\<^sub>L transfers (kinds (y#ys')) s'"
    by(rule nonInterference_path_to_Low)
  with `as = x#xs` `xs = xs'@[x']` `kind x' = (\<lambda>s. True)\<^sub>\<surd>`
    `as' = y#ys` `ys = ys'@[y']` `kind y' = (\<lambda>s. True)\<^sub>\<surd>`
  show ?thesis by(simp add:kinds_def transfers_split)
qed

end

text {* The second theorem assumes that we have a operational semantics,
whose evaluations are written @{text "\<langle>c,s\<rangle> \<Rightarrow> \<langle>c',s'\<rangle>"} and which conforms
to the CFG. The correctness theorem then states that if no high variable
influenced a low variable and the initial states were low equivalent, the
reulting states are again low equivalent: *}

locale NonInterferenceIntra =
  NonInterferenceIntraGraph sourcenode targetnode kind valid_edge Entry
    Def Use state_val backward_slice Exit H L High Low +
  BackwardSlice_wf sourcenode targetnode kind valid_edge Entry Def Use state_val
    backward_slice sem identifies
  for sourcenode :: "'edge \<Rightarrow> 'node" and targetnode :: "'edge \<Rightarrow> 'node"
  and kind :: "'edge \<Rightarrow> 'state edge_kind" and valid_edge :: "'edge \<Rightarrow> bool"
  and Entry :: "'node" ("'('_Entry'_')") and Def :: "'node \<Rightarrow> 'var set"
  and Use :: "'node \<Rightarrow> 'var set" and state_val :: "'state \<Rightarrow> 'var \<Rightarrow> 'val"
  and backward_slice :: "'node set \<Rightarrow> 'node set"
  and sem :: "'com \<Rightarrow> 'state \<Rightarrow> 'com \<Rightarrow> 'state \<Rightarrow> bool"
    ("((1\<langle>_,/_\<rangle>) \<Rightarrow>/ (1\<langle>_,/_\<rangle>))" [0,0,0,0] 81)
  and identifies :: "'node \<Rightarrow> 'com \<Rightarrow> bool" ("_ \<triangleq> _" [51, 0] 80)
  and Exit :: "'node" ("'('_Exit'_')")
  and H :: "'var set" and L :: "'var set"
  and High :: "'node"  ("'('_High'_')") and Low :: "'node"   ("'('_Low'_')") +
  fixes final :: "'com \<Rightarrow> bool"
  assumes final_edge_Low: "\<lbrakk>final c; n \<triangleq> c\<rbrakk>
  \<Longrightarrow> \<exists>a. valid_edge a \<and> sourcenode a = n \<and> targetnode a = (_Low_) \<and> kind a = \<Up>id"
begin

text{* The following theorem needs the explicit edge from @{text "(_High_)"}
  to @{text n}. An approach using a @{text "init"} predicate for initial statements,
  being reachable from @{text "(_High_)"} via a @{text "(\<lambda>s. True)\<^sub>\<surd>"} edge,
  does not work as the same statement could be identified by several nodes, some
  initial, some not. E.g., in the program \texttt{while (True) Skip;;Skip}
  two nodes identify this inital statement: the initial node and the node
  within the loop (because of loop unrolling).*}

theorem nonInterference:
  assumes "s\<^sub>1 \<approx>\<^sub>L s\<^sub>2" and "(_High_) \<notin> backward_slice S" and "(_Low_) \<in> S"
  and "valid_edge a" and "sourcenode a = (_High_)" and "targetnode a = n"
  and "kind a = (\<lambda>s. True)\<^sub>\<surd>" and "n \<triangleq> c" and "final c'"
  and "\<langle>c,s\<^sub>1\<rangle> \<Rightarrow> \<langle>c',s\<^sub>1'\<rangle>" and "\<langle>c,s\<^sub>2\<rangle> \<Rightarrow> \<langle>c',s\<^sub>2'\<rangle>"
  shows "s\<^sub>1' \<approx>\<^sub>L s\<^sub>2'"
proof -
  from High_target_Entry_edge obtain ax where "valid_edge ax"
    and "sourcenode ax = (_Entry_)" and "targetnode ax = (_High_)"
    and "kind ax = (\<lambda>s. True)\<^sub>\<surd>" by blast
  from `n \<triangleq> c` `\<langle>c,s\<^sub>1\<rangle> \<Rightarrow> \<langle>c',s\<^sub>1'\<rangle>`
  obtain n\<^sub>1 as\<^sub>1 where "n -as\<^sub>1\<rightarrow>* n\<^sub>1" and "transfers (kinds as\<^sub>1) s\<^sub>1 = s\<^sub>1'"
    and "preds (kinds as\<^sub>1) s\<^sub>1" and "n\<^sub>1 \<triangleq> c'"
    by(fastforce dest:fundamental_property)
  from `n -as\<^sub>1\<rightarrow>* n\<^sub>1` `valid_edge a` `sourcenode a = (_High_)` `targetnode a = n`
  have "(_High_) -a#as\<^sub>1\<rightarrow>* n\<^sub>1" by(rule Cons_path)
  from `final c'` `n\<^sub>1 \<triangleq> c'`
  obtain a\<^sub>1 where "valid_edge a\<^sub>1" and "sourcenode a\<^sub>1 = n\<^sub>1"
    and "targetnode a\<^sub>1 = (_Low_)" and "kind a\<^sub>1 = \<Up>id" by(fastforce dest:final_edge_Low)
  hence "n\<^sub>1 -[a\<^sub>1]\<rightarrow>* (_Low_)" by(fastforce intro:path_edge)
  with `(_High_) -a#as\<^sub>1\<rightarrow>* n\<^sub>1` have "(_High_) -(a#as\<^sub>1)@[a\<^sub>1]\<rightarrow>* (_Low_)"
    by(rule path_Append)
  with `valid_edge ax` `sourcenode ax = (_Entry_)` `targetnode ax = (_High_)`
  have "(_Entry_) -ax#((a#as\<^sub>1)@[a\<^sub>1])\<rightarrow>* (_Low_)" by -(rule Cons_path)
  from `kind ax = (\<lambda>s. True)\<^sub>\<surd>` `kind a = (\<lambda>s. True)\<^sub>\<surd>` `preds (kinds as\<^sub>1) s\<^sub>1`
    `kind a\<^sub>1 = \<Up>id` have "preds (kinds (ax#((a#as\<^sub>1)@[a\<^sub>1]))) s\<^sub>1"
    by (simp add:kinds_def preds_split)
  from `n \<triangleq> c` `\<langle>c,s\<^sub>2\<rangle> \<Rightarrow> \<langle>c',s\<^sub>2'\<rangle>`
  obtain n\<^sub>2 as\<^sub>2 where "n -as\<^sub>2\<rightarrow>* n\<^sub>2" and "transfers (kinds as\<^sub>2) s\<^sub>2 = s\<^sub>2'"
    and "preds (kinds as\<^sub>2) s\<^sub>2" and "n\<^sub>2 \<triangleq> c'"
    by(fastforce dest:fundamental_property)
  from `n -as\<^sub>2\<rightarrow>* n\<^sub>2` `valid_edge a` `sourcenode a = (_High_)` `targetnode a = n`
  have "(_High_) -a#as\<^sub>2\<rightarrow>* n\<^sub>2" by(rule Cons_path)
  from `final c'` `n\<^sub>2 \<triangleq> c'`
  obtain a\<^sub>2 where "valid_edge a\<^sub>2" and "sourcenode a\<^sub>2 = n\<^sub>2"
    and "targetnode a\<^sub>2 = (_Low_)" and "kind a\<^sub>2 = \<Up>id" by(fastforce dest:final_edge_Low)
  hence "n\<^sub>2 -[a\<^sub>2]\<rightarrow>* (_Low_)" by(fastforce intro:path_edge)
  with `(_High_) -a#as\<^sub>2\<rightarrow>* n\<^sub>2` have "(_High_) -(a#as\<^sub>2)@[a\<^sub>2]\<rightarrow>* (_Low_)"
    by(rule path_Append)
  with `valid_edge ax` `sourcenode ax = (_Entry_)` `targetnode ax = (_High_)`
  have "(_Entry_) -ax#((a#as\<^sub>2)@[a\<^sub>2])\<rightarrow>* (_Low_)" by -(rule Cons_path)
  from `kind ax = (\<lambda>s. True)\<^sub>\<surd>` `kind a = (\<lambda>s. True)\<^sub>\<surd>` `preds (kinds as\<^sub>2) s\<^sub>2`
    `kind a\<^sub>2 = \<Up>id` have "preds (kinds (ax#((a#as\<^sub>2)@[a\<^sub>2]))) s\<^sub>2"
    by (simp add:kinds_def preds_split)
  from `s\<^sub>1 \<approx>\<^sub>L s\<^sub>2` `(_High_) \<notin> backward_slice S` `(_Low_) \<in> S`
    `(_Entry_) -ax#((a#as\<^sub>1)@[a\<^sub>1])\<rightarrow>* (_Low_)` `preds (kinds (ax#((a#as\<^sub>1)@[a\<^sub>1]))) s\<^sub>1`
    `(_Entry_) -ax#((a#as\<^sub>2)@[a\<^sub>2])\<rightarrow>* (_Low_)` `preds (kinds (ax#((a#as\<^sub>2)@[a\<^sub>2]))) s\<^sub>2`
  have "transfers (kinds (ax#((a#as\<^sub>1)@[a\<^sub>1]))) s\<^sub>1 \<approx>\<^sub>L
        transfers (kinds (ax#((a#as\<^sub>2)@[a\<^sub>2]))) s\<^sub>2"
    by(rule nonInterference_path_to_Low)
  with `kind ax = (\<lambda>s. True)\<^sub>\<surd>` `kind a = (\<lambda>s. True)\<^sub>\<surd>` `kind a\<^sub>1 = \<Up>id` `kind a\<^sub>2 = \<Up>id`
    `transfers (kinds as\<^sub>1) s\<^sub>1 = s\<^sub>1'` `transfers (kinds as\<^sub>2) s\<^sub>2 = s\<^sub>2'`
  show ?thesis by(simp add:kinds_def transfers_split)
qed

end

end


(*  Title:      HOL/HOLCF/IOA/RefMappings.thy
    Author:     Olaf Müller
*)

section \<open>Refinement Mappings in HOLCF/IOA\<close>

theory RefMappings
imports Traces
begin

default_sort type

definition move :: "('a, 's) ioa \<Rightarrow> ('a, 's) pairs \<Rightarrow> 's \<Rightarrow> 'a \<Rightarrow> 's \<Rightarrow> bool"
  where "move ioa ex s a t \<longleftrightarrow>
    is_exec_frag ioa (s, ex) \<and> Finite ex \<and>
    laststate (s, ex) = t \<and>
    mk_trace ioa \<cdot> ex = (if a \<in> ext ioa then a \<leadsto> nil else nil)"

definition is_ref_map :: "('s1 \<Rightarrow> 's2) \<Rightarrow> ('a, 's1) ioa \<Rightarrow> ('a, 's2) ioa \<Rightarrow> bool"
  where "is_ref_map f C A \<longleftrightarrow>
   ((\<forall>s \<in> starts_of C. f s \<in> starts_of A) \<and>
     (\<forall>s t a. reachable C s \<and> s \<midarrow>a\<midarrow>C\<rightarrow> t \<longrightarrow> (\<exists>ex. move A ex (f s) a (f t))))"

definition is_weak_ref_map :: "('s1 \<Rightarrow> 's2) \<Rightarrow> ('a, 's1) ioa \<Rightarrow> ('a, 's2) ioa \<Rightarrow> bool"
  where "is_weak_ref_map f C A \<longleftrightarrow>
    ((\<forall>s \<in> starts_of C. f s \<in> starts_of A) \<and>
      (\<forall>s t a. reachable C s \<and> s \<midarrow>a\<midarrow>C\<rightarrow> t \<longrightarrow>
        (if a \<in> ext C then (f s) \<midarrow>a\<midarrow>A\<rightarrow> (f t) else f s = f t)))"

subsection \<open>Transitions and moves\<close>

lemma transition_is_ex: "s \<midarrow>a\<midarrow>A\<rightarrow> t \<Longrightarrow> \<exists>ex. move A ex s a t"
  apply (rule_tac x = " (a, t) \<leadsto> nil" in exI)
  apply (simp add: move_def)
  done

lemma nothing_is_ex: "a \<notin> ext A \<and> s = t \<Longrightarrow> \<exists>ex. move A ex s a t"
  apply (rule_tac x = "nil" in exI)
  apply (simp add: move_def)
  done

lemma ei_transitions_are_ex:
  "s \<midarrow>a\<midarrow>A\<rightarrow> s' \<and> s' \<midarrow>a'\<midarrow>A\<rightarrow> s'' \<and> a' \<notin> ext A \<Longrightarrow> \<exists>ex. move A ex s a s''"
  apply (rule_tac x = " (a,s') \<leadsto> (a',s'') \<leadsto>nil" in exI)
  apply (simp add: move_def)
  done

lemma eii_transitions_are_ex:
  "s1 \<midarrow>a1\<midarrow>A\<rightarrow> s2 \<and> s2 \<midarrow>a2\<midarrow>A\<rightarrow> s3 \<and> s3 \<midarrow>a3\<midarrow>A\<rightarrow> s4 \<and> a2 \<notin> ext A \<and> a3 \<notin> ext A \<Longrightarrow>
    \<exists>ex. move A ex s1 a1 s4"
  apply (rule_tac x = "(a1, s2) \<leadsto> (a2, s3) \<leadsto> (a3, s4) \<leadsto> nil" in exI)
  apply (simp add: move_def)
  done

subsection \<open>\<open>weak_ref_map\<close> and \<open>ref_map\<close>\<close>

lemma weak_ref_map2ref_map: "ext C = ext A \<Longrightarrow> is_weak_ref_map f C A \<Longrightarrow> is_ref_map f C A"
  apply (unfold is_weak_ref_map_def is_ref_map_def)
  apply auto
  apply (case_tac "a \<in> ext A")
  apply (auto intro: transition_is_ex nothing_is_ex)
  done

lemma imp_conj_lemma: "(P \<Longrightarrow> Q \<longrightarrow> R) \<Longrightarrow> P \<and> Q \<longrightarrow> R"
  by blast

declare if_split [split del]
declare if_weak_cong [cong del]

lemma rename_through_pmap:
  "is_weak_ref_map f C A \<Longrightarrow> is_weak_ref_map f (rename C g) (rename A g)"
  apply (simp add: is_weak_ref_map_def)
  apply (rule conjI)
  text \<open>1: start states\<close>
  apply (simp add: rename_def rename_set_def starts_of_def)
  text \<open>1: start states\<close>
  apply (rule allI)+
  apply (rule imp_conj_lemma)
  apply (simp (no_asm) add: rename_def rename_set_def)
  apply (simp add: externals_def asig_inputs_def asig_outputs_def asig_of_def trans_of_def)
  apply safe
  apply (simplesubst if_split)
   apply (rule conjI)
   apply (rule impI)
   apply (erule disjE)
   apply (erule exE)
  apply (erule conjE)
  text \<open>\<open>x\<close> is input\<close>
   apply (drule sym)
   apply (drule sym)
  apply simp
  apply hypsubst+
  apply (frule reachable_rename)
  apply simp
  text \<open>\<open>x\<close> is output\<close>
   apply (erule exE)
  apply (erule conjE)
   apply (drule sym)
   apply (drule sym)
  apply simp
  apply hypsubst+
  apply (frule reachable_rename)
  apply simp
  text \<open>\<open>x\<close> is internal\<close>
  apply (frule reachable_rename)
  apply auto
  done

declare if_split [split]
declare if_weak_cong [cong]

end


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

theory ExtraSpecs

imports
  "CLib.TypHeapLib"

begin

definition
  "simple_simpl_refines \<Gamma> com com'
    = (\<forall>s. (\<exists>ft. \<Gamma> \<turnstile> \<langle>com', Normal s\<rangle> \<Rightarrow> Fault ft)
        \<or> ((\<forall>xs. \<Gamma> \<turnstile> \<langle>com, Normal s\<rangle> \<Rightarrow> xs \<longrightarrow> \<Gamma> \<turnstile> \<langle>com', Normal s\<rangle> \<Rightarrow> xs)
            \<and> (\<not> terminates \<Gamma> com (Normal s) \<longrightarrow> \<not> terminates \<Gamma> com' (Normal s))))"

lemma simple_simpl_refines_no_fault_execD:
  "\<Gamma> \<turnstile> \<langle>com,Normal s\<rangle> \<Rightarrow> xs
    \<Longrightarrow> simple_simpl_refines \<Gamma> com com'
    \<Longrightarrow> (\<forall>ft. \<not> \<Gamma> \<turnstile> \<langle>com',Normal s\<rangle> \<Rightarrow> Fault ft)
    \<Longrightarrow> \<Gamma> \<turnstile> \<langle>com', Normal s\<rangle> \<Rightarrow> xs"
  by (auto simp add: simple_simpl_refines_def)

lemma simple_simpl_refines_no_fault_terminatesD:
  "simple_simpl_refines \<Gamma> com com'
    \<Longrightarrow> (\<forall>ft. \<not> \<Gamma> \<turnstile> \<langle>com',Normal s\<rangle> \<Rightarrow> Fault ft)
    \<Longrightarrow> \<not> terminates \<Gamma> com (Normal s) \<longrightarrow> \<not> terminates \<Gamma> com' (Normal s)"
  by (auto simp add: simple_simpl_refines_def)

lemma simple_simpl_refines_refl:
  "simple_simpl_refines \<Gamma> com com"
  by (auto simp add: simple_simpl_refines_def)

lemma simple_simpl_refines_from_def_eq:
  "body \<equiv> body' \<Longrightarrow> simple_simpl_refines \<Gamma> body' body"
  (* these are flipped, because the "implementation" is on the rhs of
     definitional equalities, but the lhs of refinement thms. *)
  by (simp add: simple_simpl_refines_def)

lemma simple_simpl_refines_trans:
  "simple_simpl_refines \<Gamma> com com' \<Longrightarrow> simple_simpl_refines \<Gamma> com' com''
    \<Longrightarrow> simple_simpl_refines \<Gamma> com com''"
  by (simp add: simple_simpl_refines_def, metis)

lemma simple_simpl_refines_drop_Guard:
  "simple_simpl_refines \<Gamma> com (Guard F G com)"
  apply (clarsimp simp add: simple_simpl_refines_def)
  apply (case_tac "s \<in> G")
  apply (auto intro: exec.Guard exec.GuardFault
              elim!: terminates_Normal_elim_cases)
  done

lemma simple_simpl_refines_guarded_Basic_guarded_spec_body:
  "(\<forall>s s'. (s, s') \<in> R \<longrightarrow> (s \<in> G \<and> (s, f s) \<in> R))
    \<Longrightarrow> simple_simpl_refines \<Gamma> (Guard F' G (Basic f)) (guarded_spec_body F R)"
  apply (simp add: guarded_spec_body_def simple_simpl_refines_def)
  apply (intro allI, drule_tac x=s in spec)
  apply (erule impCE)
   apply (rule disjI1)
   apply (fastforce intro: exec.GuardFault)
  apply (rule disjI2)
  apply (auto intro!: exec.Guard terminates.Guard
               intro: exec.GuardFault exec.Spec terminates.Basic image_eqI[rotated]
              elim!: exec_Normal_elim_cases terminates_Normal_elim_cases)
  done

lemmas simple_simpl_refines_Basic_guarded_spec_body
    = simple_simpl_refines_trans[OF
        simple_simpl_refines_drop_Guard[where G=UNIV]
        simple_simpl_refines_guarded_Basic_guarded_spec_body
        ]

ML \<open>
structure Get_Body_Refines = struct

fun get ctxt name = let
    fun pget sfx = try (Proof_Context.get_thm ctxt o suffix sfx) name
    val eqv = pget "_body_refines"
    val def = pget "_body_def"
  in case (eqv, def) of
      (SOME eqvt, _) => eqvt
    | (_, SOME deft) => (deft RS @{thm simple_simpl_refines_from_def_eq})
    | _ => raise THM ("Get_Body_Refines.get: "
          ^ "no body_def or body_refines: " ^ name, 1, [])
  end

end
\<close>

end