(*
    Author:      Norbert Schirmer
    Maintainer:  Norbert Schirmer, norbert.schirmer at web de
    License:     LGPL
*)

(*  Title:      HoarePartial.thy
    Author:     Norbert Schirmer, TU Muenchen

Copyright (C) 2004-2008 Norbert Schirmer
Some rights reserved, TU Muenchen

This library is free software; you can redistribute it and/or modify
it under the terms of the GNU Lesser General Public License as
published by the Free Software Foundation; either version 2.1 of the
License, or (at your option) any later version.

This library is distributed in the hope that it will be useful, but
WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
Lesser General Public License for more details.

You should have received a copy of the GNU Lesser General Public
License along with this library; if not, write to the Free Software
Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307
USA
*)

header {* Derived Hoare Rules for Partial Correctness *}

theory HoarePartial imports HoarePartialProps begin

lemma conseq_no_aux:
  "\<lbrakk>\<Gamma>,\<Theta>\<turnstile>\<^bsub>/F\<^esub> P' c Q',A';
    \<forall>s. s \<in> P \<longrightarrow> (s\<in>P' \<and> (Q' \<subseteq> Q) \<and> (A' \<subseteq> A))\<rbrakk>
  \<Longrightarrow>
  \<Gamma>,\<Theta>\<turnstile>\<^bsub>/F\<^esub> P c Q,A"
  by (rule conseq [where P'="\<lambda>Z. P'" and Q'="\<lambda>Z. Q'" and A'="\<lambda>Z. A'"]) auto

lemma conseq_exploit_pre:
             "\<lbrakk>\<forall>s \<in> P. \<Gamma>,\<Theta>\<turnstile>\<^bsub>/F\<^esub> ({s} \<inter> P) c Q,A\<rbrakk>
              \<Longrightarrow>
              \<Gamma>,\<Theta>\<turnstile>\<^bsub>/F\<^esub> P c Q,A"
  apply (rule Conseq)
  apply clarify
  apply (rule_tac x="{s} \<inter> P" in exI)
  apply (rule_tac x="Q" in exI)
  apply (rule_tac x="A" in exI)
  by simp

lemma conseq:"\<lbrakk>\<forall>Z. \<Gamma>,\<Theta>\<turnstile>\<^bsub>/F\<^esub> (P' Z) c (Q' Z),(A' Z);
              \<forall>s. s \<in> P \<longrightarrow> (\<exists> Z. s\<in>P' Z \<and> (Q' Z \<subseteq> Q) \<and> (A' Z \<subseteq> A))\<rbrakk>
              \<Longrightarrow>
              \<Gamma>,\<Theta>\<turnstile>\<^bsub>/F\<^esub> P c Q,A"
  by (rule Conseq') blast

lemma Lem: "\<lbrakk>\<forall>Z. \<Gamma>,\<Theta>\<turnstile>\<^bsub>/F\<^esub> (P' Z) c (Q' Z),(A' Z);
             P \<subseteq> {s. \<exists> Z. s\<in>P' Z \<and> (Q' Z \<subseteq> Q) \<and> (A' Z \<subseteq> A)}\<rbrakk>
             \<Longrightarrow>
             \<Gamma>,\<Theta>\<turnstile>\<^bsub>/F\<^esub> P (lem x c) Q,A"
  apply (unfold lem_def)
  apply (erule conseq)
  apply blast
  done

lemma LemAnno:
assumes conseq:  "P \<subseteq> {s. \<exists>Z. s\<in>P' Z \<and>
                     (\<forall>t. t \<in> Q' Z \<longrightarrow> t \<in> Q) \<and> (\<forall>t. t \<in> A' Z \<longrightarrow> t \<in> A)}"
assumes lem: "\<forall>Z. \<Gamma>,\<Theta>\<turnstile>\<^bsub>/F\<^esub> (P' Z) c (Q' Z),(A' Z)"
shows "\<Gamma>,\<Theta>\<turnstile>\<^bsub>/F\<^esub> P (lem x c) Q,A"
  apply (rule Lem [OF lem])
  using conseq
  by blast

lemma LemAnnoNoAbrupt:
assumes conseq:  "P \<subseteq>  {s. \<exists>Z. s\<in>P' Z \<and> (\<forall>t. t \<in> Q' Z \<longrightarrow> t \<in> Q)}"
assumes lem: "\<forall>Z. \<Gamma>,\<Theta>\<turnstile>\<^bsub>/F\<^esub> (P' Z) c (Q' Z),{}"
shows "\<Gamma>,\<Theta>\<turnstile>\<^bsub>/F\<^esub> P (lem x c) Q,{}"
  apply (rule Lem [OF lem])
  using conseq
  by blast

lemma TrivPost: "\<forall>Z. \<Gamma>,\<Theta>\<turnstile>\<^bsub>/F\<^esub> (P' Z) c (Q' Z),(A' Z)
                 \<Longrightarrow>
                 \<forall>Z. \<Gamma>,\<Theta>\<turnstile>\<^bsub>/F\<^esub> (P' Z) c UNIV,UNIV"
apply (rule allI)
apply (erule conseq)
apply auto
done

lemma TrivPostNoAbr: "\<forall>Z. \<Gamma>,\<Theta>\<turnstile>\<^bsub>/F\<^esub> (P' Z) c (Q' Z),{}
                 \<Longrightarrow>
                 \<forall>Z. \<Gamma>,\<Theta>\<turnstile>\<^bsub>/F\<^esub> (P' Z) c UNIV,{}"
apply (rule allI)
apply (erule conseq)
apply auto
done

lemma conseq_under_new_pre:"\<lbrakk>\<Gamma>,\<Theta>\<turnstile>\<^bsub>/F \<^esub>P' c Q',A';
        \<forall>s \<in> P. s \<in> P' \<and> Q' \<subseteq> Q \<and> A' \<subseteq> A\<rbrakk>
\<Longrightarrow> \<Gamma>,\<Theta>\<turnstile>\<^bsub>/F \<^esub>P c Q,A"
apply (rule conseq)
apply (rule allI)
apply assumption
apply auto
done

lemma DynComConseq:
  assumes "P \<subseteq> {s. \<exists>P' Q' A'.  \<Gamma>,\<Theta>\<turnstile>\<^bsub>/F \<^esub>P' (c s) Q',A' \<and> P \<subseteq> P' \<and> Q' \<subseteq> Q \<and> A' \<subseteq> A}"
  shows "\<Gamma>,\<Theta>\<turnstile>\<^bsub>/F \<^esub>P DynCom c Q,A"
  using assms
  apply -
  apply (rule DynCom)
  apply clarsimp
  apply (rule Conseq)
  apply clarsimp
  apply blast
  done

lemma SpecAnno:
 assumes consequence: "P \<subseteq> {s. (\<exists> Z. s\<in>P' Z \<and> (Q' Z \<subseteq> Q) \<and> (A' Z \<subseteq> A))}"
 assumes spec: "\<forall>Z. \<Gamma>,\<Theta>\<turnstile>\<^bsub>/F\<^esub> (P' Z) (c Z) (Q' Z),(A' Z)"
 assumes bdy_constant:  "\<forall>Z. c Z = c undefined"
 shows   "\<Gamma>,\<Theta>\<turnstile>\<^bsub>/F\<^esub> P (specAnno P' c Q' A') Q,A"
proof -
  from spec bdy_constant
  have "\<forall>Z. \<Gamma>,\<Theta>\<turnstile>\<^bsub>/F\<^esub> ((P' Z)) (c undefined) (Q' Z),(A' Z)"
    apply -
    apply (rule allI)
    apply (erule_tac x=Z in allE)
    apply (erule_tac x=Z in allE)
    apply simp
    done
  with consequence show ?thesis
    apply (simp add: specAnno_def)
    apply (erule conseq)
    apply blast
    done
qed

lemma SpecAnno':
 "\<lbrakk>P \<subseteq> {s.  \<exists> Z. s\<in>P' Z \<and>
            (\<forall>t. t \<in> Q' Z \<longrightarrow>  t \<in> Q) \<and> (\<forall>t. t \<in> A' Z \<longrightarrow> t \<in>  A)};
   \<forall>Z. \<Gamma>,\<Theta>\<turnstile>\<^bsub>/F\<^esub> (P' Z) (c Z) (Q' Z),(A' Z);
   \<forall>Z. c Z = c undefined
  \<rbrakk> \<Longrightarrow>
    \<Gamma>,\<Theta>\<turnstile>\<^bsub>/F\<^esub> P (specAnno P' c Q' A') Q,A"
apply (simp only: subset_iff [THEN sym])
apply (erule (1) SpecAnno)
apply assumption
done

lemma SpecAnnoNoAbrupt:
 "\<lbrakk>P \<subseteq> {s.  \<exists> Z. s\<in>P' Z \<and>
            (\<forall>t. t \<in> Q' Z \<longrightarrow>  t \<in> Q)};
   \<forall>Z. \<Gamma>,\<Theta>\<turnstile>\<^bsub>/F\<^esub> (P' Z) (c Z) (Q' Z),{};
   \<forall>Z. c Z = c undefined
  \<rbrakk> \<Longrightarrow>
    \<Gamma>,\<Theta>\<turnstile>\<^bsub>/F\<^esub> P (specAnno P' c Q' (\<lambda>s. {})) Q,A"
apply (rule SpecAnno')
apply auto
done

lemma Skip: "P \<subseteq> Q \<Longrightarrow> \<Gamma>,\<Theta>\<turnstile>\<^bsub>/F\<^esub> P Skip Q,A"
  by (rule hoarep.Skip [THEN conseqPre],simp)

lemma Basic: "P \<subseteq> {s. (f s) \<in> Q} \<Longrightarrow>  \<Gamma>,\<Theta>\<turnstile>\<^bsub>/F\<^esub> P (Basic f) Q,A"
  by (rule hoarep.Basic [THEN conseqPre])

lemma BasicCond:
  "\<lbrakk>P \<subseteq> {s. (b s \<longrightarrow> f s\<in>Q) \<and> (\<not> b s \<longrightarrow> g s\<in>Q)}\<rbrakk> \<Longrightarrow>
   \<Gamma>,\<Theta>\<turnstile>\<^bsub>/F\<^esub> P Basic (\<lambda>s. if b s then f s else g s) Q,A"
  apply (rule Basic)
  apply auto
  done

lemma Spec: "P \<subseteq> {s. (\<forall>t. (s,t) \<in> r \<longrightarrow> t \<in> Q) \<and> (\<exists>t. (s,t) \<in> r)}
            \<Longrightarrow> \<Gamma>,\<Theta>\<turnstile>\<^bsub>/F\<^esub> P (Spec r) Q,A"
by (rule hoarep.Spec [THEN conseqPre])

lemma SpecIf:
  "\<lbrakk>P \<subseteq> {s. (b s \<longrightarrow> f s \<in> Q) \<and> (\<not> b s \<longrightarrow> g s \<in> Q \<and> h s \<in> Q)}\<rbrakk> \<Longrightarrow>
   \<Gamma>,\<Theta>\<turnstile>\<^bsub>/F\<^esub> P Spec (if_rel b f g h) Q,A"
  apply (rule Spec)
  apply (auto simp add: if_rel_def)
  done

lemma Seq [trans, intro?]:
  "\<lbrakk>\<Gamma>,\<Theta>\<turnstile>\<^bsub>/F\<^esub> P c\<^sub>1 R,A; \<Gamma>,\<Theta>\<turnstile>\<^bsub>/F\<^esub> R c\<^sub>2 Q,A\<rbrakk> \<Longrightarrow> \<Gamma>,\<Theta>\<turnstile>\<^bsub>/F\<^esub> P (Seq c\<^sub>1 c\<^sub>2) Q,A"
  by (rule hoarep.Seq)

lemma SeqSwap:
  "\<lbrakk>\<Gamma>,\<Theta>\<turnstile>\<^bsub>/F\<^esub> R c2 Q,A; \<Gamma>,\<Theta>\<turnstile>\<^bsub>/F\<^esub> P c1 R,A\<rbrakk> \<Longrightarrow> \<Gamma>,\<Theta>\<turnstile>\<^bsub>/F\<^esub> P (Seq c1 c2) Q,A"
  by (rule Seq)

lemma BSeq:
  "\<lbrakk>\<Gamma>,\<Theta>\<turnstile>\<^bsub>/F\<^esub> P c\<^sub>1 R,A; \<Gamma>,\<Theta>\<turnstile>\<^bsub>/F\<^esub> R c\<^sub>2 Q,A\<rbrakk> \<Longrightarrow> \<Gamma>,\<Theta>\<turnstile>\<^bsub>/F\<^esub> P (bseq c\<^sub>1 c\<^sub>2) Q,A"
  by (unfold bseq_def) (rule Seq)

lemma Cond:
  assumes wp: "P \<subseteq> {s. (s\<in>b \<longrightarrow> s\<in>P\<^sub>1) \<and> (s\<notin>b \<longrightarrow> s\<in>P\<^sub>2)}"
  assumes deriv_c1: "\<Gamma>,\<Theta>\<turnstile>\<^bsub>/F\<^esub> P\<^sub>1 c\<^sub>1 Q,A"
  assumes deriv_c2: "\<Gamma>,\<Theta>\<turnstile>\<^bsub>/F\<^esub> P\<^sub>2 c\<^sub>2 Q,A"
  shows "\<Gamma>,\<Theta>\<turnstile>\<^bsub>/F\<^esub> P (Cond b c\<^sub>1 c\<^sub>2) Q,A"
proof (rule hoarep.Cond [THEN conseqPre])
  from deriv_c1
  show "\<Gamma>,\<Theta>\<turnstile>\<^bsub>/F\<^esub> ({s. (s \<in> b \<longrightarrow> s \<in> P\<^sub>1) \<and> (s \<notin> b \<longrightarrow> s \<in> P\<^sub>2)} \<inter> b) c\<^sub>1 Q,A"
    by (rule conseqPre) blast
next
  from deriv_c2
  show "\<Gamma>,\<Theta>\<turnstile>\<^bsub>/F\<^esub> ({s. (s \<in> b \<longrightarrow> s \<in> P\<^sub>1) \<and> (s \<notin> b \<longrightarrow> s \<in> P\<^sub>2)} \<inter> - b) c\<^sub>2 Q,A"
    by (rule conseqPre) blast
next
  show "P \<subseteq> {s. (s\<in>b \<longrightarrow> s\<in>P\<^sub>1) \<and> (s\<notin>b \<longrightarrow> s\<in>P\<^sub>2)}" by (rule wp)
qed

lemma CondSwap:
  "\<lbrakk>\<Gamma>,\<Theta>\<turnstile>\<^bsub>/F\<^esub> P1 c1 Q,A; \<Gamma>,\<Theta>\<turnstile>\<^bsub>/F\<^esub> P2 c2 Q,A; P \<subseteq> {s. (s\<in>b \<longrightarrow> s\<in>P1) \<and> (s\<notin>b \<longrightarrow> s\<in>P2)}\<rbrakk>
   \<Longrightarrow>
   \<Gamma>,\<Theta>\<turnstile>\<^bsub>/F\<^esub> P (Cond b c1 c2) Q,A"
  by (rule Cond)

lemma Cond':
  "\<lbrakk>P \<subseteq> {s. (b \<subseteq> P1) \<and> (- b \<subseteq> P2)};\<Gamma>,\<Theta>\<turnstile>\<^bsub>/F\<^esub> P1 c1 Q,A; \<Gamma>,\<Theta>\<turnstile>\<^bsub>/F\<^esub> P2 c2 Q,A\<rbrakk>
   \<Longrightarrow>
   \<Gamma>,\<Theta>\<turnstile>\<^bsub>/F\<^esub> P (Cond b c1 c2) Q,A"
  by (rule CondSwap) blast+

lemma CondInv:
  assumes wp: "P \<subseteq> Q"
  assumes inv: "Q \<subseteq> {s. (s\<in>b \<longrightarrow> s\<in>P\<^sub>1) \<and> (s\<notin>b \<longrightarrow> s\<in>P\<^sub>2)}"
  assumes deriv_c1: "\<Gamma>,\<Theta>\<turnstile>\<^bsub>/F\<^esub> P\<^sub>1 c\<^sub>1 Q,A"
  assumes deriv_c2: "\<Gamma>,\<Theta>\<turnstile>\<^bsub>/F\<^esub> P\<^sub>2 c\<^sub>2 Q,A"
  shows "\<Gamma>,\<Theta>\<turnstile>\<^bsub>/F\<^esub> P (Cond b c\<^sub>1 c\<^sub>2) Q,A"
proof -
  from wp inv
  have "P \<subseteq> {s. (s\<in>b \<longrightarrow> s\<in>P\<^sub>1) \<and> (s\<notin>b \<longrightarrow> s\<in>P\<^sub>2)}"
    by blast
  from Cond [OF this deriv_c1 deriv_c2]
  show ?thesis .
qed

lemma CondInv':
  assumes wp: "P \<subseteq> I"
  assumes inv: "I \<subseteq> {s. (s\<in>b \<longrightarrow> s\<in>P\<^sub>1) \<and> (s\<notin>b \<longrightarrow> s\<in>P\<^sub>2)}"
  assumes wp': "I \<subseteq> Q"
  assumes deriv_c1: "\<Gamma>,\<Theta>\<turnstile>\<^bsub>/F\<^esub> P\<^sub>1 c\<^sub>1 I,A"
  assumes deriv_c2: "\<Gamma>,\<Theta>\<turnstile>\<^bsub>/F\<^esub> P\<^sub>2 c\<^sub>2 I,A"
  shows "\<Gamma>,\<Theta>\<turnstile>\<^bsub>/F\<^esub> P (Cond b c\<^sub>1 c\<^sub>2) Q,A"
proof -
  from CondInv [OF wp inv deriv_c1 deriv_c2]
  have "\<Gamma>,\<Theta>\<turnstile>\<^bsub>/F\<^esub> P (Cond b c\<^sub>1 c\<^sub>2) I,A".
  from conseqPost [OF this wp' subset_refl]
  show ?thesis .
qed

lemma switchNil:
  "P \<subseteq> Q \<Longrightarrow> \<Gamma>,\<Theta>\<turnstile>\<^bsub>/F \<^esub>P (switch v []) Q,A"
  by (simp add: Skip)

lemma switchCons:
  "\<lbrakk>P \<subseteq> {s. (v s \<in> V \<longrightarrow> s \<in> P\<^sub>1) \<and> (v s \<notin> V \<longrightarrow> s \<in> P\<^sub>2)};
        \<Gamma>,\<Theta>\<turnstile>\<^bsub>/F \<^esub>P\<^sub>1 c Q,A;
        \<Gamma>,\<Theta>\<turnstile>\<^bsub>/F \<^esub>P\<^sub>2 (switch v vs) Q,A\<rbrakk>
\<Longrightarrow> \<Gamma>,\<Theta>\<turnstile>\<^bsub>/F \<^esub>P (switch v ((V,c)#vs)) Q,A"
  by (simp add: Cond)

lemma Guard:
 "\<lbrakk>P \<subseteq> g \<inter> R; \<Gamma>,\<Theta>\<turnstile>\<^bsub>/F\<^esub> R c Q,A\<rbrakk>
  \<Longrightarrow> \<Gamma>,\<Theta>\<turnstile>\<^bsub>/F\<^esub> P (Guard f g c) Q,A"
apply (rule Guard [THEN conseqPre, of _ _ _ _ R])
apply (erule conseqPre)
apply auto
done

lemma GuardSwap:
 "\<lbrakk> \<Gamma>,\<Theta>\<turnstile>\<^bsub>/F\<^esub> R c Q,A; P \<subseteq> g \<inter> R\<rbrakk>
  \<Longrightarrow> \<Gamma>,\<Theta>\<turnstile>\<^bsub>/F\<^esub> P (Guard f g c) Q,A"
  by (rule Guard)

lemma Guarantee:
 "\<lbrakk>P \<subseteq> {s. s \<in> g \<longrightarrow> s \<in> R}; \<Gamma>,\<Theta>\<turnstile>\<^bsub>/F\<^esub> R c Q,A; f \<in> F\<rbrakk>
  \<Longrightarrow> \<Gamma>,\<Theta>\<turnstile>\<^bsub>/F\<^esub> P (Guard f g c) Q,A"
apply (rule Guarantee [THEN conseqPre, of _ _ _ _ _ "{s. s \<in> g \<longrightarrow> s \<in> R}"])
apply   assumption
apply  (erule conseqPre)
apply auto
done

lemma GuaranteeSwap:
 "\<lbrakk> \<Gamma>,\<Theta>\<turnstile>\<^bsub>/F\<^esub> R c Q,A; P \<subseteq> {s. s \<in> g \<longrightarrow> s \<in> R}; f \<in> F\<rbrakk>
  \<Longrightarrow> \<Gamma>,\<Theta>\<turnstile>\<^bsub>/F\<^esub> P (Guard f g c) Q,A"
  by (rule Guarantee)

lemma GuardStrip:
 "\<lbrakk>P \<subseteq> R; \<Gamma>,\<Theta>\<turnstile>\<^bsub>/F\<^esub> R c Q,A; f \<in> F\<rbrakk>
  \<Longrightarrow> \<Gamma>,\<Theta>\<turnstile>\<^bsub>/F\<^esub> P (Guard f g c) Q,A"
apply (rule Guarantee [THEN conseqPre])
apply auto
done

lemma GuardStripSwap:
 "\<lbrakk>\<Gamma>,\<Theta>\<turnstile>\<^bsub>/F\<^esub> R c Q,A; P \<subseteq> R; f \<in> F\<rbrakk>
  \<Longrightarrow> \<Gamma>,\<Theta>\<turnstile>\<^bsub>/F\<^esub> P (Guard f g c) Q,A"
  by (rule GuardStrip)

lemma GuaranteeStrip:
 "\<lbrakk>P \<subseteq> R; \<Gamma>,\<Theta>\<turnstile>\<^bsub>/F\<^esub> R c Q,A; f \<in> F\<rbrakk>
  \<Longrightarrow> \<Gamma>,\<Theta>\<turnstile>\<^bsub>/F\<^esub> P (guaranteeStrip f g c) Q,A"
  by (unfold guaranteeStrip_def) (rule GuardStrip)

lemma GuaranteeStripSwap:
 "\<lbrakk>\<Gamma>,\<Theta>\<turnstile>\<^bsub>/F\<^esub> R c Q,A; P \<subseteq> R; f \<in> F\<rbrakk>
  \<Longrightarrow> \<Gamma>,\<Theta>\<turnstile>\<^bsub>/F\<^esub> P (guaranteeStrip f g c) Q,A"
  by (unfold guaranteeStrip_def) (rule GuardStrip)

lemma GuaranteeAsGuard:
 "\<lbrakk>P \<subseteq> g \<inter> R; \<Gamma>,\<Theta>\<turnstile>\<^bsub>/F\<^esub> R c Q,A\<rbrakk>
  \<Longrightarrow> \<Gamma>,\<Theta>\<turnstile>\<^bsub>/F\<^esub> P (guaranteeStrip f g c) Q,A"
  by (unfold guaranteeStrip_def) (rule Guard)

lemma GuaranteeAsGuardSwap:
 "\<lbrakk> \<Gamma>,\<Theta>\<turnstile>\<^bsub>/F\<^esub> R c Q,A; P \<subseteq> g \<inter> R\<rbrakk>
  \<Longrightarrow> \<Gamma>,\<Theta>\<turnstile>\<^bsub>/F\<^esub> P (guaranteeStrip f g c) Q,A"
  by (rule GuaranteeAsGuard)

lemma GuardsNil:
  "\<Gamma>,\<Theta>\<turnstile>\<^bsub>/F\<^esub> P c Q,A \<Longrightarrow>
   \<Gamma>,\<Theta>\<turnstile>\<^bsub>/F\<^esub> P (guards [] c) Q,A"
  by simp

lemma GuardsConsGuaranteeStrip:
  "\<Gamma>,\<Theta>\<turnstile>\<^bsub>/F\<^esub> P guaranteeStrip f g (guards gs c) Q,A \<Longrightarrow>
   \<Gamma>,\<Theta>\<turnstile>\<^bsub>/F\<^esub> P (guards (guaranteeStripPair f g#gs) c) Q,A"
  by (simp add: guaranteeStripPair_def guaranteeStrip_def)

lemma While:
  assumes P_I: "P \<subseteq> I"
  assumes deriv_body: "\<Gamma>,\<Theta>\<turnstile>\<^bsub>/F\<^esub> (I \<inter> b) c I,A"
  assumes I_Q: "I \<inter> -b \<subseteq> Q"
  shows "\<Gamma>,\<Theta>\<turnstile>\<^bsub>/F\<^esub> P (whileAnno b I V c) Q,A"
proof -
  from deriv_body P_I I_Q
  show ?thesis
    apply (simp add: whileAnno_def)
    apply (erule conseqPrePost [OF HoarePartialDef.While])
    apply simp_all
    done
qed

text {* @{term "J"} will be instantiated by tactic with @{term "gs' \<inter> I"} for
  those guards that are not stripped.*}
lemma  WhileAnnoG:
  "\<Gamma>,\<Theta>\<turnstile>\<^bsub>/F\<^esub> P (guards gs
                    (whileAnno  b J V (Seq c (guards gs Skip)))) Q,A
        \<Longrightarrow>
        \<Gamma>,\<Theta>\<turnstile>\<^bsub>/F\<^esub> P (whileAnnoG gs b I V c) Q,A"
  by (simp add: whileAnnoG_def whileAnno_def while_def)

text {* This form stems from @{term "strip_guards F (whileAnnoG gs b I V c)"} *}

lemma WhileAnnoGFix:
assumes whileAnnoFix:
  "\<Gamma>,\<Theta>\<turnstile>\<^bsub>/F\<^esub> P (guards gs
                (whileAnnoFix  b J V (\<lambda>Z. (Seq (c Z) (guards gs Skip))))) Q,A"
shows "\<Gamma>,\<Theta>\<turnstile>\<^bsub>/F\<^esub> P (whileAnnoGFix gs b I V c) Q,A"
  using whileAnnoFix
  by (simp add: whileAnnoGFix_def whileAnnoFix_def while_def)

lemma Bind:
  assumes adapt: "P \<subseteq> {s. s \<in> P' s}"
  assumes c: "\<forall>s. \<Gamma>,\<Theta>\<turnstile>\<^bsub>/F\<^esub> (P' s) (c (e s)) Q,A"
  shows "\<Gamma>,\<Theta>\<turnstile>\<^bsub>/F\<^esub> P (bind e c) Q,A"
apply (rule conseq [where P'="\<lambda>Z. {s. s=Z \<and> s \<in> P' Z}" and Q'="\<lambda>Z. Q" and
A'="\<lambda>Z. A"])
apply  (rule allI)
apply  (unfold bind_def)
apply  (rule DynCom)
apply  (rule ballI)
apply  simp
apply  (rule conseqPre)
apply   (rule c [rule_format])
apply  blast
using adapt
apply blast
done

lemma Block:
assumes adapt: "P \<subseteq> {s. init s \<in> P' s}"
assumes bdy: "\<forall>s. \<Gamma>,\<Theta>\<turnstile>\<^bsub>/F\<^esub> (P' s) bdy {t. return s t \<in> R s t},{t. return s t \<in> A}"
assumes c: "\<forall>s t. \<Gamma>,\<Theta>\<turnstile>\<^bsub>/F\<^esub> (R s t) (c s t) Q,A"
shows "\<Gamma>,\<Theta>\<turnstile>\<^bsub>/F\<^esub> P (block init bdy return c) Q,A"
apply (rule conseq [where P'="\<lambda>Z. {s. s=Z \<and> init s \<in> P' Z}" and Q'="\<lambda>Z. Q" and
A'="\<lambda>Z. A"])
prefer 2
using adapt
apply  blast
apply (rule allI)
apply (unfold block_def)
apply (rule DynCom)
apply (rule ballI)
apply clarsimp
apply (rule_tac R="{t. return Z t \<in> R Z t}" in SeqSwap )
apply  (rule_tac  P'="\<lambda>Z'. {t. t=Z' \<and> return Z t \<in> R Z t}" and
          Q'="\<lambda>Z'. Q" and A'="\<lambda>Z'. A" in conseq)
prefer 2 apply simp
apply  (rule allI)
apply  (rule DynCom)
apply  (clarsimp)
apply  (rule SeqSwap)
apply   (rule c [rule_format])
apply  (rule Basic)
apply  clarsimp
apply (rule_tac R="{t. return Z t \<in> A}" in Catch)
apply  (rule_tac R="{i. i \<in> P' Z}" in Seq)
apply   (rule Basic)
apply   clarsimp
apply  simp
apply  (rule bdy [rule_format])
apply (rule SeqSwap)
apply  (rule Throw)
apply (rule Basic)
apply simp
done

lemma BlockSwap:
assumes c: "\<forall>s t. \<Gamma>,\<Theta>\<turnstile>\<^bsub>/F\<^esub> (R s t) (c s t) Q,A"
assumes bdy: "\<forall>s. \<Gamma>,\<Theta>\<turnstile>\<^bsub>/F\<^esub> (P' s) bdy {t. return s t \<in> R s t},{t. return s t \<in> A}"
assumes adapt: "P \<subseteq> {s. init s \<in> P' s}"
shows "\<Gamma>,\<Theta>\<turnstile>\<^bsub>/F\<^esub> P (block init bdy return c) Q,A"
using adapt bdy c
  by (rule Block)

lemma BlockSpec:
  assumes adapt: "P \<subseteq> {s. \<exists>Z. init s \<in> P' Z \<and>
                             (\<forall>t. t \<in> Q' Z \<longrightarrow> return s t \<in> R s t) \<and>
                             (\<forall>t. t \<in> A' Z \<longrightarrow> return s t \<in> A)}"
  assumes c: "\<forall>s t. \<Gamma>,\<Theta>\<turnstile>\<^bsub>/F\<^esub> (R s t) (c s t) Q,A"
  assumes bdy: "\<forall>Z. \<Gamma>,\<Theta>\<turnstile>\<^bsub>/F\<^esub> (P' Z) bdy (Q' Z),(A' Z)"
  shows "\<Gamma>,\<Theta>\<turnstile>\<^bsub>/F\<^esub> P (block init bdy return c) Q,A"
apply (rule conseq [where P'="\<lambda>Z. {s. init s \<in> P' Z \<and>
                             (\<forall>t. t \<in> Q' Z \<longrightarrow> return s t \<in> R s t) \<and>
                             (\<forall>t. t \<in> A' Z \<longrightarrow> return s t \<in> A)}" and Q'="\<lambda>Z. Q" and
A'="\<lambda>Z. A"])
prefer 2
using adapt
apply  blast
apply (rule allI)
apply (unfold block_def)
apply (rule DynCom)
apply (rule ballI)
apply clarsimp
apply (rule_tac R="{t. return s t \<in> R s t}" in SeqSwap )
apply  (rule_tac  P'="\<lambda>Z'. {t. t=Z' \<and> return s t \<in> R s t}" and
          Q'="\<lambda>Z'. Q" and A'="\<lambda>Z'. A" in conseq)
prefer 2 apply simp
apply  (rule allI)
apply  (rule DynCom)
apply  (clarsimp)
apply  (rule SeqSwap)
apply   (rule c [rule_format])
apply  (rule Basic)
apply  clarsimp
apply (rule_tac R="{t. return s t \<in> A}" in Catch)
apply  (rule_tac R="{i. i \<in> P' Z}" in Seq)
apply   (rule Basic)
apply   clarsimp
apply  simp
apply  (rule conseq [OF bdy])
apply  clarsimp
apply  blast
apply (rule SeqSwap)
apply  (rule Throw)
apply (rule Basic)
apply simp
done

lemma Throw: "P \<subseteq> A \<Longrightarrow> \<Gamma>,\<Theta>\<turnstile>\<^bsub>/F\<^esub> P Throw Q,A"
  by (rule hoarep.Throw [THEN conseqPre])

lemmas Catch = hoarep.Catch
lemma CatchSwap: "\<lbrakk>\<Gamma>,\<Theta>\<turnstile>\<^bsub>/F\<^esub> R c\<^sub>2 Q,A; \<Gamma>,\<Theta>\<turnstile>\<^bsub>/F\<^esub> P c\<^sub>1 Q,R\<rbrakk> \<Longrightarrow> \<Gamma>,\<Theta>\<turnstile>\<^bsub>/F\<^esub> P Catch c\<^sub>1 c\<^sub>2 Q,A"
  by (rule hoarep.Catch)

lemma raise: "P \<subseteq> {s. f s \<in> A} \<Longrightarrow> \<Gamma>,\<Theta>\<turnstile>\<^bsub>/F\<^esub> P raise f Q,A"
  apply (simp add: raise_def)
  apply (rule Seq)
  apply  (rule Basic)
  apply  (assumption)
  apply (rule Throw)
  apply (rule subset_refl)
  done

lemma condCatch: "\<lbrakk>\<Gamma>,\<Theta>\<turnstile>\<^bsub>/F\<^esub> P c\<^sub>1 Q,((b \<inter> R) \<union> (-b \<inter> A));\<Gamma>,\<Theta>\<turnstile>\<^bsub>/F\<^esub> R c\<^sub>2 Q,A\<rbrakk>
                  \<Longrightarrow>  \<Gamma>,\<Theta>\<turnstile>\<^bsub>/F\<^esub>P condCatch c\<^sub>1 b c\<^sub>2 Q,A"
  apply (simp add: condCatch_def)
  apply (rule Catch)
  apply  assumption
  apply (rule CondSwap)
  apply   (assumption)
  apply  (rule hoarep.Throw)
  apply blast
  done

lemma condCatchSwap: "\<lbrakk>\<Gamma>,\<Theta>\<turnstile>\<^bsub>/F\<^esub> R c\<^sub>2 Q,A;\<Gamma>,\<Theta>\<turnstile>\<^bsub>/F\<^esub> P c\<^sub>1 Q,((b \<inter> R) \<union> (-b \<inter> A))\<rbrakk>
                  \<Longrightarrow>  \<Gamma>,\<Theta>\<turnstile>\<^bsub>/F\<^esub>P condCatch c\<^sub>1 b c\<^sub>2 Q,A"
  by (rule condCatch)

lemma ProcSpec:
  assumes adapt: "P \<subseteq> {s. \<exists>Z. init s \<in> P' Z \<and>
                             (\<forall>t. t \<in> Q' Z \<longrightarrow> return s t \<in> R s t) \<and>
                             (\<forall>t. t \<in> A' Z \<longrightarrow> return s t \<in> A)}"
  assumes c: "\<forall>s t. \<Gamma>,\<Theta>\<turnstile>\<^bsub>/F\<^esub> (R s t) (c s t) Q,A"
  assumes p: "\<forall>Z. \<Gamma>,\<Theta>\<turnstile>\<^bsub>/F\<^esub> (P' Z) Call p (Q' Z),(A' Z)"
  shows "\<Gamma>,\<Theta>\<turnstile>\<^bsub>/F\<^esub> P (call init p return c) Q,A"
using adapt c p
apply (unfold call_def)
by (rule BlockSpec)

lemma ProcSpec':
  assumes adapt: "P \<subseteq> {s. \<exists>Z. init s \<in> P' Z \<and>
                             (\<forall>t \<in> Q' Z. return s t \<in> R s t) \<and>
                             (\<forall>t \<in> A' Z. return s t \<in> A)}"
  assumes c: "\<forall>s t. \<Gamma>,\<Theta>\<turnstile>\<^bsub>/F\<^esub> (R s t) (c s t) Q,A"
  assumes p: "\<forall>Z. \<Gamma>,\<Theta>\<turnstile>\<^bsub>/F\<^esub> (P' Z) Call p (Q' Z),(A' Z)"
  shows "\<Gamma>,\<Theta>\<turnstile>\<^bsub>/F\<^esub> P (call init p return c) Q,A"
apply (rule ProcSpec [OF _ c p])
apply (insert adapt)
apply clarsimp
apply (drule (1) subsetD)
apply (clarsimp)
apply (rule_tac x=Z in exI)
apply blast
done

lemma ProcSpecNoAbrupt:
  assumes adapt: "P \<subseteq> {s. \<exists>Z. init s \<in> P' Z \<and>
                             (\<forall>t. t \<in> Q' Z \<longrightarrow> return s t \<in> R s t)}"
  assumes c: "\<forall>s t. \<Gamma>,\<Theta>\<turnstile>\<^bsub>/F\<^esub> (R s t) (c s t) Q,A"
  assumes p: "\<forall>Z. \<Gamma>,\<Theta>\<turnstile>\<^bsub>/F\<^esub> (P' Z) Call p (Q' Z),{}"
  shows "\<Gamma>,\<Theta>\<turnstile>\<^bsub>/F\<^esub> P (call init p return c) Q,A"
apply (rule ProcSpec [OF _ c p])
using adapt
apply simp
done

lemma FCall:
"\<Gamma>,\<Theta>\<turnstile>\<^bsub>/F\<^esub> P (call init p return (\<lambda>s t. c (result t))) Q,A
\<Longrightarrow> \<Gamma>,\<Theta>\<turnstile>\<^bsub>/F\<^esub> P (fcall init p return result c) Q,A"
  by (simp add: fcall_def)

lemma ProcRec:
  assumes deriv_bodies:
   "\<forall>p\<in>Procs.
    \<forall>Z. \<Gamma>,\<Theta>\<union>(\<Union>p\<in>Procs. \<Union>Z. {(P p Z,p,Q p Z,A p Z)})
        \<turnstile>\<^bsub>/F\<^esub> (P p Z) (the (\<Gamma> p)) (Q p Z),(A p Z)"
  assumes Procs_defined: "Procs \<subseteq> dom \<Gamma>"
  shows "\<forall>p\<in>Procs. \<forall>Z. \<Gamma>,\<Theta>\<turnstile>\<^bsub>/F\<^esub>(P p Z) Call p (Q p Z),(A p Z)"
  by (intro strip)
     (rule CallRec'
     [OF _   Procs_defined deriv_bodies],
     simp_all)

lemma ProcRec':
  assumes ctxt: "\<Theta>' = \<Theta>\<union>(\<Union>p\<in>Procs. \<Union>Z. {(P p Z,p,Q p Z,A p Z)})"
  assumes deriv_bodies:
   "\<forall>p\<in>Procs. \<forall>Z. \<Gamma>,\<Theta>'\<turnstile>\<^bsub>/F\<^esub> (P p Z) (the (\<Gamma> p)) (Q p Z),(A p Z)"
  assumes Procs_defined: "Procs \<subseteq> dom \<Gamma>"
  shows "\<forall>p\<in>Procs. \<forall>Z. \<Gamma>,\<Theta>\<turnstile>\<^bsub>/F\<^esub>(P p Z) Call p (Q p Z),(A p Z)"
  using ctxt deriv_bodies
  apply simp
  apply (erule ProcRec [OF _ Procs_defined])
  done

lemma ProcRecList:
  assumes deriv_bodies:
   "\<forall>p\<in>set Procs.
    \<forall>Z. \<Gamma>,\<Theta>\<union>(\<Union>p\<in>set Procs. \<Union>Z. {(P p Z,p,Q p Z,A p Z)})
        \<turnstile>\<^bsub>/F\<^esub> (P p Z) (the (\<Gamma> p)) (Q p Z),(A p Z)"
  assumes dist: "distinct Procs"
  assumes Procs_defined: "set Procs \<subseteq> dom \<Gamma>"
  shows "\<forall>p\<in>set Procs. \<forall>Z. \<Gamma>,\<Theta>\<turnstile>\<^bsub>/F\<^esub>(P p Z) Call p (Q p Z),(A p Z)"
  using deriv_bodies Procs_defined
  by (rule ProcRec)

lemma  ProcRecSpecs:
  "\<lbrakk>\<forall>(P,p,Q,A) \<in> Specs. \<Gamma>,\<Theta>\<union>Specs\<turnstile>\<^bsub>/F\<^esub> P (the (\<Gamma> p)) Q,A;
    \<forall>(P,p,Q,A) \<in> Specs. p \<in> dom \<Gamma>\<rbrakk>
  \<Longrightarrow> \<forall>(P,p,Q,A) \<in> Specs. \<Gamma>,\<Theta>\<turnstile>\<^bsub>/F\<^esub> P (Call p) Q,A"
apply (auto intro: CallRec)
done

lemma ProcRec1:
  assumes deriv_body:
   "\<forall>Z. \<Gamma>,\<Theta>\<union>(\<Union>Z. {(P Z,p,Q Z,A Z)})\<turnstile>\<^bsub>/F\<^esub> (P Z) (the (\<Gamma> p)) (Q Z),(A Z)"
  assumes p_defined: "p \<in> dom \<Gamma>"
  shows "\<forall>Z. \<Gamma>,\<Theta>\<turnstile>\<^bsub>/F\<^esub> (P Z) Call p (Q Z),(A Z)"
proof -
  from deriv_body p_defined
  have "\<forall>p\<in>{p}. \<forall>Z. \<Gamma>,\<Theta>\<turnstile>\<^bsub>/F\<^esub> (P Z) Call p (Q Z),(A Z)"
    by - (rule ProcRec [where A="\<lambda>p. A" and P="\<lambda>p. P" and Q="\<lambda>p. Q"],
          simp_all)
  thus ?thesis
    by simp
qed

lemma ProcNoRec1:
  assumes deriv_body:
   "\<forall>Z. \<Gamma>,\<Theta>\<turnstile>\<^bsub>/F\<^esub> (P Z) (the (\<Gamma> p)) (Q Z),(A Z)"
  assumes p_def: "p \<in> dom \<Gamma>"
  shows "\<forall>Z. \<Gamma>,\<Theta>\<turnstile>\<^bsub>/F\<^esub> (P Z) Call p (Q Z),(A Z)"
proof -
from deriv_body
  have "\<forall>Z. \<Gamma>,\<Theta>\<union>(\<Union>Z. {(P Z,p,Q Z,A Z)})
             \<turnstile>\<^bsub>/F\<^esub> (P Z) (the (\<Gamma> p)) (Q Z),(A Z)"
    by (blast intro: hoare_augment_context)
  from this p_def
  show ?thesis
    by (rule ProcRec1)
qed

lemma ProcBody:
 assumes WP: "P \<subseteq> P'"
 assumes deriv_body: "\<Gamma>,\<Theta>\<turnstile>\<^bsub>/F\<^esub> P' body Q,A"
 assumes body: "\<Gamma> p = Some body"
 shows "\<Gamma>,\<Theta>\<turnstile>\<^bsub>/F\<^esub> P Call p Q,A"
apply (rule conseqPre [OF _ WP])
apply (rule ProcNoRec1 [rule_format, where P="\<lambda>Z. P'" and Q="\<lambda>Z. Q" and A="\<lambda>Z. A"])
apply  (insert body)
apply  simp
apply  (rule hoare_augment_context [OF deriv_body])
apply  blast
apply fastforce
done

lemma CallBody:
assumes adapt: "P \<subseteq> {s. init s \<in> P' s}"
assumes bdy: "\<forall>s. \<Gamma>,\<Theta>\<turnstile>\<^bsub>/F\<^esub> (P' s) body {t. return s t \<in> R s t},{t. return s t \<in> A}"
assumes c: "\<forall>s t. \<Gamma>,\<Theta>\<turnstile>\<^bsub>/F\<^esub> (R s t) (c s t) Q,A"
assumes body: "\<Gamma> p = Some body"
shows "\<Gamma>,\<Theta>\<turnstile>\<^bsub>/F\<^esub> P (call init p return c) Q,A"
apply (unfold call_def)
apply (rule Block [OF adapt _ c])
apply (rule allI)
apply (rule ProcBody [where \<Gamma>=\<Gamma>, OF _ bdy [rule_format] body])
apply simp
done

lemmas ProcModifyReturn = HoarePartialProps.ProcModifyReturn
lemmas ProcModifyReturnSameFaults = HoarePartialProps.ProcModifyReturnSameFaults

lemma ProcModifyReturnNoAbr:
  assumes spec: "\<Gamma>,\<Theta>\<turnstile>\<^bsub>/F\<^esub> P (call init p return' c) Q,A"
  assumes result_conform:
      "\<forall>s t. t \<in> Modif (init s) \<longrightarrow> (return' s t) = (return s t)"
  assumes modifies_spec:
  "\<forall>\<sigma>. \<Gamma>,\<Theta>\<turnstile>\<^bsub>/UNIV\<^esub> {\<sigma>} Call p (Modif \<sigma>),{}"
  shows "\<Gamma>,\<Theta>\<turnstile>\<^bsub>/F\<^esub> P (call init p return c) Q,A"
by (rule ProcModifyReturn [OF spec result_conform _ modifies_spec]) simp

lemma ProcModifyReturnNoAbrSameFaults:
  assumes spec: "\<Gamma>,\<Theta>\<turnstile>\<^bsub>/F\<^esub> P (call init p return' c) Q,A"
  assumes result_conform:
      "\<forall>s t. t \<in> Modif (init s) \<longrightarrow> (return' s t) = (return s t)"
  assumes modifies_spec:
  "\<forall>\<sigma>. \<Gamma>,\<Theta>\<turnstile>\<^bsub>/F\<^esub> {\<sigma>} Call p (Modif \<sigma>),{}"
  shows "\<Gamma>,\<Theta>\<turnstile>\<^bsub>/F\<^esub> P (call init p return c) Q,A"
by (rule ProcModifyReturnSameFaults [OF spec result_conform _ modifies_spec]) simp

lemma DynProc:
  assumes adapt: "P \<subseteq> {s. \<exists>Z. init s \<in> P' s Z \<and>
                          (\<forall>t. t \<in> Q' s Z \<longrightarrow>  return s t \<in> R s t) \<and>
                          (\<forall>t. t \<in> A' s Z \<longrightarrow> return s t \<in> A)}"
  assumes c: "\<forall>s t. \<Gamma>,\<Theta>\<turnstile>\<^bsub>/F\<^esub> (R s t) (c s t) Q,A"
  assumes p: "\<forall>s\<in> P. \<forall>Z. \<Gamma>,\<Theta>\<turnstile>\<^bsub>/F\<^esub> (P' s Z) Call (p s) (Q' s Z),(A' s Z)"
  shows "\<Gamma>,\<Theta>\<turnstile>\<^bsub>/F\<^esub> P dynCall init p return c Q,A"
apply (rule conseq [where P'="\<lambda>Z. {s. s=Z \<and> s \<in> P}"
  and Q'="\<lambda>Z. Q" and A'="\<lambda>Z. A"])
prefer 2
using adapt
apply  blast
apply (rule allI)
apply (unfold dynCall_def call_def block_def)
apply (rule DynCom)
apply clarsimp
apply (rule DynCom)
apply clarsimp
apply (frule in_mono [rule_format, OF adapt])
apply clarsimp
apply (rename_tac Z')
apply (rule_tac R="Q' Z Z'" in Seq)
apply  (rule CatchSwap)
apply   (rule SeqSwap)
apply    (rule Throw)
apply    (rule subset_refl)
apply   (rule Basic)
apply   (rule subset_refl)
apply  (rule_tac R="{i. i \<in> P' Z Z'}" in Seq)
apply   (rule Basic)
apply   clarsimp
apply  simp
apply  (rule_tac Q'="Q' Z Z'" and A'="A' Z Z'" in conseqPost)
using p
apply    clarsimp
apply   simp
apply  clarsimp
apply  (rule_tac  P'="\<lambda>Z''. {t. t=Z'' \<and> return Z t \<in> R Z t}" and
          Q'="\<lambda>Z''. Q" and A'="\<lambda>Z''. A" in conseq)
prefer 2 apply simp
apply (rule allI)
apply (rule DynCom)
apply clarsimp
apply (rule SeqSwap)
apply  (rule c [rule_format])
apply (rule Basic)
apply clarsimp
done

lemma DynProc':
  assumes adapt: "P \<subseteq> {s. \<exists>Z. init s \<in> P' s Z \<and>
                          (\<forall>t \<in> Q' s Z. return s t \<in> R s t) \<and>
                          (\<forall>t \<in> A' s Z. return s t \<in> A)}"
  assumes c: "\<forall>s t. \<Gamma>,\<Theta>\<turnstile>\<^bsub>/F\<^esub> (R s t) (c s t) Q,A"
  assumes p: "\<forall>s\<in> P. \<forall>Z. \<Gamma>,\<Theta>\<turnstile>\<^bsub>/F\<^esub> (P' s Z) Call (p s) (Q' s Z),(A' s Z)"
  shows "\<Gamma>,\<Theta>\<turnstile>\<^bsub>/F\<^esub> P dynCall init p return c Q,A"
proof -
  from adapt have "P \<subseteq> {s. \<exists>Z. init s \<in> P' s Z \<and>
                          (\<forall>t. t \<in> Q' s Z \<longrightarrow>  return s t \<in> R s t) \<and>
                          (\<forall>t. t \<in> A' s Z \<longrightarrow> return s t \<in> A)}"
    by blast
  from this c p show ?thesis
    by (rule DynProc)
qed

lemma DynProcStaticSpec:
assumes adapt: "P \<subseteq> {s. s \<in> S \<and> (\<exists>Z. init s \<in> P' Z  \<and>
                            (\<forall>\<tau>. \<tau> \<in> Q' Z \<longrightarrow> return s \<tau> \<in> R s \<tau>) \<and>
                            (\<forall>\<tau>. \<tau> \<in> A' Z \<longrightarrow> return s \<tau> \<in> A))}"
assumes c: "\<forall>s t. \<Gamma>,\<Theta>\<turnstile>\<^bsub>/F\<^esub> (R s t) (c s t) Q,A"
assumes spec: "\<forall>s\<in>S. \<forall>Z. \<Gamma>,\<Theta>\<turnstile>\<^bsub>/F\<^esub> (P' Z) Call (p s) (Q' Z),(A' Z)"
shows "\<Gamma>,\<Theta>\<turnstile>\<^bsub>/F\<^esub> P (dynCall init p return c) Q,A"
proof -
  from adapt have P_S: "P \<subseteq> S"
    by blast
  have "\<Gamma>,\<Theta>\<turnstile>\<^bsub>/F\<^esub> (P \<inter> S) (dynCall init p return c) Q,A"
    apply (rule DynProc [where P'="\<lambda>s Z. P' Z" and Q'="\<lambda>s Z. Q' Z"
                         and A'="\<lambda>s Z. A' Z", OF _ c])
    apply  clarsimp
    apply  (frule in_mono [rule_format, OF adapt])
    apply  clarsimp
    using spec
    apply clarsimp
    done
  thus ?thesis
    by (rule conseqPre) (insert P_S,blast)
qed

lemma DynProcProcPar:
assumes adapt: "P \<subseteq> {s. p s = q \<and> (\<exists>Z. init s \<in> P' Z  \<and>
                            (\<forall>\<tau>. \<tau> \<in> Q' Z \<longrightarrow> return s \<tau> \<in> R s \<tau>) \<and>
                            (\<forall>\<tau>. \<tau> \<in> A' Z \<longrightarrow> return s \<tau> \<in> A))}"
assumes c: "\<forall>s t. \<Gamma>,\<Theta>\<turnstile>\<^bsub>/F\<^esub> (R s t) (c s t) Q,A"
assumes spec: "\<forall>Z. \<Gamma>,\<Theta>\<turnstile>\<^bsub>/F\<^esub> (P' Z) Call q (Q' Z),(A' Z)"
shows "\<Gamma>,\<Theta>\<turnstile>\<^bsub>/F\<^esub> P (dynCall init p return c) Q,A"
  apply (rule DynProcStaticSpec [where S="{s. p s = q}",simplified, OF adapt c])
  using spec
  apply simp
  done

lemma DynProcProcParNoAbrupt:
assumes adapt: "P \<subseteq> {s. p s = q \<and> (\<exists>Z. init s \<in> P' Z  \<and>
                            (\<forall>\<tau>. \<tau> \<in> Q' Z \<longrightarrow> return s \<tau> \<in> R s \<tau>))}"
assumes c: "\<forall>s t. \<Gamma>,\<Theta>\<turnstile>\<^bsub>/F\<^esub> (R s t) (c s t) Q,A"
assumes spec: "\<forall>Z. \<Gamma>,\<Theta>\<turnstile>\<^bsub>/F\<^esub> (P' Z) Call q (Q' Z),{}"
shows "\<Gamma>,\<Theta>\<turnstile>\<^bsub>/F\<^esub> P (dynCall init p return c) Q,A"
proof -
  have "P \<subseteq> {s. p s = q \<and> (\<exists> Z. init s \<in> P' Z \<and>
                      (\<forall>t. t \<in> Q' Z \<longrightarrow> return s t \<in> R s t) \<and>
                      (\<forall>t. t \<in> {} \<longrightarrow> return s t \<in> A))}"
    (is "P \<subseteq> ?P'")
  proof
    fix s
    assume P: "s\<in>P"
    with adapt obtain Z where
      Pre: "p s = q \<and> init s \<in> P' Z" and
      adapt_Norm: "\<forall>\<tau>. \<tau> \<in> Q' Z \<longrightarrow> return s \<tau> \<in> R s \<tau>"
      by blast
    from  adapt_Norm
    have "\<forall>t. t \<in> Q' Z \<longrightarrow> return s t \<in> R s t"
      by auto
    then
    show "s\<in>?P'"
      using Pre by blast
  qed
  note P = this
  show ?thesis
    apply -
    apply (rule DynProcStaticSpec [where S="{s. p s = q}",simplified, OF P c])
    apply (insert spec)
    apply auto
    done
qed

lemma DynProcModifyReturnNoAbr:
  assumes to_prove: "\<Gamma>,\<Theta>\<turnstile>\<^bsub>/F\<^esub> P (dynCall init p return' c) Q,A"
  assumes ret_nrm_modif: "\<forall>s t. t \<in> (Modif (init s))
                            \<longrightarrow> return' s t = return s t"
  assumes modif_clause:
            "\<forall>s \<in> P. \<forall>\<sigma>. \<Gamma>,\<Theta>\<turnstile>\<^bsub>/UNIV\<^esub> {\<sigma>} Call (p s)  (Modif \<sigma>),{}"
  shows "\<Gamma>,\<Theta>\<turnstile>\<^bsub>/F\<^esub> P (dynCall init p return c) Q,A"
proof -
  from ret_nrm_modif
  have "\<forall>s t. t  \<in> (Modif (init s))
        \<longrightarrow> return' s t = return s t"
    by iprover
  then
  have ret_nrm_modif': "\<forall>s t. t \<in> (Modif (init s))
                      \<longrightarrow> return' s t = return s t"
    by simp
  have ret_abr_modif': "\<forall>s t. t \<in> {}
                        \<longrightarrow> return' s t = return s t"
    by simp
  from to_prove ret_nrm_modif' ret_abr_modif' modif_clause show ?thesis
    by (rule dynProcModifyReturn)
qed

lemma ProcDynModifyReturnNoAbrSameFaults:
  assumes to_prove: "\<Gamma>,\<Theta>\<turnstile>\<^bsub>/F\<^esub> P (dynCall init p return' c) Q,A"
  assumes ret_nrm_modif: "\<forall>s t. t \<in> (Modif (init s))
                            \<longrightarrow> return' s t = return s t"
  assumes modif_clause:
            "\<forall>s \<in> P. \<forall>\<sigma>. \<Gamma>,\<Theta>\<turnstile>\<^bsub>/F\<^esub> {\<sigma>} (Call (p s)) (Modif \<sigma>),{}"
  shows "\<Gamma>,\<Theta>\<turnstile>\<^bsub>/F\<^esub> P (dynCall init p return c) Q,A"
proof -
  from ret_nrm_modif
  have "\<forall>s t. t  \<in> (Modif (init s))
        \<longrightarrow> return' s t = return s t"
    by iprover
  then
  have ret_nrm_modif': "\<forall>s t. t \<in> (Modif (init s))
                      \<longrightarrow> return' s t = return s t"
    by simp
  have ret_abr_modif': "\<forall>s t. t \<in> {}
                        \<longrightarrow> return' s t = return s t"
    by simp
  from to_prove ret_nrm_modif' ret_abr_modif' modif_clause show ?thesis
    by (rule dynProcModifyReturnSameFaults)
qed

lemma ProcProcParModifyReturn:
  assumes q: "P \<subseteq> {s. p s = q} \<inter> P'"
   --{* @{thm[source] DynProcProcPar} introduces the same constraint as first conjunction in
         @{term P'}, so the vcg can simplify it. *}
  assumes to_prove: "\<Gamma>,\<Theta>\<turnstile>\<^bsub>/F\<^esub> P' (dynCall init p return' c) Q,A"
  assumes ret_nrm_modif: "\<forall>s t. t \<in> (Modif (init s))
                            \<longrightarrow> return' s t = return s t"
  assumes ret_abr_modif: "\<forall>s t. t \<in> (ModifAbr (init s))
                            \<longrightarrow> return' s t = return s t"
  assumes modif_clause:
          "\<forall>\<sigma>. \<Gamma>,\<Theta>\<turnstile>\<^bsub>/UNIV\<^esub> {\<sigma>} (Call q) (Modif \<sigma>),(ModifAbr \<sigma>)"
  shows "\<Gamma>,\<Theta>\<turnstile>\<^bsub>/F\<^esub> P (dynCall init p return c) Q,A"
proof -
  from to_prove have "\<Gamma>,\<Theta>\<turnstile>\<^bsub>/F\<^esub> ({s. p s = q} \<inter> P') (dynCall init p return' c) Q,A"
    by (rule conseqPre) blast
  from this ret_nrm_modif
       ret_abr_modif
  have "\<Gamma>,\<Theta>\<turnstile>\<^bsub>/F\<^esub> ({s. p s = q} \<inter> P') (dynCall init p return c) Q,A"
    by (rule dynProcModifyReturn) (insert modif_clause,auto)
  from this q show ?thesis
    by (rule conseqPre)
qed

lemma ProcProcParModifyReturnSameFaults:
  assumes q: "P \<subseteq> {s. p s = q} \<inter> P'"
   --{* @{thm[source] DynProcProcPar} introduces the same constraint as first conjunction in
         @{term P'}, so the vcg can simplify it. *}
  assumes to_prove: "\<Gamma>,\<Theta>\<turnstile>\<^bsub>/F\<^esub> P' (dynCall init p return' c) Q,A"
  assumes ret_nrm_modif: "\<forall>s t. t \<in> (Modif (init s))
                            \<longrightarrow> return' s t = return s t"
  assumes ret_abr_modif: "\<forall>s t. t \<in> (ModifAbr (init s))
                            \<longrightarrow> return' s t = return s t"
  assumes modif_clause:
          "\<forall>\<sigma>. \<Gamma>,\<Theta>\<turnstile>\<^bsub>/F\<^esub> {\<sigma>} Call q (Modif \<sigma>),(ModifAbr \<sigma>)"
  shows "\<Gamma>,\<Theta>\<turnstile>\<^bsub>/F\<^esub> P (dynCall init p return c) Q,A"
proof -
  from to_prove
  have "\<Gamma>,\<Theta>\<turnstile>\<^bsub>/F\<^esub> ({s. p s = q} \<inter> P') (dynCall init p return' c) Q,A"
    by (rule conseqPre) blast
  from this ret_nrm_modif
       ret_abr_modif
  have "\<Gamma>,\<Theta>\<turnstile>\<^bsub>/F\<^esub> ({s. p s = q} \<inter> P') (dynCall init p return c) Q,A"
    by (rule dynProcModifyReturnSameFaults) (insert modif_clause,auto)
  from this q show ?thesis
    by (rule conseqPre)
qed

lemma ProcProcParModifyReturnNoAbr:
  assumes q: "P \<subseteq> {s. p s = q} \<inter> P'"
   --{* @{thm[source] DynProcProcParNoAbrupt} introduces the same constraint as
      first conjunction in @{term P'}, so the vcg can simplify it. *}
  assumes to_prove: "\<Gamma>,\<Theta>\<turnstile>\<^bsub>/F\<^esub> P' (dynCall init p return' c) Q,A"
  assumes ret_nrm_modif: "\<forall>s t. t \<in> (Modif (init s))
                            \<longrightarrow> return' s t = return s t"
  assumes modif_clause:
            "\<forall>\<sigma>. \<Gamma>,\<Theta>\<turnstile>\<^bsub>/UNIV\<^esub> {\<sigma>} (Call q) (Modif \<sigma>),{}"
  shows "\<Gamma>,\<Theta>\<turnstile>\<^bsub>/F\<^esub> P (dynCall init p return c) Q,A"
proof -
  from to_prove have "\<Gamma>,\<Theta>\<turnstile>\<^bsub>/F\<^esub> ({s. p s = q} \<inter> P') (dynCall init p return' c) Q,A"
    by (rule conseqPre) blast
  from this ret_nrm_modif
  have "\<Gamma>,\<Theta>\<turnstile>\<^bsub>/F\<^esub> ({s. p s = q} \<inter> P') (dynCall init p return c) Q,A"
    by (rule DynProcModifyReturnNoAbr) (insert modif_clause,auto)
  from this q show ?thesis
    by (rule conseqPre)
qed

lemma ProcProcParModifyReturnNoAbrSameFaults:
  assumes q: "P \<subseteq> {s. p s = q} \<inter> P'"
   --{* @{thm[source] DynProcProcParNoAbrupt} introduces the same constraint as
      first conjunction in @{term P'}, so the vcg can simplify it. *}
  assumes to_prove: "\<Gamma>,\<Theta>\<turnstile>\<^bsub>/F\<^esub> P' (dynCall init p return' c) Q,A"
  assumes ret_nrm_modif: "\<forall>s t. t \<in> (Modif (init s))
                            \<longrightarrow> return' s t = return s t"
  assumes modif_clause:
            "\<forall>\<sigma>. \<Gamma>,\<Theta>\<turnstile>\<^bsub>/F\<^esub> {\<sigma>} (Call q) (Modif \<sigma>),{}"
  shows "\<Gamma>,\<Theta>\<turnstile>\<^bsub>/F\<^esub> P (dynCall init p return c) Q,A"
proof -
  from to_prove have
    "\<Gamma>,\<Theta>\<turnstile>\<^bsub>/F\<^esub> ({s. p s = q} \<inter> P') (dynCall init p return' c) Q,A"
    by (rule conseqPre) blast
  from this ret_nrm_modif
  have "\<Gamma>,\<Theta>\<turnstile>\<^bsub>/F\<^esub> ({s. p s = q} \<inter> P') (dynCall init p return c) Q,A"
    by (rule ProcDynModifyReturnNoAbrSameFaults) (insert modif_clause,auto)
  from this q show ?thesis
    by (rule conseqPre)
qed

lemma MergeGuards_iff: "\<Gamma>,\<Theta>\<turnstile>\<^bsub>/F\<^esub> P merge_guards c Q,A = \<Gamma>,\<Theta>\<turnstile>\<^bsub>/F\<^esub> P c Q,A"
  by (auto intro: MergeGuardsI MergeGuardsD)

lemma CombineStrip':
  assumes deriv: "\<Gamma>,\<Theta>\<turnstile>\<^bsub>/F\<^esub> P c' Q,A"
  assumes deriv_strip_triv: "\<Gamma>,{}\<turnstile>\<^bsub>/{}\<^esub> P c'' UNIV,UNIV"
  assumes c'': "c''= mark_guards False (strip_guards (-F) c')"
  assumes c: "merge_guards c = merge_guards (mark_guards False c')"
  shows "\<Gamma>,\<Theta>\<turnstile>\<^bsub>/{}\<^esub> P c Q,A"
proof -
  from deriv_strip_triv have deriv_strip: "\<Gamma>,\<Theta>\<turnstile>\<^bsub>/{}\<^esub> P c'' UNIV,UNIV"
    by (auto intro: hoare_augment_context)
  from deriv_strip [simplified c'']
  have "\<Gamma>,\<Theta>\<turnstile>\<^bsub>/{}\<^esub> P (strip_guards (- F) c') UNIV,UNIV"
    by (rule MarkGuardsD)
  with deriv
  have "\<Gamma>,\<Theta>\<turnstile>\<^bsub>/{}\<^esub> P c' Q,A"
    by (rule CombineStrip)
  hence "\<Gamma>,\<Theta>\<turnstile>\<^bsub>/{}\<^esub> P mark_guards False c' Q,A"
    by (rule MarkGuardsI)
  hence "\<Gamma>,\<Theta>\<turnstile>\<^bsub>/{}\<^esub> P merge_guards (mark_guards False c') Q,A"
    by (rule MergeGuardsI)
  hence "\<Gamma>,\<Theta>\<turnstile>\<^bsub>/{}\<^esub> P merge_guards c Q,A"
    by (simp add: c)
  thus ?thesis
    by (rule MergeGuardsD)
qed

lemma CombineStrip'':
  assumes deriv: "\<Gamma>,\<Theta>\<turnstile>\<^bsub>/{True}\<^esub> P c' Q,A"
  assumes deriv_strip_triv: "\<Gamma>,{}\<turnstile>\<^bsub>/{}\<^esub> P c'' UNIV,UNIV"
  assumes c'': "c''= mark_guards False (strip_guards ({False}) c')"
  assumes c: "merge_guards c = merge_guards (mark_guards False c')"
  shows "\<Gamma>,\<Theta>\<turnstile>\<^bsub>/{}\<^esub> P c Q,A"
  apply (rule CombineStrip' [OF deriv deriv_strip_triv _ c])
  apply (insert c'')
  apply (subgoal_tac "- {True} = {False}")
  apply auto
  done

lemma AsmUN:
  "(\<Union>Z. {(P Z, p, Q Z,A Z)}) \<subseteq> \<Theta>
  \<Longrightarrow>
  \<forall>Z. \<Gamma>,\<Theta>\<turnstile>\<^bsub>/F\<^esub> (P Z) (Call p) (Q Z),(A Z)"
  by (blast intro: hoarep.Asm)

lemma augment_context':
  "\<lbrakk>\<Theta> \<subseteq> \<Theta>'; \<forall>Z. \<Gamma>,\<Theta>\<turnstile>\<^bsub>/F\<^esub> (P Z)  p (Q Z),(A Z)\<rbrakk>
   \<Longrightarrow> \<forall>Z. \<Gamma>,\<Theta>'\<turnstile>\<^bsub>/F\<^esub> (P Z) p (Q Z),(A Z)"
  by (iprover intro: hoare_augment_context)

lemma hoarep_strip:
 "\<lbrakk>\<forall>Z. \<Gamma>,{}\<turnstile>\<^bsub>/F\<^esub> (P Z) p (Q Z),(A Z); F' \<subseteq> -F\<rbrakk> \<Longrightarrow>
    \<forall>Z. strip F' \<Gamma>,{}\<turnstile>\<^bsub>/F\<^esub> (P Z) p (Q Z),(A Z)"
  by (iprover intro: hoare_strip_\<Gamma>)

lemma augment_emptyFaults:
 "\<lbrakk>\<forall>Z. \<Gamma>,{}\<turnstile>\<^bsub>/{}\<^esub> (P Z) p (Q Z),(A Z)\<rbrakk> \<Longrightarrow>
    \<forall>Z. \<Gamma>,{}\<turnstile>\<^bsub>/F\<^esub> (P Z) p (Q Z),(A Z)"
  by (blast intro: augment_Faults)

lemma augment_FaultsUNIV:
 "\<lbrakk>\<forall>Z. \<Gamma>,{}\<turnstile>\<^bsub>/F\<^esub> (P Z) p (Q Z),(A Z)\<rbrakk> \<Longrightarrow>
    \<forall>Z. \<Gamma>,{}\<turnstile>\<^bsub>/UNIV\<^esub> (P Z) p (Q Z),(A Z)"
  by (blast intro: augment_Faults)

lemma PostConjI [trans]:
  "\<lbrakk>\<Gamma>,\<Theta>\<turnstile>\<^bsub>/F\<^esub> P c Q,A; \<Gamma>,\<Theta>\<turnstile>\<^bsub>/F\<^esub> P c R,B\<rbrakk> \<Longrightarrow> \<Gamma>,\<Theta>\<turnstile>\<^bsub>/F\<^esub> P c (Q \<inter> R),(A \<inter> B)"
  by (rule PostConjI)

lemma PostConjI' :
  "\<lbrakk>\<Gamma>,\<Theta>\<turnstile>\<^bsub>/F\<^esub> P c Q,A; \<Gamma>,\<Theta>\<turnstile>\<^bsub>/F\<^esub> P c Q,A \<Longrightarrow> \<Gamma>,\<Theta>\<turnstile>\<^bsub>/F\<^esub> P c R,B\<rbrakk>
  \<Longrightarrow> \<Gamma>,\<Theta>\<turnstile>\<^bsub>/F\<^esub> P c (Q \<inter> R),(A \<inter> B)"
  by (rule PostConjI) iprover+

lemma PostConjE [consumes 1]:
  assumes conj: "\<Gamma>,\<Theta>\<turnstile>\<^bsub>/F\<^esub> P c (Q \<inter> R),(A \<inter> B)"
  assumes E: "\<lbrakk>\<Gamma>,\<Theta>\<turnstile>\<^bsub>/F\<^esub> P c Q,A; \<Gamma>,\<Theta>\<turnstile>\<^bsub>/F\<^esub> P c R,B\<rbrakk> \<Longrightarrow> S"
  shows "S"
proof -
  from conj have "\<Gamma>,\<Theta>\<turnstile>\<^bsub>/F\<^esub> P c Q,A" by (rule conseqPost) blast+
  moreover
  from conj have "\<Gamma>,\<Theta>\<turnstile>\<^bsub>/F\<^esub> P c R,B" by (rule conseqPost) blast+
  ultimately show "S"
    by (rule E)
qed

subsection {* Rules for Single-Step Proof \label{sec:hoare-isar} *}

text {*
 We are now ready to introduce a set of Hoare rules to be used in
 single-step structured proofs in Isabelle/Isar.

 \medskip Assertions of Hoare Logic may be manipulated in
 calculational proofs, with the inclusion expressed in terms of sets
 or predicates.  Reversed order is supported as well.
*}

lemma annotateI [trans]:
"\<lbrakk>\<Gamma>,\<Theta>\<turnstile>\<^bsub>/F\<^esub>P anno Q,A; c = anno\<rbrakk> \<Longrightarrow> \<Gamma>,\<Theta>\<turnstile>\<^bsub>/F\<^esub>P c Q,A"
  by simp

lemma annotate_normI:
  assumes deriv_anno: "\<Gamma>,\<Theta>\<turnstile>\<^bsub>/F\<^esub>P anno Q,A"
  assumes norm_eq: "normalize c = normalize anno"
  shows "\<Gamma>,\<Theta>\<turnstile>\<^bsub>/F\<^esub>P c Q,A"
proof -
  from NormalizeI [OF deriv_anno] norm_eq
  have "\<Gamma>,\<Theta>\<turnstile>\<^bsub>/F \<^esub>P normalize c Q,A"
    by simp
  from NormalizeD [OF this]
  show ?thesis .
qed

lemma annotateWhile:
"\<lbrakk>\<Gamma>,\<Theta>\<turnstile>\<^bsub>/F\<^esub> P (whileAnnoG gs b I V c) Q,A\<rbrakk> \<Longrightarrow> \<Gamma>,\<Theta>\<turnstile>\<^bsub>/F\<^esub> P (while gs b c) Q,A"
  by (simp add: whileAnnoG_def)

lemma reannotateWhile:
"\<lbrakk>\<Gamma>,\<Theta>\<turnstile>\<^bsub>/F\<^esub> P (whileAnnoG gs b I V c) Q,A\<rbrakk> \<Longrightarrow> \<Gamma>,\<Theta>\<turnstile>\<^bsub>/F\<^esub> P (whileAnnoG gs b J V c) Q,A"
  by (simp add: whileAnnoG_def)

lemma reannotateWhileNoGuard:
"\<lbrakk>\<Gamma>,\<Theta>\<turnstile>\<^bsub>/F\<^esub> P (whileAnno b I V c) Q,A\<rbrakk> \<Longrightarrow> \<Gamma>,\<Theta>\<turnstile>\<^bsub>/F\<^esub> P (whileAnno b J V c) Q,A"
  by (simp add: whileAnno_def)

lemma [trans] : "P' \<subseteq> P \<Longrightarrow> \<Gamma>,\<Theta>\<turnstile>\<^bsub>/F\<^esub> P c Q,A \<Longrightarrow> \<Gamma>,\<Theta>\<turnstile>\<^bsub>/F\<^esub> P' c Q,A"
  by (rule conseqPre)

lemma [trans]: "Q \<subseteq> Q' \<Longrightarrow> \<Gamma>,\<Theta>\<turnstile>\<^bsub>/F\<^esub> P c Q,A \<Longrightarrow> \<Gamma>,\<Theta>\<turnstile>\<^bsub>/F\<^esub> P c Q',A"
  by (rule conseqPost) blast+

lemma [trans]:
    "\<Gamma>,\<Theta>\<turnstile>\<^bsub>/F\<^esub> {s. P s} c Q,A \<Longrightarrow> (\<And>s. P' s \<longrightarrow> P s) \<Longrightarrow> \<Gamma>,\<Theta>\<turnstile>\<^bsub>/F\<^esub> {s. P' s} c Q,A"
  by (rule conseqPre) auto

lemma [trans]:
    "(\<And>s. P' s \<longrightarrow> P s) \<Longrightarrow> \<Gamma>,\<Theta>\<turnstile>\<^bsub>/F\<^esub> {s. P s} c Q,A \<Longrightarrow> \<Gamma>,\<Theta>\<turnstile>\<^bsub>/F\<^esub> {s. P' s} c Q,A"
  by (rule conseqPre) auto

lemma [trans]:
    "\<Gamma>,\<Theta>\<turnstile>\<^bsub>/F\<^esub>P c {s. Q s},A \<Longrightarrow> (\<And>s. Q s \<longrightarrow> Q' s) \<Longrightarrow> \<Gamma>,\<Theta>\<turnstile>\<^bsub>/F\<^esub>P c {s. Q' s},A"
  by (rule conseqPost) auto

lemma [trans]:
    "(\<And>s. Q s \<longrightarrow> Q' s) \<Longrightarrow> \<Gamma>,\<Theta>\<turnstile>\<^bsub>/F\<^esub>P c {s. Q s},A \<Longrightarrow> \<Gamma>,\<Theta>\<turnstile>\<^bsub>/F\<^esub>P c {s. Q' s},A"
  by (rule conseqPost) auto

lemma [intro?]: "\<Gamma>,\<Theta>\<turnstile>\<^bsub>/F\<^esub> P Skip P,A"
  by (rule Skip) auto

lemma CondInt [trans,intro?]:
  "\<lbrakk>\<Gamma>,\<Theta>\<turnstile>\<^bsub>/F\<^esub> (P \<inter> b) c1 Q,A; \<Gamma>,\<Theta>\<turnstile>\<^bsub>/F\<^esub> (P \<inter> - b) c2 Q,A\<rbrakk>
   \<Longrightarrow>
   \<Gamma>,\<Theta>\<turnstile>\<^bsub>/F\<^esub> P (Cond b c1 c2) Q,A"
  by (rule Cond) auto

lemma CondConj [trans, intro?]:
  "\<lbrakk>\<Gamma>,\<Theta>\<turnstile>\<^bsub>/F\<^esub> {s. P s \<and> b s} c1 Q,A; \<Gamma>,\<Theta>\<turnstile>\<^bsub>/F\<^esub> {s. P s \<and> \<not> b s} c2 Q,A\<rbrakk>
   \<Longrightarrow>
   \<Gamma>,\<Theta>\<turnstile>\<^bsub>/F\<^esub> {s. P s} (Cond {s. b s} c1 c2) Q,A"
  by (rule Cond) auto

lemma WhileInvInt [intro?]:
    "\<Gamma>,\<Theta>\<turnstile>\<^bsub>/F\<^esub> (P \<inter> b) c P,A \<Longrightarrow> \<Gamma>,\<Theta>\<turnstile>\<^bsub>/F\<^esub> P (whileAnno b P V c) (P \<inter> -b),A"
  by (rule While) auto

lemma WhileInt [intro?]:
    "\<Gamma>,\<Theta>\<turnstile>\<^bsub>/F\<^esub> (P \<inter> b) c P,A
    \<Longrightarrow>
    \<Gamma>,\<Theta>\<turnstile>\<^bsub>/F\<^esub> P (whileAnno b {s. undefined} V c) (P \<inter> -b),A"
  by (unfold whileAnno_def)
     (rule HoarePartialDef.While [THEN conseqPrePost],auto)

lemma WhileInvConj [intro?]:
  "\<Gamma>,\<Theta>\<turnstile>\<^bsub>/F\<^esub> {s. P s \<and> b s} c {s. P s},A
  \<Longrightarrow> \<Gamma>,\<Theta>\<turnstile>\<^bsub>/F\<^esub> {s. P s} (whileAnno {s. b s} {s. P s} V c) {s. P s \<and> \<not> b s},A"
  by (simp add: While Collect_conj_eq Collect_neg_eq)

lemma WhileConj [intro?]:
  "\<Gamma>,\<Theta>\<turnstile>\<^bsub>/F\<^esub> {s. P s \<and> b s} c {s. P s},A
    \<Longrightarrow>
\<Gamma>,\<Theta>\<turnstile>\<^bsub>/F\<^esub> {s. P s} (whileAnno {s. b s} {s. undefined} V c) {s. P s \<and> \<not> b s},A"
  by (unfold whileAnno_def)
     (simp add: HoarePartialDef.While [THEN conseqPrePost]
      Collect_conj_eq Collect_neg_eq)

(* FIXME: Add rules for guarded while *)

end


theory SINVAR_DomainHierarchyNG_impl
imports SINVAR_DomainHierarchyNG "../TopoS_Interface_impl"
begin

subsubsection {* SecurityInvariant DomainHierarchy List Implementation *}

code_identifier code_module SINVAR_DomainHierarchyNG_impl => (Scala) SINVAR_DomainHierarchyNG

fun sinvar :: "'v list_graph \<Rightarrow> ('v \<Rightarrow> domainNameTrust) \<Rightarrow> bool" where
  "sinvar G nP = (\<forall> (s, r) \<in> set (edgesL G). (nP r) \<sqsubseteq>\<^sub>t\<^sub>r\<^sub>u\<^sub>s\<^sub>t (nP s))"

definition DomainHierarchyNG_sanity_check_config :: "domainNameTrust list \<Rightarrow> domainTree \<Rightarrow> bool" where
  "DomainHierarchyNG_sanity_check_config host_attributes tree = (\<forall> c \<in> set host_attributes.
    case c of Unassigned \<Rightarrow> True
            | DN (level, trust) \<Rightarrow> valid_hierarchy_pos tree level
   )"

fun verify_globals :: "'v list_graph \<Rightarrow> ('v \<Rightarrow> domainNameTrust) \<Rightarrow> domainTree \<Rightarrow> bool" where
  "verify_globals G nP tree = (\<forall> v \<in> set (nodesL G).
    case (nP v) of Unassigned \<Rightarrow> True | DN (level, trust) \<Rightarrow> valid_hierarchy_pos tree level
   )"

(*TODO: to get rid of verify_globals
  this stronger DomainHierarchyNG_sanity_check_config sanity checker checks the config
  for all graphs!*)
lemma "DomainHierarchyNG_sanity_check_config c tree \<Longrightarrow>
    {x. \<exists>v. nP v = x} = set c \<Longrightarrow>
    verify_globals G nP tree"
  apply(simp add: DomainHierarchyNG_sanity_check_config_def split: if_split_asm)
  apply(clarify)
  apply(case_tac "nP v")
   apply(simp_all)
  apply(clarify)
  by force

definition DomainHierarchyNG_offending_list:: "'v list_graph \<Rightarrow> ('v \<Rightarrow> domainNameTrust) \<Rightarrow> ('v \<times> 'v) list list" where
  "DomainHierarchyNG_offending_list G nP = (if sinvar G nP then
    []
   else
    [ [e \<leftarrow> edgesL G. case e of (s,r) \<Rightarrow> \<not> (nP r) \<sqsubseteq>\<^sub>t\<^sub>r\<^sub>u\<^sub>s\<^sub>t (nP s) ] ])"

lemma "DomainHierarchyNG.node_props P =
  (\<lambda>i. case node_properties P i of None \<Rightarrow> SINVAR_DomainHierarchyNG.default_node_properties | Some property \<Rightarrow> property)"
by(fact SecurityInvariant.node_props.simps[OF TopoS_DomainHierarchyNG, of "P"])

definition "NetModel_node_props P = (\<lambda> i. (case (node_properties P) i of Some property \<Rightarrow> property | None \<Rightarrow> SINVAR_DomainHierarchyNG.default_node_properties))"
(*

(*TODO does this work?*)
lemma[code_unfold]: "DomainHierarchyNG.node_props P = NetModel_node_props P"
by(simp add: NetModel_node_props_def)

definition "DomainHierarchyNG_eval G P = (wf_list_graph G \<and>
  sinvar G (SecurityInvariant.node_props SINVAR_DomainHierarchyNG.default_node_properties P))"

interpretation DomainHierarchyNG_impl:TopoS_List_Impl
  where default_node_properties=SINVAR_DomainHierarchyNG.default_node_properties
  and sinvar_spec=SINVAR_DomainHierarchyNG.sinvar
  and sinvar_impl=sinvar
  and receiver_violation=SINVAR_DomainHierarchyNG.receiver_violation
  and offending_flows_impl=DomainHierarchyNG_offending_list
  and node_props_impl=NetModel_node_props
  and eval_impl=DomainHierarchyNG_eval
 apply(unfold TopoS_List_Impl_def)
 apply(rule conjI)
  apply(simp add: TopoS_DomainHierarchyNG list_graph_to_graph_def; fail)
 apply(rule conjI)
  apply(simp add: list_graph_to_graph_def DomainHierarchyNG_offending_set
        DomainHierarchyNG_offending_set_def DomainHierarchyNG_offending_list_def; fail)
 apply(rule conjI)
  apply(simp only: NetModel_node_props_def)
  apply(metis DomainHierarchyNG.node_props.simps DomainHierarchyNG.node_props_eq_node_props_formaldef)
 apply(simp only: DomainHierarchyNG_eval_def)
 apply(intro allI)
 apply(rule TopoS_eval_impl_proofrule[OF TopoS_DomainHierarchyNG])
 apply(simp add: list_graph_to_graph_def)
done

subsubsection {* DomainHierarchyNG packing *}
  definition SINVAR_LIB_DomainHierarchyNG :: "('v::vertex, domainNameTrust) TopoS_packed" where
    "SINVAR_LIB_DomainHierarchyNG \<equiv>
    \<lparr> nm_name = ''DomainHierarchyNG'',
      nm_receiver_violation = SINVAR_DomainHierarchyNG.receiver_violation,
      nm_default = SINVAR_DomainHierarchyNG.default_node_properties,
      nm_sinvar = sinvar,
      nm_offending_flows = DomainHierarchyNG_offending_list,
      nm_node_props = NetModel_node_props,
      nm_eval = DomainHierarchyNG_eval
      \<rparr>"
  interpretation SINVAR_LIB_DomainHierarchyNG_interpretation: TopoS_modelLibrary SINVAR_LIB_DomainHierarchyNG
      SINVAR_DomainHierarchyNG.sinvar
    apply(unfold TopoS_modelLibrary_def SINVAR_LIB_DomainHierarchyNG_def)
    apply(rule conjI)
     apply(simp)
    apply(simp)
    by(unfold_locales)

text {*Examples:*}
definition example_TUM_net :: "string list_graph" where
  "example_TUM_net \<equiv> \<lparr> nodesL=[''Gateway'', ''LowerSVR'', ''UpperSRV''],
        edgesL=[
          (''Gateway'',''LowerSVR''), (''Gateway'',''UpperSRV''),
          (''LowerSVR'', ''Gateway''),
          (''UpperSRV'', ''Gateway'')
        ] \<rparr>"
value "wf_list_graph example_TUM_net"

definition example_TUM_config :: "string \<Rightarrow> domainNameTrust" where
  "example_TUM_config \<equiv> ((\<lambda> e. default_node_properties)
        (''Gateway'':= DN (''ACD''--''AISD''--Leaf, 1),
         ''LowerSVR'':= DN (''ACD''--''AISD''--Leaf, 0),
         ''UpperSRV'':= DN (''ACD''--Leaf, 0)
       ))"

definition example_TUM_hierarchy :: "domainTree" where
"example_TUM_hierarchy \<equiv> (Department ''ACD'' [
           Department ''AISD'' []
       ])"

value "verify_globals example_TUM_net example_TUM_config example_TUM_hierarchy"
value "sinvar     example_TUM_net example_TUM_config"

definition example_TUM_net_invalid where
"example_TUM_net_invalid \<equiv> example_TUM_net\<lparr>edgesL :=
    (''LowerSRV'', ''UpperSRV'')#(edgesL example_TUM_net)\<rparr>"

value "verify_globals example_TUM_net_invalid example_TUM_config example_TUM_hierarchy"
value "sinvar     example_TUM_net_invalid example_TUM_config"
value "DomainHierarchyNG_offending_list example_TUM_net_invalid example_TUM_config"

hide_const (open) NetModel_node_props

hide_const (open) sinvar

end


(*  Title:      HOL/Library/Rewrite.thy
    Author:     Christoph Traut, Lars Noschinski, TU Muenchen

Proof method "rewrite" with support for subterm-selection based on patterns.
*)

theory Rewrite
imports Main
begin

consts rewrite_HOLE :: "'a::{}"  ("\<hole>")

lemma eta_expand:
  fixes f :: "'a::{} \<Rightarrow> 'b::{}"
  shows "f \<equiv> \<lambda>x. f x" .

lemma rewr_imp:
  assumes "PROP A \<equiv> PROP B"
  shows "(PROP A \<Longrightarrow> PROP C) \<equiv> (PROP B \<Longrightarrow> PROP C)"
  apply (rule Pure.equal_intr_rule)
  apply (drule equal_elim_rule2[OF assms]; assumption)
  apply (drule equal_elim_rule1[OF assms]; assumption)
  done

lemma imp_cong_eq:
  "(PROP A \<Longrightarrow> (PROP B \<Longrightarrow> PROP C) \<equiv> (PROP B' \<Longrightarrow> PROP C')) \<equiv>
    ((PROP B \<Longrightarrow> PROP A \<Longrightarrow> PROP C) \<equiv> (PROP B' \<Longrightarrow> PROP A \<Longrightarrow> PROP C'))"
  apply (intro Pure.equal_intr_rule)
     apply (drule (1) cut_rl; drule Pure.equal_elim_rule1 Pure.equal_elim_rule2; assumption)+
   apply (drule Pure.equal_elim_rule1 Pure.equal_elim_rule2; assumption)+
  done

ML_file "cconv.ML"
ML_file "rewrite.ML"

end


(*  Author:      Lukas Bulwahn, TU Muenchen, 2009  *)

theory Execute
imports FJSound
begin

section {* Executing FeatherweightJava programs *}
text {* We execute FeatherweightJava programs using the predicate compiler. *}

code_pred (modes: i => i => i => bool,
  i => i => o => bool as supertypes_of) subtyping .

thm subtyping.equation

text {* The reduction relation requires that we inverse the @{term List.append} function.
Therefore, we define a new predicate append and derive introduction rules. *}

definition append where "append xs ys zs = (zs = xs @ ys)"

lemma [code_pred_intro]: "append [] xs xs"
unfolding append_def by simp

lemma [code_pred_intro]: "append xs ys zs \<Longrightarrow> append (x#xs) ys (x#zs)"
unfolding append_def by simp

text {* With this at hand, we derive new introduction rules for the reduction relation: *}

lemma rc_invk_arg': "CT \<turnstile> ei \<rightarrow> ei' \<Longrightarrow> append el (ei # er) e' \<Longrightarrow> append el (ei' # er) e'' \<Longrightarrow>
CT \<turnstile> MethodInvk e m e' \<rightarrow> MethodInvk e m e''"
unfolding append_def by simp (rule reduction.intros(6))

lemma rc_new_arg': "CT \<turnstile> ei \<rightarrow> ei' \<Longrightarrow> append el (ei # er) e \<Longrightarrow> append el (ei' # er) e'
   ==> CT \<turnstile> New C e \<rightarrow> New C e'"
unfolding append_def by simp (rule reduction.intros(7))

lemmas [code_pred_intro] = reduction.intros(1-5)
  rc_invk_arg' rc_new_arg' reduction.intros(8)

code_pred (modes: i => i => i => bool, i => i => o => bool as reduce) reduction
proof -
  case append
  from this show thesis
    unfolding append_def by (cases xa) fastforce+
next
  case reduction
  from reduction.prems show thesis
  proof (cases rule: reduction.cases)
    case r_field
    with reduction(1) show thesis by fastforce
  next
    case r_invk
    with reduction(2) show thesis by fastforce
  next
    case r_cast
    with reduction(3) show thesis by fastforce
  next
    case rc_field
    with reduction(4) show thesis by fastforce
  next
    case rc_invk_recv
    with reduction(5) show thesis by fastforce
  next
    case rc_invk_arg
    with reduction(6) show thesis
      unfolding append_def by fastforce
  next
    case rc_new_arg
    with reduction(7) show thesis
      unfolding append_def by fastforce
  next
    case rc_cast
    with reduction(8) show thesis by fastforce
  qed
qed

thm reduction.equation

code_pred reductions .

thm reductions.equation

text {* We also make the class typing executable: this requires that
  we derive rules for @{term "method_typing"}. *}

definition method_typing_aux
where
  "method_typing_aux CT m D Cs C = (\<not> (\<forall>Ds D0. mtype(CT,m,D) = Ds \<rightarrow> D0 \<longrightarrow> Cs = Ds \<and> C = D0))"

lemma method_typing_aux:
  "(\<forall>Ds D0. mtype(CT,m,D) = Ds \<rightarrow> D0 \<longrightarrow> Cs = Ds \<and> C = D0) = (\<not> method_typing_aux CT m D Cs C)"
unfolding method_typing_aux_def by auto

lemma [code_pred_intro]:
  "mtype(CT,m,D) = Ds \<rightarrow> D0 \<Longrightarrow> Cs \<noteq> Ds \<Longrightarrow> method_typing_aux CT m D Cs C"
unfolding method_typing_aux_def by auto

lemma [code_pred_intro]:
  "mtype(CT,m,D) = Ds \<rightarrow> D0 \<Longrightarrow> C \<noteq> D0 \<Longrightarrow> method_typing_aux CT m D Cs C"
unfolding method_typing_aux_def by auto

declare method_typing.intros[unfolded method_typing_aux, code_pred_intro]

declare class_typing.intros[unfolded append_def[symmetric], code_pred_intro]

code_pred (modes: i => i => bool) class_typing
proof -
  case class_typing
  from class_typing.cases[OF class_typing.prems, of thesis] this(1) show thesis
    unfolding append_def by fastforce
next
  case method_typing
  from method_typing.cases[OF method_typing.prems, of thesis] this(1) show thesis
    unfolding append_def method_typing_aux_def by fastforce
next
  case method_typing_aux
  from this show thesis
    unfolding method_typing_aux_def by auto
qed

subsection {* A simple example *}

text {* We now execute a simple FJ example program: *}

abbreviation A :: className
where "A == Suc 0"

abbreviation B :: className
where "B == 2"

abbreviation cPair :: className
where "cPair == 3"

definition classA_Def :: classDef
where
  "classA_Def = \<lparr> cName = A, cSuper = Object, cFields = [], cConstructor = \<lparr>kName = A, kParams = [], kSuper = [], kInits = []\<rparr>, cMethods = []\<rparr>"

definition
  "classB_Def = \<lparr> cName = B, cSuper = Object, cFields = [], cConstructor = \<lparr>kName = B, kParams = [], kSuper = [], kInits = []\<rparr>, cMethods = []\<rparr>"

abbreviation ffst :: varName
where
  "ffst == 4"

abbreviation fsnd :: varName
where
  "fsnd == 5"

abbreviation setfst :: methodName
where
  "setfst == 6"

abbreviation newfst :: varName
where
  "newfst == 7"

definition classPair_Def :: classDef
where
  "classPair_Def = \<lparr> cName = cPair, cSuper = Object,
    cFields = [\<lparr> vdName = ffst, vdType = Object \<rparr>, \<lparr> vdName = fsnd, vdType = Object \<rparr>],
    cConstructor = \<lparr> kName = cPair, kParams = [\<lparr> vdName = ffst, vdType = Object \<rparr>, \<lparr> vdName = fsnd, vdType = Object \<rparr>], kSuper = [], kInits = [ffst, fsnd]\<rparr> ,
    cMethods = [\<lparr> mReturn = cPair, mName = setfst, mParams = [\<lparr>vdName = newfst, vdType = Object \<rparr>],
      mBody = New cPair [Var newfst, FieldProj (Var this) fsnd]  \<rparr>]\<rparr>"

definition exampleProg :: classTable
  where "exampleProg = (((%x. None)(A := Some classA_Def))(B := Some classB_Def))(cPair := Some classPair_Def)"

value "exampleProg \<turnstile> classA_Def OK"
value "exampleProg \<turnstile> classB_Def OK"
value "exampleProg \<turnstile> classPair_Def OK"

values "{x. exampleProg \<turnstile> MethodInvk (New cPair [New A [], New B []]) setfst [New B []] \<rightarrow>* x}"
values "{x. exampleProg \<turnstile> FieldProj (FieldProj (New cPair [New cPair [New A [], New B []], New A []]) ffst) fsnd \<rightarrow>* x}"

end