(*  Title:      JinjaThreads/J/DefAssPreservation.thy
    Author:     Andreas Lochbihler, Tobias Nipkow
*)

section \<open>Preservation of definite assignment\<close>

theory DefAssPreservation
imports
  DefAss
  JWellForm
  SmallStep
begin

text\<open>Preservation of definite assignment more complex and requires a
few lemmas first.\<close>

lemma D_extRetJ [intro!]: "\<D> e A \<Longrightarrow> \<D> (extRet2J e va) A"
by(cases va) simp_all

lemma blocks_defass [iff]: "\<And>A. \<lbrakk> length Vs = length Ts; length vs = length Ts\<rbrakk> \<Longrightarrow>
 \<D> (blocks Vs Ts vs e) A = \<D> e (A \<squnion> \<lfloor>set Vs\<rfloor>)"
(*<*)
apply(induct Vs Ts vs e rule:blocks.induct)
apply(simp_all add:hyperset_defs)
done
(*>*)

context J_heap_base begin

lemma red_lA_incr: "extTA,P,t \<turnstile> \<langle>e,s\<rangle> -ta\<rightarrow> \<langle>e',s'\<rangle> \<Longrightarrow> \<lfloor>dom (lcl s)\<rfloor> \<squnion> \ e \<sqsubseteq>  \<lfloor>dom (lcl s')\<rfloor> \<squnion> \ e'"
  and reds_lA_incr: "extTA,P,t \<turnstile> \<langle>es,s\<rangle> [-ta\<rightarrow>] \<langle>es',s'\<rangle> \<Longrightarrow> \<lfloor>dom (lcl s)\<rfloor> \<squnion> \s es \<sqsubseteq>  \<lfloor>dom (lcl s')\<rfloor> \<squnion> \s es'"
apply(induct rule:red_reds.inducts)
apply(simp_all del:fun_upd_apply add:hyperset_defs)
apply blast
apply blast
apply blast
apply blast
apply blast
apply blast
apply blast
apply blast
apply blast
apply blast
apply blast
apply blast
apply blast
apply blast
apply blast
apply(force split: if_split_asm)
apply blast
apply blast
apply blast
apply blast
apply blast
apply(blast dest: red_lcl_incr)
apply(blast dest: red_lcl_incr)
by blast+

end

text\<open>Now preservation of definite assignment.\<close>

declare hyperUn_comm [simp del]
declare hyperUn_leftComm [simp del]

context J_heap_base begin

lemma assumes wf: "wf_J_prog P"
  shows red_preserves_defass: "extTA,P,t \<turnstile> \<langle>e,s\<rangle> -ta\<rightarrow> \<langle>e',s'\<rangle> \<Longrightarrow> \<D> e \<lfloor>dom (lcl s)\<rfloor> \<Longrightarrow> \<D> e' \<lfloor>dom (lcl s')\<rfloor>"
  and reds_preserves_defass: "extTA,P,t \<turnstile> \<langle>es,s\<rangle> [-ta\<rightarrow>] \<langle>es',s'\<rangle> \<Longrightarrow> \<D>s es \<lfloor>dom (lcl s)\<rfloor> \<Longrightarrow> \<D>s es' \<lfloor>dom (lcl s')\<rfloor>"
proof (induction rule:red_reds.inducts)
  case BinOpRed1 thus ?case by (auto elim!: D_mono[OF red_lA_incr])
next
  case AAccRed1 thus ?case by (auto elim!: D_mono[OF red_lA_incr])
next
  case AAssRed1 thus ?case by(auto intro: red_lA_incr sqUn_lem D_mono)
next
  case AAssRed2 thus ?case by (auto elim!: D_mono[OF red_lA_incr])
next
  case FAssRed1 thus ?case by (auto elim!: D_mono[OF red_lA_incr])
next
  case CASRed1 thus ?case by(auto intro: red_lA_incr sqUn_lem D_mono)
next
  case CASRed2 thus ?case by (auto elim!: D_mono[OF red_lA_incr])
next
  case CallObj thus ?case by (auto elim!: Ds_mono[OF red_lA_incr])
next
  case CallParams thus ?case by(auto elim!: Ds_mono[OF red_lA_incr])
