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

(*  Title:      HoarePartialDef.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
*)

section \<open>Hoare Logic for Partial Correctness\<close>
theory HoarePartialDef imports Semantic begin

type_synonym ('s,'p) quadruple = "('s assn \<times> 'p \<times> 's assn \<times> 's assn)"

subsection \<open>Validity of Hoare Tuples: \<open>\<Gamma>,\<Theta>\<Turnstile>\<^bsub>/F\<^esub> P c Q,A\<close>\<close>

definition
  valid :: "[('s,'p,'f) body,'f set,'s assn,('s,'p,'f) com,'s assn,'s assn] => bool"
                ("_\<Turnstile>\<^bsub>'/_\<^esub>/ _ _ _,_"  [61,60,1000, 20, 1000,1000] 60)
where
 "\<Gamma>\<Turnstile>\<^bsub>/F\<^esub> P c Q,A \<equiv> \<forall>s t. \<Gamma>\<turnstile>\<langle>c,s\<rangle> \<Rightarrow> t \<longrightarrow> s \<in> Normal ` P \<longrightarrow> t \<notin> Fault ` F
                      \<longrightarrow>  t \<in>  Normal ` Q \<union> Abrupt ` A"

definition
  cvalid::
  "[('s,'p,'f) body,('s,'p) quadruple set,'f set,
      's assn,('s,'p,'f) com,'s assn,'s assn] =>bool"
                ("_,_\<Turnstile>\<^bsub>'/_\<^esub>/ _ _ _,_"  [61,60,60,1000, 20, 1000,1000] 60)
where
 "\<Gamma>,\<Theta>\<Turnstile>\<^bsub>/F\<^esub> P c Q,A \<equiv> (\<forall>(P,p,Q,A)\<in>\<Theta>. \<Gamma>\<Turnstile>\<^bsub>/F\<^esub> P (Call p) Q,A) \<longrightarrow> \<Gamma> \<Turnstile>\<^bsub>/F\<^esub> P c Q,A"

definition
  nvalid :: "[('s,'p,'f) body,nat,'f set,
                's assn,('s,'p,'f) com,'s assn,'s assn] => bool"
                ("_\<Turnstile>_:\<^bsub>'/_\<^esub>/ _ _ _,_"  [61,60,60,1000, 20, 1000,1000] 60)
where
 "\<Gamma>\<Turnstile>n:\<^bsub>/F\<^esub> P c Q,A \<equiv> \<forall>s t. \<Gamma>\<turnstile>\<langle>c,s \<rangle> =n\<Rightarrow> t \<longrightarrow> s \<in> Normal ` P \<longrightarrow> t \<notin> Fault ` F
                        \<longrightarrow> t \<in>  Normal ` Q \<union> Abrupt ` A"

definition
  cnvalid::
  "[('s,'p,'f) body,('s,'p) quadruple set,nat,'f set,
     's assn,('s,'p,'f) com,'s assn,'s assn] \<Rightarrow> bool"
                ("_,_\<Turnstile>_:\<^bsub>'/_\<^esub>/ _ _ _,_"  [61,60,60,60,1000, 20, 1000,1000] 60)
where
 "\<Gamma>,\<Theta>\<Turnstile>n:\<^bsub>/F\<^esub> P c Q,A \<equiv> (\<forall>(P,p,Q,A)\<in>\<Theta>. \<Gamma>\<Turnstile>n:\<^bsub>/F\<^esub> P (Call p) Q,A) \<longrightarrow> \<Gamma> \<Turnstile>n:\<^bsub>/F\<^esub> P c Q,A"

notation (ASCII)
  valid  ("_|='/_/ _ _ _,_"  [61,60,1000, 20, 1000,1000] 60) and
  cvalid  ("_,_|='/_/ _ _ _,_"  [61,60,60,1000, 20, 1000,1000] 60) and
  nvalid  ("_|=_:'/_/ _ _ _,_"  [61,60,60,1000, 20, 1000,1000] 60) and
  cnvalid  ("_,_|=_:'/_/ _ _ _,_"  [61,60,60,60,1000, 20, 1000,1000] 60)

subsection \<open>Properties of Validity\<close>

lemma valid_iff_nvalid: "\<Gamma>\<Turnstile>\<^bsub>/F\<^esub> P c Q,A = (\<forall>n. \<Gamma>\<Turnstile>n:\<^bsub>/F\<^esub> P c Q,A)"
  apply (simp only: valid_def nvalid_def exec_iff_execn )
  apply (blast dest: exec_final_notin_to_execn)
  done

lemma cnvalid_to_cvalid: "(\<forall>n. \<Gamma>,\<Theta>\<Turnstile>n:\<^bsub>/F\<^esub> P c Q,A) \<Longrightarrow> \<Gamma>,\<Theta>\<Turnstile>\<^bsub>/F\<^esub> P c Q,A"
  apply (unfold cvalid_def cnvalid_def valid_iff_nvalid [THEN eq_reflection])
  apply fast
  done

lemma nvalidI:
 "\<lbrakk>\<And>s t. \<lbrakk>\<Gamma>\<turnstile>\<langle>c,Normal s \<rangle> =n\<Rightarrow> t;s \<in> P; t\<notin> Fault ` F\<rbrakk> \<Longrightarrow> t \<in> Normal ` Q \<union> Abrupt ` A\<rbrakk>
  \<Longrightarrow> \<Gamma>\<Turnstile>n:\<^bsub>/F\<^esub> P c Q,A"
  by (auto simp add: nvalid_def)

lemma validI:
 "\<lbrakk>\<And>s t. \<lbrakk>\<Gamma>\<turnstile>\<langle>c,Normal s \<rangle> \<Rightarrow> t;s \<in> P; t\<notin>Fault ` F\<rbrakk> \<Longrightarrow> t \<in> Normal ` Q \<union> Abrupt ` A\<rbrakk>
  \<Longrightarrow> \<Gamma>\<Turnstile>\<^bsub>/F\<^esub> P c Q,A"
  by (auto simp add: valid_def)

