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

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

Copyright (C) 2006-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 "Experiments on State Composition"

theory Compose imports "../HoareTotalProps" begin

text \<open>
We develop some theory to support state-space modular development of programs.
These experiments aim at the representation of state-spaces with records.
If we use \<open>statespaces\<close> instead we get this kind of compositionality for free.
\<close>

subsection \<open>Changing the State-Space\<close>

(* Lift a command on statespace 'b to work on statespace 'a *)

definition lift\<^sub>f:: "('S \<Rightarrow> 's) \<Rightarrow> ('S \<Rightarrow> 's \<Rightarrow> 'S) \<Rightarrow> ('s \<Rightarrow> 's) \<Rightarrow> ('S \<Rightarrow> 'S)"
  where "lift\<^sub>f prj inject f = (\<lambda>S. inject S (f (prj S)))"

definition lift\<^sub>s:: "('S \<Rightarrow> 's) \<Rightarrow> 's set \<Rightarrow> 'S set"
  where "lift\<^sub>s prj A = {S. prj S \<in> A}"

definition lift\<^sub>r:: "('S \<Rightarrow> 's) \<Rightarrow> ('S \<Rightarrow> 's \<Rightarrow> 'S) \<Rightarrow> ('s \<times> 's) set
                       \<Rightarrow> ('S \<times> 'S) set"
where
"lift\<^sub>r prj inject R = {(S,T). (prj S,prj T) \<in> R \<and> T=inject S (prj T)}"

primrec lift\<^sub>c:: "('S \<Rightarrow> 's) \<Rightarrow> ('S \<Rightarrow> 's \<Rightarrow> 'S) \<Rightarrow> ('s,'p,'f) com \<Rightarrow> ('S,'p,'f) com"
where
"lift\<^sub>c prj inject Skip = Skip" |
"lift\<^sub>c prj inject (Basic f) = Basic (lift\<^sub>f prj inject f)" |
"lift\<^sub>c prj inject (Spec r) = Spec (lift\<^sub>r prj inject r)" |
"lift\<^sub>c prj inject (Seq c\<^sub>1 c\<^sub>2)  =
  (Seq (lift\<^sub>c prj inject c\<^sub>1) (lift\<^sub>c prj inject c\<^sub>2))" |
"lift\<^sub>c prj inject (Cond b c\<^sub>1 c\<^sub>2) =
  Cond (lift\<^sub>s prj b) (lift\<^sub>c prj inject c\<^sub>1) (lift\<^sub>c prj inject c\<^sub>2)" |
"lift\<^sub>c prj inject (While b c) =
  While (lift\<^sub>s prj b) (lift\<^sub>c prj inject c)" |
"lift\<^sub>c prj inject (Call p) = Call p" |
"lift\<^sub>c prj inject (DynCom c) = DynCom (\<lambda>s. lift\<^sub>c prj inject (c (prj s)))" |
"lift\<^sub>c prj inject (Guard f g c) = Guard f (lift\<^sub>s prj g) (lift\<^sub>c prj inject c)" |
"lift\<^sub>c prj inject Throw = Throw" |
"lift\<^sub>c prj inject (Catch c\<^sub>1 c\<^sub>2) =
  Catch (lift\<^sub>c prj inject c\<^sub>1) (lift\<^sub>c prj inject c\<^sub>2)"

lemma lift\<^sub>c_Skip: "(lift\<^sub>c prj inject c = Skip) = (c = Skip)"
  by (cases c) auto

lemma lift\<^sub>c_Basic:
  "(lift\<^sub>c prj inject c = Basic lf) = (\<exists>f. c = Basic f \<and> lf = lift\<^sub>f prj inject f)"
  by (cases c) auto

lemma lift\<^sub>c_Spec:
  "(lift\<^sub>c prj inject c = Spec lr) = (\<exists>r. c = Spec r \<and> lr = lift\<^sub>r prj inject r)"
  by (cases c) auto

lemma lift\<^sub>c_Seq:
  "(lift\<^sub>c prj inject c = Seq lc\<^sub>1 lc\<^sub>2) =
     (\<exists> c\<^sub>1 c\<^sub>2. c = Seq c\<^sub>1 c\<^sub>2 \<and>
               lc\<^sub>1 = lift\<^sub>c prj inject c\<^sub>1 \<and> lc\<^sub>2 = lift\<^sub>c prj inject c\<^sub>2 )"
    by (cases c) auto

lemma lift\<^sub>c_Cond:
  "(lift\<^sub>c prj inject c = Cond lb lc\<^sub>1 lc\<^sub>2) =
     (\<exists>b c\<^sub>1 c\<^sub>2. c = Cond b c\<^sub>1 c\<^sub>2 \<and> lb = lift\<^sub>s prj b \<and>
                lc\<^sub>1 = lift\<^sub>c prj inject c\<^sub>1 \<and> lc\<^sub>2 = lift\<^sub>c prj inject c\<^sub>2 )"
  by (cases c) auto

lemma lift\<^sub>c_While:
  "(lift\<^sub>c prj inject c = While lb lc') =
     (\<exists>b c'. c = While b c' \<and> lb = lift\<^sub>s prj b \<and>
               lc' = lift\<^sub>c prj inject c')"
  by (cases c) auto

lemma lift\<^sub>c_Call:
  "(lift\<^sub>c prj inject c = Call p) = (c = Call p)"
  by (cases c) auto

lemma lift\<^sub>c_DynCom:
  "(lift\<^sub>c prj inject c = DynCom lc) =
     (\<exists>C. c=DynCom C \<and> lc = (\<lambda>s. lift\<^sub>c prj inject (C (prj s))))"
  by (cases c) auto

lemma lift\<^sub>c_Guard:
  "(lift\<^sub>c prj inject c = Guard f lg lc') =
     (\<exists>g c'. c = Guard f g c' \<and> lg = lift\<^sub>s prj g \<and>
             lc' = lift\<^sub>c prj inject c')"
   by (cases c) auto

lemma lift\<^sub>c_Throw:
  "(lift\<^sub>c prj inject c = Throw) = (c = Throw)"
  by (cases c) auto

lemma lift\<^sub>c_Catch:
  "(lift\<^sub>c prj inject c = Catch lc\<^sub>1 lc\<^sub>2) =
     (\<exists> c\<^sub>1 c\<^sub>2. c = Catch c\<^sub>1 c\<^sub>2 \<and>
               lc\<^sub>1 = lift\<^sub>c prj inject c\<^sub>1 \<and> lc\<^sub>2 = lift\<^sub>c prj inject c\<^sub>2 )"
    by (cases c) auto

definition xstate_map:: "('S \<Rightarrow> 's) \<Rightarrow> ('S,'f) xstate \<Rightarrow> ('s,'f) xstate"
where
"xstate_map g x = (case x of
                      Normal s \<Rightarrow> Normal (g s)
                    | Abrupt s \<Rightarrow> Abrupt (g s)
                    | Fault f \<Rightarrow> Fault f
                    | Stuck \<Rightarrow> Stuck)"

lemma xstate_map_simps [simp]:
"xstate_map g (Normal s) = Normal (g s)"
"xstate_map g (Abrupt s) = Abrupt (g s)"
"xstate_map g (Fault f) = (Fault f)"
"xstate_map g Stuck = Stuck"
  by (auto simp add: xstate_map_def)

lemma xstate_map_Normal_conv:
  "xstate_map g S = Normal s = (\<exists>s'. S=Normal s' \<and> s = g s')"
  by (cases S) auto

lemma xstate_map_Abrupt_conv:
  "xstate_map g S = Abrupt s = (\<exists>s'. S=Abrupt s' \<and> s = g s')"
  by (cases S) auto

lemma xstate_map_Fault_conv:
  "xstate_map g S = Fault f = (S=Fault f)"
  by (cases S) auto

lemma xstate_map_Stuck_conv:
  "xstate_map g S = Stuck = (S=Stuck)"
  by (cases S) auto

lemmas xstate_map_convs = xstate_map_Normal_conv xstate_map_Abrupt_conv
 xstate_map_Fault_conv xstate_map_Stuck_conv

definition state:: "('s,'f) xstate \<Rightarrow> 's"
where
"state x = (case x of
               Normal s \<Rightarrow> s
             | Abrupt s \<Rightarrow> s
             | Fault g \<Rightarrow> undefined
             | Stuck \<Rightarrow> undefined)"

lemma state_simps [simp]:
"state (Normal s) = s"
"state (Abrupt s) = s"
  by (auto simp add: state_def )

locale lift_state_space =
  fixes project::"'S \<Rightarrow> 's"
  fixes "inject"::"'S \<Rightarrow> 's \<Rightarrow> 'S"
  fixes "project\<^sub>x"::"('S,'f) xstate \<Rightarrow> ('s,'f) xstate"
  fixes "lift\<^sub>e"::"('s,'p,'f) body \<Rightarrow> ('S,'p,'f) body"
  fixes lift\<^sub>c:: "('s,'p,'f) com \<Rightarrow> ('S,'p,'f) com"
  fixes lift\<^sub>f:: "('s \<Rightarrow> 's) \<Rightarrow> ('S \<Rightarrow> 'S)"
  fixes lift\<^sub>s:: "'s set \<Rightarrow> 'S set"
  fixes lift\<^sub>r:: "('s \<times> 's) set \<Rightarrow> ('S \<times> 'S) set"
  assumes proj_inj_commute: "\<And>S s.  project (inject S s) = s"
  defines "lift\<^sub>c \<equiv> Compose.lift\<^sub>c project inject"
  defines "project\<^sub>x \<equiv> xstate_map project"
  defines "lift\<^sub>e \<equiv> (\<lambda>\<Gamma> p. map_option lift\<^sub>c (\<Gamma> p))"
  defines "lift\<^sub>f \<equiv> Compose.lift\<^sub>f project inject"
  defines "lift\<^sub>s \<equiv> Compose.lift\<^sub>s project"
  defines "lift\<^sub>r \<equiv> Compose.lift\<^sub>r project inject"

lemma (in lift_state_space) lift\<^sub>f_simp:
 "lift\<^sub>f f \<equiv> \<lambda>S. inject S (f (project S))"
  by (simp add: lift\<^sub>f_def Compose.lift\<^sub>f_def)

lemma (in lift_state_space) lift\<^sub>s_simp:
  "lift\<^sub>s A \<equiv> {S. project S \<in> A}"
  by  (simp add: lift\<^sub>s_def Compose.lift\<^sub>s_def)

lemma (in lift_state_space) lift\<^sub>r_simp:
"lift\<^sub>r R \<equiv> {(S,T). (project S,project T) \<in> R \<and> T=inject S (project T)}"
  by  (simp add: lift\<^sub>r_def Compose.lift\<^sub>r_def)

(* Causes loop when instantiating locale
lemmas (in lift_state_space) lift\<^sub>f_simp  = Compose.lift\<^sub>f_def
 [of project "inject", folded lift\<^sub>f_def]
lemmas (in lift_state_space) lift\<^sub>s_simp  = Compose.lift\<^sub>s_def
 [of project, folded lift\<^sub>s_def]
lemmas (in lift_state_space) lift\<^sub>r_simp  = Compose.lift\<^sub>r_def
 [of project "inject", folded lift\<^sub>r_def]
*)
lemma (in lift_state_space) lift\<^sub>c_Skip_simp [simp]:
 "lift\<^sub>c Skip = Skip"
  by (simp add: lift\<^sub>c_def)
lemma (in lift_state_space) lift\<^sub>c_Basic_simp [simp]:
"lift\<^sub>c (Basic f) = Basic (lift\<^sub>f f)"
  by (simp add: lift\<^sub>c_def lift\<^sub>f_def)
lemma (in lift_state_space) lift\<^sub>c_Spec_simp [simp]:
"lift\<^sub>c (Spec r) = Spec (lift\<^sub>r r)"
  by (simp add: lift\<^sub>c_def lift\<^sub>r_def)
lemma (in lift_state_space) lift\<^sub>c_Seq_simp [simp]:
"lift\<^sub>c (Seq c\<^sub>1 c\<^sub>2)  =
  (Seq (lift\<^sub>c c\<^sub>1) (lift\<^sub>c c\<^sub>2))"
  by (simp add: lift\<^sub>c_def)
lemma (in lift_state_space) lift\<^sub>c_Cond_simp [simp]:
"lift\<^sub>c (Cond b c\<^sub>1 c\<^sub>2) =
  Cond (lift\<^sub>s b) (lift\<^sub>c c\<^sub>1) (lift\<^sub>c c\<^sub>2)"
  by (simp add: lift\<^sub>c_def lift\<^sub>s_def)
lemma (in lift_state_space) lift\<^sub>c_While_simp [simp]:
"lift\<^sub>c (While b c) =
  While (lift\<^sub>s b) (lift\<^sub>c c)"
  by (simp add: lift\<^sub>c_def lift\<^sub>s_def)
lemma (in lift_state_space) lift\<^sub>c_Call_simp [simp]:
"lift\<^sub>c (Call p) = Call p"
  by (simp add: lift\<^sub>c_def)
lemma (in lift_state_space) lift\<^sub>c_DynCom_simp [simp]:
"lift\<^sub>c (DynCom c) = DynCom (\<lambda>s. lift\<^sub>c (c (project s)))"
  by (simp add: lift\<^sub>c_def)
lemma (in lift_state_space) lift\<^sub>c_Guard_simp [simp]:
"lift\<^sub>c (Guard f g c) = Guard f (lift\<^sub>s g) (lift\<^sub>c c)"
  by (simp add: lift\<^sub>c_def lift\<^sub>s_def)
lemma (in lift_state_space) lift\<^sub>c_Throw_simp [simp]:
"lift\<^sub>c Throw = Throw"
  by (simp add: lift\<^sub>c_def)
lemma (in lift_state_space) lift\<^sub>c_Catch_simp [simp]:
"lift\<^sub>c (Catch c\<^sub>1 c\<^sub>2) =
  Catch (lift\<^sub>c c\<^sub>1) (lift\<^sub>c c\<^sub>2)"
  by (simp add: lift\<^sub>c_def)