next
  case RedCall thus ?case by(auto dest!:sees_wf_mdecl[OF wf] simp:wf_mdecl_def elim!:D_mono')
next
  case BlockRed thus ?case
    by(auto simp:hyperset_defs elim!:D_mono' simp del:fun_upd_apply split: if_split_asm)
next
  case SynchronizedRed1 thus ?case by(auto elim!: D_mono[OF red_lA_incr])
next
  case SeqRed thus ?case by (auto elim!: D_mono[OF red_lA_incr])
next
  case CondRed thus ?case by (auto elim!: D_mono[OF red_lA_incr])
next
  case TryRed thus ?case
    by (fastforce dest:red_lcl_incr intro:D_mono' simp:hyperset_defs)
next
  case RedWhile thus ?case by(auto simp:hyperset_defs elim!:D_mono')
next
  case ListRed1 thus ?case by (auto elim!: Ds_mono[OF red_lA_incr])
qed (auto simp:hyperset_defs)

end

end


theory StandardModel
imports
  Protocol
  ExecMessage
  Subst
begin

section{* Operational Semantics *}

types execstep = "i \<times> rolestep"

types trace = "execstep list"

fun spies :: "subst \<Rightarrow> trace \<Rightarrow> execmsg set"
where
  "spies s [] = IK0"
| "spies s ((i, Send l pt) # es) =
     insert (inst s i pt) (spies s es)"
| "spies s ((i, Recv l pt) # es) = spies s es"

types threadpool = "i \<rightharpoonup> (rolestep list \<times> rolestep list)"

types state = "trace \<times> threadpool \<times> subst"

inductive_set
  ossp :: "proto \<Rightarrow> state set"
  for P     :: "proto"
where
  init:  "\<lbrakk> \<forall> i done todo. r i = Some (done,todo) \<longrightarrow>
                             done = [] \<and> todo \<in> P;
            domS s = {EVar (AVar a) i | a i. True};
            ranS s \<subseteq> {Lit (EHonest a) | a. True} \<union> {Lit (Eve a) | a. True}
          \<rbrakk>
          \<Longrightarrow> ([], r, s) \<in> ossp P"

| send:  "\<lbrakk> (t, r, s) \<in> ossp P;
            r i = Some (done, Send l pt # todo)
          \<rbrakk>
          \<Longrightarrow> ( t @ [(i, Send l pt)],
                r(i \<mapsto> (done@[Send l pt], todo)), s) \<in> ossp P"

| recv:  "\<lbrakk> (t, r, s) \<in> ossp P;
            r i = Some (done, Recv l pt # todo);
            domS \<alpha> = { EVar v i | v. v \<in> FV pt };
            inst (extendS s \<alpha>) i pt \<in> infer (spies s t)
          \<rbrakk>
          \<Longrightarrow> (t @ [(i, Recv l pt)],
               r(i \<mapsto> (done@[Recv l pt], todo)), extendS s \<alpha>) \<in> ossp P"

locale ossp_state = wf_proto+
  fixes t :: trace
  and r :: threadpool
  and s :: subst
  assumes ossp: "(t,r,s) \<in> ossp P"

subsubsection{* Properties *}

lemma spies_conv_set:
  "spies s t = IK0 \<union> { inst s i pt
                     | i l pt. (i, Send l pt) \<in> set t }"
  by (induct t rule: spies.induct) auto

lemma in_IK0_in_spies [simp,intro]: "m \<in> IK0 \<Longrightarrow> m \<in> spies s t"
  by (simp add: spies_conv_set)

lemma spies_append [simp]:
  "spies s (t@t') = spies s t \<union> spies s t'"
  by (auto simp: spies_conv_set)

lemma spies_Un_IK0_conv_spies [simp]:
  "spies s t \<union> IK0 = spies s t"
  "IK0 \<union> spies s t = spies s t"
  by(auto)

section{* Security Properties *}

definition runs :: "threadpool \<Rightarrow> i \<Rightarrow> role \<Rightarrow> bool"
where "runs r i R \<equiv> case r i of
                        Some (done, todo) \<Rightarrow> R = done@todo
                      | None \<Rightarrow> False"

(* TODO: adapt names: knows \<rightarrow> learnt, kntrace \<rightarrow> ?, \<dots>*)
definition known :: "subst \<Rightarrow> trace \<Rightarrow> execmsg set"
where "known s t \<equiv> infer (spies s t)"

types honesty_asms = "id set"

definition secret :: "proto \<Rightarrow> role \<Rightarrow> rolestep \<Rightarrow> honesty_asms \<Rightarrow> pattern  \<Rightarrow> bool"
where
  "secret P R step H pt \<equiv> \<forall> (t,r,s) \<in> ossp P. \<forall> i.
     ( runs r i R \<and> (i,step) \<in> set t \<and>
       (\<forall> a \<in> H. Rep_subst s (EVar (AVar a) i) \<notin> Compromised)
     ) \<longrightarrow>
     ( inst s i pt \<notin> known s t )"

subsection{* Parts from other theories to be ported  *}

subsection{* Relation to Operational Semantics *}

(* TODO: Port to substitution-less explicit model

subsubsection{* From Explicit Traces to Implicit Traces *}

fun execsteps :: "explicit_trace \<Rightarrow> trace"
where
  "execsteps []               = []"
| "execsteps (Step estep # t) =  estep # execsteps t"
| "execsteps (_ # t)          =          execsteps t"

lemma execsteps_append [simp]:
  "execsteps (t@t') = execsteps t @ execsteps t'"
  by(induct t rule: execsteps.induct, auto)

lemma set_execsteps_conv_set [simp]:
  "set (execsteps t) =
   { (i,step) | i step. (i, step) \<in> steps t}"
  by(induct t rule: execsteps.induct, auto)

context reachable_state begin

lemma spies_execsteps_extendS [simp]:
  "spies (extendS s \<alpha>) (execsteps t) =
   spies s (execsteps t)"
  apply(auto simp: spies_conv_set)
  apply(force dest: steps_ground)+
  done

(* MOVE *)
lemmas infer_monoD = rev_subsetD[OF _ infer_mono]

lemma knows_spies_execsteps:
  "m \<in> knows t \<Longrightarrow> m \<in> infer (spies s (execsteps t))"
proof(induct arbitrary: m rule: reachable_induct)
  case init thus ?case by simp
next
  case (send t r s i "done" l msg todo m' m) thus ?case
    by(fastsimp elim!: infer_monoD pairParts_in_infer)
next
  case (recv t r s i "done" l msg todo \<alpha> m)
  then interpret this_state: reachable_state P t r s by unfold_locales
  show ?case using recv
    by(simp add: this_state.spies_execsteps_extendS)
next
  case hash thus ?case by(fastsimp intro: infer.Hash)
next
  case encr thus ?case by(fastsimp intro: infer.Enc)
next
  case decr thus ?case
    by(simp, blast intro: pairParts_in_infer[OF _ infer.Dec])
next
  case tuple thus ?case by fastsimp
qed

lemma in_ossp:
  "(execsteps t, r, s) \<in> ossp P"
proof (induct rule: reachable_induct)
  case init thus ?case by (simp add: ossp.init)
next
  case (send t r s i "done" l msg todo m) thus ?case
    by(fastsimp simp del: Fun.fun_upd_apply
                  intro!: ossp.send)
next
  case (recv t r s i "done" l msg todo \<alpha>)
  then interpret this_state: reachable_state P t r s by unfold_locales
  show ?case using recv
    by(fastsimp simp del: Fun.fun_upd_apply
                  intro!: ossp.recv
                          this_state.knows_spies_execsteps)
qed auto

end

subsubsection{* Implicit to Explicit Traces *}

context reachable_state
begin

lemma infer_known_subset_in_knows:
  assumes m: "m \<in> infer M"
  and M: "M \<subseteq> knows t"
  shows "\<exists> t'. (t@t',r,s) \<in> reachable P \<and> execsteps t' = [] \<and>
            m \<in> knows (t@t') \<and> (\<forall> x \<in> M. x \<notin> knows t')"
  (is "\<exists> t'. ?extension t t' m")
using m M reachable
proof(induct arbitrary: t rule: infer.induct)
  case (Inj m t)
  hence "?extension t [] m" by auto
  thus ?case by fast
next
  case (Fst x y t) then
  obtain t' where ext: "?extension t t' \<lbrace>x, y\<rbrace>" by fastsimp
  then interpret ext_state: reachable_state P "t@t'" r s
    by unfold_locales auto
  from ext have "?extension t t' x"
    by (fastsimp simp del: knows_append
                    intro: ext_state.knows_pairParts_closedD)
  thus ?case by fast
next
  case (Snd x y t) then
  obtain t' where ext: "?extension t t' \<lbrace>x, y\<rbrace>" by fastsimp
  then interpret ext_state: reachable_state P "t@t'" r s
    by unfold_locales auto
  from ext have "?extension t t' y"
    by (fastsimp simp del: knows_append
                    intro: ext_state.knows_pairParts_closedD)
  thus ?case by fast
next
  case (Hash m t) then
  obtain t' where ext: "?extension t t' m" by fastsimp
  then interpret ext_state: reachable_state P "t@t'" r s
    by unfold_locales auto
  show ?case
  proof(cases "Hash m \<in> knows (t@t')")
    case True thus ?thesis using ext by auto
  next
    case False
    hence "((t@t')@[Learns {Hash m}], r, s) \<in> reachable P"
      using ext
      by(fastsimp intro!: reachable.hash simp del: append_assoc)
    thus ?thesis using ext and `M \<subseteq> knows t` and False
      by(fastsimp)
  qed
next
  case (Tup x y t)
  then obtain t' where ext1: "?extension t t' x" by fastsimp
  hence "\<exists> t''. ?extension (t@t') t'' y" using Tup
    apply-
    apply(rule prems)
    apply(auto)
    done
  then obtain t'' where ext2: "?extension t (t'@t'') y"
    using ext1 by auto
  then interpret ext_state: reachable_state P "t@t'@t''" r s
    by unfold_locales auto
  show ?case
  proof(cases "Tup x y \<in> knows (t@t'@t'')")
    case True thus ?thesis using ext2 by auto
  next
    case False
    hence "((t@t'@t'')@[Learns {Tup x y}], r, s) \<in> reachable P"
      using ext1 and ext2
      by(fastsimp intro!: reachable.tuple simp del: append_assoc)
    thus ?thesis using ext1 ext2 `M \<subseteq> knows t` and False
      by(fastsimp)
  qed
next
  case (Enc m k t)
  then obtain t' where ext1: "?extension t t' m" by fastsimp
  hence "\<exists> t''. ?extension (t@t') t'' k" using Enc
    apply-
    apply(rule prems)
    apply(auto)
    done
  then obtain t'' where ext2: "?extension t (t'@t'') k"
    using ext1 by auto
  then interpret ext_state: reachable_state P "t@t'@t''" r s
    by unfold_locales auto
  show ?case
  proof(cases "Enc m k \<in> knows (t@t'@t'')")
    case True thus ?thesis using ext2 by auto
  next
    case False
    hence "((t@t'@t'')@[Learns {Enc m k}], r, s) \<in> reachable P"
      using ext1 and ext2
      by(fastsimp intro!: reachable.encr simp del: append_assoc)
    thus ?thesis using ext1 ext2 `M \<subseteq> knows t` and False
      by(fastsimp)
  qed
next
  case (Dec m k t)
  then obtain t' where ext1: "?extension t t' (Enc m k)" by fastsimp
  hence "\<exists> t''. ?extension (t@t') t'' (inv k)" using Dec
    apply-
    apply(rule prems)
    apply(auto)
    done
  then obtain t'' where ext2: "?extension t (t'@t'') (inv k)"
    using ext1 by auto
  then interpret ext_state: reachable_state P "t@t'@t''" r s
    by unfold_locales auto
  show ?case
  proof(cases "m \<in> knows (t@t'@t'')")
    case True thus ?thesis using ext2 by auto
  next
    case False
    hence "((t@t'@t'')@[Learns (pairParts m - knows (t@t'@t''))], r, s)
           \<in> reachable P"
      using ext1 and ext2
      by(fastsimp intro!: reachable.decr simp del: append_assoc)
    thus ?thesis using ext1 ext2 `M \<subseteq> knows t` and False
      by(fastsimp)
  qed
qed

lemma  in_spies_imp_in_knows:
  "m \<in> spies s (execsteps t) \<Longrightarrow> m \<in> knows t"
proof(induct rule: reachable_induct)
  case (recv t r s i "done" l msg todo \<alpha>)
  then interpret this_state: reachable_state P t r s by unfold_locales
  show ?case using recv
    by(simp add: this_state.spies_execsteps_extendS)
qed auto

lemma in_infer_spies_imp_in_ext_knows:
  assumes "m \<in> infer (spies s (execsteps t))"
  shows "\<exists> t'. execsteps t' = [] \<and> (t@t',r,s) \<in> reachable P \<and>
               m \<in> knows (t@t')"
proof -
  from `m \<in> infer (spies s (execsteps t))`
  obtain M
    where "finite M"
    and "m \<in> infer M"
    and "M \<subseteq> spies s (execsteps t)"
    by (blast dest: infer_finite_support)
  hence "M \<subseteq> knows t"
    by (fast intro!: in_spies_imp_in_knows)
  with `m \<in> infer M`
  obtain t' where "(t @ t', r, s) \<in> reachable P"
    and "execsteps t' = []"
    and "m \<in> knows (t @ t')"
    by (fast dest!: infer_known_subset_in_knows)
  thus ?thesis by fast
qed

lemma refine_attack_raw:
  assumes subset: "M \<subseteq> infer (spies s (execsteps t))"
  and finite: "finite M"
  shows "\<exists> t'. execsteps t' = [] \<and> (t@t',r,s) \<in> reachable P \<and>
               M \<subseteq> knows (t@t')"
  (is "\<exists> t'. ?extension M t'")
using finite subset
proof(induct rule: finite.induct)
  case emptyI
  have "execsteps [] = []" by simp
  thus ?case by fastsimp
next
  case (insertI M m)
  then obtain t' where ext1: "?extension M t'" by auto
  moreover
  then interpret s1: reachable_state P "t@t'" r s
    by unfold_locales auto
  have infer_m: "m \<in> infer (spies s (execsteps (t@t')))"
    using insertI ext1 by fastsimp
  then obtain t''
    where "execsteps t'' = []"
      "(t@(t'@t''),r,s) \<in> reachable P"
      "m \<in> knows (t@t'@t'')"
    using ext1 s1.in_infer_spies_imp_in_ext_knows[OF infer_m]
    by(auto)
  ultimately show ?case
    apply-
    apply(rule_tac x="t'@t''" in exI)
    by(auto)
qed

end

context ossp_state
begin

(* TODO: move *)
lemmas ossp_induct =
  ossp.induct[OF ossp, consumes 0, case_names init send recv]

lemma in_reachable:
  "\<exists> t'. t = execsteps t' \<and> (t',r,s) \<in> reachable P"
  (is "\<exists> t'. ?witness t r s t'")
proof(induct rule: ossp_induct)
  case (init r s)
  hence "?witness [] r s [Learns IK0]"
    by(fastsimp intro!: reachable.init)
  thus ?case by fast
next
  case (send t r s i "done" l pt todo) then
  obtain t' where "?witness t r s t'" by fast
  hence "?witness (t @ [(i, Send l pt)])
                  (r(i \<mapsto> (done @ [Send l pt], todo)))
                  s
    (t'@[Step (i, Send l pt),
         Learns (pairParts (inst s i pt) - knows t')])"
    using send
    by(fastsimp intro!: reachable.send)
  thus ?case by fast
next
  case (recv t r s i "done" l pt todo \<alpha>)
  then obtain t' where "?witness t r s t'" by fast
  hence "t = execsteps t'" and "(t', r, s) \<in> reachable P" by auto
  then interpret s1: reachable_state P t' r s by unfold_locales auto
  let ?m = "inst (extendS s \<alpha>) i pt"
  from `?m \<in> infer (spies s t)` and `t = execsteps t'`
  obtain t'' where "(t' @ t'', r, s) \<in> reachable P"
    and "execsteps t'' = []"
    and "?m \<in> knows (t' @ t'')"
    by (fastsimp dest!: s1.in_infer_spies_imp_in_ext_knows)
  hence "?witness (t @ [(i, Recv l pt)])
                  (r(i \<mapsto> (done @ [Recv l pt], todo)))
                  (extendS s \<alpha>)
                  ((t'@t'')@[Step (i, Recv l pt)])"
    using `t = execsteps t'` and recv
    by(fastsimp intro!: reachable.recv)
  thus ?case by fast
qed

end

lemma (in wf_proto) ossp_conv_reachable:
  "ossp P = {(execsteps t,r,s) | t r s. (t,r,s) \<in> reachable P}"
proof -
  { fix t r s
    assume "(t,r,s) \<in> ossp P"
    then interpret s1: ossp_state P t r s by unfold_locales
    note this = s1.in_reachable
  }
  moreover
  { fix t r s
    assume "(t,r,s) \<in> reachable P"
    then interpret s2: reachable_state P t r s by unfold_locales
    note this = s2.in_ossp
  }
  ultimately
  show ?thesis by fast
qed

*)

subsection{* Reduction Rules for Security Properties *}

(* TODO: Port to substitition-less explicit model

lemma runs_conv_roleMap [iff]:
  "runs r i R = (roleMap r i = Some R)"
by(auto simp: runs_def roleMap_def split: option.splits)

lemma (in reachable_state) in_known_kntrace_imp_in_ext_knows:
  assumes known: "m \<in> known s (execsteps t)"
  shows "\<exists> t'. execsteps t' = [] \<and> (t@t',r,s) \<in> reachable P \<and>
                m \<in> knows (t@t')"
using known unfolding known_def
by (rule in_infer_spies_imp_in_ext_knows)

lemma (in ossp_state) known_in_ext_knows:
  assumes "m \<in> known s t"
  shows "\<exists> t'. t = execsteps t' \<and> (t',r,s) \<in> reachable P \<and>
                m \<in> knows t'"
proof -
  from in_reachable
  obtain t' where "t = execsteps t'" and "(t',r,s) \<in> reachable P"
    by fast
  moreover
  then interpret s1: reachable_state P t' r s
    by unfold_locales auto
  from `m \<in> known s t` and `t = execsteps t'`
  obtain t''
    where "execsteps t'' = []"
    and "(t'@t'',r,s) \<in> reachable P"
    and "m \<in> knows (t'@t'')"
    by (fast dest!: s1.in_known_kntrace_imp_in_ext_knows)
  moreover
  with `t = execsteps t'`
  have "t = execsteps (t'@t'')" by simp
  ultimately
  show ?thesis by fast
qed

lemma (in wf_proto) secretI:
  assumes reachable_secrecy:
    "\<And> t r s i.
     \<lbrakk> (t, r, s) \<in> reachable P; roleMap r i = Some R;
       \<forall> a \<in> H. Rep_subst s (EVar (AVar a) i) \<notin> Compromised;
       (i, step) \<in> steps t;
       inst s i msg \<in> knows t
     \<rbrakk> \<Longrightarrow> False "
  shows "secret P R step H msg"
proof -
  { fix t r s i
    assume asms:
      "(t, r, s) \<in> ossp P"
      "runs r i R"
      "\<forall> a \<in> H. Rep_subst s (EVar (AVar a) i) \<notin> Compromised"
      "(i,step) \<in> set t"
      "inst s i msg \<in> known s t" (is "?m \<in> known s t")
    moreover
    then interpret s1: ossp_state P t r s by unfold_locales
    obtain t'
      where "(t', r, s) \<in> reachable P"
      and "t = execsteps t'"
      and "?m \<in> knows t'"
      using asms by (fast dest!: s1.known_in_ext_knows)
    ultimately
    have "False"
      by (fastsimp dest!: reachable_secrecy)
  }
  thus ?thesis by (fastsimp simp: secret_def)
qed

lemma listOrd_kntrace_conv_predOrd [iff]:
  "listOrd (execsteps t) (i,step) (i',step') =
   predOrd t (St (i, step)) (St (i', step'))"
by (induct t rule: execsteps.induct) auto

*)

end


(*  Title:      HOL/UNITY/SubstAx.thy
    Author:     Lawrence C Paulson, Cambridge University Computer Laboratory
    Copyright   1998  University of Cambridge

Weak LeadsTo relation (restricted to the set of reachable states)
*)

section\<open>Weak Progress\<close>

theory SubstAx imports WFair Constrains begin

definition Ensures :: "['a set, 'a set] => 'a program set" (infixl "Ensures" 60) where
    "A Ensures B == {F. F \<in> (reachable F \<inter> A) ensures B}"

definition LeadsTo :: "['a set, 'a set] => 'a program set" (infixl "LeadsTo" 60) where
    "A LeadsTo B == {F. F \<in> (reachable F \<inter> A) leadsTo B}"

notation LeadsTo  (infixl "\<longmapsto>w" 60)

text\<open>Resembles the previous definition of LeadsTo\<close>
lemma LeadsTo_eq_leadsTo:
     "A LeadsTo B = {F. F \<in> (reachable F \<inter> A) leadsTo (reachable F \<inter> B)}"
apply (unfold LeadsTo_def)
apply (blast dest: psp_stable2 intro: leadsTo_weaken)
done

subsection\<open>Specialized laws for handling invariants\<close>

(** Conjoining an Always property **)

lemma Always_LeadsTo_pre:
     "F \<in> Always INV ==> (F \<in> (INV \<inter> A) LeadsTo A') = (F \<in> A LeadsTo A')"
by (simp add: LeadsTo_def Always_eq_includes_reachable Int_absorb2
              Int_assoc [symmetric])

lemma Always_LeadsTo_post:
     "F \<in> Always INV ==> (F \<in> A LeadsTo (INV \<inter> A')) = (F \<in> A LeadsTo A')"
by (simp add: LeadsTo_eq_leadsTo Always_eq_includes_reachable Int_absorb2
              Int_assoc [symmetric])

(* [| F \<in> Always C;  F \<in> (C \<inter> A) LeadsTo A' |] ==> F \<in> A LeadsTo A' *)
lemmas Always_LeadsToI = Always_LeadsTo_pre [THEN iffD1]

(* [| F \<in> Always INV;  F \<in> A LeadsTo A' |] ==> F \<in> A LeadsTo (INV \<inter> A') *)
lemmas Always_LeadsToD = Always_LeadsTo_post [THEN iffD2]

subsection\<open>Introduction rules: Basis, Trans, Union\<close>

lemma leadsTo_imp_LeadsTo: "F \<in> A leadsTo B ==> F \<in> A LeadsTo B"
apply (simp add: LeadsTo_def)
apply (blast intro: leadsTo_weaken_L)
done

lemma LeadsTo_Trans:
     "[| F \<in> A LeadsTo B;  F \<in> B LeadsTo C |] ==> F \<in> A LeadsTo C"
apply (simp add: LeadsTo_eq_leadsTo)
apply (blast intro: leadsTo_Trans)
done

lemma LeadsTo_Union:
     "(!!A. A \<in> S ==> F \<in> A LeadsTo B) ==> F \<in> (\<Union>S) LeadsTo B"
apply (simp add: LeadsTo_def)
apply (subst Int_Union)
apply (blast intro: leadsTo_UN)
done

subsection\<open>Derived rules\<close>

lemma LeadsTo_UNIV [simp]: "F \<in> A LeadsTo UNIV"
by (simp add: LeadsTo_def)

text\<open>Useful with cancellation, disjunction\<close>
lemma LeadsTo_Un_duplicate:
     "F \<in> A LeadsTo (A' \<union> A') ==> F \<in> A LeadsTo A'"
by (simp add: Un_ac)

lemma LeadsTo_Un_duplicate2:
     "F \<in> A LeadsTo (A' \<union> C \<union> C) ==> F \<in> A LeadsTo (A' \<union> C)"
by (simp add: Un_ac)

lemma LeadsTo_UN:
     "(!!i. i \<in> I ==> F \<in> (A i) LeadsTo B) ==> F \<in> (\<Union>i \<in> I. A i) LeadsTo B"
apply (blast intro: LeadsTo_Union)
done

text\<open>Binary union introduction rule\<close>
lemma LeadsTo_Un:
     "[| F \<in> A LeadsTo C; F \<in> B LeadsTo C |] ==> F \<in> (A \<union> B) LeadsTo C"
  using LeadsTo_UN [of "{A, B}" F id C] by auto

text\<open>Lets us look at the starting state\<close>
lemma single_LeadsTo_I:
     "(!!s. s \<in> A ==> F \<in> {s} LeadsTo B) ==> F \<in> A LeadsTo B"
by (subst UN_singleton [symmetric], rule LeadsTo_UN, blast)

lemma subset_imp_LeadsTo: "A \<subseteq> B ==> F \<in> A LeadsTo B"
apply (simp add: LeadsTo_def)
apply (blast intro: subset_imp_leadsTo)
done

lemmas empty_LeadsTo = empty_subsetI [THEN subset_imp_LeadsTo, simp]

lemma LeadsTo_weaken_R:
     "[| F \<in> A LeadsTo A';  A' \<subseteq> B' |] ==> F \<in> A LeadsTo B'"
apply (simp add: LeadsTo_def)
apply (blast intro: leadsTo_weaken_R)
done

lemma LeadsTo_weaken_L:
     "[| F \<in> A LeadsTo A';  B \<subseteq> A |]
      ==> F \<in> B LeadsTo A'"
apply (simp add: LeadsTo_def)
apply (blast intro: leadsTo_weaken_L)
done

lemma LeadsTo_weaken:
     "[| F \<in> A LeadsTo A';
         B  \<subseteq> A;   A' \<subseteq> B' |]
      ==> F \<in> B LeadsTo B'"
by (blast intro: LeadsTo_weaken_R LeadsTo_weaken_L LeadsTo_Trans)

lemma Always_LeadsTo_weaken:
     "[| F \<in> Always C;  F \<in> A LeadsTo A';
         C \<inter> B \<subseteq> A;   C \<inter> A' \<subseteq> B' |]
      ==> F \<in> B LeadsTo B'"
by (blast dest: Always_LeadsToI intro: LeadsTo_weaken intro: Always_LeadsToD)

(** Two theorems for "proof lattices" **)

lemma LeadsTo_Un_post: "F \<in> A LeadsTo B ==> F \<in> (A \<union> B) LeadsTo B"
by (blast intro: LeadsTo_Un subset_imp_LeadsTo)

lemma LeadsTo_Trans_Un:
     "[| F \<in> A LeadsTo B;  F \<in> B LeadsTo C |]
      ==> F \<in> (A \<union> B) LeadsTo C"
by (blast intro: LeadsTo_Un subset_imp_LeadsTo LeadsTo_weaken_L LeadsTo_Trans)

(** Distributive laws **)

lemma LeadsTo_Un_distrib:
     "(F \<in> (A \<union> B) LeadsTo C)  = (F \<in> A LeadsTo C & F \<in> B LeadsTo C)"
by (blast intro: LeadsTo_Un LeadsTo_weaken_L)

lemma LeadsTo_UN_distrib:
     "(F \<in> (\<Union>i \<in> I. A i) LeadsTo B)  =  (\<forall>i \<in> I. F \<in> (A i) LeadsTo B)"
by (blast intro: LeadsTo_UN LeadsTo_weaken_L)

lemma LeadsTo_Union_distrib:
     "(F \<in> (\<Union>S) LeadsTo B)  =  (\<forall>A \<in> S. F \<in> A LeadsTo B)"
by (blast intro: LeadsTo_Union LeadsTo_weaken_L)

(** More rules using the premise "Always INV" **)

lemma LeadsTo_Basis: "F \<in> A Ensures B ==> F \<in> A LeadsTo B"
by (simp add: Ensures_def LeadsTo_def leadsTo_Basis)

lemma EnsuresI:
     "[| F \<in> (A-B) Co (A \<union> B);  F \<in> transient (A-B) |]
      ==> F \<in> A Ensures B"
apply (simp add: Ensures_def Constrains_eq_constrains)
apply (blast intro: ensuresI constrains_weaken transient_strengthen)
done

lemma Always_LeadsTo_Basis:
     "[| F \<in> Always INV;
         F \<in> (INV \<inter> (A-A')) Co (A \<union> A');
         F \<in> transient (INV \<inter> (A-A')) |]
  ==> F \<in> A LeadsTo A'"
apply (rule Always_LeadsToI, assumption)
apply (blast intro: EnsuresI LeadsTo_Basis Always_ConstrainsD [THEN Constrains_weaken] transient_strengthen)
done

text\<open>Set difference: maybe combine with \<open>leadsTo_weaken_L\<close>??
  This is the most useful form of the "disjunction" rule\<close>
lemma LeadsTo_Diff:
     "[| F \<in> (A-B) LeadsTo C;  F \<in> (A \<inter> B) LeadsTo C |]
      ==> F \<in> A LeadsTo C"
by (blast intro: LeadsTo_Un LeadsTo_weaken)

lemma LeadsTo_UN_UN:
     "(!! i. i \<in> I ==> F \<in> (A i) LeadsTo (A' i))
      ==> F \<in> (\<Union>i \<in> I. A i) LeadsTo (\<Union>i \<in> I. A' i)"
apply (blast intro: LeadsTo_Union LeadsTo_weaken_R)
done

text\<open>Version with no index set\<close>
lemma LeadsTo_UN_UN_noindex:
     "(!!i. F \<in> (A i) LeadsTo (A' i)) ==> F \<in> (\<Union>i. A i) LeadsTo (\<Union>i. A' i)"
by (blast intro: LeadsTo_UN_UN)

text\<open>Version with no index set\<close>
lemma all_LeadsTo_UN_UN:
     "\<forall>i. F \<in> (A i) LeadsTo (A' i)
      ==> F \<in> (\<Union>i. A i) LeadsTo (\<Union>i. A' i)"
by (blast intro: LeadsTo_UN_UN)

text\<open>Binary union version\<close>
lemma LeadsTo_Un_Un:
     "[| F \<in> A LeadsTo A'; F \<in> B LeadsTo B' |]
            ==> F \<in> (A \<union> B) LeadsTo (A' \<union> B')"
by (blast intro: LeadsTo_Un LeadsTo_weaken_R)

(** The cancellation law **)

lemma LeadsTo_cancel2:
     "[| F \<in> A LeadsTo (A' \<union> B); F \<in> B LeadsTo B' |]
      ==> F \<in> A LeadsTo (A' \<union> B')"
by (blast intro: LeadsTo_Un_Un subset_imp_LeadsTo LeadsTo_Trans)

lemma LeadsTo_cancel_Diff2:
     "[| F \<in> A LeadsTo (A' \<union> B); F \<in> (B-A') LeadsTo B' |]
      ==> F \<in> A LeadsTo (A' \<union> B')"
apply (rule LeadsTo_cancel2)
prefer 2 apply assumption
apply (simp_all (no_asm_simp))
done

lemma LeadsTo_cancel1:
     "[| F \<in> A LeadsTo (B \<union> A'); F \<in> B LeadsTo B' |]
      ==> F \<in> A LeadsTo (B' \<union> A')"
apply (simp add: Un_commute)
apply (blast intro!: LeadsTo_cancel2)
done

lemma LeadsTo_cancel_Diff1:
     "[| F \<in> A LeadsTo (B \<union> A'); F \<in> (B-A') LeadsTo B' |]
      ==> F \<in> A LeadsTo (B' \<union> A')"
apply (rule LeadsTo_cancel1)
prefer 2 apply assumption
apply (simp_all (no_asm_simp))
done

text\<open>The impossibility law\<close>

text\<open>The set "A" may be non-empty, but it contains no reachable states\<close>
lemma LeadsTo_empty: "[|F \<in> A LeadsTo {}; all_total F|] ==> F \<in> Always (-A)"
apply (simp add: LeadsTo_def Always_eq_includes_reachable)
apply (drule leadsTo_empty, auto)
done

subsection\<open>PSP: Progress-Safety-Progress\<close>

text\<open>Special case of PSP: Misra's "stable conjunction"\<close>
lemma PSP_Stable:
     "[| F \<in> A LeadsTo A';  F \<in> Stable B |]
      ==> F \<in> (A \<inter> B) LeadsTo (A' \<inter> B)"
apply (simp add: LeadsTo_eq_leadsTo Stable_eq_stable)
apply (drule psp_stable, assumption)
apply (simp add: Int_ac)
done

lemma PSP_Stable2:
     "[| F \<in> A LeadsTo A'; F \<in> Stable B |]
      ==> F \<in> (B \<inter> A) LeadsTo (B \<inter> A')"
by (simp add: PSP_Stable Int_ac)

lemma PSP:
     "[| F \<in> A LeadsTo A'; F \<in> B Co B' |]
      ==> F \<in> (A \<inter> B') LeadsTo ((A' \<inter> B) \<union> (B' - B))"
apply (simp add: LeadsTo_def Constrains_eq_constrains)
apply (blast dest: psp intro: leadsTo_weaken)
done

lemma PSP2:
     "[| F \<in> A LeadsTo A'; F \<in> B Co B' |]
      ==> F \<in> (B' \<inter> A) LeadsTo ((B \<inter> A') \<union> (B' - B))"
by (simp add: PSP Int_ac)

lemma PSP_Unless:
     "[| F \<in> A LeadsTo A'; F \<in> B Unless B' |]
      ==> F \<in> (A \<inter> B) LeadsTo ((A' \<inter> B) \<union> B')"
apply (unfold Unless_def)
apply (drule PSP, assumption)
apply (blast intro: LeadsTo_Diff LeadsTo_weaken subset_imp_LeadsTo)
done

lemma Stable_transient_Always_LeadsTo:
     "[| F \<in> Stable A;  F \<in> transient C;
         F \<in> Always (-A \<union> B \<union> C) |] ==> F \<in> A LeadsTo B"
apply (erule Always_LeadsTo_weaken)
apply (rule LeadsTo_Diff)
   prefer 2
   apply (erule
          transient_imp_leadsTo [THEN leadsTo_imp_LeadsTo, THEN PSP_Stable2])
   apply (blast intro: subset_imp_LeadsTo)+
done

subsection\<open>Induction rules\<close>

(** Meta or object quantifier ????? **)
lemma LeadsTo_wf_induct:
     "[| wf r;
         \<forall>m. F \<in> (A \<inter> f-`{m}) LeadsTo
                    ((A \<inter> f-`(r\<inverse> `` {m})) \<union> B) |]
      ==> F \<in> A LeadsTo B"
apply (simp add: LeadsTo_eq_leadsTo)
apply (erule leadsTo_wf_induct)
apply (blast intro: leadsTo_weaken)
done

lemma Bounded_induct:
     "[| wf r;
         \<forall>m \<in> I. F \<in> (A \<inter> f-`{m}) LeadsTo
                      ((A \<inter> f-`(r\<inverse> `` {m})) \<union> B) |]
      ==> F \<in> A LeadsTo ((A - (f-`I)) \<union> B)"
apply (erule LeadsTo_wf_induct, safe)
apply (case_tac "m \<in> I")
apply (blast intro: LeadsTo_weaken)
apply (blast intro: subset_imp_LeadsTo)
done

lemma LessThan_induct:
     "(!!m::nat. F \<in> (A \<inter> f-`{m}) LeadsTo ((A \<inter> f-`(lessThan m)) \<union> B))
      ==> F \<in> A LeadsTo B"
by (rule wf_less_than [THEN LeadsTo_wf_induct], auto)

text\<open>Integer version.  Could generalize from 0 to any lower bound\<close>
lemma integ_0_le_induct:
     "[| F \<in> Always {s. (0::int) \<le> f s};
         !! z. F \<in> (A \<inter> {s. f s = z}) LeadsTo
                   ((A \<inter> {s. f s < z}) \<union> B) |]
      ==> F \<in> A LeadsTo B"
apply (rule_tac f = "nat o f" in LessThan_induct)
apply (simp add: vimage_def)
apply (rule Always_LeadsTo_weaken, assumption+)
apply (auto simp add: nat_eq_iff nat_less_iff)
done

lemma LessThan_bounded_induct:
     "!!l::nat. \<forall>m \<in> greaterThan l.
                   F \<in> (A \<inter> f-`{m}) LeadsTo ((A \<inter> f-`(lessThan m)) \<union> B)
            ==> F \<in> A LeadsTo ((A \<inter> (f-`(atMost l))) \<union> B)"
apply (simp only: Diff_eq [symmetric] vimage_Compl
                  Compl_greaterThan [symmetric])
apply (rule wf_less_than [THEN Bounded_induct], simp)
done

lemma GreaterThan_bounded_induct:
     "!!l::nat. \<forall>m \<in> lessThan l.
                 F \<in> (A \<inter> f-`{m}) LeadsTo ((A \<inter> f-`(greaterThan m)) \<union> B)
      ==> F \<in> A LeadsTo ((A \<inter> (f-`(atLeast l))) \<union> B)"
apply (rule_tac f = f and f1 = "%k. l - k"
       in wf_less_than [THEN wf_inv_image, THEN LeadsTo_wf_induct])
apply (simp add: Image_singleton, clarify)
apply (case_tac "m<l")
 apply (blast intro: LeadsTo_weaken_R diff_less_mono2)
apply (blast intro: not_le_imp_less subset_imp_LeadsTo)
done

subsection\<open>Completion: Binary and General Finite versions\<close>

lemma Completion:
     "[| F \<in> A LeadsTo (A' \<union> C);  F \<in> A' Co (A' \<union> C);
         F \<in> B LeadsTo (B' \<union> C);  F \<in> B' Co (B' \<union> C) |]
      ==> F \<in> (A \<inter> B) LeadsTo ((A' \<inter> B') \<union> C)"
apply (simp add: LeadsTo_eq_leadsTo Constrains_eq_constrains Int_Un_distrib)
apply (blast intro: completion leadsTo_weaken)
done

lemma Finite_completion_lemma:
     "finite I
      ==> (\<forall>i \<in> I. F \<in> (A i) LeadsTo (A' i \<union> C)) -->
          (\<forall>i \<in> I. F \<in> (A' i) Co (A' i \<union> C)) -->
          F \<in> (\<Inter>i \<in> I. A i) LeadsTo ((\<Inter>i \<in> I. A' i) \<union> C)"
apply (erule finite_induct, auto)
apply (rule Completion)
   prefer 4
   apply (simp only: INT_simps [symmetric])
   apply (rule Constrains_INT, auto)
done

lemma Finite_completion:
     "[| finite I;
         !!i. i \<in> I ==> F \<in> (A i) LeadsTo (A' i \<union> C);
         !!i. i \<in> I ==> F \<in> (A' i) Co (A' i \<union> C) |]
      ==> F \<in> (\<Inter>i \<in> I. A i) LeadsTo ((\<Inter>i \<in> I. A' i) \<union> C)"
by (blast intro: Finite_completion_lemma [THEN mp, THEN mp])

lemma Stable_completion:
     "[| F \<in> A LeadsTo A';  F \<in> Stable A';
         F \<in> B LeadsTo B';  F \<in> Stable B' |]
      ==> F \<in> (A \<inter> B) LeadsTo (A' \<inter> B')"
apply (unfold Stable_def)
apply (rule_tac C1 = "{}" in Completion [THEN LeadsTo_weaken_R])
apply (force+)
done

lemma Finite_stable_completion:
     "[| finite I;
         !!i. i \<in> I ==> F \<in> (A i) LeadsTo (A' i);
         !!i. i \<in> I ==> F \<in> Stable (A' i) |]
      ==> F \<in> (\<Inter>i \<in> I. A i) LeadsTo (\<Inter>i \<in> I. A' i)"
apply (unfold Stable_def)
apply (rule_tac C1 = "{}" in Finite_completion [THEN LeadsTo_weaken_R])
apply (simp_all, blast+)
done

end


(*
   Title: The pi-calculus
   Author/Maintainer: Jesper Bengtson (jebe.dk), 2012
*)
theory Weak_Late_Cong_Pres
  imports Weak_Late_Cong Weak_Late_Step_Sim_Pres Weak_Late_Bisim_Pres
begin

lemma tauPres:
  fixes P :: pi
  and   Q :: pi

  assumes "P \<simeq> Q"

  shows "\<tau>.(P) \<simeq> \<tau>.(Q)"
using assms
by(blast intro: unfoldI Weak_Late_Step_Sim_Pres.tauPres dest: congruenceWeakBisim symetric)

lemma outputPres:
  fixes P :: pi
  and   Q :: pi

  assumes "P \<simeq> Q"

  shows "a{b}.P \<simeq> a{b}.Q"
using assms
by(blast intro: unfoldI Weak_Late_Step_Sim_Pres.outputPres dest: congruenceWeakBisim symetric)

lemma inputPres:
  fixes P :: pi
  and   Q :: pi
  and   a :: name
  and   x :: name

  assumes PSimQ: "\<forall>y. P[x::=y] \<simeq> Q[x::=y]"

  shows "a<x>.P \<simeq> a<x>.Q"
using assms
apply(rule_tac unfoldI)
apply(rule_tac Weak_Late_Step_Sim_Pres.inputPres, auto intro: congruenceWeakBisim)
by(rule_tac Weak_Late_Step_Sim_Pres.inputPres, auto intro: congruenceWeakBisim Weak_Late_Bisim.symmetric)

  assumes "P \<simeq> Q"

  shows "[a\<frown>b]P \<simeq> [a\<frown>b]Q"
using assms
by(blast intro: unfoldI Weak_Late_Step_Sim_Pres.matchPres dest: unfoldE symetric)

lemma mismatchPres:
  fixes P :: pi
  and   Q :: pi
  and   a :: name
  and   b :: name

  assumes "P \<simeq> Q"

  shows "[a\<noteq>b]P \<simeq> [a\<noteq>b]Q"
using assms
by(blast intro: unfoldI Weak_Late_Step_Sim_Pres.mismatchPres dest: unfoldE symetric)

lemma sumPres:
  fixes P :: pi
  and   Q :: pi
  and   R :: pi

  assumes "P \<simeq> Q"

  shows "P \<oplus> R \<simeq> Q \<oplus> R"
using assms
by(blast intro: Weak_Late_Bisim.reflexive unfoldI Weak_Late_Step_Sim_Pres.sumPres dest: unfoldE symetric)

lemma parPres:
  fixes P :: pi
  and   Q :: pi
  and   R :: pi

  assumes "P \<simeq> Q"

  shows "P \<parallel> R \<simeq> Q \<parallel> R"
proof -
  have "\<And>P Q R. \<lbrakk>P \<leadsto><weakBisim> Q; P \<approx> Q\<rbrakk> \<Longrightarrow> P \<parallel> R \<leadsto><weakBisim> Q \<parallel> R"
  proof -
    fix P Q R
    assume "P \<leadsto><weakBisim> Q" and "P \<approx> Q"
    thus "P \<parallel> R \<leadsto><weakBisim> Q \<parallel> R"
      using Weak_Late_Bisim_Pres.parPres Weak_Late_Bisim_Pres.resPres Weak_Late_Bisim.reflexive Weak_Late_Bisim.eqvt
      by(blast intro: Weak_Late_Step_Sim_Pres.parPres)
  qed
  with assms show ?thesis
    by(blast intro: unfoldI dest: congruenceWeakBisim unfoldE symetric)
qed

  assumes PeqQ: "P \<simeq> Q"

  shows "<\<nu>x>P \<simeq> <\<nu>x>Q"
proof -
  have "\<And>P Q x. P \<leadsto><weakBisim> Q \<Longrightarrow> <\<nu>x>P \<leadsto><weakBisim> <\<nu>x>Q"
  proof -
    fix P Q x
    assume "P \<leadsto><weakBisim> Q"
    with Weak_Late_Bisim.eqvt Weak_Late_Bisim_Pres.resPres show "<\<nu>x>P \<leadsto><weakBisim> <\<nu>x>Q"
      by(blast intro: Weak_Late_Step_Sim_Pres.resPres)
  qed
  with assms show ?thesis
    by(blast intro: unfoldI dest: congruenceWeakBisim unfoldE symetric)
qed

lemma congruenceBang:
  fixes P :: pi
  and   Q :: pi

  assumes "P \<simeq> Q"

  shows "!P \<simeq> !Q"
proof -
  have "\<And>P Q. \<lbrakk>P \<leadsto><weakBisim> Q; P \<simeq> Q\<rbrakk> \<Longrightarrow> !P \<leadsto><weakBisim> !Q"
  proof -
    fix P Q
    assume "P \<leadsto><weakBisim> Q" and "P \<simeq> Q"
    hence "!P \<leadsto><bangRel weakBisim> !Q" using unfoldE(1) congruenceWeakBisim Weak_Late_Bisim.eqvt
      by(rule Weak_Late_Step_Sim_Pres.bangPres)
    moreover have "bangRel weakBisim \<subseteq> weakBisim"
      proof auto
        fix a b
        assume "(a, b) \<in> bangRel weakBisim"
        thus   "a \<approx> b"
          apply(induct rule: bangRel.induct)
          apply (metis Weak_Late_Bisim_Pres.bangPres)
          apply (metis Weak_Late_Bisim.reflexive Weak_Late_Bisim.symmetric Weak_Late_Bisim.transitive Weak_Late_Bisim_Pres.parPres Weak_Late_Bisim_SC.parSym)
          by (metis Weak_Late_Bisim_Pres.resPres)
      qed
    ultimately show"!P \<leadsto><weakBisim> !Q"
      by(rule Weak_Late_Step_Sim.monotonic)
  qed

  with assms show ?thesis
    by(blast intro: unfoldI dest: unfoldE symetric congruenceWeakBisim)
qed

end


(*
 * Copyright 2014, NICTA
 *
 * This software may be distributed and modified according to the terms of
 * the BSD 2-Clause license. Note that NO WARRANTY is provided.
 * See "LICENSE_BSD2.txt" for details.
 *
 * @TAG(NICTA_BSD)
 *)

theory spec_annotated_fn
imports "../CTranslation"
begin

declare sep_conj_ac [simp add]

install_C_file "spec_annotated_fn.c"

print_locale spec_annotated_fn
print_locale Square_spec

thm Square_spec_def

context spec_annotated_fn
begin

thm Square_body_def
thm Square_impl
thm Square_spec_def
thm \<Gamma>_def
thm f_spec_def
thm f_body_def

end

lemma (in Square_spec) foo:
  shows "\<Gamma> \<turnstile> \<lbrace> T \<rbrace> \<acute>ret__unsigned :== CALL Square(4) \<lbrace> \<acute>ret__unsigned = 16 \<rbrace> "
apply vcg
apply simp
done

lemma (in spec_annotated_fn)
shows "\<forall>n. \<Gamma> \<turnstile> \<lbrace> \<acute>n = n \<rbrace> \<acute>ret__unsigned :== PROC Square(\<acute>n)
               \<lbrace>\<acute>ret__unsigned = n * n \<rbrace>"
apply vcg
done

lemma (in spec_annotated_fn)
shows "\<forall>n. \<Gamma> \<turnstile> \<lbrace> \<acute>n = n \<rbrace> \<acute>ret__unsigned :== PROC f(\<acute>n) \<lbrace> \<acute>ret__unsigned = n * n \<rbrace>"
apply vcg
apply clarsimp
apply (simp add: mex_def meq_def)
done

end


           (*-------------------------------------------*
            |        CSP-Prover on Isabelle2004         |
            |               December 2004               |
            |                   June 2005 (modified)    |
            |                 August 2005 (modified)    |
            |                                           |
            |        CSP-Prover on Isabelle2005         |
            |                October 2005  (modified)   |
            |                  April 2006  (modified)   |
            |                  March 2007  (modified)   |
            |                 August 2007  (modified)   |
            |                                           |
            |        Yoshinao Isobe (AIST JAPAN)        |
            *-------------------------------------------*)

theory CSP_F_domain
imports CSP_T_traces CSP_F_failures
begin

(*  The following simplification rules are deleted in this theory file *)
(*  because they unexpectly rewrite UnionT and InterT.                 *)
(*                  disj_not1: (~ P | Q) = (P --> Q)                   *)

declare disj_not1 [simp del]

(*********************************************************
                        domF
 *********************************************************)

(*--------------------------------*
 |             STOP               |
 *--------------------------------*)

(* T2 *)

lemma STOP_T2 : "HC_T2 (traces(STOP) (fstF o M), failures(STOP) M)"
by (simp add: HC_T2_def in_traces in_failures)

(* F3 *)

lemma STOP_F3 : "HC_F3 (traces(STOP) (fstF o M), failures(STOP) M)"
by (simp add: HC_F3_def in_traces in_failures)

(* T3_F4 *)

lemma STOP_T3_F4 : "HC_T3_F4 (traces(STOP) (fstF o M), failures(STOP) M)"
by (auto simp add: HC_T3_F4_def in_traces in_failures)

(*** STOP_domF ***)

lemma STOP_domF : "(traces(STOP) (fstF o M), failures(STOP) M) : domF"
apply (simp add: domF_iff)
apply (simp add: STOP_T2)
apply (simp add: STOP_F3)
apply (simp add: STOP_T3_F4)
done

(*--------------------------------*
 |             SKIP               |
 *--------------------------------*)

(* T2 *)

lemma SKIP_T2 : "HC_T2 (traces(SKIP) (fstF o M), failures(SKIP) M)"
by (simp add: HC_T2_def in_traces in_failures)

(* F3 *)

lemma SKIP_F3 : "HC_F3 (traces(SKIP) (fstF o M), failures(SKIP) M)"
apply (simp add: HC_F3_def in_traces in_failures)
by (auto simp add: Evset_def)

(* T3_F4 *)

lemma SKIP_T3_F4 : "HC_T3_F4 (traces(SKIP) (fstF o M), failures(SKIP) M)"
by (auto simp add: HC_T3_F4_def in_traces in_failures)

(*** SKIP_domF ***)

lemma SKIP_domF : "(traces(SKIP) (fstF o M), failures(SKIP) M) : domF"
apply (simp add: domF_iff)
apply (simp add: SKIP_T2)
apply (simp add: SKIP_F3)
apply (simp add: SKIP_T3_F4)
done

(*--------------------------------*
 |              DIV               |
 *--------------------------------*)

(* T2 *)

lemma DIV_T2 : "HC_T2 (traces(DIV) (fstF o M), failures(DIV) M)"
by (simp add: HC_T2_def in_traces in_failures)

(* F3 *)

lemma DIV_F3 : "HC_F3 (traces(DIV) (fstF o M), failures(DIV) M)"
by (simp add: HC_F3_def in_traces in_failures)

(* T3_F4 *)

lemma DIV_T3_F4 : "HC_T3_F4 (traces(DIV) (fstF o M), failures(DIV) M)"
by (auto simp add: HC_T3_F4_def in_traces in_failures)

(*** DIV_domF ***)

lemma DIV_domF : "(traces(DIV) (fstF o M), failures(DIV) M) : domF"
apply (simp add: domF_iff)
apply (simp add: DIV_T2)
apply (simp add: DIV_F3)
apply (simp add: DIV_T3_F4)
done

(*--------------------------------*
 |          Act_prefix            |
 *--------------------------------*)

(* T2 *)

lemma Act_prefix_T2 :
  "(traces(P) (fstF o M), failures(P) M) : domF
    ==> HC_T2 (traces(a -> P) (fstF o M), failures(a -> P) M)"
apply (simp add: HC_T2_def in_traces in_failures)
apply (intro allI impI)
apply (elim conjE exE, simp)

apply (simp add: domF_def HC_T2_def)
apply (elim conjE)
apply (drule_tac x="sa" in spec)
by (force)

(* F3 *)

lemma Act_prefix_F3 :
  "(traces(P) (fstF o M), failures(P) M) : domF
    ==> HC_F3 (traces(a -> P) (fstF o M), failures(a -> P) M)"
apply (simp add: HC_F3_def in_traces in_failures)
apply (intro allI impI)

apply (elim conjE disjE, simp)
apply (case_tac "Ev a ~: Y", simp)  (* show "Ev a : Y --> contradict" *)
apply (drule_tac x="Ev a" in spec, simp)
apply (drule_tac x="<>" in spec, simp)

apply (elim conjE exE, simp)
apply (simp add: domF_def HC_F3_def)
apply (elim conjE)
apply (drule_tac x="sa" in spec)
apply (drule_tac x="X" in spec)
apply (drule_tac x="Y" in spec)
apply (simp)

apply (drule mp)
 apply (intro allI impI)
 apply (drule_tac x="aa" in spec, simp)
 apply (drule_tac x="sa ^^^ <aa>" in spec)
apply (simp add: appt_assoc)
by (simp)

(* T3_F4 *)

lemma Act_prefix_T3_F4 :
  "(traces(P) (fstF o M), failures(P) M) : domF
    ==> HC_T3_F4 (traces(a -> P) (fstF o M), failures(a -> P) M)"
apply (simp add: HC_T3_F4_def in_traces in_failures)
apply (intro allI impI)
apply (elim conjE exE)
apply (insert trace_nil_or_Tick_or_Ev)
apply (drule_tac x="s" in spec)

apply (erule disjE, simp)   (* s ^^^ <Tick> = <> --> contradict *)
apply (erule disjE, simp)   (* s = <> --> contradict *)
apply (erule disjE, simp)   (* s = <Tick> --> contradict *)

apply (elim conjE exE)      (* s = [Ev a]t ^^^ sb *)

apply (simp add: domF_iff HC_T3_F4_def)
apply (elim conjE exE)
apply (drule_tac x="sb" in spec)
apply (simp add: appt_assoc)
done

(*** Act_prefix_domF ***)

lemma Act_prefix_domF :
  "(traces(P) (fstF o M), failures(P) M) : domF
    ==> (traces(a -> P) (fstF o M), failures(a -> P) M) : domF"
apply (simp (no_asm) add: domF_iff)
apply (simp add: Act_prefix_T2)
apply (simp add: Act_prefix_F3)
apply (simp add: Act_prefix_T3_F4)
done

(*--------------------------------*
 |        Ext_pre_choice          |
 *--------------------------------*)

(* T2 *)

lemma Ext_pre_choice_T2 :
  "ALL a. (traces(Pf a) (fstF o M), failures(Pf a) M) : domF
     ==> HC_T2 (traces(? :X -> Pf) (fstF o M), failures(? :X -> Pf) M)"
apply (simp add: HC_T2_def in_traces in_failures)
apply (intro allI impI)
apply (elim conjE exE, simp)

apply (drule_tac x="a" in spec)
apply (simp add: domF_def HC_T2_def)
apply (elim conjE)
apply (drule_tac x="sa" in spec)
by (force)

(* F3 *)

lemma Ext_pre_choice_F3 :
  "ALL a. (traces(Pf a) (fstF o M), failures(Pf a) M) : domF
     ==> HC_F3 (traces(? :X -> Pf) (fstF o M), failures(? :X -> Pf) M)"
apply (simp add: HC_F3_def in_traces in_failures)
apply (intro allI impI)

apply (elim conjE disjE, simp)

(* s = <> *)
apply (case_tac "EX a. Ev a :Ev ` X Int (Xa Un Y)")  (* show contradiction" *)
 apply (elim conjE exE)
 apply (drule_tac x="Ev a" in spec)
 apply (drule mp)
  apply (simp)                      (* show "Ev a : Y" *)
  apply (elim conjE disjE)
  apply (fast)                      (* contradict *)
  apply (simp)

 apply (drule_tac x="a" in spec)
 apply (drule_tac x="a" in spec)
 apply (simp)
 apply (drule_tac x="s" in spec)
 apply (simp)
 apply (fast)                      (* contradict *)
apply (fast)                       (* Ev ` X Int (Xa Un Y) = {} *)

(* s ~= <> *)
apply (elim conjE exE, simp)
apply (drule_tac x="a" in spec)
apply (simp add: domF_def HC_F3_def)
apply (elim conjE)
apply (drule_tac x="sa" in spec)
apply (drule_tac x="Xa" in spec)
apply (drule_tac x="Y" in spec)
apply (simp)

apply (drule mp)
 apply (intro allI impI)
 apply (drule_tac x="aa" in spec, simp)
 apply (drule_tac x="a" in spec)
 apply (drule_tac x="sa ^^^ <aa>" in spec)
 apply (simp add: appt_assoc)
by (simp)

(* T3_F4 *)

lemma Ext_pre_choice_T3_F4 :
  "ALL a. (traces(Pf a) (fstF o M), failures(Pf a) M) : domF
     ==> HC_T3_F4 (traces(? :X -> Pf) (fstF o M), failures(? :X -> Pf) M)"
apply (simp add: HC_T3_F4_def in_traces in_failures)
apply (intro allI impI)
apply (elim conjE exE)
apply (insert trace_nil_or_Tick_or_Ev)
apply (drule_tac x="s" in spec)

apply (erule disjE, simp)   (* contradict *)
apply (erule disjE, simp)   (* s = <> --> contradict *)
apply (erule disjE, simp)   (* s = <Tick> --> contradict *)

apply (elim conjE exE)      (* s = [Ev aa]t ^^^ sb *)
apply (drule_tac x="a" in spec)
apply (simp add: domF_iff HC_T3_F4_def)
apply (elim conjE exE)
apply (drule_tac x="sb" in spec)
apply (simp add: appt_assoc)
done

(*** Ext_pre_choice_domF ***)

lemma Ext_pre_choice_domF :
  "ALL a. (traces(Pf a) (fstF o M), failures(Pf a) M) : domF
     ==> (traces(? :X -> Pf) (fstF o M), failures(? :X -> Pf) M) : domF"
apply (simp (no_asm) add: domF_iff)
apply (simp add: Ext_pre_choice_T2)
apply (simp add: Ext_pre_choice_F3)
apply (simp add: Ext_pre_choice_T3_F4)
done

(*--------------------------------*
 |          Ext_choice            |
 *--------------------------------*)

(* T2 *)

lemma Ext_choice_T2 :
  "[| (traces(P) (fstF o M), failures(P) M) : domF ;
      (traces(Q) (fstF o M), failures(Q) M) : domF |]
     ==> HC_T2 (traces(P [+] Q) (fstF o M), failures(P [+] Q) M)"
apply (simp add: HC_T2_def in_traces in_failures)
apply (intro allI impI)
apply (elim conjE exE)

apply (simp add: domF_def HC_T2_def)
apply (elim conjE)
apply (drule_tac x="s" in spec)
apply (drule_tac x="s" in spec)
by (fast)

(* F3 *)

lemma Ext_choice_F3 :
  "[| (traces(P) (fstF o M), failures(P) M) : domF ;
      (traces(Q) (fstF o M), failures(Q) M) : domF |]
     ==> HC_F3 (traces(P [+] Q) (fstF o M), failures(P [+] Q) M)"
apply (simp add: HC_F3_def in_traces in_failures)
apply (intro allI impI)

apply (elim conjE disjE)
apply (simp_all add: domF_def HC_F3_def)
by (auto simp add: Evset_def)

(* T3_F4 *)

lemma Ext_choice_T3_F4 :
  "[| (traces(P) (fstF o M), failures(P) M) : domF ;
      (traces(Q) (fstF o M), failures(Q) M) : domF |]
     ==> HC_T3_F4 (traces(P [+] Q) (fstF o M), failures(P [+] Q) M)"
apply (simp add: HC_T3_F4_def in_traces in_failures)
apply (intro allI impI)
apply (elim conjE exE)

apply (simp add: domF_iff HC_T3_F4_def)
apply (elim conjE)
apply (drule_tac x="s" in spec)
apply (drule_tac x="s" in spec)
by (auto)

(*** Ext_choice_domF ***)

lemma Ext_choice_domF :
  "[| (traces(P) (fstF o M), failures(P) M) : domF ;
      (traces(Q) (fstF o M), failures(Q) M) : domF |]
     ==> (traces(P [+] Q) (fstF o M), failures(P [+] Q) M) : domF"
apply (simp (no_asm) add: domF_iff)
apply (simp add: Ext_choice_T2)
apply (simp add: Ext_choice_F3)
apply (simp add: Ext_choice_T3_F4)
done

(*--------------------------------*
 |          Int_choice            |
 *--------------------------------*)

(* T2 *)

lemma Int_choice_T2 :
  "[| (traces(P) (fstF o M), failures(P) M) : domF ;
      (traces(Q) (fstF o M), failures(Q) M) : domF |]
     ==> HC_T2 (traces(P |~| Q) (fstF o M), failures(P |~| Q) M)"
apply (simp add: HC_T2_def in_traces in_failures)
apply (simp add: domF_def HC_T2_def)
by (auto)

(* F3 *)

lemma Int_choice_F3 :
  "[| (traces(P) (fstF o M), failures(P) M) : domF ;
      (traces(Q) (fstF o M), failures(Q) M) : domF |]
     ==> HC_F3 (traces(P |~| Q) (fstF o M), failures(P |~| Q) M)"
apply (simp add: HC_F3_def in_traces in_failures)
apply (simp add: domF_def HC_F3_def)
by (auto)

(* T3_F4 *)

lemma Int_choice_T3_F4 :
  "[| (traces(P) (fstF o M), failures(P) M) : domF ;
      (traces(Q) (fstF o M), failures(Q) M) : domF |]
     ==> HC_T3_F4 (traces(P |~| Q) (fstF o M), failures(P |~| Q) M)"
apply (simp add: HC_T3_F4_def in_traces in_failures)
apply (simp add: domF_iff HC_T3_F4_def)
by (auto)

(*** Int_choice_domF ***)

lemma Int_choice_domF :
  "[| (traces(P) (fstF o M), failures(P) M) : domF ;
      (traces(Q) (fstF o M), failures(Q) M) : domF |]
     ==> (traces(P |~| Q) (fstF o M), failures(P |~| Q) M) : domF"
apply (simp (no_asm) add: domF_iff)
apply (simp add: Int_choice_T2)
apply (simp add: Int_choice_F3)
apply (simp add: Int_choice_T3_F4)
done

(*--------------------------------*
 |        Rep_int_choice          |
 *--------------------------------*)

(* T2 *)

lemma Union_proc_T2:
  "ALL c. (Tf c, Ff c) : domF
   ==> HC_T2 ({t. t = <> | (EX c:C. t :t Tf c)}t,
                         {f. EX c:C. f :f Ff c}f)"
apply (simp add: HC_T2_def)
apply (simp add: in_traces)
apply (simp add: in_failures)
apply (intro allI impI)
apply (elim conjE bexE exE)
apply (rule disjI2)
apply (drule_tac x="c" in spec)
apply (rule_tac x="c" in bexI)
apply (simp add: domF_def HC_T2_def)
by (auto)

lemma Rep_int_choice_T2 :
  "ALL c. (traces(Pf c) (fstF o M), failures(Pf c) M) : domF
     ==> HC_T2 (traces(!! :C .. Pf) (fstF o M), failures(!! :C .. Pf) M)"
apply (simp add: traces_iff failures_iff)
apply (simp add: Union_proc_T2)
done

(* F3 *)

lemma Union_proc_F3:
  "ALL c. (Tf c, Ff c) : domF
   ==>
   HC_F3 ({t. t = <> | (EX c:C. t :t Tf c)}t,
          {f. EX c:C. f :f Ff c}f)"
apply (simp add: HC_F3_def)
apply (simp add: in_traces)
apply (simp add: in_failures)
apply (intro allI)
apply (intro impI)
apply (elim conjE bexE)
apply (rule_tac x="c" in bexI)
apply (drule_tac x="c" in spec)
apply (rule domF_F3)
apply (auto)
done

lemma Rep_int_choice_nat :
  "ALL c. (traces(Pf c) (fstF o M), failures(Pf c) M) : domF
     ==> HC_F3 (traces(!! :C .. Pf) (fstF o M), failures(!! :C .. Pf) M)"
apply (simp add: traces_iff failures_iff)
apply (simp add: Union_proc_F3)
done

(* T3_F4 *)

lemma Union_proc_T3_F4:
  "ALL c. (Tf c, Ff c) : domF
   ==>
   HC_T3_F4 ({t. t = <> | (EX c:C. t :t Tf c)}t,
             {f. EX c:C. f :f Ff c}f)"
apply (simp add: HC_T3_F4_def)
apply (simp add: in_traces)
apply (simp add: in_failures)
apply (auto)
apply (rule_tac x="c" in bexI)
apply (rule domF_F4)
apply (simp_all)
apply (rule_tac x="c" in bexI)
apply (rule domF_T3)
apply (simp_all)
done

lemma Rep_int_choice_T3_F4 :
  "ALL c. (traces(Pf c) (fstF o M), failures(Pf c) M) : domF
     ==> HC_T3_F4 (traces(!! :C .. Pf) (fstF o M),
                   failures(!! :C .. Pf) M)"
apply (simp add: traces_iff failures_iff)
apply (simp add: Union_proc_T3_F4)
done

(*** F ***)

lemma Union_proc_domF:
  "ALL c. (Tf c, Ff c) : domF
   ==> ({t. t = <> | (EX c:C. t :t Tf c)}t,
        {f. EX c:C. f :f Ff c}f) : domF"
apply (simp (no_asm) add: domF_iff)
apply (simp add: Union_proc_T2)
apply (simp add: Union_proc_F3)
apply (simp add: Union_proc_T3_F4)
done

(*** Rep_int_choice_domF ***)

lemma Rep_int_choice_domF :
  "ALL c. (traces(Pf c) (fstF o M), failures(Pf c) M) : domF
     ==> (traces(!! :C .. Pf) (fstF o M), failures(!! :C .. Pf) M) : domF"
apply (simp add: traces_iff failures_iff)
apply (simp add: Union_proc_domF)
done

(*--------------------------------*
 |               IF               |
 *--------------------------------*)

(* T2 *)

lemma IF_T2 :
  "[| (traces(P) (fstF o M), failures(P) M) : domF ;
      (traces(Q) (fstF o M), failures(Q) M) : domF |]
     ==> HC_T2 (traces(IF b THEN P ELSE Q) (fstF o M),
                failures(IF b THEN P ELSE Q) M)"
by (simp add: HC_T2_def in_traces in_failures domF_def)

(* F3 *)

lemma IF_F3 :
  "[| (traces(P) (fstF o M), failures(P) M) : domF ;
      (traces(Q) (fstF o M), failures(Q) M) : domF |]
     ==> HC_F3 (traces(IF b THEN P ELSE Q) (fstF o M), failures(IF b THEN P ELSE Q) M)"
by (simp add: HC_F3_def in_traces in_failures domF_def)

(* T3_F4 *)

lemma IF_T3_F4 :
  "[| (traces(P) (fstF o M), failures(P) M) : domF ;
      (traces(Q) (fstF o M), failures(Q) M) : domF |]
     ==> HC_T3_F4 (traces(IF b THEN P ELSE Q) (fstF o M),
                   failures(IF b THEN P ELSE Q) M)"
by (simp add: HC_T3_F4_def in_traces in_failures domF_iff)

(*** IF_domF ***)

lemma IF_domF :
  "[| (traces(P) (fstF o M), failures(P) M) : domF ;
      (traces(Q) (fstF o M), failures(Q) M) : domF |]
     ==> (traces(IF b THEN P ELSE Q) (fstF o M),
          failures(IF b THEN P ELSE Q) M) : domF"
apply (simp (no_asm) add: domF_iff)
apply (simp add: IF_T2)
apply (simp add: IF_F3)
apply (simp add: IF_T3_F4)
done

(*--------------------------------*
 |           Parallel             |
 *--------------------------------*)

(*** T2 ***)

lemma Parallel_T2 :
  "[| (traces(P) (fstF o M), failures(P) M) : domF ;
      (traces(Q) (fstF o M), failures(Q) M) : domF |]
     ==> HC_T2 (traces(P |[X]| Q) (fstF o M), failures(P |[X]| Q) M)"
apply (simp add: HC_T2_def in_traces in_failures)
apply (intro allI impI)
apply (elim conjE exE)
apply (rule_tac x="sa" in exI)
apply (rule_tac x="t" in exI)
apply (simp)
apply (simp add: domF_def HC_T2_def)
apply (elim conjE)
apply (drule_tac x="sa" in spec)
apply (drule_tac x="t" in spec)

apply (drule mp, rule_tac x="Y" in exI, simp)
apply (drule mp, rule_tac x="Z" in exI, simp)
by (simp)

(*** F3 ***)

lemma Parallel_F3_lm1: "X1 Un (X2 Un X3) - X = (X1 - X) Un (X2 - X) Un (X3 - X)"
by (auto)

lemma Parallel_F3_lm2: "[| X1 = X2 ; Y1 = Y2 |] ==> X1 Un Y1 = X2 Un Y2"
by (auto)

lemma Parallel_F3 :
  "[| (traces(P) (fstF o M), failures(P) M) : domF ;
      (traces(Q) (fstF o M), failures(Q) M) : domF |]
     ==> HC_F3 (traces(P |[X]| Q) (fstF o M), failures(P |[X]| Q) M)"
apply (simp add: HC_F3_def in_traces in_failures)
apply (intro allI impI)
apply (elim conjE exE)
apply (rename_tac u X12 Y X1 X2 s t)

(* (u, X12) :f [[P |[X]| Q]]F *)
(* (s, X1)  :f [[P]]F         *)
(* (t, X2)  :f [[Q]]F         *)
(*  X12 = X1 Un X2               *)

apply (rule_tac x=
        "X1 Un
         ({a. a : Y & (a = Tick | a : Ev ` X) & s ^^^ <a> ~:t traces(P) (fstF o M)} Un
          {a. a : Y & a ~= Tick & a ~: Ev ` X})" in exI)       (* Z1 *)
apply (rule_tac x=
        "X2 Un
         ({a. a : Y & (a = Tick | a : Ev ` X) & t ^^^ <a> ~:t traces(Q) (fstF o M)} Un
          {a. a : Y & a ~= Tick & a ~: Ev ` X})" in exI)       (* Z2 *)

apply (subgoal_tac "noTick s & noTick t", simp)
apply (rule conjI)

(* show X12 Un Y = X1 Un Z1 Un Z2 *)
apply (rule equalityI)

 (* <= *)
 apply (rule subsetI, simp)
 apply (erule disjE, simp)
 apply (erule disjE, simp)
 apply (simp)

 apply (drule_tac x="x" in spec, simp)
 apply (drule_tac x="s ^^^ <x>" in spec)
 apply (drule_tac x="t ^^^ <x>" in spec)

  (* no sync *)
  apply (case_tac "x ~= Tick & x ~: Ev ` X", simp)
  (* sync *)
  apply (simp add: par_tr_last)
  apply (erule disjE, simp)
  apply (force)

  apply (rotate_tac -2)
  apply (erule disjE, simp)
  apply (force)
  apply (simp)
  apply (force)

 (* => *)
 apply (force)

apply (rule conjI)

 (* show X1 Un ... = X2 Un ... *)
 apply (simp add: Parallel_F3_lm1)
 apply (rule Parallel_F3_lm2)
 apply (rule Parallel_F3_lm2)
 apply (simp)
 apply (force)
 apply (simp)

 (* condition 2 *)
 apply (rule_tac x="s" in exI)
 apply (rule_tac x="t" in exI)
 apply (simp)

 apply (simp add: domF_def HC_F3_def)
 apply (elim conjE)
 apply (drule_tac x="s" in spec)
 apply (drule_tac x="t" in spec)
 apply (drule_tac x="X1" in spec)
 apply (drule_tac x="X2" in spec)
 apply (drule_tac x=
   "{a. a : Y & (a = Tick | a : Ev ` X) & s ^^^ <a> ~:t traces(P) (fstF o M)} Un
    {a. a : Y & a ~= Tick & a ~: Ev ` X}" in spec)
 apply (drule_tac x=
   "{a. a : Y & (a = Tick | a : Ev ` X) & t ^^^ <a> ~:t traces(Q) (fstF o M)} Un
    {a. a : Y & a ~= Tick & a ~: Ev ` X}" in spec)
 apply (simp)

 (* left *)
 apply (drule mp)
  apply (intro allI impI)
  apply (drule_tac x="a" in spec, simp)
  apply (drule_tac x="s ^^^ <a>" in spec)
  apply (drule_tac x="t" in spec)
  apply (erule disjE)
  apply (simp add: par_tr_last)
  apply (fast)

  apply (erule disjE, simp)
  apply (simp add: HC_T2_def)
  apply (drule_tac x="s" in spec)
  apply (drule_tac x="t" in spec)
  apply (force)

 (* right *)
 apply (drule mp)
  apply (intro allI impI)
  apply (drule_tac x="a" in spec, simp)
  apply (drule_tac x="s" in spec)
  apply (drule_tac x="t ^^^ <a>" in spec)
  apply (erule disjE)
  apply (simp add: par_tr_last)
  apply (fast)

  apply (erule disjE)
  apply (simp add: HC_T2_def)
  apply (drule_tac x="s" in spec)
  apply (drule_tac x="t" in spec)
  apply (force)
  apply (simp)
 apply (simp)

(* notick s & notick t *)
apply (simp add: par_tr_noTick_decompo)
done

(* T3_F4 *)

lemma Parallel_T3_F4 :
  "[| (traces(P) (fstF o M), failures(P) M) : domF ;
      (traces(Q) (fstF o M), failures(Q) M) : domF |]
     ==> HC_T3_F4 (traces(P |[X]| Q) (fstF o M), failures(P |[X]| Q) M)"
apply (simp add: HC_T3_F4_def in_traces in_failures)
apply (intro allI impI)
apply (elim conjE exE)
apply (simp add: par_tr_last)
apply (elim conjE exE)
apply (rule conjI)

 (* F4 *)
 apply (rule_tac x="Evset" in exI)
 apply (rule_tac x="Evset" in exI)
 apply (simp)
 apply (rule_tac x="s'" in exI)
 apply (rule_tac x="t'" in exI)
 apply (simp add: domF_def HC_F4_def)

 (* T3 *)
 apply (rule allI)
 apply (rule_tac x="Xa" in exI)
 apply (rule_tac x="Xa" in exI)
 apply (simp)
 apply (rule_tac x="sa" in exI)
 apply (rule_tac x="t" in exI)
 apply (simp add: domF_def HC_T3_def)
 apply (fast)
done

(*** Parallel_domF ***)

lemma Parallel_domF :
  "[| (traces(P) (fstF o M), failures(P) M) : domF ;
      (traces(Q) (fstF o M), failures(Q) M) : domF |]
     ==> (traces(P |[X]| Q) (fstF o M), failures(P |[X]| Q) M) : domF"
apply (simp (no_asm) add: domF_iff)
apply (simp add: Parallel_T2)
apply (simp add: Parallel_F3)
apply (simp add: Parallel_T3_F4)
done

(*--------------------------------*
 |            Hiding              |
 *--------------------------------*)

(*** T2 ***)

lemma Hiding_T2 :
  "(traces(P) (fstF o M), failures(P) M) : domF
   ==> HC_T2 (traces(P -- X) (fstF o M), failures(P -- X) M)"
apply (simp add: HC_T2_def in_traces in_failures)
apply (intro allI impI)
apply (elim conjE exE)
apply (rule_tac x="sa" in exI)
apply (simp add: domF_def HC_T2_def)
apply (elim conjE)
apply (drule_tac x="sa" in spec)
by (force)

(*** F3 ***)

lemma Hiding_F3 :
  "(traces(P) (fstF o M), failures(P) M) : domF
   ==> HC_F3 (traces(P -- X) (fstF o M), failures(P -- X) M)"
apply (simp add: HC_F3_def in_traces in_failures)
apply (intro allI impI)
apply (elim conjE exE)
apply (rename_tac t Y Z s)
apply (rule_tac x="s" in exI, simp)

apply (simp add: domF_def HC_F3_def)
apply (elim conjE)
apply (drule_tac x="s" in spec)
apply (drule_tac x="Ev ` X Un Y" in spec)
apply (drule_tac x="Z - Ev ` X" in spec)
apply (simp)

apply (drule mp)
 apply (intro allI impI)
 apply (drule_tac x="a" in spec)
 apply (simp)

 apply (insert event_Tick_or_Ev)
 apply (drule_tac x="a" in spec)
 apply (erule disjE)
  (* Tick *)
  apply (drule_tac x="s ^^^ <Tick>" in spec)
  apply (simp)
  (* Ev *)
  apply (elim conjE exE)
  apply (drule_tac x="s ^^^ <Ev aa>" in spec)
  apply (simp)
  apply (subgoal_tac "aa ~: X", simp_all)
  apply (force)

apply (subgoal_tac "Ev ` X Un Y Un (Z - Ev ` X) = Ev ` X Un (Y Un Z)", simp)
by (auto)

(* T3_F4 *)

lemma Hiding_T3_F4 :
  "(traces(P) (fstF o M), failures(P) M) : domF
   ==> HC_T3_F4 (traces(P -- X) (fstF o M), failures(P -- X) M)"
apply (simp add: HC_T3_F4_def in_traces in_failures)
apply (intro allI impI)
apply (elim conjE exE)
apply (drule sym)
apply (simp add: hide_tr_decompo)
apply (elim conjE exE)
apply (rotate_tac -1)
apply (drule sym)

apply (subgoal_tac "(EX t''. t' = t'' ^^^ <Tick> & sett t'' <= Ev ` X)")
 apply (elim conjE exE)
 apply (simp)

 (* F4 *)
 apply (rule conjI)
  apply (rule_tac x="s' ^^^ t''" in exI)
  apply (simp)
  apply (subgoal_tac "t'' --tr X = <>", simp)
   apply (simp add: domF_def HC_F4_def)
   apply (elim conjE)
   apply (drule_tac x="s' ^^^ t''" in spec)
   apply (subgoal_tac "noTick t''")
    apply (simp add: appt_assoc)
   apply (simp add: noTick_def)
   apply (force)
  apply (simp add: hide_tr_nilt_sett)

 (* T3 *)
 apply (rule allI)
 apply (rule_tac x="sa" in exI, simp)
 apply (simp add: domF_def HC_T3_def)
 apply (elim conjE)
 apply (drule_tac x="s' ^^^ t''" in spec, simp)
 apply (subgoal_tac "noTick t''")
  apply (simp add: appt_assoc)
 apply (simp add: noTick_def)
 apply (force)

apply (auto simp add: hide_tr_Tick_sett)
done

(*** Hiding_domF ***)

lemma Hiding_domF :
  "(traces(P) (fstF o M), failures(P) M) : domF
   ==> (traces(P -- X) (fstF o M), failures(P -- X) M) : domF"
apply (simp (no_asm) add: domF_iff)
apply (simp add: Hiding_T2)
apply (simp add: Hiding_F3)
apply (simp add: Hiding_T3_F4)
done

(*--------------------------------*
 |           Renaming             |
 *--------------------------------*)

(*** T2 ***)

lemma Renaming_T2 :
  "(traces(P) (fstF o M), failures(P) M) : domF
   ==> HC_T2 (traces(P [[r]]) (fstF o M), failures(P [[r]]) M)"
apply (simp add: HC_T2_def in_traces in_failures)
apply (intro allI impI)
apply (elim conjE exE)
apply (rule_tac x="sa" in exI)
apply (simp add: domF_def HC_T2_def)
apply (elim conjE)
apply (drule_tac x="sa" in spec)
by (force)

(*** F3 ***)

lemma Renaming_F3 :
  "(traces(P) (fstF o M), failures(P) M) : domF
   ==> HC_F3 (traces(P [[r]]) (fstF o M), failures(P [[r]]) M)"
apply (simp add: HC_F3_def in_traces in_failures)
apply (intro allI impI)
apply (elim conjE exE)
apply (rule_tac x="sa" in exI, simp)

apply (simp add: domF_def HC_F3_def)
apply (elim conjE)
apply (drule_tac x="sa" in spec)
apply (drule_tac x="[[r]]inv X" in spec)
apply (drule_tac x="[[r]]inv Y" in spec)

apply (drule mp)
 apply (simp add: ren_tr_noTick_right)
 apply (intro allI impI)
 apply (simp add: ren_inv_def)
 apply (erule bexE)
 apply (fold ren_inv_def)
 apply (drule_tac x="eb" in spec, simp)

  (* Tick *)
  apply (erule disjE)
  apply (drule_tac x=" sa ^^^ <a>" in spec)
  apply (simp add: ren_tr_noTick_right)
  (* Ev *)
  apply (elim conjE exE)
  apply (drule_tac x=" sa ^^^ <Ev aa>" in spec)
  apply (simp add: ren_tr_noTick_right)
by (simp)

(* T3_F4 *)

lemma Renaming_T3_F4 :
  "(traces(P) (fstF o M), failures(P) M) : domF
   ==> HC_T3_F4 (traces(P [[r]]) (fstF o M), failures(P [[r]]) M)"
apply (simp add: HC_T3_F4_def in_traces in_failures)
apply (intro allI impI)
apply (elim conjE exE)
apply (simp add: ren_tr_appt_decompo)
apply (elim conjE exE)
apply (case_tac "~ noTick s1", simp)
apply (simp)

 (* F4 *)
 apply (rule conjI)
 apply (rule_tac x="s1" in exI, simp)
 apply (simp add: domF_def HC_F4_def)
 apply (elim conjE)
 apply (drule_tac x="s1" in spec, simp)
 apply (rule memF_F2, simp, simp)

 (* T3 *)
 apply (rule allI)
 apply (rule_tac x="s1 ^^^ <Tick>" in exI)
 apply (simp add: domF_def HC_T3_def)
 apply (fast)
done

(*** Renaming_domF ***)

lemma Renaming_domF :
  "(traces(P) (fstF o M), failures(P) M) : domF
   ==> (traces(P [[r]]) (fstF o M), failures(P [[r]]) M) : domF"
apply (simp (no_asm) add: domF_iff)
apply (simp add: Renaming_T2)
apply (simp add: Renaming_F3)
apply (simp add: Renaming_T3_F4)
done

(*--------------------------------*
 |           Seq_compo            |
 *--------------------------------*)

(*** T2 ***)

lemma Seq_compo_T2 :
  "[| (traces(P) (fstF o M), failures(P) M) : domF ;
      (traces(Q) (fstF o M), failures(Q) M) : domF |]
     ==> HC_T2 (traces(P ;; Q) (fstF o M), failures(P ;; Q) M)"
apply (simp add: HC_T2_def in_traces in_failures)
apply (intro allI)
apply (rule conjI)

 (* case 1 *)
 apply (intro impI)
 apply (rule disjI1)
 apply (rule_tac x="s" in exI, simp)
 apply (simp add: domF_def HC_T2_def)
 apply (elim conjE)
 apply (drule_tac x="s" in spec)
 apply (force)

 (* case 2 *)
 apply (intro impI)
 apply (elim conjE exE disjE)
 apply (rule disjI2)
 apply (rule_tac x="sa" in exI)
 apply (rule_tac x="t" in exI)
 apply (simp add: domF_def HC_T2_def)
 apply (elim conjE)
 apply (rotate_tac 4)
 apply (drule_tac x="t" in spec)
 apply (force)
done

(*** F3 ***)

lemma Seq_compo_F3 :
  "[| (traces(P) (fstF o M), failures(P) M) : domF ;
      (traces(Q) (fstF o M), failures(Q) M) : domF |]
     ==> HC_F3 (traces(P ;; Q) (fstF o M), failures(P ;; Q) M)"
apply (simp add: HC_F3_def in_traces in_failures)
apply (intro allI impI)
apply (elim conjE exE disjE)

 (* case 1 *)
 apply (simp add: domF_def HC_F3_def)
 apply (elim conjE)
 apply (drule_tac x="s" in spec)
 apply (drule_tac x="insert Tick X" in spec)
 apply (drule_tac x="Y-{Tick}" in spec)
 apply (simp)
 apply (drule mp)
  apply (intro allI impI)
  apply (drule_tac x="a" in spec, simp)
  apply (simp add: not_Tick_to_Ev)
  apply (elim conjE exE, simp)
  apply (rotate_tac -3)
  apply (drule_tac x="s ^^^ <Ev aa>" in spec, simp)
 apply (subgoal_tac
   "insert Tick (X Un (Y - {Tick})) = insert Tick (X Un Y)", simp)
 apply (force)

 (* case 2 *)
 apply (simp add: domF_def HC_F3_def)
 apply (elim conjE)
 apply (rotate_tac -2)
 apply (drule_tac x="t" in spec)
 apply (drule_tac x="X" in spec)
 apply (drule_tac x="Y" in spec)
 apply (simp)
 apply (drule mp)
  apply (intro allI impI)
  apply (drule_tac x="a" in spec, simp)
  apply (elim conjE)
  apply (rotate_tac -1)
  apply (drule_tac x="sa" in spec)
  apply (rotate_tac -1)
  apply (drule_tac x="t ^^^ <a>" in spec)
  apply (simp add: appt_assoc)
 apply (rule disjI2)
 apply (rule_tac x="sa" in exI)
 apply (rule_tac x="t" in exI)
 apply (simp)
done

(* T3_F4 *)

lemma Seq_compo_T3_F4 :
  "[| (traces(P) (fstF o M), failures(P) M) : domF ;
      (traces(Q) (fstF o M), failures(Q) M) : domF |]
     ==> HC_T3_F4 (traces(P ;; Q) (fstF o M), failures(P ;; Q) M)"
apply (simp add: HC_T3_F4_def in_traces in_failures)
apply (intro allI impI)
apply (elim conjE disjE)

 (* case 1 *)
 apply (elim conjE exE)
 apply (subgoal_tac "noTick (s ^^^ <Tick>) ~= noTick (rmTick sa)", simp)
 apply (simp (no_asm_use))
 apply (drule sym)
 apply (simp)

 (* case 2 *)
 apply (elim conjE exE)
 apply (case_tac "~ noTick sa", simp)
 apply (insert trace_last_nil_or_unnil)
 apply (drule_tac x="t" in spec)
 apply (simp)
  (* <> *)
  apply (erule disjE)
  apply (rotate_tac -5)
  apply (drule_tac sym, simp)   (* contradict *)

  (* ... <Tick> *)
  apply (elim conjE exE, simp)
  apply (simp add: appt_assoc_sym)
  apply (erule conjE)
  apply (rule conjI)

   (* F4 *)
   apply (rule disjI2)
   apply (rule_tac x="sa" in exI)
   apply (rule_tac x="sb" in exI)
   apply (simp add: domF_def HC_F4_def)

   (* T3 *)
   apply (rule allI)
   apply (rule_tac x="sa" in exI)
   apply (rule_tac x="t" in exI)
   apply (simp add: appt_assoc_sym domF_def HC_T3_def)
done

(*** Seq_compo_domF ***)

lemma Seq_compo_domF :
  "[| (traces(P) (fstF o M), failures(P) M) : domF ;
      (traces(Q) (fstF o M), failures(Q) M) : domF |]
     ==> (traces(P ;; Q) (fstF o M), failures(P ;; Q) M) : domF"
apply (simp (no_asm) add: domF_iff)
apply (simp add: Seq_compo_T2)
apply (simp add: Seq_compo_F3)
apply (simp add: Seq_compo_T3_F4)
done

(*--------------------------------*
 |          Depth_rest            |
 *--------------------------------*)

(*** T2 ***)

lemma Depth_rest_T2 :
  "(traces(P) (fstF o M), failures(P) M) : domF
   ==> HC_T2 (traces(P |. n) (fstF o M), failures(P |. n) M)"
apply (simp add: HC_T2_def in_traces in_failures)
apply (intro allI impI)
apply (elim conjE exE)
apply (simp add: domF_def HC_T2_def)
apply (elim conjE)
apply (drule_tac x="s" in spec)
by (force)

(*** F3 ***)

lemma Depth_rest_F3 :
  "(traces(P) (fstF o M), failures(P) M) : domF
   ==> HC_F3 (traces(P |. n) (fstF o M), failures(P |. n) M)"
apply (simp add: HC_F3_def in_traces in_failures)
apply (intro allI impI)
apply (elim conjE exE)

apply (simp add: domF_def HC_F3_def)
apply (elim conjE)
apply (drule_tac x="s" in spec)
apply (drule_tac x="X" in spec)
apply (drule_tac x="Y" in spec)
apply (simp)
apply (erule disjE)
apply (simp)
apply (simp)
apply (elim conjE exE)
apply (simp)
done

(* T3_F4 *)

lemma Depth_rest_T3_F4 :
  "(traces(P) (fstF o M), failures(P) M) : domF
   ==> HC_T3_F4 (traces(P |. n) (fstF o M), failures(P |. n) M)"
apply (simp add: HC_T3_F4_def in_traces in_failures)
apply (intro allI impI)
apply (elim conjE exE)
apply (simp)

 (* F4 *)
 apply (rule conjI)
 apply (simp add: domF_def HC_F4_def)

 (* T3 *)
 apply (simp add: domF_def HC_T3_def)
 apply (case_tac "Suc (lengtht s) < n")
 apply (simp)
 apply (simp)
 apply (fast)
done

(*** Depth_rest_domF ***)

lemma Depth_rest_domF :
  "(traces(P) (fstF o M), failures(P) M) : domF
   ==> (traces(P |. n) (fstF o M), failures(P |. n) M) : domF"
apply (simp (no_asm) add: domF_iff)
apply (simp add: Depth_rest_T2)
apply (simp add: Depth_rest_F3)
apply (simp add: Depth_rest_T3_F4)
done

(*--------------------------------*
 |        Proc_name_dom           |
 *--------------------------------*)

(*** T2 ***)

lemma Proc_name_T2 :
  "HC_T2 (traces ($p) (fstF o M), failures ($p) M)"
apply (simp add: HC_T2_def in_traces in_failures)
apply (intro allI impI)
apply (elim exE)
apply (simp add: pairF_domF_T2)
done

(*** F3 ***)

lemma Proc_name_F3 :
  "HC_F3 (traces ($p) (fstF o M), failures ($p) M)"
apply (simp add: HC_F3_def in_traces in_failures)
apply (intro allI impI)
apply (simp add: pairF_domF_F3)
done

(* T3_F4 *)

lemma Proc_name_T3_F4 :
  "HC_T3_F4 (traces ($p) (fstF o M), failures ($p) M)"
apply (simp add: HC_T3_F4_def in_traces in_failures)
apply (intro allI impI)
apply (simp add: pairF_domF_T3)
apply (simp add: pairF_domF_F4)
done

(*** Proc_name_domF ***)

lemma Proc_name_domF :
  "(traces ($p) (fstF o M), failures ($p) M) : domF"
apply (simp (no_asm) add: domF_iff)
apply (simp add: Proc_name_T2)
apply (simp add: Proc_name_F3)
apply (simp add: Proc_name_T3_F4)
done

(*--------------------------------*
 |             proc               |
 *--------------------------------*)

declare o_apply [simp del]

lemma proc_domF[simp]: "(traces(P) (fstF o M), failures(P) M) : domF"
apply (induct_tac P)
apply (simp add: STOP_domF)
apply (simp add: SKIP_domF)
apply (simp add: DIV_domF)
apply (simp add: Act_prefix_domF)
apply (simp add: Ext_pre_choice_domF)
apply (simp add: Ext_choice_domF)
apply (simp add: Int_choice_domF)
apply (simp add: Rep_int_choice_domF)
apply (simp add: IF_domF)
apply (simp add: Parallel_domF)
apply (simp add: Hiding_domF)
apply (simp add: Renaming_domF)
apply (simp add: Seq_compo_domF)
apply (simp add: Depth_rest_domF)
apply (simp add: Proc_name_domF)
done

declare o_apply [simp]

(*--------------------------------*
 |          fstF sndF             |
 *--------------------------------*)

lemma fstF_proc_domF[simp]:
   "fstF (traces(P) (fstF o M),, failures(P) M) = traces(P) (fstF o M)"
by (simp add: pairF)

lemma sndF_proc_domF[simp]:
   "sndF (traces(P) (fstF o M),, failures(P) M) = failures(P) M"
by (simp add: pairF)

lemma fstF_proc_domF2[simp]:
   "fstF (traces(P) (%x. fstF (M x)),, failures(P) M) = traces(P) (fstF o M)"
apply (fold comp_def)
apply (simp)
done

lemma sndF_proc_domF2[simp]:
   "sndF (traces(P) (%x. fstF (M x)),, failures(P) M) = failures(P) M"
apply (fold comp_def)
apply (simp)
done

lemma fstF_proc_domF_fun:
   "fstF o (%p. (traces(f p) (fstF o M),, failures(f p) M))
     = (%p. traces(f p) (fstF o M))"
apply (unfold comp_def)
apply (fold comp_def)
apply (simp add: fun_eq_iff)
done

lemma sndF_proc_domF_fun:
   "sndF o (%p. (traces(f p) (fstF o M),, failures(f p) M))
     = (%p.  failures(f p) M)"
apply (unfold comp_def)
apply (fold comp_def)
apply (simp add: fun_eq_iff)
done

lemma fstF_semFf[simp]: "fstF ([[P]]Ff M) = traces(P) (fstF o M)"
by (simp add: semFf_def)

lemma fstF_semF[simp]: "fstF ([[P]]F) = traces(P) (fstF o MF)"
by (simp add: semF_def)

lemma sndF_semFf[simp]: "sndF ([[P]]Ff M) = failures(P) M"
by (simp add: semFf_def)

lemma sndF_semF[simp]: "sndF ([[P]]F) = failures(P) MF"
by (simp add: semF_def)

(*** decomposition ***)

lemma semFf_decompo:
  "([[P]]Ff M = SF) = ((traces P (fstF o M) = fstF SF) &
                        failures P M = sndF SF)"
apply (simp add: semFf_def)
apply (rule)
apply (drule sym)
apply (simp)
apply (simp)
done

lemma semF_decompo:
  "([[P]]F = SF) = ((traces P (fstF o MF) = fstF SF) &
                     failures P MF = sndF SF)"
apply (simp add: semF_def)
apply (simp add: semFf_decompo)
done

lemma semFf_decompo_fstF:
  "([[P]]Ff M = SF) ==> traces P (fstF o M) = fstF SF"
by (simp add: semFf_decompo)

lemma semF_decompo_fstF:
  "([[P]]F = SF) ==> traces P (fstF o MF) = fstF SF"
by (simp add: semF_decompo)

lemma semFf_decompo_sndF:
  "([[P]]Ff M = SF) ==>  failures P M = sndF SF"
by (simp add: semFf_decompo)

lemma semF_decompo_sndF:
  "([[P]]F = SF) ==>  failures P MF = sndF SF"
by (simp add: semF_decompo)

(*--------------------------------*
 |            [[$p]]Ff            |
 *--------------------------------*)

lemma semFf_Proc_name: "[[$p]]Ff = (%M. M p)"
apply (simp add: semFf_def)
apply (simp add: traces_iff)
apply (simp add: failures_iff)
done

(*--------------------------------*
 |          =F and <=F            |
 *--------------------------------*)

lemma cspF_eqF_semantics:
  "(P =F[M1,M2] Q) =
       ((traces P (fstF o M1) = traces Q (fstF o M2)) &
        (failures P M1 = failures Q M2))"
apply (simp add: eqF_def)
apply (simp add: semFf_def)
apply (simp add: eqF_decompo)
done

lemma cspF_refF_semantics:
  "(P <=F[M1,M2] Q) =
       ((traces Q (fstF o M2) <= traces P (fstF o M1)) &
        (failures Q M2 <= failures P M1))"
apply (simp add: refF_def)
apply (simp add: semFf_def)
apply (simp add: subdomF_decompo)
done

lemmas cspF_semantics = cspF_eqF_semantics  cspF_refF_semantics

lemma cspF_cspT_eqF_semantics:
  "(P =F[M1,M2] Q) =
       ((P =T[fstF o M1,fstF o M2] Q) &
        (failures P M1 = failures Q M2))"
apply (simp add: cspF_eqF_semantics)
apply (simp add: eqT_def)
apply (simp add: semTf_def)
done

lemma cspF_cspT_refF_semantics:
  "(P <=F[M1,M2] Q) =
       ((P <=T[fstF o M1,fstF o M2] Q) &
        (failures Q M2 <= failures P M1))"
apply (simp add: cspF_refF_semantics)
apply (simp add: refT_def)
apply (simp add: semTf_def)
done

lemmas cspF_cspT_semantics = cspF_cspT_eqF_semantics  cspF_cspT_refF_semantics

(*--------------------------------*
 |            Timeout             |
 *--------------------------------*)

lemma in_failures_Timeout1:
  "(f :f failures(P [> Q) M) =
   (f :f failures(Q) M |
   (EX s X. f = (s, X) & s ~= <> & (s, X) :f failures(P) M) |
   (EX X. f = (<>, X) & X <= Evset & <Tick> :t traces(P) (fstF o M)))"
apply (rule)

(* <= *)
 apply (simp add: in_failures)
 apply (elim conjE exE disjE)
 apply (simp_all)
 apply (simp add: in_traces)
 apply (rule disjI1)
 apply (rule domF_F2_F4, simp_all)

 (* <= *)
 apply (simp add: in_failures in_traces)
 apply (elim conjE exE disjE, simp_all)
 apply (auto elim: memF_pairE)
done

lemma in_failures_Timeout2:
  "(f :f failures(P [>def Q) M) =
   (f :f failures(Q) M |
   (EX s X. f = (s, X) & s ~= <> & (s, X) :f failures(P) M) |
   (EX X. f = (<>, X) & X <= Evset & <Tick> :t traces(P) (fstF o M)))"
apply (simp add: Timeout_def)
apply (simp add: in_failures_Timeout1)
done

lemmas in_failures_Timeout = in_failures_Timeout1 in_failures_Timeout2

(*--------------------------------*
 |           Depth rest           |
 *--------------------------------*)

lemma semFf_Depth_rest: "[[P |. n]]Ff M = [[P]]Ff M .|. n"
apply (simp add: semFf_def)
apply (simp add: traces.simps)
apply (simp add: failures.simps)
apply (simp add: rest_domF_def)
apply (simp add: restTF_def)
apply (simp add: pairF_def)
apply (simp add: Abs_domF_inverse)
apply (simp add: pair_restriction_def)
done

lemma semF_Depth_rest: "[[P |. n]]F = [[P]]F .|. n"
apply (simp add: semF_def)
apply (simp add: semFf_Depth_rest)
done

(*---------------------------------------------------*
 |         Healthiness conditions for proc           |
 *---------------------------------------------------*)

lemma proc_T2:
    "(s, X) :f failures(P) M ==> s :t traces(P) (fstF o M)"
apply (insert pairF_domF_T2[of "s" "X" "(traces(P) (fstF o M),, failures(P) M)"])
by (simp)

lemma proc_T3:
  "[| s ^^^ <Tick> :t traces(P) (fstF o M); noTick s |]
   ==> (s ^^^ <Tick>, X) :f failures(P) M"
apply (insert pairF_domF_T3[of "s" "(traces(P) (fstF o M),, failures(P) M)" "X"])
by (simp)

lemma proc_T3_Tick:
  "<Tick> :t traces(P) (fstF o M) ==> (<Tick>, X) :f failures(P) M"
apply (insert proc_T3[of "<>" P M X])
by (simp)

lemma proc_F4:
  "[| s ^^^ <Tick> :t traces(P) (fstF o M) ; noTick s |]
   ==> (s, Evset) :f failures(P) M"
apply (insert pairF_domF_F4[of "s" "(traces(P) (fstF o M),, failures(P) M)"])
by (simp)

lemma proc_F3:
  "[| (s, X) :f failures(P) M ; noTick s ;
      (ALL a. a : Y --> s ^^^ <a> ~:t  traces(P) (fstF o M)) |]
   ==> (s, X Un Y) :f  failures(P) M"
apply (insert pairF_domF_F3[of "s" "X" "(traces(P) (fstF o M),, failures(P) M)" "Y"])
by (simp)

lemma proc_F3I:
  "[| (s, X) :f failures(P) M ; noTick s ;
      (ALL a. a : Y --> s ^^^ <a> ~:t traces(P) (fstF o M)) ;
      Z = X Un Y |]
   ==> (s, Z) :f failures(P) M"
by (simp add: proc_F3)

(*** F2_F4 ***)

lemma proc_F2_F4:
  "[| s ^^^ <Tick> :t traces(P) (fstF o M) ; noTick s ; X <= Evset|]
   ==> (s, X) :f failures(P) M"
apply (insert pairF_domF_F2_F4[of "s" "(traces(P) (fstF o M),, failures(P) M)" "X"])
by (simp)

(*** T2_T3 ***)

lemma proc_T2_T3:
  "[| (s ^^^ <Tick>, X) :f failures(P) M ; noTick s |]
  ==> (s ^^^ <Tick>, Y) :f failures(P) M"
apply (rule proc_T3)
apply (rule proc_T2)
by (simp_all)

(*------------------------------------------------------*
 |   Union in domF  (used for generic internal choice   |
 *------------------------------------------------------*)

lemma non_empty_UnionT_UnionF_T2:
 "Ps ~= {} ==>
  HC_T2 (UnionT {(traces P (fstF o M)) |P. P : Ps} ,
         UnionF {(failures P M) |P. P : Ps})"
apply (simp add: HC_T2_def)
apply (intro allI impI)
apply (subgoal_tac "{(traces P (fstF o M)) |P. P : Ps} ~= {}")
apply (simp)
apply (elim conjE bexE exE)
apply (simp)
apply (rule_tac x="traces Pa (fstF o M)" in exI)
apply (rule conjI)
apply (rule_tac x="Pa" in exI)
apply (simp)
apply (simp add: proc_T2)
by (auto)

lemma non_empty_UnionT_UnionF_F3:
 "Ps ~= {} ==>
  HC_F3 (UnionT {(traces P (fstF o M)) |P. P : Ps} ,
         UnionF {(failures P M) |P. P : Ps})"
apply (simp add: HC_F3_def)
apply (intro allI impI)
apply (subgoal_tac "{(traces P (fstF o M)) |P. P : Ps} ~= {}")
apply (simp)
apply (elim conjE exE)
apply (simp)
apply (rule_tac x="failures Pa M" in exI)
apply (rule conjI)
apply (rule_tac x="Pa" in exI)
apply (simp)
apply (rule proc_F3)
apply (simp_all)
apply (intro allI impI)
apply (drule_tac x="a" in spec)
apply (simp)
apply (drule_tac x="traces Pa  (fstF o M)" in spec)
apply (erule disjE)
apply (drule_tac x="Pa" in spec)
apply (simp)
apply (simp)
apply (auto)
done

lemma non_empty_UnionT_UnionF_T3_F4:
 "Ps ~= {} ==>
  HC_T3_F4 (UnionT {(traces P (fstF o M)) |P. P : Ps} ,
            UnionF {(failures P M) |P. P : Ps})"
apply (simp add: HC_T3_F4_def)
apply (intro allI impI)
apply (subgoal_tac "{(traces P (fstF o M)) |P. P : Ps} ~= {}")
apply (simp)
apply (elim conjE bexE exE)
apply (simp)
apply (rule conjI)
 apply (rule_tac x="failures Pa M" in exI)
 apply (rule conjI)
 apply (fast)
 apply (rule proc_F4)
 apply (simp_all)

 apply (rule allI)
 apply (rule_tac x="failures Pa M" in exI)
 apply (rule conjI)
 apply (fast)
 apply (rule proc_T3)
 apply (simp_all)
by (auto)

lemma non_empty_UnionT_UnionF_domF:
 "Ps ~= {} ==>
  (UnionT {(traces P (fstF o M)) |P. P : Ps} ,
   UnionF {(failures P M) |P. P : Ps}) : domF"
apply (simp (no_asm) add: domF_iff)
apply (simp add: non_empty_UnionT_UnionF_T2)
apply (simp add: non_empty_UnionT_UnionF_F3)
apply (simp add: non_empty_UnionT_UnionF_T3_F4)
done

(*------------------------------------------------------*
 |   Union in domF  (used for generic internal choice   |
 *------------------------------------------------------*)

lemma UnionT_UnionF_T2:
 "HC_T2 ({t. t = <> | (EX P:Ps. t :t traces(P) (fstF o M)) }t ,
         {f. EX P:Ps. f :f failures(P) M}f )"
apply (simp add: HC_T2_def)
apply (intro allI impI)
apply (simp add: in_traces_Union_proc)
apply (simp add: in_failures_Union_proc)
apply (elim conjE bexE exE)
apply (rule disjI2)
apply (rule_tac x="P" in bexI)
apply (simp add: proc_T2)
apply (simp)
done

lemma UnionT_UnionF_F3:
 "HC_F3 ({t. t = <> | (EX P:Ps. t :t traces(P) (fstF o M)) }t ,
         {f. EX P:Ps. f :f failures(P) M}f )"
apply (simp add: HC_F3_def)
apply (intro allI impI)
apply (simp add: in_traces_Union_proc)
apply (simp add: in_failures_Union_proc)
apply (elim conjE bexE exE)
apply (simp)
apply (rule_tac x="P" in bexI)
apply (rule proc_F3)
apply (simp_all)
done

lemma UnionT_UnionF_T3_F4:
 "HC_T3_F4 ({t. t = <> | (EX P:Ps. t :t traces(P) (fstF o M)) }t ,
            {f. EX P:Ps. f :f failures(P) M}f )"
apply (simp add: HC_T3_F4_def)
apply (intro allI impI)
apply (simp add: in_traces_Union_proc)
apply (simp add: in_failures_Union_proc)
apply (elim conjE bexE exE)
apply (simp)
apply (elim bexE)
apply (rule conjI)
 apply (rule_tac x="P" in bexI)
 apply (rule proc_F4)
 apply (simp_all)

 apply (rule allI)
 apply (rule_tac x="P" in bexI)
 apply (rule proc_T3)
 apply (simp_all)
done

lemma UnionT_UnionF_domF:
 "({t. t = <> | (EX P:Ps. t :t traces(P) (fstF o M)) }t ,
            {f. EX P:Ps. f :f failures(P) M}f) : domF"
apply (simp (no_asm) add: domF_iff)
apply (simp add: UnionT_UnionF_T2)
apply (simp add: UnionT_UnionF_F3)
apply (simp add: UnionT_UnionF_T3_F4)
done

(*-----------------------------------------*
 |              substitution               |
 *-----------------------------------------*)

lemma semF_subst:
  "[[P<<f]]F = [[P]]Ff (%q. [[f q]]F)"
apply (induct_tac P)
apply (simp add: semF_def semFf_def,
       simp add: eqF_decompo,
       simp add: traces_iff failures_iff)+
done

lemma semF_subst_semFfun:
  "(%q. [[ (Pf q)<<f ]]F) = ([[Pf]]Ffun (%q. [[f q]]F))"
apply (simp add: semFfun_def)
apply (simp add: fun_eq_iff)
apply (rule allI)
apply (simp add: semF_subst)
done

lemma failrues_subst:
  "failures(P<<f) M = failures P (%q. [[f q]]Ff M)"
apply (induct_tac P)
apply (simp_all add: semF_def semFf_def traces_iff failures_iff)+
apply (simp add: fstF_proc_domF_fun)
apply (simp add: traces_subst)

apply (simp add: fstF_proc_domF_fun)
apply (simp add: traces_subst)
done

(*-----------------------------------------*
 |               semT -- semF              |
 *-----------------------------------------*)

lemma semTfun_fstF_semFf:
  "[[Pf]]Tfun (fstF o M) p = fstF ([[Pf p]]Ff M)"
apply (simp add: semTfun_def)
apply (simp add: semTf_def)
done

(****************** to add them again ******************)

declare disj_not1   [simp]

end


theory ValueOntology     (*Benzmüller, Fuenmayor & Lomfeld, 2020*)
  imports PreferenceLogicBasics
begin (*** Lomfeld's value ontology is encoded ***)
(*two legal parties (there can be more in principle)*)
datatype c = p | d (*parties/contenders: plaintiff, defendant*)
fun other::"c\<Rightarrow>c" ("_\<inverse>") where "p\<inverse> = d" | "d\<inverse>= p"

consts For::"c\<Rightarrow>\<sigma>"    (*decision: find/rule for party*)
axiomatization where ForAx: "\<lfloor>For x \<^bold>\<leftrightarrow> (\<^bold>\<not>For x\<inverse>)\<rfloor>"

(* abbreviation relPref::\<nu> ("_\<^bold>\<prec>_") where "\<phi> \<^bold>\<prec> \<psi> \<equiv> \<phi> \<^bold>\<preceq>\<^sub>A\<^sub>E \<psi> " *)
abbreviation relPref::\<nu> ("_\<^bold>\<prec>_") where "\<phi> \<^bold>\<prec> \<psi> \<equiv> \<psi> \<^bold>\<succ>\<^sub>E\<^sub>A \<phi>"

datatype (*ethico-legal values/principles*)
   VAL = WILL | RELI | RESP | EQUI | FAIR | EFFI | STAB | GAIN

(*predicate c\<up>UV: (a decision for) party c promotes value V*)
consts V::"c\<Rightarrow>VAL\<Rightarrow>\<sigma>" ("_\<upharpoonleft>_")

(*upper values and their compliance with ethico-legal values*)
abbreviation "SECURITY x \<equiv> (x\<upharpoonleft>RELI \<^bold>\<or> x\<upharpoonleft>EQUI \<^bold>\<or> x\<upharpoonleft>STAB \<^bold>\<or> x\<upharpoonleft>EFFI)"
abbreviation "EQUALITY x \<equiv> (x\<upharpoonleft>FAIR \<^bold>\<or> x\<upharpoonleft>RESP \<^bold>\<or> x\<upharpoonleft>EQUI \<^bold>\<or> x\<upharpoonleft>RELI)"
abbreviation "LIBERTY x \<equiv> (x\<upharpoonleft>WILL \<^bold>\<or> x\<upharpoonleft>GAIN \<^bold>\<or> x\<upharpoonleft>RESP \<^bold>\<or> x\<upharpoonleft>FAIR)"
abbreviation "UTILITY x \<equiv> (x\<upharpoonleft>EFFI \<^bold>\<or> x\<upharpoonleft>STAB \<^bold>\<or> x\<upharpoonleft>GAIN \<^bold>\<or> x\<upharpoonleft>WILL)"
abbreviation (*inconsistency of upper values*)
 "INCONS x \<equiv> (SECURITY x \<^bold>\<and> EQUALITY x \<^bold>\<and> LIBERTY x \<^bold>\<and> UTILITY x)"
abbreviation (*Indifference*)
 "INDIFF x \<equiv> \<^bold>\<not>(SECURITY x \<^bold>\<or> EQUALITY x \<^bold>\<or> LIBERTY x \<^bold>\<or> UTILITY x)"

(*some useful settings for model finder: enforce information*)
nitpick_params [eval=INCONS SECURITY EQUALITY LIBERTY UTILITY V]
(*exploring the consistency and models of the ontology*)
lemma "True" nitpick[satisfy,show_all,card i=1] oops
lemma "True" nitpick[satisfy,show_all,card i=10] oops
lemma "\<lfloor>(\<^bold>\<not>INDIFF d) \<^bold>\<and> (\<^bold>\<not>INDIFF p) \<^bold>\<and> (\<^bold>\<not>INCONS d) \<^bold>\<and> (\<^bold>\<not>INCONS p) \<^bold>\<and>
  d\<upharpoonleft>RELI \<^bold>\<and> p\<upharpoonleft>WILL\<rfloor>"  nitpick[satisfy,max_genuine=10,show_all] oops

(*useful shorthand notation for aggregated values*)
abbreviation agg::"\<sigma>\<Rightarrow>\<sigma>\<Rightarrow>\<sigma>" ("_\<^bold>\<oplus>_") where "v\<^sub>1\<^bold>\<oplus>v\<^sub>2 \<equiv> v\<^sub>1 \<^bold>\<or> v\<^sub>2"
abbreviation Agg2 ("_\<upharpoonleft>[_\<oplus>_]") where "c\<upharpoonleft>[V1\<oplus>V2] \<equiv> c\<upharpoonleft>V1 \<^bold>\<oplus> c\<upharpoonleft>V2"
abbreviation Agg3 ("_\<upharpoonleft>[_\<oplus>_\<oplus>_]")
  where "c\<upharpoonleft>[V1\<oplus>V2\<oplus>V3] \<equiv> c\<upharpoonleft>V1 \<^bold>\<oplus> (c\<upharpoonleft>V2 \<^bold>\<oplus> c\<upharpoonleft>V3)"
abbreviation Agg4 ("_\<upharpoonleft>[_\<oplus>_\<oplus>_\<oplus>_]")
  where "c\<upharpoonleft>[V1\<oplus>V2\<oplus>V3\<oplus>V4] \<equiv> c\<upharpoonleft>V1 \<^bold>\<oplus> (c\<upharpoonleft>V2 \<^bold>\<oplus> (c\<upharpoonleft>V3 \<^bold>\<oplus> c\<upharpoonleft>V4))"

(*exploring implied knowledge*)
lemma "\<lfloor>x\<upharpoonleft>[WILL\<oplus>STAB] \<^bold>\<rightarrow> INCONS x\<rfloor>"
  nitpick oops (*two non-opposed quadrants \<oplus> (noq): consistent*)
lemma "\<lfloor>x\<upharpoonleft>[WILL\<oplus>GAIN\<oplus>EFFI\<oplus>STAB] \<^bold>\<rightarrow> INCONS x\<rfloor>"
  nitpick oops (*two noq \<oplus>: consistent*)
lemma "\<lfloor>x\<upharpoonleft>[WILL\<oplus>EFFI\<oplus>RELI] \<^bold>\<rightarrow> INCONS x\<rfloor>" nitpick (*TODO redefine INCONS appropriately to validate this*)
  by simp (*three quadrants \<oplus>: inconsistent*)
lemma "\<lfloor>x\<upharpoonleft>[RESP\<oplus>STAB] \<^bold>\<rightarrow> INCONS x\<rfloor>"  nitpick (*TODO redefine INCONS appropriately to validate this*)
  by simp (*two opposed quadrants \<oplus> (oq): inconsistent*)
lemma "\<lfloor>x\<upharpoonleft>EQUI \<^bold>\<and> y\<upharpoonleft>EFFI \<^bold>\<rightarrow> (INCONS x \<^bold>\<or> INCONS y)\<rfloor>"
  nitpick oops (*two noq (different parties): consistent*)
lemma "\<lfloor>x\<upharpoonleft>RESP \<^bold>\<and> y\<upharpoonleft>STAB \<^bold>\<rightarrow> (INCONS x \<^bold>\<or> INCONS y)\<rfloor>"
  nitpick oops (*two oq (different parties): consistent*)

(*Important: only AE/EA preference variants are suitable for the
logic of value aggregation (aggregating values by union/disjunction)*)
lemma "\<lfloor>x\<upharpoonleft>WILL \<^bold>\<prec> x\<upharpoonleft>[WILL\<oplus>STAB]\<rfloor>"
  nitpick nitpick[satisfy] oops (*contingent --TODO: should also be countersatisfiable(?)*)
lemma "\<lfloor>x\<upharpoonleft>WILL \<^bold>\<prec> x\<upharpoonleft>STAB\<rfloor> \<longrightarrow> \<lfloor>x\<upharpoonleft>WILL \<^bold>\<prec> x\<upharpoonleft>[WILL\<oplus>STAB]\<rfloor>" by blast
lemma "\<lfloor>x\<upharpoonleft>WILL \<^bold>\<prec> x\<upharpoonleft>STAB\<rfloor> \<longrightarrow> \<lfloor>x\<upharpoonleft>WILL \<^bold>\<prec> x\<upharpoonleft>[RELI\<oplus>STAB]\<rfloor>" by blast
lemma "\<lfloor>x\<upharpoonleft>WILL \<^bold>\<prec> x\<upharpoonleft>[WILL\<oplus>STAB]\<rfloor> \<longrightarrow> \<lfloor>x\<upharpoonleft>WILL \<^bold>\<prec> x\<upharpoonleft>STAB\<rfloor>"
  nitpick nitpick[satisfy] oops (*contingent --TODO: should also be countersatisfiable(?)*)
lemma "\<lfloor>x\<upharpoonleft>WILL \<^bold>\<prec> x\<upharpoonleft>[RELI\<oplus>STAB]\<rfloor> \<longrightarrow> \<lfloor>x\<upharpoonleft>WILL \<^bold>\<prec> x\<upharpoonleft>STAB\<rfloor>"
  nitpick nitpick[satisfy] oops (*contingent*)
lemma "\<lfloor>x\<upharpoonleft>[WILL\<oplus>STAB] \<^bold>\<prec> x\<upharpoonleft>WILL\<rfloor>"
  nitpick nitpick[satisfy] oops (*contingent --TODO: should also be satisfiable(?)*)
lemma "\<lfloor>x\<upharpoonleft>[WILL\<oplus>STAB] \<^bold>\<prec> x\<upharpoonleft>WILL\<rfloor> \<longrightarrow> \<lfloor>x\<upharpoonleft>STAB \<^bold>\<prec> x\<upharpoonleft>WILL\<rfloor>" by blast
lemma "\<lfloor>x\<upharpoonleft>[RELI\<oplus>STAB] \<^bold>\<prec> x\<upharpoonleft>WILL\<rfloor> \<longrightarrow> \<lfloor>x\<upharpoonleft>STAB \<^bold>\<prec> x\<upharpoonleft>WILL\<rfloor>" by blast
lemma "\<lfloor>x\<upharpoonleft>STAB \<^bold>\<prec> x\<upharpoonleft>WILL\<rfloor> \<longrightarrow> \<lfloor>x\<upharpoonleft>[WILL\<oplus>STAB] \<^bold>\<prec> x\<upharpoonleft>WILL\<rfloor>"
  nitpick nitpick[satisfy] oops (*contingent --TODO: should also be countersatisfiable(?)*)
lemma "\<lfloor>x\<upharpoonleft>STAB \<^bold>\<prec> x\<upharpoonleft>WILL\<rfloor> \<longrightarrow> \<lfloor>x\<upharpoonleft>[RELI\<oplus>STAB] \<^bold>\<prec> x\<upharpoonleft>WILL\<rfloor>"
  nitpick nitpick[satisfy] oops (*contingent*)

end


theory Indep_Vars
imports Main Refine_Util Mpat_Antiquot
begin

definition [simp]: "INDEP v \<equiv> True"
lemma INDEPI: "INDEP v" by simp

ML {*
  signature INDEP_VARS = sig
    val indep_tac: tactic'
  end

  structure Indep_Vars :INDEP_VARS = struct

    local
      fun vsubterms (Abs (_,_,t)) = vsubterms t
        | vsubterms (t as (_$_)) = let
            val (f,args) = strip_comb t
            val args_vsts = map vsubterms args |> flat
          in
            case f of
              (Var (name,vT)) => [(name,vT,fastype_of t,args)]@args_vsts
            | _ => vsubterms f @ args_vsts
          end
        | vsubterms _ = []

      fun indep_vars t st = let
        val thy = theory_of_thm st
        val cert = cterm_of thy

        fun inst_of (name,vT,T,args) = let
          val Ts = map fastype_of args |> rev
          val t' = fold absdummy Ts (Var (name,T))
          val inst = (cert (Var (name,vT)), cert t')
        in inst end

        val inst = vsubterms t
          |> distinct (op = o pairself #1)
          |> map inst_of

        val st' = Drule.instantiate_normalize ([],inst) st
          |> Conv.fconv_rule (Thm.beta_conversion true)
      in
        Seq.single st'
      end

      fun indep_tac_aux i st = case Logic.concl_of_goal (prop_of st) i of
        @{mpat "Trueprop (INDEP ?v)"}
          => (indep_vars v THEN rtac @{thm INDEPI} i) st
      | _ => Seq.empty

    in
      (* Remove explicit parameters from schematic variable. *)
      val indep_tac = IF_EXGOAL
        (CONVERSION Thm.eta_conversion THEN' indep_tac_aux)
    end
  end
*}

(*schematic_lemma
  "!!x y z. INDEP (?R x z)"
  "!!x y z. ?R x z 1"
  apply (tactic {* Indep_Vars.indep_tac 1 *})
  apply rule
  done
*)

end

(*

      fun indep_vars t st = case strip_comb t of
        (v as Var (name,_),args) => let
          val thy = theory_of_thm st
          val cert = cterm_of thy

          val T = fastype_of t
          val Ts = map fastype_of args |> rev
          val t' = fold absdummy Ts (Var (name,T))
          val inst = ([],[(cert v, cert t')]) handle e =>
            ( tracing (Syntax.pretty_term_global thy t |> Pretty.string_of);
              reraise e
            )

          val st' = Drule.instantiate_normalize inst st
            |> Conv.fconv_rule (Thm.beta_conversion true)

          val _ = Config.get_global thy cfg_trace andalso (Pretty.block [
            Pretty.str "INDEP ", Syntax.pretty_term_global thy t,
              Pretty.brk 1, Pretty.str ":", Pretty.brk 1,
              Syntax.pretty_term_global thy v,
              Pretty.brk 1, Pretty.str "->", Pretty.brk 1,
              Syntax.pretty_term_global thy t',
              Pretty.fbrk,
              Pretty.indent 2 (
                Pretty.big_list "Goals: "
                  (Goal_Display.pretty_goals_without_context st'))
          ] |> Pretty.string_of |> tracing; true)

        in Seq.single st' end
      | _ => (
        Pretty.block [
            Pretty.str "INDEP on non-variable: ",
            Syntax.pretty_term_global (theory_of_thm st) t
          ] |> Pretty.string_of |> warning;
        Seq.single st
      )

  Old version: Removes all functionality, not only explicit parameters
  structure Indep_Vars :INDEP_VARS = struct
    local
      (* Remove explicit parameters from relation variable. *)
      fun indep_var (name,typ) = let
        val (Ts,T) = strip_type typ |>> rev
        val r = fold absdummy Ts (Var (name,T))
      in
        r
      end

      fun indep_vars R st = let
        val vs = Term.add_vars R []
        val cert = cterm_of (theory_of_thm st)
        val inst = map (fn v => (cert (Var v), cert (indep_var v))) vs
        val st' = Drule.instantiate_normalize ([],inst) st
          |> Conv.fconv_rule (Thm.beta_conversion true)
      in
        Seq.single st'
      end

      fun indep_tac_aux i st = case Logic.concl_of_goal (prop_of st) i of
        @{mpat "Trueprop (INDEP ?v)"}
          => (indep_vars v THEN rtac @{thm INDEPI} i) st
      | _ => Seq.empty

    in
      val indep_tac = IF_EXGOAL indep_tac_aux

    end
  end

*)