lemma cvalidI:
 "\<lbrakk>\<And>s t. \<lbrakk>\<forall>(P,p,Q,A)\<in>\<Theta>. \<Gamma>\<Turnstile>\<^bsub>/F\<^esub> P (Call p) Q,A;\<Gamma>\<turnstile>\<langle>c,Normal s\<rangle> \<Rightarrow> t;s \<in> P;t\<notin>Fault ` F\<rbrakk>
          \<Longrightarrow> t \<in> Normal ` Q \<union> Abrupt ` A\<rbrakk>
  \<Longrightarrow> \<Gamma>,\<Theta>\<Turnstile>\<^bsub>/F\<^esub> P c Q,A"
  by (auto simp add: cvalid_def valid_def)

lemma cvalidD:
 "\<lbrakk>\<Gamma>,\<Theta>\<Turnstile>\<^bsub>/F\<^esub> P c Q,A;\<forall>(P,p,Q,A)\<in>\<Theta>. \<Gamma>\<Turnstile>\<^bsub>/F\<^esub> P (Call p) Q,A;\<Gamma>\<turnstile>\<langle>c,Normal s\<rangle> \<Rightarrow> t;s \<in> P;t\<notin>Fault ` F\<rbrakk>
  \<Longrightarrow> t \<in> Normal ` Q \<union> Abrupt ` A"
  by (auto simp add: cvalid_def valid_def)

lemma cnvalidI:
 "\<lbrakk>\<And>s t. \<lbrakk>\<forall>(P,p,Q,A)\<in>\<Theta>. \<Gamma>\<Turnstile>n:\<^bsub>/F\<^esub> P (Call p) Q,A;
   \<Gamma>\<turnstile>\<langle>c,Normal s \<rangle> =n\<Rightarrow> t;s \<in> P;t\<notin>Fault ` F\<rbrakk>
          \<Longrightarrow> t \<in> Normal ` Q \<union> Abrupt ` A\<rbrakk>
  \<Longrightarrow> \<Gamma>,\<Theta>\<Turnstile>n:\<^bsub>/F\<^esub> P c Q,A"
  by (auto simp add: cnvalid_def nvalid_def)

lemma cnvalidD:
 "\<lbrakk>\<Gamma>,\<Theta>\<Turnstile>n:\<^bsub>/F\<^esub> P c Q,A;\<forall>(P,p,Q,A)\<in>\<Theta>. \<Gamma>\<Turnstile>n:\<^bsub>/F\<^esub> P (Call p) Q,A;
   \<Gamma>\<turnstile>\<langle>c,Normal s \<rangle> =n\<Rightarrow> t;s \<in> P;
   t\<notin>Fault ` F\<rbrakk>
  \<Longrightarrow> t \<in> Normal ` Q \<union> Abrupt ` A"
  by (auto simp add: cnvalid_def nvalid_def)

lemma nvalid_augment_Faults:
  assumes validn:"\<Gamma>\<Turnstile>n:\<^bsub>/F\<^esub> P c Q,A"
  assumes F': "F \<subseteq> F'"
  shows "\<Gamma>\<Turnstile>n:\<^bsub>/F'\<^esub> P c Q,A"
proof (rule nvalidI)
  fix s t
  assume exec: "\<Gamma>\<turnstile>\<langle>c,Normal s \<rangle> =n\<Rightarrow> t"
  assume P: "s \<in> P"
  assume F: "t \<notin> Fault ` F'"
  with F' have "t \<notin> Fault ` F"
    by blast
  with exec P validn
  show "t \<in> Normal ` Q \<union> Abrupt ` A"
    by (auto simp add: nvalid_def)
qed

lemma valid_augment_Faults:
  assumes validn:"\<Gamma>\<Turnstile>\<^bsub>/F\<^esub> P c Q,A"
  assumes F': "F \<subseteq> F'"
  shows "\<Gamma>\<Turnstile>\<^bsub>/F'\<^esub> P c Q,A"
proof (rule validI)
  fix s t
  assume exec: "\<Gamma>\<turnstile>\<langle>c,Normal s \<rangle> \<Rightarrow> t"
  assume P: "s \<in> P"
  assume F: "t \<notin> Fault ` F'"
  with F' have "t \<notin> Fault ` F"
    by blast
  with exec P validn
  show "t \<in> Normal ` Q \<union> Abrupt ` A"
    by (auto simp add: valid_def)
qed

lemma nvalid_to_nvalid_strip:
  assumes validn:"\<Gamma>\<Turnstile>n:\<^bsub>/F\<^esub> P c Q,A"
  assumes F': "F' \<subseteq> -F"
  shows "strip F' \<Gamma>\<Turnstile>n:\<^bsub>/F\<^esub> P c Q,A"
proof (rule nvalidI)
  fix s t
  assume exec_strip: "strip F' \<Gamma>\<turnstile>\<langle>c,Normal s \<rangle> =n\<Rightarrow> t"
  assume P: "s \<in> P"
  assume F: "t \<notin> Fault ` F"
  from exec_strip obtain t' where
    exec: "\<Gamma>\<turnstile>\<langle>c,Normal s \<rangle> =n\<Rightarrow> t'" and
    t': "t' \<in> Fault ` (-F') \<longrightarrow> t'=t" "\<not> isFault t' \<longrightarrow> t'=t"
    by (blast dest: execn_strip_to_execn)
  show "t \<in> Normal ` Q \<union> Abrupt ` A"
  proof (cases "t' \<in> Fault ` F")
    case True
    with t' F F' have False
      by blast
    thus ?thesis ..
  next
    case False
    with exec P validn
    have *: "t' \<in> Normal ` Q \<union> Abrupt ` A"
      by (auto simp add: nvalid_def)
    with t' have "t'=t"
      by auto
    with * show ?thesis
      by simp
  qed
qed

lemma valid_to_valid_strip:
  assumes valid:"\<Gamma>\<Turnstile>\<^bsub>/F\<^esub> P c Q,A"
  assumes F': "F' \<subseteq> -F"
  shows "strip F' \<Gamma>\<Turnstile>\<^bsub>/F\<^esub> P c Q,A"
proof (rule validI)
  fix s t
  assume exec_strip: "strip F' \<Gamma>\<turnstile>\<langle>c,Normal s \<rangle> \<Rightarrow> t"
  assume P: "s \<in> P"
  assume F: "t \<notin> Fault ` F"
  from exec_strip obtain t' where
    exec: "\<Gamma>\<turnstile>\<langle>c,Normal s \<rangle> \<Rightarrow> t'" and
    t': "t' \<in> Fault ` (-F') \<longrightarrow> t'=t" "\<not> isFault t' \<longrightarrow> t'=t"
    by (blast dest: exec_strip_to_exec)
  show "t \<in> Normal ` Q \<union> Abrupt ` A"
  proof (cases "t' \<in> Fault ` F")
    case True
    with t' F F' have False
      by blast
    thus ?thesis ..
  next
    case False
    with exec P valid
    have *: "t' \<in> Normal ` Q \<union> Abrupt ` A"
      by (auto simp add: valid_def)
    with t' have "t'=t"
      by auto
    with * show ?thesis
      by simp
  qed