lemma (in lift_state_space) project\<^sub>x_def':
"project\<^sub>x s \<equiv> (case s of
                 Normal s \<Rightarrow> Normal (project s)
                | Abrupt s \<Rightarrow> Abrupt (project s)
                | Fault f \<Rightarrow> Fault f
                | Stuck \<Rightarrow> Stuck)"
  by (simp add: xstate_map_def project\<^sub>x_def)

lemma (in lift_state_space) lift\<^sub>e_def':
  "lift\<^sub>e \<Gamma> p \<equiv> (case \<Gamma> p of Some bdy \<Rightarrow> Some (lift\<^sub>c bdy) | None \<Rightarrow> None)"
  by (simp add: lift\<^sub>e_def map_option_case)

text \<open>
The problem is that @{term "(lift\<^sub>c project inject \<circ> \<Gamma>)"} is quite
a strong premise. The problem is that @{term "\<Gamma>"} is a function here.
A map would be better. We only have to lift those procedures in the domain
of @{term "\<Gamma>"}:
\<open>\<Gamma> p = Some bdy \<longrightarrow> \<Gamma>' p = Some lift\<^sub>c project inject bdy\<close>.
We then can com up with theorems that allow us to extend the domains
of @{term \<Gamma>} and preserve validity.
\<close>

lemma (in lift_state_space)
"{(S,T). \<exists>t. (project S,t) \<in> r \<and> T=inject S t}
 \<subseteq> {(S,T). (project S,project T) \<in> r \<and> T=inject S (project T)}"
  apply clarsimp
  apply (rename_tac S t)
  apply (simp add: proj_inj_commute)
  done

lemma (in lift_state_space)
"{(S,T). (project S,project T) \<in> r \<and> T=inject S (project T)}
 \<subseteq> {(S,T). \<exists>t. (project S,t) \<in> r \<and> T=inject S t}"
  apply clarsimp
  apply (rename_tac S T)
  apply (rule_tac x="project T" in exI)
  apply simp
  done

lemma (in lift_state_space) lift_exec:
assumes exec_lc: "(lift\<^sub>e \<Gamma>)\<turnstile>\<langle>lc,s\<rangle> \<Rightarrow> t"
shows "\<And>c. \<lbrakk> lift\<^sub>c c = lc\<rbrakk> \<Longrightarrow>
              \<Gamma>\<turnstile>\<langle>c,project\<^sub>x s\<rangle> \<Rightarrow>  project\<^sub>x t"
using exec_lc
proof (induct)
  case Skip thus ?case
    by (auto simp add: project\<^sub>x_def lift\<^sub>c_Skip lift\<^sub>c_def intro: exec.Skip)
next
  case Guard thus ?case
    by (auto simp add: project\<^sub>x_def lift\<^sub>s_def Compose.lift\<^sub>s_def lift\<^sub>c_Guard lift\<^sub>c_def
      intro: exec.Guard)
next
  case GuardFault thus ?case
    by (auto simp add: project\<^sub>x_def lift\<^sub>s_def Compose.lift\<^sub>s_def lift\<^sub>c_Guard lift\<^sub>c_def
      intro: exec.GuardFault)
next
  case FaultProp thus ?case
    by (fastforce simp add: project\<^sub>x_def)
next
  case Basic
  thus ?case
    by (fastforce simp add: project\<^sub>x_def lift\<^sub>c_Basic lift\<^sub>f_def Compose.lift\<^sub>f_def
      lift\<^sub>c_def
        proj_inj_commute
        intro: exec.Basic)
next
  case Spec
  thus ?case
    by (fastforce simp add: project\<^sub>x_def lift\<^sub>c_Spec lift\<^sub>f_def Compose.lift\<^sub>f_def
        lift\<^sub>r_def Compose.lift\<^sub>r_def lift\<^sub>c_def
        proj_inj_commute
        intro: exec.Spec)
next
  case (SpecStuck s r)
  thus ?case
    apply (simp add: project\<^sub>x_def)
    apply (clarsimp simp add: lift\<^sub>c_Spec lift\<^sub>c_def)
    apply (unfold lift\<^sub>r_def Compose.lift\<^sub>r_def)
    apply (rule exec.SpecStuck)
    apply (rule allI)
    apply (erule_tac x="inject s t" in allE)
    apply clarsimp
    apply (simp add: proj_inj_commute)
    done
next
  case Seq
  thus ?case
    by (fastforce simp add: project\<^sub>x_def lift\<^sub>c_Seq lift\<^sub>c_def intro: exec.intros)
next
  case CondTrue
  thus ?case
     by (auto simp add: project\<^sub>x_def lift\<^sub>s_def Compose.lift\<^sub>s_def lift\<^sub>c_Cond lift\<^sub>c_def
         intro: exec.CondTrue)
next
  case CondFalse
  thus ?case
     by (auto simp add: project\<^sub>x_def lift\<^sub>s_def Compose.lift\<^sub>s_def lift\<^sub>c_Cond lift\<^sub>c_def
         intro: exec.CondFalse)
next
  case WhileTrue
  thus ?case
     by (fastforce simp add: project\<^sub>x_def lift\<^sub>s_def Compose.lift\<^sub>s_def
         lift\<^sub>c_While lift\<^sub>c_def
         intro: exec.WhileTrue)
next
  case WhileFalse
  thus ?case
     by (fastforce simp add: project\<^sub>x_def lift\<^sub>s_def Compose.lift\<^sub>s_def
         lift\<^sub>c_While lift\<^sub>c_def
         intro: exec.WhileFalse)
next
  case Call
  thus ?case
    by (fastforce simp add:
               project\<^sub>x_def lift\<^sub>c_Call lift\<^sub>f_def Compose.lift\<^sub>f_def lift\<^sub>c_def
               lift\<^sub>e_def
          intro: exec.Call)
next
  case CallUndefined
  thus ?case
    by (fastforce simp add:
               project\<^sub>x_def lift\<^sub>c_Call lift\<^sub>f_def Compose.lift\<^sub>f_def lift\<^sub>c_def
               lift\<^sub>e_def
          intro: exec.CallUndefined)
next
  case StuckProp thus ?case
    by (fastforce simp add: project\<^sub>x_def)
next
  case DynCom
  thus ?case
    by (fastforce simp add:
               project\<^sub>x_def lift\<^sub>c_DynCom lift\<^sub>f_def Compose.lift\<^sub>f_def lift\<^sub>c_def
          intro: exec.DynCom)
next
  case Throw thus ?case
    by (fastforce simp add: project\<^sub>x_def lift\<^sub>c_Throw lift\<^sub>c_def intro: exec.Throw)
next
  case AbruptProp thus ?case
    by (fastforce simp add: project\<^sub>x_def)
next
  case CatchMatch
  thus ?case
    by (fastforce simp add: project\<^sub>x_def lift\<^sub>c_Catch lift\<^sub>c_def intro: exec.CatchMatch)
next
  case (CatchMiss c\<^sub>1 s t c\<^sub>2 c)
  thus ?case
    by (cases t)
       (fastforce simp add: project\<^sub>x_def lift\<^sub>c_Catch lift\<^sub>c_def intro: exec.CatchMiss)+
qed

lemma (in lift_state_space) lift_exec':
assumes exec_lc: "(lift\<^sub>e \<Gamma>)\<turnstile>\<langle>lift\<^sub>c c,s\<rangle> \<Rightarrow> t"
shows "\<Gamma>\<turnstile>\<langle>c,project\<^sub>x s\<rangle> \<Rightarrow> project\<^sub>x t"
  using lift_exec [OF exec_lc]
  by simp

lemma (in lift_state_space) lift_valid:
  assumes valid: "\<Gamma>\<Turnstile>\<^bsub>/F\<^esub> P c Q,A"
  shows
   "(lift\<^sub>e \<Gamma>)\<Turnstile>\<^bsub>/F\<^esub> (lift\<^sub>s P) (lift\<^sub>c c) (lift\<^sub>s Q),(lift\<^sub>s A)"
proof (rule validI)
  fix s t
  assume lexec:
    "(lift\<^sub>e \<Gamma>)\<turnstile>\<langle>lift\<^sub>c c,Normal s\<rangle> \<Rightarrow> t"
  assume lP: "s \<in> lift\<^sub>s P"
  assume noFault: "t \<notin> Fault ` F"
  show "t \<in> Normal ` lift\<^sub>s Q \<union> Abrupt ` lift\<^sub>s A"
  proof -
    from lexec
    have "\<Gamma>\<turnstile> \<langle>c,project\<^sub>x (Normal s)\<rangle> \<Rightarrow> (project\<^sub>x t)"
      by (rule lift_exec) (simp_all)
    moreover
    from lP have "project s \<in> P"
      by (simp add: lift\<^sub>s_def Compose.lift\<^sub>s_def project\<^sub>x_def)
    ultimately
    have "project\<^sub>x t \<in> Normal ` Q \<union> Abrupt ` A"
      using valid noFault
      apply (clarsimp simp add: valid_def project\<^sub>x_def)
      apply (cases t)
      apply auto
      done
    thus ?thesis
      apply (simp add: lift\<^sub>s_def Compose.lift\<^sub>s_def)
      apply (cases t)
      apply (auto simp add: project\<^sub>x_def)
      done
  qed
qed

lemma (in lift_state_space) lift_hoarep:
  assumes deriv: "\<Gamma>,{}\<turnstile>\<^bsub>/F\<^esub> P c Q,A"
  shows
   "(lift\<^sub>e \<Gamma>),{}\<turnstile>\<^bsub>/F\<^esub> (lift\<^sub>s P) (lift\<^sub>c c) (lift\<^sub>s Q),(lift\<^sub>s A)"
apply (rule hoare_complete)
apply (insert hoare_sound [OF deriv])
apply (rule lift_valid)
apply (simp add: cvalid_def)
done

lemma (in lift_state_space) lift_hoarep':
  "\<forall>Z. \<Gamma>,{}\<turnstile>\<^bsub>/F\<^esub> (P Z) c (Q Z),(A Z) \<Longrightarrow>
    \<forall>Z. (lift\<^sub>e \<Gamma>),{}\<turnstile>\<^bsub>/F\<^esub> (lift\<^sub>s (P Z)) (lift\<^sub>c c)
                                  (lift\<^sub>s (Q Z)),(lift\<^sub>s (A Z))"
apply (iprover intro: lift_hoarep)
done

lemma (in lift_state_space) lift_termination:
assumes termi: "\<Gamma>\<turnstile>c\<down>s"
shows "\<And>S. project\<^sub>x S = s \<Longrightarrow>
  lift\<^sub>e \<Gamma> \<turnstile>(lift\<^sub>c c)\<down>S"
  using termi
proof (induct)
  case Skip thus ?case
    by (clarsimp simp add: terminates.Skip project\<^sub>x_def xstate_map_convs)
next
  case Basic thus ?case
    by (fastforce simp add: project\<^sub>x_def xstate_map_convs intro: terminates.intros)
next
  case Spec thus ?case
    by (fastforce simp add: project\<^sub>x_def xstate_map_convs intro: terminates.intros)
next
  case Guard thus ?case
    by (auto simp add: project\<^sub>x_def xstate_map_convs intro: terminates.intros)
next
  case GuardFault thus ?case
    by (auto simp add: project\<^sub>x_def xstate_map_convs lift\<^sub>s_def Compose.lift\<^sub>s_def
           intro: terminates.intros)
next
  case Fault thus ?case by (clarsimp simp add: project\<^sub>x_def xstate_map_convs)