qed

subsection \<open>The Hoare Rules: \<open>\<Gamma>,\<Theta>\<turnstile>\<^bsub>/F\<^esub> P c Q,A\<close>\<close>

lemma mono_WeakenContext: "A \<subseteq> B \<Longrightarrow>
        (\<lambda>(P, c, Q, A'). (\<Gamma>, \<Theta>, F, P, c, Q, A') \<in> A) x \<longrightarrow>
        (\<lambda>(P, c, Q, A'). (\<Gamma>, \<Theta>, F, P, c, Q, A') \<in> B) x"
apply blast
done

inductive "hoarep"::"[('s,'p,'f) body,('s,'p) quadruple set,'f set,
    's assn,('s,'p,'f) com, 's assn,'s assn] => bool"
    ("(3_,_/\<turnstile>\<^bsub>'/_ \<^esub>(_/ (_)/ _,/_))" [60,60,60,1000,20,1000,1000]60)
  for \<Gamma>::"('s,'p,'f) body"
where
  Skip: "\<Gamma>,\<Theta>\<turnstile>\<^bsub>/F\<^esub> Q Skip Q,A"

| Basic: "\<Gamma>,\<Theta>\<turnstile>\<^bsub>/F\<^esub> {s. f s \<in> Q} (Basic f) Q,A"

| Spec: "\<Gamma>,\<Theta>\<turnstile>\<^bsub>/F\<^esub> {s. (\<forall>t. (s,t) \<in> r \<longrightarrow> t \<in> Q) \<and> (\<exists>t. (s,t) \<in> r)} (Spec r) Q,A"

| Seq: "\<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"

| Cond: "\<lbrakk>\<Gamma>,\<Theta>\<turnstile>\<^bsub>/F\<^esub> (P \<inter> b) c\<^sub>1 Q,A; \<Gamma>,\<Theta>\<turnstile>\<^bsub>/F\<^esub> (P \<inter> - b) c\<^sub>2 Q,A\<rbrakk>
         \<Longrightarrow>
         \<Gamma>,\<Theta>\<turnstile>\<^bsub>/F\<^esub> P (Cond b c\<^sub>1 c\<^sub>2) Q,A"

| While: "\<Gamma>,\<Theta>\<turnstile>\<^bsub>/F\<^esub> (P \<inter> b) c P,A
          \<Longrightarrow>
          \<Gamma>,\<Theta>\<turnstile>\<^bsub>/F\<^esub> P (While b c) (P \<inter> - b),A"

| Guard: "\<Gamma>,\<Theta>\<turnstile>\<^bsub>/F\<^esub> (g \<inter> P) c Q,A
          \<Longrightarrow>
          \<Gamma>,\<Theta>\<turnstile>\<^bsub>/F\<^esub> (g \<inter> P) (Guard f g c) Q,A"

| Guarantee: "\<lbrakk>f \<in> F; \<Gamma>,\<Theta>\<turnstile>\<^bsub>/F\<^esub> (g \<inter> P) c Q,A\<rbrakk>
              \<Longrightarrow>
              \<Gamma>,\<Theta>\<turnstile>\<^bsub>/F\<^esub> P (Guard f g c) Q,A"

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

| DynCom:
      "\<forall>s \<in> P. \<Gamma>,\<Theta>\<turnstile>\<^bsub>/F\<^esub> P (c s) Q,A
      \<Longrightarrow>
      \<Gamma>,\<Theta>\<turnstile>\<^bsub>/F\<^esub> P (DynCom c) Q,A"

| Throw: "\<Gamma>,\<Theta>\<turnstile>\<^bsub>/F\<^esub> A Throw Q,A"

| Catch: "\<lbrakk>\<Gamma>,\<Theta>\<turnstile>\<^bsub>/F\<^esub> P c\<^sub>1 Q,R; \<Gamma>,\<Theta>\<turnstile>\<^bsub>/F\<^esub> R c\<^sub>2 Q,A\<rbrakk> \<Longrightarrow>  \<Gamma>,\<Theta>\<turnstile>\<^bsub>/F\<^esub> P Catch c\<^sub>1 c\<^sub>2 Q,A"

| Conseq: "\<forall>s \<in> P. \<exists>P' Q' A'. \<Gamma>,\<Theta>\<turnstile>\<^bsub>/F\<^esub> P' c Q',A' \<and> s \<in> P' \<and> Q' \<subseteq> Q \<and> A' \<subseteq> A
           \<Longrightarrow> \<Gamma>,\<Theta>\<turnstile>\<^bsub>/F\<^esub> P c Q,A"

| Asm: "\<lbrakk>(P,p,Q,A) \<in> \<Theta>\<rbrakk>
         \<Longrightarrow>
         \<Gamma>,\<Theta>\<turnstile>\<^bsub>/F\<^esub> P (Call p) Q,A"

| ExFalso: "\<lbrakk>\<forall>n. \<Gamma>,\<Theta>\<Turnstile>n:\<^bsub>/F\<^esub> P c Q,A; \<not> \<Gamma>\<Turnstile>\<^bsub>/F\<^esub> P c Q,A\<rbrakk> \<Longrightarrow> \<Gamma>,\<Theta>\<turnstile>\<^bsub>/F\<^esub> P c Q,A"
  \<comment> \<open>This is a hack rule that enables us to derive completeness for
        an arbitrary context \<open>\<Theta>\<close>, from completeness for an empty context.\<close>

text \<open>Does not work, because of rule ExFalso, the context \<open>\<Theta>\<close> is to blame.
 A weaker version with empty context can be derived from soundness
 and completeness later on.\<close>
lemma hoare_strip_\<Gamma>:
  assumes deriv: "\<Gamma>,\<Theta>\<turnstile>\<^bsub>/F\<^esub> P p Q,A"
  shows "strip (-F) \<Gamma>,\<Theta>\<turnstile>\<^bsub>/F\<^esub> P p Q,A"
using deriv
proof induct
  case Skip thus ?case by (iprover intro: hoarep.Skip)
next
  case Basic thus ?case by (iprover intro: hoarep.Basic)
next
  case Spec thus ?case by (iprover intro: hoarep.Spec)
next
  case Seq thus ?case by (iprover intro: hoarep.Seq)
next
  case Cond thus ?case by (iprover intro: hoarep.Cond)
next
  case While thus ?case by (iprover intro: hoarep.While)
next
  case Guard thus ?case by (iprover intro: hoarep.Guard)
(*next
  case CallSpec thus ?case by (iprover intro: hoarep.CallSpec)
next
  case (CallRec A Abr Abr' Init P Post Pre Procs Q R Result Return Z \<Gamma> \<Theta> init p
         result return )
  from CallRec.hyps
  have "\<forall>p\<in>Procs. \<forall>Z. (strip \<Gamma>),\<Theta> \<union>
             (\<Union>\<^bsub>p\<in>Procs\<^esub>
                 \<Union>\<^bsub>Z\<^esub> {(Pre p Z, Call (Init p) p (Return p) (Result p),
                      Post p Z, Abr p Z)})\<turnstile>
            (Pre p Z) (the (\<Gamma> p)) (R p Z),(Abr' p Z)" by blast
  hence "\<forall>p\<in>Procs. \<forall>Z. (strip \<Gamma>),\<Theta> \<union>
             (\<Union>\<^bsub>p\<in>Procs\<^esub>
                 \<Union>\<^bsub>Z\<^esub> {(Pre p Z, Call (Init p) p (Return p) (Result p),
                      Post p Z, Abr p Z)})\<turnstile>
            (Pre p Z) (the ((strip \<Gamma>) p)) (R p Z),(Abr' p Z)"
    by (auto intro: hoarep.StripI)
  then show ?case
    apply -
    apply (rule hoarep.CallRec)
    apply (assumption | simp only:dom_strip)+
    done*)
next
  case DynCom
  thus ?case
    by - (rule hoarep.DynCom,best  elim!: ballE exE)
next
  case Throw thus ?case by (iprover intro: hoarep.Throw)
next
  case Catch thus ?case by (iprover intro: hoarep.Catch)
(*next
  case CONSEQ thus ?case apply (auto intro: hoarep.CONSEQ)*)
next
  case Asm thus ?case by (iprover intro: hoarep.Asm)
next
  case ExFalso
  thus ?case
    oops

lemma hoare_augment_context:
  assumes deriv: "\<Gamma>,\<Theta>\<turnstile>\<^bsub>/F\<^esub> P p Q,A"
  shows "\<And>\<Theta>'. \<Theta> \<subseteq> \<Theta>' \<Longrightarrow> \<Gamma>,\<Theta>'\<turnstile>\<^bsub>/F\<^esub> P p Q,A"
using deriv
proof (induct)
  case CallRec
  case (CallRec P p Q A Specs \<Theta> F \<Theta>')
  from CallRec.prems
  have "\<Theta>\<union>Specs
       \<subseteq> \<Theta>'\<union>Specs"
    by blast
  with CallRec.hyps (2)
  have "\<forall>(P,p,Q,A)\<in>Specs.  p \<in> dom \<Gamma> \<and> \<Gamma>,\<Theta>'\<union>Specs \<turnstile>\<^bsub>/F\<^esub> P  (the (\<Gamma> p)) Q,A"
    by fastforce

  with CallRec show ?case by - (rule hoarep.CallRec)
next
  case DynCom thus ?case by (blast intro: hoarep.DynCom)
next
  case (Conseq P \<Theta> F c Q A \<Theta>')
  from Conseq
  have "\<forall>s \<in> P.
         (\<exists>P' Q' A'. \<Gamma>,\<Theta>' \<turnstile>\<^bsub>/F\<^esub> P' c Q',A' \<and> s \<in> P' \<and> Q' \<subseteq> Q \<and> A' \<subseteq> A)"
    by blast
  with Conseq show ?case by - (rule hoarep.Conseq)
next
  case (ExFalso \<Theta> F P c Q A \<Theta>')
  have valid_ctxt: "\<forall>n. \<Gamma>,\<Theta>\<Turnstile>n:\<^bsub>/F\<^esub> P c Q,A" "\<Theta> \<subseteq> \<Theta>'" by fact+
  hence "\<forall>n. \<Gamma>,\<Theta>'\<Turnstile>n:\<^bsub>/F\<^esub> P c Q,A"
    by (simp add: cnvalid_def) blast
  moreover have invalid: "\<not> \<Gamma>\<Turnstile>\<^bsub>/F\<^esub> P c Q,A"  by fact
  ultimately show ?case
    by (rule hoarep.ExFalso)
qed (blast intro: hoarep.intros)+

subsection \<open>Some Derived Rules\<close>

lemma  Conseq': "\<forall>s. s \<in> P \<longrightarrow>
            (\<exists>P' Q' A'.
              (\<forall> Z. \<Gamma>,\<Theta>\<turnstile>\<^bsub>/F\<^esub> (P' Z) c (Q' Z),(A' Z)) \<and>
                    (\<exists>Z. s \<in> P' Z \<and> (Q' Z \<subseteq> Q) \<and> (A' Z \<subseteq> A)))
           \<Longrightarrow>
           \<Gamma>,\<Theta>\<turnstile>\<^bsub>/F\<^esub> P c Q,A"
apply (rule Conseq)
apply (rule ballI)
apply (erule_tac x=s in allE)
apply (clarify)
apply (rule_tac x="P' Z" in exI)
apply (rule_tac x="Q' Z" in exI)
apply (rule_tac x="A' Z" in exI)
apply blast
done

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

theorem conseqPrePost [trans]:
  "\<Gamma>,\<Theta>\<turnstile>\<^bsub>/F\<^esub> P' c Q',A' \<Longrightarrow> P \<subseteq> P' \<Longrightarrow>  Q' \<subseteq> Q \<Longrightarrow> A' \<subseteq> A \<Longrightarrow>  \<Gamma>,\<Theta>\<turnstile>\<^bsub>/F\<^esub> P c Q,A"
  by (rule conseq [where ?P'="\<lambda>Z. P'" and ?Q'="\<lambda>Z. Q'"]) auto

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

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

lemma CallRec':
  "\<lbrakk>p\<in>Procs; Procs \<subseteq> dom \<Gamma>;
   \<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)\<rbrakk>
   \<Longrightarrow>
   \<Gamma>,\<Theta>\<turnstile>\<^bsub>/F\<^esub> (P p Z) (Call p) (Q p Z),(A p Z)"
apply (rule CallRec [where Specs="\<Union>p\<in>Procs. \<Union>Z. {((P p Z),p,Q p Z,A p Z)}"])
apply  blast
apply blast
done

end


theory WordArrayScorres
  imports
    WordArrayMono
    "build/Generated_SCorres_Normal"
    AutoCorres.AutoCorres
begin

section "Shallow word array method definitions"

primrec swa_to_list
  where
"swa_to_list (SWA xs) = xs"

fun list_to_swa
  where
"list_to_swa xs = SWA xs"

overloading swa_length \<equiv> wordarray_length
begin
definition swa_length :: "'a WordArray \<Rightarrow> 32 word"
  where
"swa_length x = (of_nat (length (swa_to_list x)) :: 32 word)"
end (* of overloading *)

overloading swa_get \<equiv> wordarray_get
begin
definition swa_get :: "('a WordArray, 32 word, 'a) WordArrayGetP \<Rightarrow> 'a"
  where
"swa_get x =
  (let arr = swa_to_list (WordArrayGetP.arr\<^sub>f x);
         i = unat (WordArrayGetP.idx\<^sub>f x);
         v = WordArrayGetP.val\<^sub>f x
   in if i < length arr then arr ! i else v)"
end (* of overloading *)

overloading swa_put \<equiv> wordarray_put
begin
definition swa_put :: "('a WordArray, 32 word, 'a) WordArrayGetP \<Rightarrow> 'a WordArray"
  where
"swa_put x =
  (let arr = swa_to_list (WordArrayGetP.arr\<^sub>f x);
         i = unat (WordArrayGetP.idx\<^sub>f x);
         v = WordArrayGetP.val\<^sub>f x
   in list_to_swa (arr[i:= v]))"
end (* of overloading *)

overloading swa_get_opt \<equiv> wordarray_get_opt
begin
definition swa_get_opt :: "('a WordArray, 32 word) WordArrayGetOP \<Rightarrow> (unit, 'a) Opt"
  where
"swa_get_opt x =
  (let arr = swa_to_list (WordArrayGetOP.arr\<^sub>f x);
         i = unat (WordArrayGetOP.idx\<^sub>f x)
   in if i < length arr then Something (arr ! i) else Nothing ())"
end (* of overloading *)

overloading
  valRel_WordArrayWord \<equiv> valRel
begin
definition valRel_WordArrayWord:
"\<And>\<xi>' x v.
  valRel_WordArrayWord (\<xi>' :: (funtyp, vabstyp) vabsfuns) (x :: (('a::len8) word) WordArray) (v :: (funtyp, vabstyp) vval) \<equiv>
    (if len_of TYPE('a) = 8 then
        \<exists>xs xs'. v = VAbstract (VWA (TPrim (Num U8)) xs) \<and> xs' = swa_to_list x \<and> length xs' = length xs \<and> (\<forall>i < length xs. (xs ! i) = VPrim (LU8 (ucast (xs' ! i))))
      else if len_of TYPE('a) = 16 then
        \<exists>xs xs'. v = VAbstract (VWA (TPrim (Num U16)) xs) \<and> xs' = swa_to_list x \<and> length xs' = length xs \<and> (\<forall>i < length xs. (xs ! i) = VPrim (LU16 (ucast (xs' ! i))))
      else if len_of TYPE('a) = 32 then
        \<exists>xs xs'. v = VAbstract (VWA (TPrim (Num U32)) xs) \<and> xs' = swa_to_list x \<and> length xs' = length xs \<and> (\<forall>i < length xs. (xs ! i) = VPrim (LU32 (ucast (xs' ! i))))
      else if len_of TYPE('a) = 64 then
        \<exists>xs xs'. v = VAbstract (VWA (TPrim (Num U64)) xs) \<and> xs' = swa_to_list x \<and> length xs' = length xs \<and> (\<forall>i < length xs. (xs ! i) = VPrim (LU64 (ucast (xs' ! i))))
      else False)"