next
  case (Seq c1 s c2)
  have "project\<^sub>x S = Normal s" by fact
  then obtain s' where S: "S=Normal s'" and s: "s = project s'"
    by (auto simp add: project\<^sub>x_def xstate_map_convs)
  from Seq have "lift\<^sub>e \<Gamma>\<turnstile>lift\<^sub>c c1 \<down> S"
    by simp
  moreover
  {
    fix w
    assume exec_lc1: "lift\<^sub>e \<Gamma>\<turnstile>\<langle>lift\<^sub>c c1,Normal s'\<rangle> \<Rightarrow> w"
    have "lift\<^sub>e \<Gamma>\<turnstile>lift\<^sub>c c2 \<down> w"
    proof (cases w)
      case (Normal w')
      with lift_exec [where c=c1, OF exec_lc1] s
      have "\<Gamma>\<turnstile>\<langle>c1,Normal s\<rangle> \<Rightarrow> Normal (project w')"
        by (simp add: project\<^sub>x_def)
      from Seq.hyps (3) [rule_format, OF this] Normal
      show "lift\<^sub>e \<Gamma>\<turnstile>lift\<^sub>c c2 \<down> w"
        by (auto simp add: project\<^sub>x_def xstate_map_convs)
    qed (auto)
  }
  ultimately show ?case
    using S s
    by (auto intro: terminates.intros)
next
  case CondTrue thus ?case
    by (fastforce simp add: project\<^sub>x_def lift\<^sub>s_def Compose.lift\<^sub>s_def xstate_map_convs
      intro: terminates.intros)
next
  case CondFalse thus ?case
    by (fastforce simp add: project\<^sub>x_def lift\<^sub>s_def Compose.lift\<^sub>s_def xstate_map_convs
      intro: terminates.intros)
next
  case (WhileTrue s b c)
  have "project\<^sub>x S = Normal s" by fact
  then obtain s' where S: "S=Normal s'" and s: "s = project s'"
    by (auto simp add: project\<^sub>x_def xstate_map_convs)
  from WhileTrue have "lift\<^sub>e \<Gamma>\<turnstile>lift\<^sub>c c \<down> S"
    by simp
  moreover
  {
    fix w
    assume exec_lc: "lift\<^sub>e \<Gamma>\<turnstile>\<langle>lift\<^sub>c c,Normal s'\<rangle> \<Rightarrow> w"
    have "lift\<^sub>e \<Gamma>\<turnstile>lift\<^sub>c (While b c) \<down> w"
    proof (cases w)
      case (Normal w')
      with lift_exec [where c=c, OF exec_lc] s
      have "\<Gamma>\<turnstile>\<langle>c,Normal s\<rangle> \<Rightarrow> Normal (project w')"
        by (simp add: project\<^sub>x_def)
      from WhileTrue.hyps (4) [rule_format, OF this] Normal
      show "lift\<^sub>e \<Gamma>\<turnstile>lift\<^sub>c (While b c) \<down> w"
        by (auto simp add: project\<^sub>x_def xstate_map_convs)
    qed (auto)
  }
  ultimately show ?case
    using S s
    by (auto intro: terminates.intros)
next
  case WhileFalse thus ?case
    by (fastforce simp add: project\<^sub>x_def lift\<^sub>s_def Compose.lift\<^sub>s_def xstate_map_convs
      intro: terminates.intros)
next
  case Call thus ?case
    by (fastforce simp add: project\<^sub>x_def xstate_map_convs lift\<^sub>e_def
      intro: terminates.intros)
next
  case CallUndefined thus ?case
    by (fastforce simp add: project\<^sub>x_def xstate_map_convs lift\<^sub>e_def
      intro: terminates.intros)
next
  case Stuck thus ?case
    by (fastforce simp add: project\<^sub>x_def xstate_map_convs)
next
  case DynCom thus ?case
    by (fastforce simp add: project\<^sub>x_def xstate_map_convs
      intro: terminates.intros)
next
  case Throw thus ?case
    by (fastforce simp add: project\<^sub>x_def xstate_map_convs
      intro: terminates.intros)
next
  case Abrupt thus ?case
    by (fastforce simp add: project\<^sub>x_def xstate_map_convs
      intro: terminates.intros)
next
  case (Catch c1 s c2)
  have "project\<^sub>x S = Normal s" by fact
  then obtain s' where S: "S=Normal s'" and s: "s = project s'"
    by (auto simp add: project\<^sub>x_def xstate_map_convs)
  from Catch have "lift\<^sub>e \<Gamma>\<turnstile>lift\<^sub>c c1 \<down> S"
    by simp
  moreover
  {
    fix w
    assume exec_lc1: "lift\<^sub>e \<Gamma>\<turnstile>\<langle>lift\<^sub>c c1,Normal s'\<rangle> \<Rightarrow> Abrupt w"
    have "lift\<^sub>e \<Gamma>\<turnstile>lift\<^sub>c c2 \<down> Normal w"
    proof -
      from lift_exec [where c=c1, OF exec_lc1] s
      have "\<Gamma>\<turnstile>\<langle>c1,Normal s\<rangle> \<Rightarrow> Abrupt (project w)"
        by (simp add: project\<^sub>x_def)
      from Catch.hyps (3) [rule_format, OF this]
      show "lift\<^sub>e \<Gamma>\<turnstile>lift\<^sub>c c2 \<down> Normal w"
        by (auto simp add: project\<^sub>x_def xstate_map_convs)
    qed
  }
  ultimately show ?case
    using S s
    by (auto intro: terminates.intros)
qed

lemma (in lift_state_space) lift_termination':
assumes termi: "\<Gamma>\<turnstile>c\<down>project\<^sub>x S"
shows "lift\<^sub>e \<Gamma> \<turnstile>(lift\<^sub>c c)\<down>S"
  using lift_termination [OF termi]
  by iprover

lemma (in lift_state_space) lift_validt:
  assumes valid: "\<Gamma>\<Turnstile>\<^sub>t\<^bsub>/F\<^esub> P c Q,A"
  shows "(lift\<^sub>e \<Gamma>)\<Turnstile>\<^sub>t\<^bsub>/F\<^esub> (lift\<^sub>s P) (lift\<^sub>c c) (lift\<^sub>s Q),(lift\<^sub>s A)"
proof -
  from valid
  have "(lift\<^sub>e \<Gamma>)\<Turnstile>\<^bsub>/F\<^esub> (lift\<^sub>s P) (lift\<^sub>c c) (lift\<^sub>s Q),(lift\<^sub>s A)"
    by (auto intro: lift_valid simp add: validt_def)
  moreover
  {
    fix S
    assume "S \<in> lift\<^sub>s P"
    hence "project S \<in> P"
      by (simp add: lift\<^sub>s_def Compose.lift\<^sub>s_def)
    with valid have "\<Gamma>\<turnstile>c \<down> project\<^sub>x (Normal S)"
      by (simp add: validt_def project\<^sub>x_def)
    hence "lift\<^sub>e \<Gamma>\<turnstile>lift\<^sub>c c \<down> Normal S"
      by (rule lift_termination')
  }
  ultimately show ?thesis
    by (simp add: validt_def)
qed

lemma (in lift_state_space) lift_hoaret:
  assumes deriv: "\<Gamma>,{}\<turnstile>\<^sub>t\<^bsub>/F\<^esub> P c Q,A"
  shows
   "(lift\<^sub>e \<Gamma>),{}\<turnstile>\<^sub>t\<^bsub>/F\<^esub> (lift\<^sub>s P) (lift\<^sub>c c) (lift\<^sub>s Q),(lift\<^sub>s A)"
apply (rule hoaret_complete)
apply (insert hoaret_sound [OF deriv])
apply (rule lift_validt)
apply (simp add: cvalidt_def)
done

locale lift_state_space_ext = lift_state_space +
  assumes inj_proj_commute: "\<And>S. inject S (project S) = S"
  assumes inject_last: "\<And>S s t. inject (inject S s) t = inject S t"

(* \<exists>x. state t = inject (state s) x *)
lemma (in lift_state_space_ext) lift_exec_inject_same:
assumes exec_lc: "(lift\<^sub>e \<Gamma>)\<turnstile>\<langle>lc,s\<rangle> \<Rightarrow> t"
shows "\<And>c. \<lbrakk>lift\<^sub>c c = lc; t \<notin> (Fault ` UNIV) \<union> {Stuck}\<rbrakk> \<Longrightarrow>
              state t = inject (state s) (project (state t))"
using exec_lc
proof (induct)
  case Skip thus ?case
    by (clarsimp simp add: inj_proj_commute)
next
  case Guard thus ?case
    by (clarsimp simp add: lift\<^sub>c_Guard lift\<^sub>c_def)
next
  case GuardFault thus ?case
    by simp
next
  case FaultProp thus ?case by simp
next
  case Basic thus ?case
    by (clarsimp simp add: lift\<^sub>f_def Compose.lift\<^sub>f_def
        proj_inj_commute lift\<^sub>c_Basic lift\<^sub>c_def)
next
  case (Spec r) thus ?case
    by (clarsimp simp add: Compose.lift\<^sub>r_def lift\<^sub>c_Spec lift\<^sub>c_def)
next
  case SpecStuck
  thus ?case by simp
next
  case (Seq lc1 s s' lc2 t c)
  have t: "t \<notin> Fault ` UNIV \<union> {Stuck}" by fact
  have "lift\<^sub>c c = Seq lc1 lc2" by fact
  then obtain c1 c2 where
    c: "c = Seq c1 c2" and
    lc1: "lc1 = lift\<^sub>c c1" and
    lc2: "lc2 = lift\<^sub>c c2"
    by (auto simp add: lift\<^sub>c_Seq lift\<^sub>c_def)
  show ?case
  proof (cases s')
    case (Normal s'')
    from Seq.hyps (2) [OF lc1 [symmetric]] this
    have "s'' = inject s (project s'')"
      by auto
    moreover from Seq.hyps (4) [OF lc2 [symmetric]] Normal t
    have "state t = inject s'' (project (state t))"
      by auto
    ultimately have "state t = inject (inject s (project s'')) (project (state t))"
      by simp
    then show ?thesis
      by (simp add: inject_last)
  next
    case (Abrupt s'')
    from Seq.hyps (2) [OF lc1 [symmetric]] this
    have "s'' = inject s (project s'')"
      by auto
    moreover from Seq.hyps (4) [OF lc2 [symmetric]] Abrupt t
    have "state t = inject s'' (project (state t))"
      by auto
    ultimately have "state t = inject (inject s (project s'')) (project (state t))"
      by simp
    then show ?thesis
      by (simp add: inject_last)
  next
    case (Fault f)
    with Seq
    have "t = Fault f"
      by (auto dest: Fault_end)
    with t have False by simp
    thus ?thesis ..
  next
    case Stuck
    with Seq
    have "t = Stuck"
      by (auto dest: Stuck_end)
    with t have False by simp
    thus ?thesis ..
  qed
next
  case CondTrue thus ?case
    by (clarsimp simp add: lift\<^sub>c_Cond lift\<^sub>c_def)
next
  case CondFalse thus ?case
    by (clarsimp simp add: lift\<^sub>c_Cond lift\<^sub>c_def)
next
  case (WhileTrue s lb lc' s' t c)
  have t: "t \<notin> Fault ` UNIV \<union> {Stuck}" by fact
  have lw: "lift\<^sub>c c = While lb lc'" by fact
  then obtain b c' where
    c: "c = While b c'" and
    lb: "lb = lift\<^sub>s b" and
    lc: "lc' = lift\<^sub>c c'"
    by (auto simp add: lift\<^sub>c_While lift\<^sub>s_def lift\<^sub>c_def)
  show ?case
  proof (cases s')
    case (Normal s'')
    from WhileTrue.hyps (3) [OF lc [symmetric]] this
    have "s'' = inject s (project s'')"
      by auto
    moreover from WhileTrue.hyps (5) [OF lw] Normal t
    have "state t = inject s'' (project (state t))"
      by auto
    ultimately have "state t = inject (inject s (project s'')) (project (state t))"
      by simp
    then show ?thesis
      by (simp add: inject_last)
  next
    case (Abrupt s'')
    from WhileTrue.hyps (3) [OF lc [symmetric]] this
    have "s'' = inject s (project s'')"
      by auto
    moreover from WhileTrue.hyps (5) [OF lw] Abrupt t
    have "state t = inject s'' (project (state t))"
      by auto
    ultimately have "state t = inject (inject s (project s'')) (project (state t))"
      by simp
    then show ?thesis
      by (simp add: inject_last)
  next
    case (Fault f)
    with WhileTrue
    have "t = Fault f"
      by (auto dest: Fault_end)
    with t have False by simp
    thus ?thesis ..
  next
    case Stuck
    with WhileTrue
    have "t = Stuck"
      by (auto dest: Stuck_end)
    with t have False by simp
    thus ?thesis ..
  qed
next
  case WhileFalse thus ?case
    by (clarsimp simp add: lift\<^sub>c_While inj_proj_commute)
next
  case Call thus ?case
    by (clarsimp simp add: inject_last lift\<^sub>c_Call lift\<^sub>e_def lift\<^sub>c_def)
next
  case CallUndefined thus ?case by simp
next
  case StuckProp thus ?case by simp
next
  case DynCom
  thus ?case
    by (clarsimp simp add: lift\<^sub>c_DynCom lift\<^sub>c_def)
next
  case Throw thus ?case
    by (simp add: inj_proj_commute)
next
  case AbruptProp thus ?case by (simp add: inj_proj_commute)
next
  case (CatchMatch lc1 s s' lc2 t c)
  have t: "t \<notin> Fault ` UNIV \<union> {Stuck}" by fact
  have "lift\<^sub>c c = Catch lc1 lc2" by fact
  then obtain c1 c2 where
    c: "c = Catch c1 c2" and
    lc1: "lc1 = lift\<^sub>c c1" and
    lc2: "lc2 = lift\<^sub>c c2"
    by (auto simp add: lift\<^sub>c_Catch lift\<^sub>c_def)
  from CatchMatch.hyps (2) [OF lc1 [symmetric]] this
  have "s' = inject s (project s')"
    by auto
  moreover
  from CatchMatch.hyps (4) [OF lc2 [symmetric]] t
  have "state t = inject s' (project (state t))"
    by auto
  ultimately have "state t = inject (inject s (project s')) (project (state t))"
    by simp
  then show ?case
    by (simp add: inject_last)
next
  case CatchMiss
  thus ?case
    by (clarsimp simp add: lift\<^sub>c_Catch lift\<^sub>c_def)
qed

lemma (in lift_state_space_ext) valid_inject_project:
 assumes noFaultStuck:
  "\<Gamma>\<turnstile>\<langle>c,Normal (project \<sigma>)\<rangle> \<Rightarrow>\<notin>(Fault ` UNIV \<union> {Stuck})"
 shows "lift\<^sub>e \<Gamma>\<Turnstile>\<^bsub>/F\<^esub> {\<sigma>} lift\<^sub>c c
                {t. t=inject \<sigma> (project t)}, {t. t=inject \<sigma> (project t)}"
proof (rule validI)
  fix s t
  assume exec: "lift\<^sub>e \<Gamma>\<turnstile>\<langle>lift\<^sub>c c,Normal s\<rangle> \<Rightarrow> t"
  assume P: "s \<in> {\<sigma>}"
  assume noFault: "t \<notin> Fault ` F"
  show "t \<in> Normal ` {t. t = inject \<sigma> (project t)} \<union>
        Abrupt ` {t. t = inject \<sigma> (project t)}"
  proof -
    from lift_exec [OF exec]
    have "\<Gamma>\<turnstile>\<langle>c,project\<^sub>x (Normal s)\<rangle> \<Rightarrow> project\<^sub>x t"
      by simp
    with noFaultStuck P have t: "t \<notin> Fault ` UNIV \<union> {Stuck}"
      by (auto simp add: final_notin_def project\<^sub>x_def)
    from lift_exec_inject_same [OF exec refl this] P
    have "state t = inject \<sigma> (project (state t))"
      by simp
    with t show ?thesis
      by (cases t) auto
  qed
qed

lemma (in lift_state_space_ext) lift_exec_inject_same':
assumes exec_lc: "(lift\<^sub>e \<Gamma>)\<turnstile>\<langle>lift\<^sub>c c,S\<rangle> \<Rightarrow> T"
shows "\<And>c. \<lbrakk>T \<notin> (Fault ` UNIV) \<union> {Stuck}\<rbrakk> \<Longrightarrow>
              state T = inject (state S) (project (state T))"
  using lift_exec_inject_same [OF exec_lc]
  by simp

lemma (in lift_state_space_ext) valid_lift_modifies:
  assumes valid: "\<forall>s. \<Gamma>\<Turnstile>\<^bsub>/F\<^esub> {s} c (Modif s),(ModifAbr s)"
  shows "(lift\<^sub>e \<Gamma>)\<Turnstile>\<^bsub>/F\<^esub> {S} (lift\<^sub>c c)
           {T. T \<in> lift\<^sub>s (Modif (project S)) \<and> T=inject S (project T)},
           {T. T \<in> lift\<^sub>s (ModifAbr (project S)) \<and> T=inject S (project T)}"
proof (rule validI)
  fix s t
  assume exec: "lift\<^sub>e \<Gamma>\<turnstile>\<langle>lift\<^sub>c c,Normal s\<rangle> \<Rightarrow> t"
  assume P: "s \<in> {S}"
  assume noFault: "t \<notin> Fault ` F"
  show "t \<in> Normal `
                 {t \<in> lift\<^sub>s (Modif (project S)).
                  t = inject S (project t)} \<union>
                 Abrupt `
                 {t \<in> lift\<^sub>s (ModifAbr (project S)).
                  t = inject S (project t)}"
  proof -
    from lift_exec [OF exec]
    have "\<Gamma>\<turnstile> \<langle>c,project\<^sub>x (Normal s)\<rangle> \<Rightarrow> project\<^sub>x t"
      by auto
    moreover
    from noFault have "project\<^sub>x t \<notin> Fault ` F"
      by (cases "t") (auto simp add: project\<^sub>x_def)
    ultimately
    have "project\<^sub>x t \<in>
            Normal ` (Modif (project s)) \<union> Abrupt ` (ModifAbr (project s))"
      using valid [rule_format, of "(project s)"]
      by (auto simp add: valid_def project\<^sub>x_def)
    hence t: "t \<in> Normal ` lift\<^sub>s (Modif (project s)) \<union>
               Abrupt ` lift\<^sub>s (ModifAbr (project s))"
      by (cases t) (auto simp add: project\<^sub>x_def lift\<^sub>s_def Compose.lift\<^sub>s_def)
    then have "t \<notin> Fault ` UNIV \<union> {Stuck}"
      by (cases t) auto
    from lift_exec_inject_same [OF exec _ this]
    have "state t = inject (state (Normal s)) (project (state t))"
      by simp
    with t show ?thesis
      using P by auto
  qed
qed

lemma (in lift_state_space_ext) hoare_lift_modifies:
  assumes deriv: "\<forall>\<sigma>. \<Gamma>,{}\<turnstile>\<^bsub>/F\<^esub> {\<sigma>} c (Modif \<sigma>),(ModifAbr \<sigma>)"
  shows "\<forall>\<sigma>. (lift\<^sub>e \<Gamma>),{}\<turnstile>\<^bsub>/F\<^esub> {\<sigma>} (lift\<^sub>c c)
           {T. T \<in> lift\<^sub>s (Modif (project \<sigma>)) \<and> T=inject \<sigma> (project T)},
           {T. T \<in> lift\<^sub>s (ModifAbr (project \<sigma>)) \<and> T=inject \<sigma> (project T)}"
apply (rule allI)
apply (rule hoare_complete)
apply (rule valid_lift_modifies)
apply (rule allI)
apply (insert hoare_sound [OF deriv [rule_format]])
apply (simp add: cvalid_def)
done

lemma (in lift_state_space_ext) hoare_lift_modifies':
  assumes deriv: "\<forall>\<sigma>. \<Gamma>,{}\<turnstile>\<^bsub>/F\<^esub> {\<sigma>} c (Modif \<sigma>),(ModifAbr \<sigma>)"
  shows "\<forall>\<sigma>. (lift\<^sub>e \<Gamma>),{}\<turnstile>\<^bsub>/F\<^esub> {\<sigma>} (lift\<^sub>c c)
           {T. T \<in> lift\<^sub>s (Modif (project \<sigma>)) \<and>
                   (\<exists>T'. T=inject \<sigma> T')},
           {T. T \<in> lift\<^sub>s (ModifAbr (project \<sigma>)) \<and>
                   (\<exists>T'. T=inject \<sigma> T')}"
apply (rule allI)
apply (rule HoarePartialDef.conseq [OF hoare_lift_modifies [OF deriv]])
apply blast
done

subsection \<open>Renaming Procedures\<close>

primrec rename:: "('p \<Rightarrow> 'q) \<Rightarrow> ('s,'p,'f) com \<Rightarrow> ('s,'q,'f) com"
where
"rename N Skip = Skip" |
"rename N (Basic f) = Basic f" |
"rename N (Spec r) = Spec r" |
"rename N (Seq c\<^sub>1 c\<^sub>2)  = (Seq (rename N c\<^sub>1) (rename N c\<^sub>2))" |
"rename N (Cond b c\<^sub>1 c\<^sub>2) = Cond b (rename N c\<^sub>1) (rename N c\<^sub>2)" |
"rename N (While b c) = While b (rename N c)" |
"rename N (Call p) = Call (N p)" |
"rename N (DynCom c) = DynCom (\<lambda>s. rename N (c s))" |
"rename N (Guard f g c) = Guard f g (rename N c)" |
"rename N Throw = Throw" |
"rename N (Catch c\<^sub>1 c\<^sub>2) = Catch (rename N c\<^sub>1) (rename N c\<^sub>2)"

lemma rename_Skip: "rename h c = Skip = (c=Skip)"
  by (cases c) auto

lemma rename_Basic:
  "(rename h c = Basic f) = (c=Basic f)"
  by (cases c) auto

lemma rename_Spec:
  "(rename h c = Spec r) = (c=Spec r)"
  by (cases c) auto

lemma rename_Seq:
  "(rename h c = Seq rc\<^sub>1 rc\<^sub>2) =
     (\<exists> c\<^sub>1 c\<^sub>2. c = Seq c\<^sub>1 c\<^sub>2 \<and>
               rc\<^sub>1 = rename h c\<^sub>1 \<and> rc\<^sub>2 = rename h c\<^sub>2 )"
    by (cases c) auto

lemma rename_Cond:
  "(rename h c = Cond b rc\<^sub>1 rc\<^sub>2) =
     (\<exists>c\<^sub>1 c\<^sub>2. c = Cond b c\<^sub>1 c\<^sub>2  \<and> rc\<^sub>1 = rename h c\<^sub>1 \<and> rc\<^sub>2 = rename h c\<^sub>2 )"
  by (cases c) auto

lemma rename_While:
  "(rename h c = While b rc') = (\<exists>c'. c = While b c' \<and> rc' = rename h c')"
  by (cases c) auto

lemma rename_Call:
  "(rename h c = Call q) = (\<exists>p. c = Call p \<and> q=h p)"
  by (cases c) auto

lemma rename_Guard:
  "(rename h c = Guard f g rc') =
     (\<exists>c'. c = Guard f g c' \<and> rc' = rename h c')"
   by (cases c) auto

lemma rename_Throw:
  "(rename h c = Throw) = (c = Throw)"
  by (cases c) auto

lemma rename_Catch:
  "(rename h c = Catch rc\<^sub>1 rc\<^sub>2) =
     (\<exists>c\<^sub>1 c\<^sub>2. c = Catch c\<^sub>1 c\<^sub>2 \<and> rc\<^sub>1 = rename h c\<^sub>1 \<and> rc\<^sub>2 = rename h c\<^sub>2 )"
    by (cases c) auto

lemma exec_rename_to_exec:
  assumes \<Gamma>: "\<forall>p bdy. \<Gamma> p = Some bdy \<longrightarrow> \<Gamma>' (h p) = Some (rename h bdy)"
  assumes exec: "\<Gamma>'\<turnstile>\<langle>rc,s\<rangle> \<Rightarrow> t"
  shows "\<And>c. rename h c = rc\<Longrightarrow>  \<exists>t'. \<Gamma>\<turnstile>\<langle>c,s\<rangle> \<Rightarrow> t' \<and> (t'=Stuck \<or> t'=t)"
using exec
proof (induct)
  case Skip thus ?case by (fastforce intro: exec.intros simp add: rename_Skip)
next
  case Guard thus ?case by (fastforce intro: exec.intros simp add: rename_Guard)
next
  case GuardFault thus ?case by (fastforce intro: exec.intros simp add: rename_Guard)
next
  case FaultProp thus ?case by (fastforce intro: exec.intros)
next
  case Basic thus ?case by (fastforce intro: exec.intros simp add: rename_Basic)
next
  case Spec thus ?case by (fastforce intro: exec.intros simp add: rename_Spec)
next
  case SpecStuck thus ?case by (fastforce intro: exec.intros simp add: rename_Spec)
next
  case Seq thus ?case by (fastforce intro: exec.intros simp add: rename_Seq)
next
  case CondTrue thus ?case by (fastforce intro: exec.intros simp add: rename_Cond)
next
  case CondFalse thus ?case by (fastforce intro: exec.intros simp add: rename_Cond)
next
  case WhileTrue thus ?case by (fastforce intro: exec.intros simp add: rename_While)
next
  case WhileFalse thus ?case by (fastforce intro: exec.intros simp add: rename_While)
next
  case (Call p rbdy s t)
  have rbdy: "\<Gamma>' p = Some rbdy" by fact
  have "rename h c = Call p" by fact
  then obtain q where c: "c=Call q" and p: "p=h q"
    by (auto simp add: rename_Call)
  show ?case
  proof (cases "\<Gamma> q")
    case None
    with c show ?thesis by (auto intro: exec.CallUndefined)
  next
    case (Some bdy)
    from \<Gamma> [rule_format, OF this] p rbdy
    have "rename h bdy = rbdy" by simp
    with Call.hyps c Some
    show ?thesis
      by (fastforce intro: exec.intros)
  qed
next
  case (CallUndefined p s)
  have undef: "\<Gamma>' p = None" by fact
  have "rename h c = Call p" by fact
  then obtain q where c: "c=Call q" and p: "p=h q"
    by (auto simp add: rename_Call)
  from undef p \<Gamma> have "\<Gamma> q = None"
    by (cases "\<Gamma> q") auto
  with p c show ?case
    by (auto intro: exec.intros)
next
  case StuckProp thus ?case by (fastforce intro: exec.intros)
next
  case DynCom thus ?case by (fastforce intro: exec.intros simp add: rename_DynCom)
next
  case Throw thus ?case by (fastforce intro: exec.intros simp add: rename_Throw)
next
  case AbruptProp thus ?case by (fastforce intro: exec.intros)
next
  case CatchMatch thus ?case by (fastforce intro: exec.intros simp add: rename_Catch)
next
  case CatchMiss thus ?case by (fastforce intro: exec.intros simp add: rename_Catch)
qed

lemma exec_rename_to_exec':
  assumes \<Gamma>: "\<forall>p bdy. \<Gamma> p = Some bdy \<longrightarrow> \<Gamma>' (N p) = Some (rename N bdy)"
  assumes exec: "\<Gamma>'\<turnstile>\<langle>rename N c,s\<rangle> \<Rightarrow> t"
  shows "\<exists>t'. \<Gamma>\<turnstile>\<langle>c,s\<rangle> \<Rightarrow> t' \<and> (t'=Stuck \<or> t'=t)"
  using exec_rename_to_exec [OF \<Gamma> exec]
  by  auto

lemma valid_to_valid_rename:
  assumes \<Gamma>: "\<forall>p bdy. \<Gamma> p = Some bdy \<longrightarrow> \<Gamma>' (N p) = Some (rename N bdy)"
  assumes valid: "\<Gamma>\<Turnstile>\<^bsub>/F\<^esub> P c Q,A"
  shows "\<Gamma>'\<Turnstile>\<^bsub>/F\<^esub> P (rename N c) Q,A"
proof (rule validI)
  fix s t
  assume execr: "\<Gamma>'\<turnstile> \<langle>rename N c,Normal s\<rangle> \<Rightarrow> t"
  assume P: "s \<in> P"
  assume noFault: "t \<notin> Fault ` F"
  show "t \<in> Normal ` Q \<union> Abrupt ` A"
  proof -
    from exec_rename_to_exec [OF \<Gamma> execr]
    obtain t' where
      exec: "\<Gamma>\<turnstile> \<langle>c,Normal s\<rangle> \<Rightarrow> t'"  and t': "(t' = Stuck \<or> t' = t)"
      by auto
    with valid noFault P show ?thesis
      by (auto simp add: valid_def)
  qed
qed

lemma hoare_to_hoare_rename:
  assumes \<Gamma>: "\<forall>p bdy. \<Gamma> p = Some bdy \<longrightarrow> \<Gamma>' (N p) = Some (rename N bdy)"
  assumes deriv: "\<Gamma>,{}\<turnstile>\<^bsub>/F\<^esub> P c Q,A"
  shows "\<Gamma>',{}\<turnstile>\<^bsub>/F\<^esub> P (rename N c) Q,A"
apply (rule hoare_complete)
apply (insert hoare_sound [OF deriv])
apply (rule valid_to_valid_rename)
apply  (rule \<Gamma>)
apply (simp add: cvalid_def)
done

lemma hoare_to_hoare_rename':
  assumes \<Gamma>: "\<forall>p bdy. \<Gamma> p = Some bdy \<longrightarrow> \<Gamma>' (N p) = Some (rename N bdy)"
  assumes deriv: "\<forall>Z. \<Gamma>,{}\<turnstile>\<^bsub>/F\<^esub> (P Z) c (Q Z),(A Z)"
  shows "\<forall>Z. \<Gamma>',{}\<turnstile>\<^bsub>/F\<^esub> (P Z) (rename N c) (Q Z),(A Z)"
apply rule
apply (rule hoare_to_hoare_rename [OF \<Gamma>])
apply (rule deriv[rule_format])
done

lemma terminates_to_terminates_rename:
  assumes \<Gamma>: "\<forall>p bdy. \<Gamma> p = Some bdy \<longrightarrow> \<Gamma>' (N p) = Some (rename N bdy)"
  assumes termi: "\<Gamma>\<turnstile> c \<down> s"
  assumes noStuck: "\<Gamma>\<turnstile> \<langle>c,s\<rangle> \<Rightarrow>\<notin>{Stuck}"
  shows "\<Gamma>'\<turnstile> rename N c \<down> s"
using termi noStuck
proof (induct)
  case Skip thus ?case by (fastforce intro: terminates.intros)
next
  case Basic thus ?case by (fastforce intro: terminates.intros)
next
  case Spec thus ?case by (fastforce intro: terminates.intros)
next
  case Guard thus ?case by (fastforce intro: terminates.intros
    simp add: final_notin_def exec.intros)
next
  case GuardFault thus ?case by (fastforce intro: terminates.intros)
next
  case Fault thus ?case by (fastforce intro: terminates.intros)
next
  case Seq
  thus ?case
    by (force intro!: terminates.intros exec.intros dest: exec_rename_to_exec [OF \<Gamma>]
         simp add: final_notin_def)
next
  case CondTrue thus ?case by (fastforce intro: terminates.intros
    simp add: final_notin_def exec.intros)
next
  case CondFalse thus ?case by (fastforce intro: terminates.intros
    simp add: final_notin_def exec.intros)
next
  case (WhileTrue s b c)
  have s_in_b: "s \<in> b" by fact
  have noStuck: "\<Gamma>\<turnstile> \<langle>While b c,Normal s\<rangle> \<Rightarrow>\<notin>{Stuck}" by fact
  with s_in_b have "\<Gamma>\<turnstile> \<langle>c,Normal s\<rangle> \<Rightarrow>\<notin>{Stuck}"
    by (auto simp add: final_notin_def intro: exec.intros)
  with WhileTrue.hyps have "\<Gamma>'\<turnstile>rename N c \<down> Normal s"
    by simp
  moreover
  {
    fix t
    assume exec_rc: "\<Gamma>'\<turnstile> \<langle>rename N c,Normal s\<rangle> \<Rightarrow> t"
    have "\<Gamma>'\<turnstile> While b (rename N c) \<down> t"
    proof -
      from exec_rename_to_exec [OF \<Gamma> exec_rc] obtain t'
        where exec_c: "\<Gamma>\<turnstile> \<langle>c,Normal s\<rangle> \<Rightarrow> t'" and t': "(t' = Stuck \<or> t' = t)"
        by auto
      with s_in_b noStuck obtain "t'=t" and "\<Gamma>\<turnstile> \<langle>While b c,t\<rangle> \<Rightarrow>\<notin>{Stuck}"
        by (auto simp add: final_notin_def intro: exec.intros)
      with exec_c WhileTrue.hyps
      show ?thesis
        by auto
    qed
  }
  ultimately show ?case
    using s_in_b
    by (auto intro: terminates.intros)
next
  case WhileFalse thus ?case by (fastforce intro: terminates.intros)
next
  case (Call p bdy s)
  have "\<Gamma> p = Some bdy" by fact
  from \<Gamma> [rule_format, OF this]
  have bdy': "\<Gamma>' (N p) = Some (rename N bdy)".
  from Call have "\<Gamma>'\<turnstile>rename N bdy \<down> Normal s"
    by (auto simp add: final_notin_def intro: exec.intros)
  with bdy' have "\<Gamma>'\<turnstile>Call (N p) \<down> Normal s"
    by (auto intro: terminates.intros)
  thus ?case by simp
next
  case (CallUndefined p s)
  have "\<Gamma> p = None" "\<Gamma>\<turnstile> \<langle>Call p,Normal s\<rangle> \<Rightarrow>\<notin>{Stuck}" by fact+
  hence False by (auto simp add: final_notin_def intro: exec.intros)
  thus ?case ..
next
  case Stuck thus ?case by (fastforce intro: terminates.intros)
next
  case DynCom thus ?case by (fastforce intro: terminates.intros
    simp add: final_notin_def exec.intros)
next
  case Throw thus ?case by (fastforce intro: terminates.intros)
next
  case Abrupt thus ?case by (fastforce intro: terminates.intros)
next
  case (Catch c1 s c2)
  have noStuck: "\<Gamma>\<turnstile> \<langle>Catch c1 c2,Normal s\<rangle> \<Rightarrow>\<notin>{Stuck}" by fact
  hence "\<Gamma>\<turnstile> \<langle>c1,Normal s\<rangle> \<Rightarrow>\<notin>{Stuck}"
    by (fastforce simp add: final_notin_def intro: exec.intros)
  with Catch.hyps have "\<Gamma>'\<turnstile>rename N c1 \<down> Normal s"
    by auto
  moreover
  {
    fix t
    assume exec_rc1:"\<Gamma>'\<turnstile> \<langle>rename N c1,Normal s\<rangle> \<Rightarrow> Abrupt t"
    have "\<Gamma>'\<turnstile>rename N c2 \<down> Normal t"
    proof -
      from exec_rename_to_exec [OF \<Gamma> exec_rc1] obtain t'
        where exec_c: "\<Gamma>\<turnstile> \<langle>c1,Normal s\<rangle> \<Rightarrow> t'" and "(t' = Stuck \<or> t' = Abrupt t)"
        by auto
      with noStuck have t': "t'=Abrupt t"
        by (fastforce simp add: final_notin_def intro: exec.intros)
      with exec_c noStuck have "\<Gamma>\<turnstile> \<langle>c2,Normal t\<rangle> \<Rightarrow>\<notin>{Stuck}"
        by (auto simp add: final_notin_def intro: exec.intros)
      with exec_c t' Catch.hyps
      show ?thesis
        by auto
    qed
  }
  ultimately show ?case
    by (auto intro: terminates.intros)
qed

lemma validt_to_validt_rename:
  assumes \<Gamma>: "\<forall>p bdy. \<Gamma> p = Some bdy \<longrightarrow> \<Gamma>' (N p) = Some (rename N bdy)"
  assumes valid: "\<Gamma>\<Turnstile>\<^sub>t\<^bsub>/F\<^esub> P c Q,A"
  shows "\<Gamma>'\<Turnstile>\<^sub>t\<^bsub>/F\<^esub> P (rename N c) Q,A"
proof -
  from valid
  have "\<Gamma>'\<Turnstile>\<^bsub>/F\<^esub> P (rename N c) Q,A"
    by (auto intro: valid_to_valid_rename [OF \<Gamma>] simp add: validt_def)
  moreover
  {
    fix s
    assume "s \<in> P"
    with valid obtain "\<Gamma>\<turnstile>c \<down> (Normal s)" "\<Gamma>\<turnstile> \<langle>c,Normal s\<rangle> \<Rightarrow>\<notin>{Stuck}"
      by (auto simp add: validt_def valid_def final_notin_def)
    from terminates_to_terminates_rename [OF \<Gamma> this]
    have "\<Gamma>'\<turnstile>rename N c \<down> Normal s"
      .
  }
  ultimately show ?thesis
    by (simp add: validt_def)
qed

lemma hoaret_to_hoaret_rename:
  assumes \<Gamma>: "\<forall>p bdy. \<Gamma> p = Some bdy \<longrightarrow> \<Gamma>' (N p) = Some (rename N bdy)"
  assumes deriv: "\<Gamma>,{}\<turnstile>\<^sub>t\<^bsub>/F\<^esub> P c Q,A"
  shows "\<Gamma>',{}\<turnstile>\<^sub>t\<^bsub>/F\<^esub> P (rename N c) Q,A"
apply (rule hoaret_complete)
apply (insert hoaret_sound [OF deriv])
apply (rule validt_to_validt_rename)
apply  (rule \<Gamma>)
apply (simp add: cvalidt_def)
done

lemma hoaret_to_hoaret_rename':
  assumes \<Gamma>: "\<forall>p bdy. \<Gamma> p = Some bdy \<longrightarrow> \<Gamma>' (N p) = Some (rename N bdy)"
  assumes deriv: "\<forall>Z. \<Gamma>,{}\<turnstile>\<^sub>t\<^bsub>/F\<^esub> (P Z) c (Q Z),(A Z)"
  shows "\<forall>Z. \<Gamma>',{}\<turnstile>\<^sub>t\<^bsub>/F\<^esub> (P Z) (rename N c) (Q Z),(A Z)"
apply rule
apply (rule hoaret_to_hoaret_rename [OF \<Gamma>])
apply (rule deriv[rule_format])
done

lemma lift\<^sub>c_whileAnno [simp]: "lift\<^sub>c prj inject (whileAnno b I V c) =
    whileAnno (lift\<^sub>s prj b)
              (lift\<^sub>s prj I) (lift\<^sub>r prj inject V) (lift\<^sub>c prj inject c)"
  by (simp add: whileAnno_def)

lemma lift\<^sub>c_block [simp]: "lift\<^sub>c prj inject (block init bdy return c) =
  block (lift\<^sub>f prj inject init) (lift\<^sub>c prj inject bdy)
        (\<lambda>s. (lift\<^sub>f prj inject (return (prj s))))
        (\<lambda>s t. lift\<^sub>c prj inject (c (prj s) (prj t)))"
  by (simp add: block_def)

(*
lemma lift\<^sub>c_block [simp]: "lift\<^sub>c prj inject (block init bdy return c) =
  block (lift\<^sub>f prj inject init) (lift\<^sub>c prj inject bdy)
        (\<lambda>s t. inject s (return (prj s) (prj t)))
        (\<lambda>s t. lift\<^sub>c prj inject (c (prj s) (prj t)))"
  apply (simp add: block_def)
  apply (simp add: lift\<^sub>f_def)
*)
lemma lift\<^sub>c_call [simp]: "lift\<^sub>c prj inject (call init p return c) =
  call (lift\<^sub>f prj inject init) p
        (\<lambda>s. (lift\<^sub>f prj inject (return (prj s))))
        (\<lambda>s t. lift\<^sub>c prj inject (c (prj s) (prj t)))"
  by (simp add: call_def lift\<^sub>c_block)

lemma rename_whileAnno [simp]: "rename h (whileAnno b I V c) =
   whileAnno b I V (rename h c)"
  by (simp add: whileAnno_def)

lemma rename_block [simp]: "rename h (block init bdy return c) =
  block init (rename h bdy) return (\<lambda>s t. rename h (c s t))"
  by (simp add: block_def)

lemma rename_call [simp]: "rename h (call init p return c) =
  call init (h p) return (\<lambda>s t. rename h (c s t))"
  by (simp add: call_def)

end


theory SINVAR_Tainting
imports "../TopoS_Helper"
begin

subsection {* SecurityInvariant Tainting for IFS  *}

context
begin

  qualified type_synonym taints = "string set"

  text{*Warning: an infinite set has cardinality 0*}
  lemma "card (UNIV::taints) = 0" by (simp add: infinite_UNIV_listI)

  qualified definition default_node_properties :: "taints"
    where  "default_node_properties \<equiv> {}"

  (*The definition we want to present*)
  text{*For all nodes @{term n} in the graph, for all nodes @{term r} which are reachable from @{term n},
        node @{term n} needs the appropriate tainting fields which are set by @{term r}*}
  definition sinvar_tainting :: "'v graph \<Rightarrow> ('v \<Rightarrow> taints) \<Rightarrow> bool" where
    "sinvar_tainting G nP \<equiv> \<forall> n \<in> (nodes G). \<forall>r \<in> (succ_tran G n). nP n \<subseteq> nP r"

  private lemma sinvar_tainting_edges_def: "wf_graph G \<Longrightarrow>
    sinvar_tainting G nP \<longleftrightarrow> (\<forall> (v1,v2) \<in> edges G. \<forall>r \<in> (succ_tran G v1). nP v1 \<subseteq> nP r)"
    unfolding sinvar_tainting_def
    proof
      assume a1: "wf_graph G"
        and  a2: "\<forall>n\<in>nodes G. \<forall>r\<in>succ_tran G n. nP n \<subseteq> nP r"
        from a1[simplified wf_graph_def] have f1: "fst ` edges G \<subseteq> nodes G" by simp
        from f1 a2 have "\<forall>v \<in> (fst ` edges G). \<forall>r\<in>succ_tran G v. nP v \<subseteq> nP r" by auto
        thus "\<forall>(v1, _)\<in>edges G. \<forall>r\<in>succ_tran G v1. nP v1 \<subseteq> nP r" by fastforce
      next
      assume a1: "wf_graph G"
        and  a2: "\<forall>(v1, v2)\<in>edges G. \<forall>r\<in>succ_tran G v1. nP v1 \<subseteq> nP r"
        from a2 have g1: "\<forall> v \<in> (fst ` edges G). \<forall>r\<in>succ_tran G v. nP v \<subseteq> nP r" by fastforce
        from FiniteGraph.succ_tran_empty[OF a1]
        have g2: "\<forall> v. v \<notin> (fst ` edges G) \<longrightarrow> (\<forall>r\<in>succ_tran G v. nP v \<subseteq> nP r)" by blast
        from g1 g2 show "\<forall>n\<in>nodes G. \<forall>r\<in>succ_tran G n. nP n \<subseteq> nP r" by metis
    qed

  text{*Alternative definition of the @{const sinvar_tainting}*}

  qualified definition sinvar :: "'v graph \<Rightarrow> ('v \<Rightarrow> taints) \<Rightarrow> bool" where
    "sinvar G nP \<equiv> \<forall> (v1,v2) \<in> edges G. nP v1 \<subseteq> nP v2"

  qualified lemma sinvar_preferred_def:
    "wf_graph G \<Longrightarrow> sinvar_tainting G nP = sinvar G nP"
    proof(unfold sinvar_tainting_edges_def sinvar_def, rule iffI, goal_cases)
    case 2
        have "(v, v') \<in> (edges G)\<^sup>+ \<Longrightarrow> nP v \<subseteq> nP v'" for v v'
          proof(induction rule: trancl_induct)
          case base thus ?case using 2(2) by fastforce
          next
          case step thus ?case using 2(2) by fastforce
          qed
        thus ?case
        by(simp add: succ_tran_def)
      next
      case 1
        from 1(1)[simplified wf_graph_def] have f1: "fst ` edges G \<subseteq> nodes G" by simp
        from f1 1(2) have "\<forall>v \<in> (fst ` edges G). \<forall>v'\<in>succ_tran G v. nP v \<subseteq> nP v'" by fastforce
        thus ?case unfolding succ_tran_def by fastforce
    qed

  text{*Information Flow Security*}
  qualified definition receiver_violation :: "bool" where "receiver_violation \<equiv> True"

  private

end

end


(*File: OBJ.thy*)
(*Authors: Lennart Beringer and Martin Hofmann, LMU Munich 2008*)
theory OBJ imports Main begin

section\<open>Base-line non-interference with objects\<close>

text\<open>\label{sec:Objects} We now extend the encoding for base-line
non-interference to a language with objects.  The development follows
the structure of Sections \ref{sec:IMP} to
\ref{sec:BaseLineNI}. Syntax and operational semantics are defined in
Section \ref{sec:ObjLanguage}, the axiomatic semantics in Section
\ref{sec:ObjLogic}. The generalised definition of non-interference is
given in \ref{sec:ObjNI}, the derived proof rules in Section
\ref{sec:ObjDerivedRules}, and a type system in the style of Volpano
et al.~in Section \ref{sec:ObjTypeSystem}. Finally, Section
\ref{sec:contextObj} concludes with results on contextual closure.\<close>

subsection \<open>Syntax and operational semantics\<close>
text\<open>\label{sec:ObjLanguage}\<close>

text\<open>First, some operations for association lists\<close>

primrec lookup :: "('a \<times> 'b) list \<Rightarrow> 'a \<Rightarrow> 'b option"
where
"lookup [] l = None" |
"lookup (h # t) l = (if (fst h)=l then Some (snd h) else lookup t l)"

definition Dom::"('a \<times> 'b) list \<Rightarrow> 'a set"
where "Dom L = {l . \<exists> a . lookup L l = Some a}"

(*<*)
lemma lookupNoneAppend[rule_format]:
"\<forall> l L2. (lookup L1 l = None \<longrightarrow> lookup L2 l = None \<longrightarrow> lookup (L1 @ L2) l = None)"
by (induct L1, simp+)

lemma DomAppendUnion[rule_format]: "\<forall> ab. Dom (a @ ab) = Dom a \<union> Dom ab"
apply (induct a)
apply (simp add: Dom_def)
apply (simp add: Dom_def)
apply clarsimp apply fast
done

lemma DomAppend: "Dom L \<subseteq> Dom((a, b) # L)"
by (simp add: Dom_def, auto)

lemma lookupSomeAppend1[rule_format]:
"\<forall> L2 l c . lookup L1 l = Some c \<longrightarrow> lookup (L1 @ L2) l = Some c"
by (induct L1, simp, simp)

lemma DomUnion[rule_format]:"Dom ((a,b) # L) = {a} \<union> Dom L"
by (simp add: Dom_def DomAppendUnion, fast)

lemma lookupSomeAppend2[rule_format]:
"\<forall> l c L2 . lookup L2 l = Some c \<longrightarrow> Dom L1 \<inter> Dom L2 = {} \<longrightarrow> lookup (L1 @ L2) l = Some c"
apply (induct L1)
apply (simp add: Dom_def)
apply clarsimp
  apply rule
    apply clarsimp apply (subgoal_tac "l:Dom L2") apply (simp add: DomUnion)
   apply (simp add: Dom_def)
apply clarsimp
  apply (erule_tac x=l in allE)
  apply (erule_tac x=c in allE)
  apply (erule_tac x=L2 in allE)
  apply simp apply (erule impE) apply (simp add: DomUnion)
  apply simp
done
(*>*)

text\<open>Abstract types of variables, class names, field names, and
locations.\<close>

typedecl Var
typedecl Class
typedecl Field
typedecl Location

text\<open>References are either null or a location. Values are either
integers or references.\<close>

datatype Ref = Nullref | Loc Location

datatype Val = RVal Ref | IVal int

text\<open>The heap is a finite map from locations to objects. Objects have
a dynamic class and a field map.\<close>

type_synonym Object = "Class \<times> ((Field \<times> Val) list)"
type_synonym Heap = "(Location \<times> Object) list"

text\<open>Stores contain values for all variables, and states are pairs of
stores and heaps.\<close>

type_synonym Store = "Var \<Rightarrow> Val"

definition update :: "Store \<Rightarrow> Var \<Rightarrow> Val \<Rightarrow> Store"
where "update s x v = (\<lambda> y . if x=y then v else s y)"

type_synonym State = "Store \<times> Heap"

text\<open>Arithmetic and boolean expressions are as before.\<close>

datatype Expr =
    varE Var
  | valE Val
  | opE "Val \<Rightarrow> Val \<Rightarrow> Val" Expr Expr

datatype BExpr = compB "Val \<Rightarrow> Val \<Rightarrow> bool" Expr Expr

text\<open>The same applies to their semantics.\<close>

primrec evalE::"Expr \<Rightarrow> Store \<Rightarrow> Val"
where
"evalE (varE x) s = s x" |
"evalE (valE v) s = v" |
"evalE (opE f e1 e2) s = f (evalE e1 s) (evalE e2 s)"

primrec evalB::"BExpr \<Rightarrow> Store \<Rightarrow> bool"
where
"evalB (compB f e1 e2) s = f (evalE e1 s) (evalE e2 s)"

text\<open>The category of commands is extended by instructions for
allocating a fresh object, obtaining a value from a field and assigning
a value to a field.\<close>

datatype OBJ =
    Skip
  | Assign Var Expr
  | New Var Class
  | Get Var Var Field
  | Put Var Field Expr
  | Comp OBJ OBJ
  | While BExpr OBJ
  | Iff BExpr OBJ OBJ
  | Call

text\<open>The body of the procedure is identified by the same constant as
before.\<close>

consts body :: OBJ

text\<open>The operational semantics is again a standard big-step
relation.\<close>

inductive_set Semn :: "(State \<times> OBJ \<times> nat \<times> State) set"
where
SemSkip: "s=t \<Longrightarrow> (s,Skip,1, t):Semn"

| SemAssign:
  "\<lbrakk> t = (update (fst s) x (evalE e (fst s)), snd s)\<rbrakk>
  \<Longrightarrow> (s, Assign x e, 1, t):Semn"

| SemNew:
  "\<lbrakk>l \<notin> Dom (snd s);
       t = (update (fst s) x (RVal (Loc l)), (l,(C,[])) # (snd s))\<rbrakk>
  \<Longrightarrow> (s, New x C, 1, t):Semn"

| SemGet:
  "\<lbrakk>(fst s) y = RVal(Loc l); lookup (snd s) l = Some(C,Flds);
       lookup Flds F = Some v; t = (update (fst s) x v, snd s)\<rbrakk>
  \<Longrightarrow> (s, Get x y F, 1, t):Semn"

| SemPut:
  "\<lbrakk>(fst s) x = RVal(Loc l); lookup (snd s) l = Some(C,Flds);
       t = (fst s, (l,(C,(F,evalE e (fst s)) # Flds)) # (snd s))\<rbrakk>
  \<Longrightarrow> (s, Put x F e, 1, t):Semn"

| SemComp:
  "\<lbrakk> (s, c, n, r):Semn; (r,d, m, t):Semn; k=(max n m)+1\<rbrakk>
  \<Longrightarrow> (s, Comp c d, k, t):Semn"

| SemWhileT:
  "\<lbrakk>evalB b (fst s); (s,c, n, r):Semn; (r, While b c, m, t):Semn; k=((max n m)+1)\<rbrakk>
  \<Longrightarrow> (s, While b c, k, t):Semn"

| SemWhileF:
  "\<lbrakk>\<not> (evalB b (fst s)); t=s\<rbrakk> \<Longrightarrow> (s, While b c, 1, t):Semn"

| SemTrue:
  "\<lbrakk>evalB b (fst s); (s,c1, n, t):Semn\<rbrakk>
  \<Longrightarrow> (s, Iff b c1 c2, n+1, t):Semn"

| SemFalse:
  "\<lbrakk>\<not> (evalB b (fst s)); (s,c2, n, t):Semn\<rbrakk>
  \<Longrightarrow> (s, Iff b c1 c2, n+1, t):Semn"

| SemCall: "\<lbrakk> (s,body,n, t):Semn\<rbrakk> \<Longrightarrow> (s,Call,n+1, t):Semn"

abbreviation
  SemN  :: "[State, OBJ, nat, State] \<Rightarrow> bool"   (" _ , _ \<rightarrow>\<^sub>_  _ ")
where
"s,c \<rightarrow>\<^sub>n t == (s,c,n,t) : Semn"

text\<open>Often, the height index does not matter, so we define a notion
hiding it.\<close>

definition
Sem :: "[State, OBJ, State] \<Rightarrow> bool" ("_ , _ \<Down> _ " 1000)
where "s,c \<Down> t = (\<exists> n. s,c \<rightarrow>\<^sub>n t)"

inductive_cases Sem_eval_cases:
 "s,Skip \<rightarrow>\<^sub>n t"
 "s,(Assign x e) \<rightarrow>\<^sub>n t"
 "s,(New x C) \<rightarrow>\<^sub>n t"
 "s,(Get x y F) \<rightarrow>\<^sub>n t"
 "s,(Put x F e) \<rightarrow>\<^sub>n t"
 "s,(Comp c1 c2) \<rightarrow>\<^sub>n t"
 "s,(While b c) \<rightarrow>\<^sub>n t"
 "s,(Iff b c1 c2) \<rightarrow>\<^sub>n t"
 "s, Call \<rightarrow>\<^sub>n t"

(*<*)
lemma Sem_no_zero_height_derivsAux: "\<forall> s t. ((s, c \<rightarrow>\<^sub>0 t) \<longrightarrow> False)"
by (induct_tac c, auto elim: Sem_eval_cases)
(*>*)
lemma Sem_no_zero_height_derivs: "(s, c \<rightarrow>\<^sub>0 t) \<Longrightarrow> False"
(*<*)by (insert Sem_no_zero_height_derivsAux, fastforce)(*>*)

text\<open>Determinism does not hold as allocation is nondeterministic.\<close>

text\<open>End of theory OBJ\<close>
end


(*  Title:       Counterexample-Reducing Inference Systems and the Standard Redundancy Criterion
    Author:      Jasmin Blanchette <j.c.blanchette at vu.nl>, 2014, 2017, 2020
    Author:      Dmitriy Traytel <traytel at inf.ethz.ch>, 2014
    Author:      Anders Schlichtkrull <andschl at dtu.dk>, 2017
    Author:      Martin Desharnais <desharnais at mpi-inf.mpg.de>, 2021
*)

section \<open>Counterexample-Reducing Inference Systems and the Standard Redundancy Criterion\<close>

theory Standard_Redundancy_Criterion
  imports
    Saturation_Framework.Calculus
    "HOL-Library.Multiset_Order"
begin

text \<open>
The standard redundancy criterion can be defined uniformly for all inference systems equipped with
a compact consequence relation. The essence of the refutational completeness argument can be carried
out abstractly for counterexample-reducing inference systems, which enjoy a ``smallest
counterexample'' property. This material is partly based on Section 4.2 of Bachmair and Ganzinger's
\emph{Handbook} chapter, but adapted to the saturation framework of Waldmann et al.
\<close>

subsection \<open>Counterexample-Reducing Inference Systems\<close>

abbreviation main_prem_of :: "'f inference \<Rightarrow> 'f" where
  "main_prem_of \<iota> \<equiv> last (prems_of \<iota>)"

abbreviation side_prems_of :: "'f inference \<Rightarrow> 'f list" where
  "side_prems_of \<iota> \<equiv> butlast (prems_of \<iota>)"

lemma set_prems_of:
  "set (prems_of \<iota>) = (if prems_of \<iota> = [] then {} else {main_prem_of \<iota>} \<union> set (side_prems_of \<iota>))"
  by clarsimp (metis Un_insert_right append_Nil2 append_butlast_last_id list.set(2) set_append)

locale counterex_reducing_inference_system = inference_system Inf + consequence_relation
  for Inf :: "'f inference set" +
  fixes
    I_of :: "'f set \<Rightarrow> 'f set" and
    less :: "'f \<Rightarrow> 'f \<Rightarrow> bool" (infix "\<prec>" 50)
  assumes
    wfP_less: "wfP (\<prec>)" and
    Inf_counterex_reducing:
      "N \<inter> Bot = {} \<Longrightarrow> D \<in> N \<Longrightarrow> \<not> I_of N \<Turnstile> {D} \<Longrightarrow>
      (\<And>C. C \<in> N \<Longrightarrow> \<not> I_of N \<Turnstile> {C} \<Longrightarrow> D \<prec> C \<or> D = C) \<Longrightarrow>
      \<exists>\<iota> \<in> Inf. prems_of \<iota> \<noteq> [] \<and> main_prem_of \<iota> = D \<and> set (side_prems_of \<iota>) \<subseteq> N \<and>
        I_of N \<Turnstile> set (side_prems_of \<iota>) \<and> \<not> I_of N \<Turnstile> {concl_of \<iota>} \<and> concl_of \<iota> \<prec> D"

begin

lemma ex_min_counterex:
  fixes N :: "'f set"
  assumes "\<not> I \<Turnstile> N"
  shows "\<exists>C \<in> N. \<not> I \<Turnstile> {C} \<and> (\<forall>D \<in> N. D \<prec> C \<longrightarrow> I \<Turnstile> {D})"
proof -
  obtain C where
    "C \<in> N" and "\<not> I \<Turnstile> {C}"
    using assms all_formulas_entailed by blast
  then have c_in: "C \<in> {C \<in> N. \<not> I \<Turnstile> {C}}"
    by blast
  show ?thesis
    using wfP_eq_minimal[THEN iffD1, rule_format, OF wfP_less c_in] by blast
qed

end

text \<open>
Theorem 4.4 (generalizes Theorems 3.9 and 3.16):
\<close>

locale counterex_reducing_inference_system_with_trivial_redundancy =
  counterex_reducing_inference_system _ _ Inf + calculus _ Inf _ "\<lambda>_. {}" "\<lambda>_. {}"
  for Inf :: "'f inference set" +
  assumes less_total: "\<And>C D. C \<noteq> D \<Longrightarrow> C \<prec> D \<or> D \<prec> C"
begin

theorem saturated_model:
  assumes
    satur: "saturated N" and
    bot_ni_n: "N \<inter> Bot = {}"
  shows "I_of N \<Turnstile> N"
proof (rule ccontr)
  assume "\<not> I_of N \<Turnstile> N"
  then obtain D :: 'f where
    d_in_n: "D \<in> N" and
    d_cex: "\<not> I_of N \<Turnstile> {D}" and
    d_min: "\<And>C. C \<in> N \<Longrightarrow> C \<prec> D \<Longrightarrow> I_of N \<Turnstile> {C}"
    by (meson ex_min_counterex)
  then obtain \<iota> :: "'f inference" where
    \<iota>_inf: "\<iota> \<in> Inf" and
    concl_cex: "\<not> I_of N \<Turnstile> {concl_of \<iota>}" and
    concl_lt_d: "concl_of \<iota> \<prec> D"
    using Inf_counterex_reducing[OF bot_ni_n] less_total
    by force
  have "concl_of \<iota> \<in> N"
    using \<iota>_inf Red_I_of_Inf_to_N by blast
  then show False
    using concl_cex concl_lt_d d_min by blast
qed

text \<open>
An abstract version of Corollary 3.10 does not hold without some conditions, according to Nitpick:
\<close>

corollary saturated_complete:
  assumes
    satur: "saturated N" and
    unsat: "N \<Turnstile> Bot"
  shows "N \<inter> Bot \<noteq> {}"
  oops

end

subsection \<open>Compactness\<close>

locale concl_compact_consequence_relation = consequence_relation +
  assumes
    entails_concl_compact: "finite EE \<Longrightarrow> CC \<Turnstile> EE \<Longrightarrow> \<exists>CC' \<subseteq> CC. finite CC' \<and> CC' \<Turnstile> EE"
begin

lemma entails_concl_compact_union:
  assumes
    fin_e: "finite EE" and
    cd_ent: "CC \<union> DD \<Turnstile> EE"
  shows "\<exists>CC' \<subseteq> CC. finite CC' \<and> CC' \<union> DD \<Turnstile> EE"
proof -
  obtain CCDD' where
    cd1_fin: "finite CCDD'" and
    cd1_sub: "CCDD' \<subseteq> CC \<union> DD" and
    cd1_ent: "CCDD' \<Turnstile> EE"
    using entails_concl_compact[OF fin_e cd_ent] by blast

  define CC' where
    "CC' = CCDD' - DD"
  have "CC' \<subseteq> CC"
    unfolding CC'_def using cd1_sub by blast
  moreover have "finite CC'"
    unfolding CC'_def using cd1_fin by blast
  moreover have "CC' \<union> DD \<Turnstile> EE"
    unfolding CC'_def using cd1_ent
    by (metis Un_Diff_cancel2 Un_upper1 entails_trans subset_entailed)
  ultimately show ?thesis
    by blast
qed

end

subsection \<open>The Finitary Standard Redundancy Criterion\<close>

locale finitary_standard_formula_redundancy =
  consequence_relation Bot "(\<Turnstile>)"
  for
    Bot :: "'f set" and
    entails :: "'f set \<Rightarrow> 'f set \<Rightarrow> bool" (infix "\<Turnstile>" 50) +
  fixes
    less :: "'f \<Rightarrow> 'f \<Rightarrow> bool" (infix "\<prec>" 50)
  assumes
    transp_less: "transp (\<prec>)" and
    wfP_less: "wfP (\<prec>)"
begin

definition Red_F :: "'f set \<Rightarrow> 'f set" where
  "Red_F N = {C. \<exists>DD \<subseteq> N. finite DD \<and> DD \<Turnstile> {C} \<and> (\<forall>D \<in> DD. D \<prec> C)}"

text \<open>
The following results correspond to Lemma 4.5. The lemma \<open>wlog_non_Red_F\<close> generalizes the core of
the argument.
\<close>

lemma Red_F_of_subset: "N \<subseteq> N' \<Longrightarrow> Red_F N \<subseteq> Red_F N'"
  unfolding Red_F_def by fast

lemma wlog_non_Red_F:
  assumes
    dd0_fin: "finite DD0" and
    dd0_sub: "DD0 \<subseteq> N" and
    dd0_ent: "DD0 \<union> CC \<Turnstile> {E}" and
    dd0_lt: "\<forall>D' \<in> DD0. D' \<prec> D"
  shows "\<exists>DD \<subseteq> N - Red_F N. finite DD \<and> DD \<union> CC \<Turnstile> {E} \<and> (\<forall>D' \<in> DD. D' \<prec> D)"
proof -
  have mset_DD0_in: "mset_set DD0 \<in>
    {DD. set_mset DD \<subseteq> N \<and> set_mset DD \<union> CC \<Turnstile> {E} \<and> (\<forall>D' \<in> set_mset DD. D' \<prec> D)}"
    using assms finite_set_mset_mset_set by simp
  obtain DD :: "'f multiset" where
    dd_subs_n: "set_mset DD \<subseteq> N" and
    ddcc_ent_e: "set_mset DD \<union> CC \<Turnstile> {E}" and
    dd_lt_d: "\<forall>D' \<in># DD. D' \<prec> D" and
    d_min: "\<forall>y. multp (\<prec>) y DD \<longrightarrow>
      y \<notin> {DD. set_mset DD \<subseteq> N \<and> set_mset DD \<union> CC \<Turnstile> {E} \<and> (\<forall>D'\<in>#DD. D' \<prec> D)}"
    using wfP_eq_minimal[THEN iffD1, rule_format, OF wfP_less[THEN wfP_multp] mset_DD0_in]
    by blast

  have "\<forall>Da \<in># DD. Da \<notin> Red_F N"
  proof clarify
    fix Da :: 'f
    assume
      da_in_dd: "Da \<in># DD" and
      da_rf: "Da \<in> Red_F N"

    obtain DDa0 :: "'f set" where
      dda0_subs_n: "DDa0 \<subseteq> N" and
      dda0_fin: "finite DDa0" and
      dda0_ent_da: "DDa0 \<Turnstile> {Da}" and
      dda0_lt_da: "\<forall>D \<in> DDa0. D \<prec> Da"
      using da_rf unfolding Red_F_def mem_Collect_eq
      by blast

    define DDa :: "'f multiset" where
      "DDa = DD - {#Da#} + mset_set DDa0"

    have "set_mset DDa \<subseteq> N"
      unfolding DDa_def using dd_subs_n dda0_subs_n finite_set_mset_mset_set[OF dda0_fin]
      by (smt (verit, best) contra_subsetD in_diffD subsetI union_iff)
    moreover have "set_mset DDa \<union> CC \<Turnstile> {E}"
    proof (rule entails_trans_strong[of _ "{Da}"])
      show "set_mset DDa \<union> CC \<Turnstile> {Da}"
        unfolding DDa_def set_mset_union finite_set_mset_mset_set[OF dda0_fin]
        by (rule entails_trans[OF _ dda0_ent_da]) (auto intro: subset_entailed)
    next
      have H: "set_mset (DD - {#Da#} + mset_set DDa0) \<union> CC \<union> {Da} =
        set_mset (DD + mset_set DDa0) \<union> CC"
        by (smt (verit) Un_insert_left Un_insert_right da_in_dd insert_DiffM
            set_mset_add_mset_insert set_mset_union sup_bot.right_neutral)
      show "set_mset DDa \<union> CC \<union> {Da} \<Turnstile> {E}"
        unfolding DDa_def H
        by (rule entails_trans[OF _ ddcc_ent_e]) (auto intro: subset_entailed)
    qed
    moreover have "\<forall>D' \<in># DDa. D' \<prec> D"
      using dd_lt_d dda0_lt_da da_in_dd unfolding DDa_def
      using transp_less[THEN transpD]
      using finite_set_mset_mset_set[OF dda0_fin]
      by (metis insert_DiffM2 union_iff)
    moreover have "multp (\<prec>) DDa DD"
      unfolding DDa_def multp_eq_multp\<^sub>D\<^sub>M[OF wfP_imp_asymp[OF wfP_less] transp_less] multp\<^sub>D\<^sub>M_def
      using finite_set_mset_mset_set[OF dda0_fin]
      by (metis da_in_dd dda0_lt_da mset_subset_eq_single multi_self_add_other_not_self
          union_single_eq_member)
    ultimately show False
      using d_min by (auto intro!: antisym)
  qed
  then show ?thesis
    using dd_subs_n ddcc_ent_e dd_lt_d by blast
qed

lemma Red_F_imp_ex_non_Red_F:
  assumes c_in: "C \<in> Red_F N"
  shows "\<exists>CC \<subseteq> N - Red_F N. finite CC \<and> CC \<Turnstile> {C} \<and> (\<forall>C' \<in> CC. C' \<prec> C)"
proof -
  obtain DD :: "'f set" where
    dd_fin: "finite DD" and
    dd_sub: "DD \<subseteq> N" and
    dd_ent: "DD \<Turnstile> {C}" and
    dd_lt: "\<forall>D \<in> DD. D \<prec> C"
    using c_in[unfolded Red_F_def] by fast
  show ?thesis
    by (rule wlog_non_Red_F[of "DD" N "{}" C C, simplified, OF dd_fin dd_sub dd_ent dd_lt])
qed

lemma Red_F_subs_Red_F_diff_Red_F: "Red_F N \<subseteq> Red_F (N - Red_F N)"
proof
  fix C
  assume c_rf: "C \<in> Red_F N"
  then obtain CC :: "'f set" where
    cc_subs: "CC \<subseteq> N - Red_F N" and
    cc_fin: "finite CC" and
    cc_ent_c: "CC \<Turnstile> {C}" and
    cc_lt_c: "\<forall>C' \<in> CC. C' \<prec> C"
    using Red_F_imp_ex_non_Red_F[of C N] by blast
  have "\<forall>D \<in> CC. D \<notin> Red_F N"
    using cc_subs by fast
  then have cc_nr:
    "\<forall>C \<in> CC. \<forall>DD \<subseteq> N. finite DD \<and> DD \<Turnstile> {C} \<longrightarrow> (\<exists>D \<in> DD. \<not> D \<prec> C)"
    unfolding Red_F_def by simp
  have "CC \<subseteq> N"
    using cc_subs by auto
  then have "CC \<subseteq> N - {C. \<exists>DD \<subseteq> N. finite DD \<and> DD \<Turnstile> {C} \<and> (\<forall>D \<in> DD. D \<prec> C)}"
    using cc_nr by blast
  then show "C \<in> Red_F (N - Red_F N)"
    using cc_fin cc_ent_c cc_lt_c unfolding Red_F_def by blast
qed

lemma Red_F_eq_Red_F_diff_Red_F: "Red_F N = Red_F (N - Red_F N)"
  by (simp add: Red_F_of_subset Red_F_subs_Red_F_diff_Red_F set_eq_subset)

text \<open>
The following results correspond to Lemma 4.6.
\<close>

lemma Red_F_of_Red_F_subset: "N' \<subseteq> Red_F N \<Longrightarrow> Red_F N \<subseteq> Red_F (N - N')"
  by (metis Diff_mono Red_F_eq_Red_F_diff_Red_F Red_F_of_subset order_refl)

lemma Red_F_model: "M \<Turnstile> N - Red_F N \<Longrightarrow> M \<Turnstile> N"
  by (metis (no_types) DiffI Red_F_imp_ex_non_Red_F entail_set_all_formulas entails_trans
      subset_entailed)

lemma Red_F_Bot: "B \<in> Bot \<Longrightarrow> N \<Turnstile> {B} \<Longrightarrow> N - Red_F N \<Turnstile> {B}"
  using Red_F_model entails_trans subset_entailed by blast

end

locale calculus_with_finitary_standard_redundancy =
  inference_system Inf + finitary_standard_formula_redundancy Bot "(\<Turnstile>)" "(\<prec>)"
  for
    Inf :: "'f inference set" and
    Bot :: "'f set" and
    entails :: "'f set \<Rightarrow> 'f set \<Rightarrow> bool" (infix "\<Turnstile>" 50) and
    less :: "'f \<Rightarrow> 'f \<Rightarrow> bool" (infix "\<prec>" 50) +
  assumes
    Inf_has_prem: "\<iota> \<in> Inf \<Longrightarrow> prems_of \<iota> \<noteq> []" and
    Inf_reductive: "\<iota> \<in> Inf \<Longrightarrow> concl_of \<iota> \<prec> main_prem_of \<iota>"
begin

definition redundant_infer :: "'f set \<Rightarrow> 'f inference \<Rightarrow> bool" where
  "redundant_infer N \<iota> \<longleftrightarrow>
   (\<exists>DD \<subseteq> N. finite DD \<and> DD \<union> set (side_prems_of \<iota>) \<Turnstile> {concl_of \<iota>} \<and> (\<forall>D \<in> DD. D \<prec> main_prem_of \<iota>))"

definition Red_I :: "'f set \<Rightarrow> 'f inference set" where
  "Red_I N = {\<iota> \<in> Inf. redundant_infer N \<iota>}"

text \<open>
The following results correspond to Lemma 4.6. It also uses @{thm [source] wlog_non_Red_F}.
\<close>

lemma Red_I_of_subset: "N \<subseteq> N' \<Longrightarrow> Red_I N \<subseteq> Red_I N'"
  unfolding Red_I_def redundant_infer_def by auto

lemma Red_I_subs_Red_I_diff_Red_F: "Red_I N \<subseteq> Red_I (N - Red_F N)"
proof
  fix \<iota>
  assume \<iota>_ri: "\<iota> \<in> Red_I N"
  define CC :: "'f set" where
    "CC = set (side_prems_of \<iota>)"
  define D :: 'f where
    "D = main_prem_of \<iota>"
  define E :: 'f where
    "E = concl_of \<iota>"
  obtain DD :: "'f set" where
    dd_fin: "finite DD" and
    dd_sub: "DD \<subseteq> N" and
    dd_ent: "DD \<union> CC \<Turnstile> {E}" and
    dd_lt_d: "\<forall>C \<in> DD. C \<prec> D"
    using \<iota>_ri unfolding Red_I_def redundant_infer_def CC_def D_def E_def by blast
  obtain DDa :: "'f set" where
    "DDa \<subseteq> N - Red_F N" and "finite DDa" and "DDa \<union> CC \<Turnstile> {E}" and "\<forall>D' \<in> DDa. D' \<prec> D"
    using wlog_non_Red_F[OF dd_fin dd_sub dd_ent dd_lt_d] by blast
  then show "\<iota> \<in> Red_I (N - Red_F N)"
    using \<iota>_ri unfolding Red_I_def redundant_infer_def CC_def D_def E_def by blast
qed

lemma Red_I_eq_Red_I_diff_Red_F: "Red_I N = Red_I (N - Red_F N)"
  by (metis Diff_subset Red_I_of_subset Red_I_subs_Red_I_diff_Red_F subset_antisym)

lemma Red_I_to_Inf: "Red_I N \<subseteq> Inf"
  unfolding Red_I_def by blast

lemma Red_I_of_Red_F_subset: "N' \<subseteq> Red_F N \<Longrightarrow> Red_I N \<subseteq> Red_I (N - N')"
  by (metis Diff_mono Red_I_eq_Red_I_diff_Red_F Red_I_of_subset order_refl)

lemma Red_I_of_Inf_to_N:
  assumes
    in_\<iota>: "\<iota> \<in> Inf" and
    concl_in: "concl_of \<iota> \<in> N"
  shows "\<iota> \<in> Red_I N"
proof -
  have "redundant_infer N \<iota>"
    unfolding redundant_infer_def
    by (rule exI[where x = "{concl_of \<iota>}"])
      (simp add: Inf_reductive[OF in_\<iota>] subset_entailed concl_in)
  then show "\<iota> \<in> Red_I N"
    by (simp add: Red_I_def in_\<iota>)
qed

text \<open>
The following corresponds to Theorems 4.7 and 4.8:
\<close>

sublocale calculus Bot Inf "(\<Turnstile>)" Red_I Red_F
  by (unfold_locales, fact Red_I_to_Inf, fact Red_F_Bot, fact Red_F_of_subset,
      fact Red_I_of_subset, fact Red_F_of_Red_F_subset, fact Red_I_of_Red_F_subset,
      fact Red_I_of_Inf_to_N)

end

subsection \<open>The Standard Redundancy Criterion\<close>

locale standard_formula_redundancy =
  concl_compact_consequence_relation Bot "(\<Turnstile>)"
  for
    Bot :: "'f set" and
    entails :: "'f set \<Rightarrow> 'f set \<Rightarrow> bool" (infix "\<Turnstile>" 50) +
  fixes
    less :: "'f \<Rightarrow> 'f \<Rightarrow> bool" (infix "\<prec>" 50)
  assumes
    transp_less: "transp (\<prec>)" and
    wfP_less: "wfP (\<prec>)"
begin

definition Red_F :: "'f set \<Rightarrow> 'f set" where
  "Red_F N = {C. \<exists>DD \<subseteq> N. DD \<Turnstile> {C} \<and> (\<forall>D \<in> DD. D \<prec> C)}"

text \<open>
Compactness of @{term "(\<Turnstile>)"} implies that @{const Red_F} is equivalent to its finitary
  counterpart.
\<close>

interpretation fin_std_red_F: finitary_standard_formula_redundancy Bot "(\<Turnstile>)" "(\<prec>)"
  using transp_less asymp_on_less wfP_less by unfold_locales

lemma Red_F_conv: "Red_F = fin_std_red_F.Red_F"
proof (intro ext)
  fix N
  show "Red_F N = fin_std_red_F.Red_F N"
    unfolding Red_F_def fin_std_red_F.Red_F_def
    using entails_concl_compact
    by (smt (verit, best) Collect_cong finite.emptyI finite_insert subset_eq)
qed

text \<open>
The results from @{locale finitary_standard_formula_redundancy} can now be lifted.

The following results correspond to Lemma 4.5.
\<close>

lemma Red_F_of_subset: "N \<subseteq> N' \<Longrightarrow> Red_F N \<subseteq> Red_F N'"
  unfolding Red_F_conv
  by (rule fin_std_red_F.Red_F_of_subset)

lemma Red_F_imp_ex_non_Red_F: "C \<in> Red_F N \<Longrightarrow> \<exists>CC \<subseteq> N - Red_F N. CC \<Turnstile> {C} \<and> (\<forall>C' \<in> CC. C' \<prec> C)"
  unfolding Red_F_conv
  using fin_std_red_F.Red_F_imp_ex_non_Red_F by meson

lemma Red_F_subs_Red_F_diff_Red_F: "Red_F N \<subseteq> Red_F (N - Red_F N)"
  unfolding Red_F_conv
  by (rule fin_std_red_F.Red_F_subs_Red_F_diff_Red_F)

lemma Red_F_eq_Red_F_diff_Red_F: "Red_F N = Red_F (N - Red_F N)"
  unfolding Red_F_conv
  by (rule fin_std_red_F.Red_F_eq_Red_F_diff_Red_F)

text \<open>
The following results correspond to Lemma 4.6.
\<close>

lemma Red_F_of_Red_F_subset: "N' \<subseteq> Red_F N \<Longrightarrow> Red_F N \<subseteq> Red_F (N - N')"
  unfolding Red_F_conv
  by (rule fin_std_red_F.Red_F_of_Red_F_subset)

lemma Red_F_model: "M \<Turnstile> N - Red_F N \<Longrightarrow> M \<Turnstile> N"
  unfolding Red_F_conv
  by (rule fin_std_red_F.Red_F_model)

lemma Red_F_Bot: "B \<in> Bot \<Longrightarrow> N \<Turnstile> {B} \<Longrightarrow> N - Red_F N \<Turnstile> {B}"
  unfolding Red_F_conv
  by (rule fin_std_red_F.Red_F_Bot)

end

locale calculus_with_standard_redundancy =
  inference_system Inf + standard_formula_redundancy Bot "(\<Turnstile>)" "(\<prec>)"
  for
    Inf :: "'f inference set" and
    Bot :: "'f set" and
    entails :: "'f set \<Rightarrow> 'f set \<Rightarrow> bool" (infix "\<Turnstile>" 50) and
    less :: "'f \<Rightarrow> 'f \<Rightarrow> bool" (infix "\<prec>" 50) +
  assumes
    Inf_has_prem: "\<iota> \<in> Inf \<Longrightarrow> prems_of \<iota> \<noteq> []" and
    Inf_reductive: "\<iota> \<in> Inf \<Longrightarrow> concl_of \<iota> \<prec> main_prem_of \<iota>"
begin

definition redundant_infer :: "'f set \<Rightarrow> 'f inference \<Rightarrow> bool" where
  "redundant_infer N \<iota> \<longleftrightarrow>
   (\<exists>DD \<subseteq> N. DD \<union> set (side_prems_of \<iota>) \<Turnstile> {concl_of \<iota>} \<and> (\<forall>D \<in> DD. D \<prec> main_prem_of \<iota>))"

definition Red_I :: "'f set \<Rightarrow> 'f inference set" where
  "Red_I N = {\<iota> \<in> Inf. redundant_infer N \<iota>}"

text \<open>
Compactness of @{term "(\<Turnstile>)"} implies that @{const Red_I} is equivalent to its finitary counterpart.
\<close>

interpretation fin_std_red: calculus_with_finitary_standard_redundancy Inf Bot "(\<Turnstile>)"
  using transp_less asymp_on_less wfP_less Inf_has_prem Inf_reductive by unfold_locales

lemma redundant_infer_conv: "redundant_infer = fin_std_red.redundant_infer"
proof (intro ext)
  fix N \<iota>
  show "redundant_infer N \<iota> \<longleftrightarrow> fin_std_red.redundant_infer N \<iota>"
    unfolding redundant_infer_def fin_std_red.redundant_infer_def
    using entails_concl_compact_union
    by (smt (verit, ccfv_threshold) finite.emptyI finite_insert subset_eq)
qed

lemma Red_I_conv: "Red_I = fin_std_red.Red_I"
  unfolding Red_I_def fin_std_red.Red_I_def
  unfolding redundant_infer_conv
  by (rule refl)

text \<open>
The results from @{locale calculus_with_finitary_standard_redundancy} can now be lifted.

The following results correspond to Lemma 4.6.
\<close>

lemma Red_I_of_subset: "N \<subseteq> N' \<Longrightarrow> Red_I N \<subseteq> Red_I N'"
  unfolding Red_I_conv
  by (rule fin_std_red.Red_I_of_subset)

lemma Red_I_subs_Red_I_diff_Red_F: "Red_I N \<subseteq> Red_I (N - Red_F N)"
  unfolding Red_F_conv Red_I_conv
  by (rule fin_std_red.Red_I_subs_Red_I_diff_Red_F)

lemma Red_I_eq_Red_I_diff_Red_F: "Red_I N = Red_I (N - Red_F N)"
  unfolding Red_F_conv Red_I_conv
  by (rule fin_std_red.Red_I_eq_Red_I_diff_Red_F)

lemma Red_I_to_Inf: "Red_I N \<subseteq> Inf"
  unfolding Red_I_conv
  by (rule fin_std_red.Red_I_to_Inf)

lemma Red_I_of_Red_F_subset: "N' \<subseteq> Red_F N \<Longrightarrow> Red_I N \<subseteq> Red_I (N - N')"
  unfolding Red_F_conv Red_I_conv
  by (rule fin_std_red.Red_I_of_Red_F_subset)

lemma Red_I_of_Inf_to_N:
  "\<iota> \<in> Inf \<Longrightarrow> concl_of \<iota> \<in> N \<Longrightarrow> \<iota> \<in> Red_I N"
  unfolding Red_I_conv
  by (rule fin_std_red.Red_I_of_Inf_to_N)

text \<open>
The following corresponds to Theorems 4.7 and 4.8:
\<close>

sublocale calculus Bot Inf "(\<Turnstile>)" Red_I Red_F
  by (unfold_locales, fact Red_I_to_Inf, fact Red_F_Bot, fact Red_F_of_subset,
      fact Red_I_of_subset, fact Red_F_of_Red_F_subset, fact Red_I_of_Red_F_subset,
      fact Red_I_of_Inf_to_N)

end

subsection \<open>Refutational Completeness\<close>

locale calculus_with_standard_inference_redundancy = calculus Bot Inf "(\<Turnstile>)" Red_I Red_F
  for Bot :: "'f set" and Inf and entails (infix "\<Turnstile>" 50) and Red_I and Red_F +
  fixes
    less :: "'f \<Rightarrow> 'f \<Rightarrow> bool" (infix "\<prec>" 50)
  assumes
    Inf_has_prem: "\<iota> \<in> Inf \<Longrightarrow> prems_of \<iota> \<noteq> []" and
    Red_I_imp_redundant_infer: "\<iota> \<in> Red_I N \<Longrightarrow>
      (\<exists>DD\<subseteq>N. DD \<union> set (side_prems_of \<iota>) \<Turnstile> {concl_of \<iota>} \<and> (\<forall>C\<in>DD. C \<prec> main_prem_of \<iota>))"

sublocale calculus_with_finitary_standard_redundancy \<subseteq>
  calculus_with_standard_inference_redundancy Bot Inf "(\<Turnstile>)" Red_I Red_F
  using Inf_has_prem
  by (unfold_locales) (auto simp: Red_I_def redundant_infer_def)

sublocale calculus_with_standard_redundancy \<subseteq>
  calculus_with_standard_inference_redundancy Bot Inf "(\<Turnstile>)" Red_I Red_F
  using Inf_has_prem
  by (unfold_locales) (simp_all add: Red_I_def redundant_infer_def)

locale counterex_reducing_calculus_with_standard_inferance_redundancy =
  calculus_with_standard_inference_redundancy Bot Inf "(\<Turnstile>)" Red_I Red_F "(\<prec>)" +
  counterex_reducing_inference_system Bot "(\<Turnstile>)" Inf I_of "(\<prec>)"
  for
    Bot :: "'f set" and
    Inf :: "'f inference set" and
    entails :: "'f set \<Rightarrow> 'f set \<Rightarrow> bool" (infix "\<Turnstile>" 50) and
    Red_I :: "'f set \<Rightarrow> 'f inference set" and
    Red_F :: "'f set \<Rightarrow> 'f set" and
    I_of :: "'f set \<Rightarrow> 'f set" and
    less :: "'f \<Rightarrow> 'f \<Rightarrow> bool" (infix "\<prec>" 50) +
  assumes less_total: "\<And>C D. C \<noteq> D \<Longrightarrow> C \<prec> D \<or> D \<prec> C"
begin

text \<open>
The following result loosely corresponds to Theorem 4.9.
\<close>

lemma saturated_model:
  assumes
    satur: "saturated N" and
    bot_ni_n: "N \<inter> Bot = {}"
  shows "I_of N \<Turnstile> N"
proof (rule ccontr)
  assume "\<not> I_of N \<Turnstile> N"
  then obtain D :: 'f where
    d_in_n: "D \<in> N" and
    d_cex: "\<not> I_of N \<Turnstile> {D}" and
    d_min: "\<And>C. C \<in> N \<Longrightarrow> C \<prec> D \<Longrightarrow> I_of N \<Turnstile> {C}"
    using ex_min_counterex by blast
  then obtain \<iota> :: "'f inference" where
    \<iota>_in: "\<iota> \<in> Inf" and
    \<iota>_mprem: "D = main_prem_of \<iota>" and
    sprem_subs_n: "set (side_prems_of \<iota>) \<subseteq> N" and
    sprem_true: "I_of N \<Turnstile> set (side_prems_of \<iota>)" and
    concl_cex: "\<not> I_of N \<Turnstile> {concl_of \<iota>}" and
    concl_lt_d: "concl_of \<iota> \<prec> D"
    using Inf_counterex_reducing[OF bot_ni_n] less_total by metis
  have "\<iota> \<in> Red_I N"
    by (rule subsetD[OF satur[unfolded saturated_def Inf_from_def]],
        simp add: \<iota>_in set_prems_of Inf_has_prem)
      (use \<iota>_mprem d_in_n sprem_subs_n  in blast)
  then have "\<iota> \<in> Red_I N"
    using Red_I_without_red_F by blast
  then obtain DD :: "'f set" where
    dd_subs_n: "DD \<subseteq> N" and
    dd_cc_ent_d: "DD \<union> set (side_prems_of \<iota>) \<Turnstile> {concl_of \<iota>}" and
    dd_lt_d: "\<forall>C \<in> DD. C \<prec> D"
    unfolding \<iota>_mprem using Red_I_imp_redundant_infer by meson
  from dd_subs_n dd_lt_d have "I_of N \<Turnstile> DD"
    using d_min by (meson ex_min_counterex subset_iff)
  then have "I_of N \<Turnstile> {concl_of \<iota>}"
    using entails_trans dd_cc_ent_d entail_union sprem_true by blast
  then show False
    using concl_cex by auto
qed

text \<open>
A more faithful abstract version of Theorem 4.9 does not hold without some conditions, according to
Nitpick:
\<close>

corollary saturated_complete:
  assumes
    satur: "saturated N" and
    unsat: "N \<Turnstile> Bot"
  shows "N \<inter> Bot \<noteq> {}"
  oops

end

end