end

sublocale level0_value \<subseteq> shallow l0v_typing
  by (unfold_locales)

sublocale WordArrayValue \<subseteq> shallow wa_abs_typing_v
  by (unfold_locales)

context WordArrayValue begin

lemma wordarray_length_scorres:
  "\<xi> ''wordarray_length'' =  vwa_length
    \<Longrightarrow> scorres (wordarray_length :: ('a :: len8) word WordArray \<Rightarrow> 32 word)
        (AFun ''wordarray_length'' ts []) \<gamma> \<xi>"
  apply (clarsimp simp: scorres_def)
  apply (erule v_sem_afunE; clarsimp)
  apply (erule notE)
  unfolding vwa_length_def swa_length_def valRel_WordArrayWord
  apply (clarsimp split: if_splits)
  done

lemma wordarray_get_u8_scorres:
  "\<xi> ''wordarray_get'' =  vwa_get
    \<Longrightarrow> scorres
       (wordarray_get :: (8 word WordArray, 32 word, 8 word) WordArrayGetP \<Rightarrow> 8 word)
       (AFun ''wordarray_get'' ts []) \<gamma> \<xi>"
  apply (clarsimp simp: scorres_def)
  apply (erule v_sem_afunE; clarsimp)
  apply (erule notE)
  unfolding vwa_get_def swa_get_def valRel_WordArrayWord valRel_records
  apply (clarsimp split: if_splits simp: Let_def ucast_id valRel_records)
  done

lemma wordarray_get_u16_scorres:
  "\<xi> ''wordarray_get'' =  vwa_get
    \<Longrightarrow> scorres
        (wordarray_get :: (16 word WordArray, 32 word, 16 word) WordArrayGetP \<Rightarrow> 16 word)
        (AFun ''wordarray_get'' ts []) \<gamma> \<xi>"
  apply (clarsimp simp: scorres_def)
  apply (erule v_sem_afunE; clarsimp)
  apply (erule notE)
  unfolding vwa_get_def swa_get_def valRel_WordArrayWord valRel_records
  apply (clarsimp split: if_splits simp: Let_def ucast_id valRel_records)
  done

lemma wordarray_get_u32_scorres:
  "\<xi> ''wordarray_get'' =  vwa_get
    \<Longrightarrow> scorres
        (wordarray_get :: (32 word WordArray, 32 word, 32 word) WordArrayGetP \<Rightarrow> 32 word)
        (AFun ''wordarray_get'' ts []) \<gamma> \<xi>"
  apply (clarsimp simp: scorres_def)
  apply (erule v_sem_afunE; clarsimp)
  apply (erule notE)
  unfolding vwa_get_def swa_get_def valRel_WordArrayWord valRel_records
  apply (clarsimp split: if_splits simp: Let_def ucast_id valRel_records)
  done

lemma wordarray_get_u64_scorres:
  "\<xi> ''wordarray_get'' =  vwa_get
    \<Longrightarrow> scorres
        (wordarray_get :: (64 word WordArray, 32 word, 64 word) WordArrayGetP \<Rightarrow> 64 word)
        (AFun ''wordarray_get'' ts []) \<gamma> \<xi>"
  apply (clarsimp simp: scorres_def)
  apply (erule v_sem_afunE; clarsimp)
  apply (erule notE)
  unfolding vwa_get_def swa_get_def valRel_WordArrayWord valRel_records
  apply (clarsimp split: if_splits simp: Let_def ucast_id valRel_records)
  done

lemma wordarray_put_u8_scorres:
  "\<xi> ''wordarray_put'' =  vwa_put
    \<Longrightarrow> scorres
        (wordarray_put :: (8 word WordArray, 32 word, 8 word) WordArrayGetP \<Rightarrow> 8 word WordArray)
        (AFun ''wordarray_put'' ts []) \<gamma> \<xi>"
  apply (clarsimp simp: scorres_def)
  apply (erule v_sem_afunE; clarsimp)
  apply (erule notE)
  unfolding vwa_put_def swa_put_def valRel_WordArrayWord valRel_records
  apply (clarsimp split: if_splits simp: Let_def ucast_id valRel_records)
  by (metis (no_types, hide_lams) nth_list_update_eq nth_list_update_neq)

lemma wordarray_put_u16_scorres:
  "\<xi> ''wordarray_put'' =  vwa_put
    \<Longrightarrow> scorres (wordarray_put :: (16 word WordArray, 32 word, 16 word) WordArrayGetP \<Rightarrow> 16 word WordArray) (AFun ''wordarray_put'' ts []) \<gamma> \<xi>"
  apply (clarsimp simp: scorres_def)
  apply (erule v_sem_afunE; clarsimp)
  apply (erule notE)
  unfolding vwa_put_def swa_put_def valRel_WordArrayWord valRel_records
  apply (clarsimp split: if_splits simp: Let_def ucast_id valRel_records)
  by (metis (no_types, hide_lams) nth_list_update_eq nth_list_update_neq)

lemma wordarray_put_u32_scorres:
  "\<xi> ''wordarray_put'' =  vwa_put
    \<Longrightarrow> scorres (wordarray_put :: (32 word WordArray, 32 word, 32 word) WordArrayGetP \<Rightarrow> 32 word WordArray) (AFun ''wordarray_put'' ts []) \<gamma> \<xi>"
  apply (clarsimp simp: scorres_def)
  apply (erule v_sem_afunE; clarsimp)
  apply (erule notE)
  unfolding vwa_put_def swa_put_def valRel_WordArrayWord valRel_records
  apply (clarsimp split: if_splits simp: Let_def ucast_id valRel_records)
  by (metis (no_types, hide_lams) nth_list_update_eq nth_list_update_neq)

lemma wordarray_put_u64_scorres:
  "\<xi> ''wordarray_put'' =  vwa_put
    \<Longrightarrow> scorres (wordarray_put :: (64 word WordArray, 32 word, 64 word) WordArrayGetP \<Rightarrow> 64 word WordArray) (AFun ''wordarray_put'' ts []) \<gamma> \<xi>"
  apply (clarsimp simp: scorres_def)
  apply (erule v_sem_afunE; clarsimp)
  apply (erule notE)
  unfolding vwa_put_def swa_put_def valRel_WordArrayWord valRel_records
  apply (clarsimp split: if_splits simp: Let_def ucast_id valRel_records)
  by (metis (no_types, hide_lams) nth_list_update_eq nth_list_update_neq)

lemma wordarray_get_opt_u8_scorres:
  "\<xi> ''wordarray_get_opt'' =  vwa_get_opt
    \<Longrightarrow> scorres (wordarray_get_opt :: (8 word WordArray, 32 word) WordArrayGetOP \<Rightarrow> (unit, 8 word) Opt) (AFun ''wordarray_get_opt'' ts []) \<gamma> \<xi>"
  apply (clarsimp simp: scorres_def)
  apply (erule v_sem_afunE; clarsimp)
  apply (erule notE)
  unfolding vwa_get_opt_def swa_get_opt_def valRel_WordArrayWord valRel_records
  apply (clarsimp split: if_splits simp: Let_def ucast_id valRel_records)
  done

lemma wordarray_get_opt_u16_scorres:
  "\<xi> ''wordarray_get_opt'' =  vwa_get_opt
    \<Longrightarrow> scorres (wordarray_get_opt :: (16 word WordArray, 32 word) WordArrayGetOP \<Rightarrow> (unit, 16 word) Opt) (AFun ''wordarray_get_opt'' ts []) \<gamma> \<xi>"
  apply (clarsimp simp: scorres_def)
  apply (erule v_sem_afunE; clarsimp)
  apply (erule notE)
  unfolding vwa_get_opt_def swa_get_opt_def valRel_WordArrayWord valRel_records
  apply (clarsimp split: if_splits simp: Let_def ucast_id valRel_records)
  done

lemma wordarray_get_opt_u32_scorres:
  "\<xi> ''wordarray_get_opt'' =  vwa_get_opt
    \<Longrightarrow> scorres (wordarray_get_opt :: (32 word WordArray, 32 word) WordArrayGetOP \<Rightarrow> (unit, 32 word) Opt) (AFun ''wordarray_get_opt'' ts []) \<gamma> \<xi>"
  apply (clarsimp simp: scorres_def)
  apply (erule v_sem_afunE; clarsimp)
  apply (erule notE)
  unfolding vwa_get_opt_def swa_get_opt_def valRel_WordArrayWord valRel_records
  apply (clarsimp split: if_splits simp: Let_def ucast_id valRel_records)
  done

lemma wordarray_get_opt_u64_scorres:
  "\<xi> ''wordarray_get_opt'' =  vwa_get_opt
    \<Longrightarrow> scorres (wordarray_get_opt :: (64 word WordArray, 32 word) WordArrayGetOP \<Rightarrow> (unit, 64 word) Opt) (AFun ''wordarray_get_opt'' ts []) \<gamma> \<xi>"
  apply (clarsimp simp: scorres_def)
  apply (erule v_sem_afunE; clarsimp)
  apply (erule notE)
  unfolding vwa_get_opt_def swa_get_opt_def valRel_WordArrayWord valRel_records
  apply (clarsimp split: if_splits simp: Let_def ucast_id valRel_records)
  done

end (* of context *)

end


(*  Title:      ZF/Induct/Datatypes.thy
    Author:     Lawrence C Paulson, Cambridge University Computer Laboratory
    Copyright   1994  University of Cambridge
*)

section \<open>Sample datatype definitions\<close>

theory Datatypes imports Main begin

subsection \<open>A type with four constructors\<close>

text \<open>
  It has four contructors, of arities 0--3, and two parameters \<open>A\<close> and \<open>B\<close>.
\<close>

consts
  data :: "[i, i] => i"

datatype "data(A, B)" =
    Con0
  | Con1 ("a \<in> A")
  | Con2 ("a \<in> A", "b \<in> B")
  | Con3 ("a \<in> A", "b \<in> B", "d \<in> data(A, B)")

lemma data_unfold: "data(A, B) = ({0} + A) + (A \<times> B + A \<times> B \<times> data(A, B))"
  by (fast intro!: data.intros [unfolded data.con_defs]
    elim: data.cases [unfolded data.con_defs])

text \<open>
  \medskip Lemmas to justify using @{term data} in other recursive
  type definitions.
\<close>

lemma data_mono: "[| A \<subseteq> C; B \<subseteq> D |] ==> data(A, B) \<subseteq> data(C, D)"
  apply (unfold data.defs)
  apply (rule lfp_mono)
   apply (rule data.bnd_mono)+
  apply (rule univ_mono Un_mono basic_monos | assumption)+
  done

lemma data_univ: "data(univ(A), univ(A)) \<subseteq> univ(A)"
  apply (unfold data.defs data.con_defs)
  apply (rule lfp_lowerbound)
   apply (rule_tac [2] subset_trans [OF A_subset_univ Un_upper1, THEN univ_mono])
  apply (fast intro!: zero_in_univ Inl_in_univ Inr_in_univ Pair_in_univ)
  done

lemma data_subset_univ:
    "[| A \<subseteq> univ(C); B \<subseteq> univ(C) |] ==> data(A, B) \<subseteq> univ(C)"
  by (rule subset_trans [OF data_mono data_univ])

subsection \<open>Example of a big enumeration type\<close>

text \<open>
  Can go up to at least 100 constructors, but it takes nearly 7
  minutes \dots\ (back in 1994 that is).
\<close>

consts
  enum :: i

datatype enum =
    C00 | C01 | C02 | C03 | C04 | C05 | C06 | C07 | C08 | C09
  | C10 | C11 | C12 | C13 | C14 | C15 | C16 | C17 | C18 | C19
  | C20 | C21 | C22 | C23 | C24 | C25 | C26 | C27 | C28 | C29
  | C30 | C31 | C32 | C33 | C34 | C35 | C36 | C37 | C38 | C39
  | C40 | C41 | C42 | C43 | C44 | C45 | C46 | C47 | C48 | C49
  | C50 | C51 | C52 | C53 | C54 | C55 | C56 | C57 | C58 | C59

end


(* @LICENSE(NICTA_CORE) *)

(*  Author:     Rafal Kolanski, NICTA & UNSW

    Machine setup for 32-bit little-endian ARM.

    Machines should export the types:
    * machine_word
    * virtual/physical address width types: paddr_word, vaddr_word

    Machines should export the functions:
    * machine_w2b - transform words to bytes (of size \<le> machine_word)
    * machine_b2w - transform bytes to words (of size \<le> machine_word)

    FIXME: these can be derived if we know paddr_word, vaddr_word
    * address types: vaddr, paddr
    * memory_size - size of physical memory address space in bytes
    * addr_space_size - size of virtual memory address space in bytes

    Understanding is: a virtual pointer carrying a virtual address resolves to
    a physical address; the smallest granularity of memory is a byte.
*)

theory MachineARM
imports Pointers Word_Lib.Word_Lib
begin

text \<open>Address types\<close>

type_synonym machine_word = "32 word"
type_synonym vaddr_word = "32 word"
type_synonym paddr_word = "32 word"

type_synonym vaddr = "(vaddr_word,virtual) addr_t"
type_synonym paddr = "(paddr_word,physical) addr_t"

translations
  (type) "paddr" <=(type) "(32 word,physical) addr_t"
  (type) "vaddr" <=(type) "(32 word,virtual) addr_t"
  (*XXX: these can be derived, but you'd have to expand vaddr_word etc.*)

text \<open>Memory size\<close>

definition
  memory_size :: nat where
  "memory_size \<equiv> 2 ^ size (addr_val(undefined::paddr))"
definition
  addr_space_size :: nat where
  "addr_space_size \<equiv> 2 ^ size (addr_val(undefined::vaddr))"

(*XXX: not derivable*)
lemma memory_size: "memory_size = 2 ^ 32" (*XXX: used to be [simp]*)
  by (simp add: memory_size_def word_size)
lemma addr_space_size: "addr_space_size = 2 ^ 32" (*XXX: used to be [simp]*)
  by (simp add: addr_space_size_def word_size)

text \<open>Endianness setup\<close>

definition
  machine_w2b :: "'a::len0 word \<Rightarrow> 8 word list" where
  "machine_w2b \<equiv> rev \<circ> word_rsplit"

definition
  machine_b2w :: "8 word list => 'b :: len0 word" where
  "machine_b2w \<equiv> word_rcat \<circ> rev"

end


(*  Title:      Jinja/Compiler/Compiler.thy

    Author:     Tobias Nipkow
    Copyright   TUM 2003
*)

header {* \isaheader{Combining Stages 1 and 2} *}

theory Compiler
imports Correctness1 Correctness2
begin

definition J2JVM :: "J_prog \<Rightarrow> jvm_prog"
where
  "J2JVM  \<equiv>  compP\<^sub>2 \<circ> compP\<^sub>1"

theorem comp_correct:
assumes wwf: "wwf_J_prog P"
and method: "P \<turnstile> C sees M:Ts\<rightarrow>T = (pns,body) in C"
and eval: "P \<turnstile> \<langle>body,(h,[this#pns [\<mapsto>] vs])\<rangle> \<Rightarrow> \<langle>e',(h',l')\<rangle>"
and sizes: "size vs = size pns + 1"    "size rest = max_vars body"
shows "J2JVM P \<turnstile> (None,h,[([],vs@rest,C,M,0)]) -jvm\<rightarrow> (exception e',h',[])"
(*<*)
proof -
  let ?P\<^sub>1 = "compP\<^sub>1 P"
  have fv: "fv body \<subseteq> set (this#pns)"
    using wwf method by(auto dest!:sees_wf_mdecl simp:wf_mdecl_def)
  have init: "[this#pns [\<mapsto>] vs] \<subseteq>\<^sub>m [this#pns [\<mapsto>] vs@rest]"
    using sizes by simp
  have "?P\<^sub>1 \<turnstile> C sees M: Ts\<rightarrow>T = (compE\<^sub>1 (this#pns) body) in C"
    using sees_method_compP[OF method, of "\<lambda>(pns,e). compE\<^sub>1 (this#pns) e"]
    by(simp)
  moreover obtain ls' where
    "?P\<^sub>1 \<turnstile>\<^sub>1 \<langle>compE\<^sub>1 (this#pns) body, (h, vs@rest)\<rangle> \<Rightarrow> \<langle>fin\<^sub>1 e', (h',ls')\<rangle>"
    using eval\<^sub>1_eval[OF wwf eval fv init] sizes by auto
  ultimately show ?thesis using comp\<^sub>2_correct eval_final[OF eval]
    by(fastforce simp add:J2JVM_def final_def)
qed
(*>*)

end


(*  Title:      HOL/Statespace/StateFun.thy
    Author:     Norbert Schirmer, TU Muenchen
*)

section \<open>State Space Representation as Function \label{sec:StateFun}\<close>

theory StateFun imports DistinctTreeProver
begin

text \<open>The state space is represented as a function from names to
values. We neither fix the type of names nor the type of values. We
define lookup and update functions and provide simprocs that simplify
expressions containing these, similar to HOL-records.

The lookup and update function get constructor/destructor functions as
parameters. These are used to embed various HOL-types into the
abstract value type. Conceptually the abstract value type is a sum of
all types that we attempt to store in the state space.

The update is actually generalized to a map function. The map supplies
better compositionality, especially if you think of nested state
spaces.\<close>

definition K_statefun :: "'a \<Rightarrow> 'b \<Rightarrow> 'a" where "K_statefun c x \<equiv> c"

lemma K_statefun_apply [simp]: "K_statefun c x = c"
  by (simp add: K_statefun_def)

lemma K_statefun_comp [simp]: "(K_statefun c \<circ> f) = K_statefun c"
  by (rule ext) (simp add: comp_def)

lemma K_statefun_cong [cong]: "K_statefun c x = K_statefun c x"
  by (rule refl)

definition lookup :: "('v \<Rightarrow> 'a) \<Rightarrow> 'n \<Rightarrow> ('n \<Rightarrow> 'v) \<Rightarrow> 'a"
  where "lookup destr n s = destr (s n)"

definition update ::
  "('v \<Rightarrow> 'a1) \<Rightarrow> ('a2 \<Rightarrow> 'v) \<Rightarrow> 'n \<Rightarrow> ('a1 \<Rightarrow> 'a2) \<Rightarrow> ('n \<Rightarrow> 'v) \<Rightarrow> ('n \<Rightarrow> 'v)"
  where "update destr constr n f s = s(n := constr (f (destr (s n))))"

lemma lookup_update_same:
  "(\<And>v. destr (constr v) = v) \<Longrightarrow> lookup destr n (update destr constr n f s) =
         f (destr (s n))"
  by (simp add: lookup_def update_def)

lemma lookup_update_id_same:
  "lookup destr n (update destr' id n (K_statefun (lookup id n s')) s) =
     lookup destr n s'"
  by (simp add: lookup_def update_def)

lemma lookup_update_other:
  "n\<noteq>m \<Longrightarrow> lookup destr n (update destr' constr m f s) = lookup destr n s"
  by (simp add: lookup_def update_def)

lemma id_id_cancel: "id (id x) = x"
  by (simp add: id_def)

lemma destr_contstr_comp_id: "(\<And>v. destr (constr v) = v) \<Longrightarrow> destr \<circ> constr = id"
  by (rule ext) simp

lemma block_conj_cong: "(P \<and> Q) = (P \<and> Q)"
  by simp

lemma conj1_False: "P \<equiv> False \<Longrightarrow> (P \<and> Q) \<equiv> False"
  by simp

lemma conj2_False: "Q \<equiv> False \<Longrightarrow> (P \<and> Q) \<equiv> False"
  by simp

lemma conj_True: "P \<equiv> True \<Longrightarrow> Q \<equiv> True \<Longrightarrow> (P \<and> Q) \<equiv> True"
  by simp

lemma conj_cong: "P \<equiv> P' \<Longrightarrow> Q \<equiv> Q' \<Longrightarrow> (P \<and> Q) \<equiv> (P' \<and> Q')"
  by simp

lemma update_apply: "(update destr constr n f s x) =
     (if x=n then constr (f (destr (s n))) else s x)"
  by (simp add: update_def)

lemma ex_id: "\<exists>x. id x = y"
  by (simp add: id_def)

lemma swap_ex_eq:
  "\<exists>s. f s = x \<equiv> True \<Longrightarrow>
   \<exists>s. x = f s \<equiv> True"
  apply (rule eq_reflection)
  apply auto
  done

lemmas meta_ext = eq_reflection [OF ext]

(* This lemma only works if the store is welltyped:
    "\<exists>x.  s ''n'' = (c x)"
   or in general when c (d x) = x,
     (for example: c=id and d=id)
 *)
lemma "update d c n (K_statespace (lookup d n s)) s = s"
  apply (simp add: update_def lookup_def)
  apply (rule ext)
  apply simp
  oops

end