(*<*)
(*  Author : Peter Chapman *)
(* License: LGPL *)
section "Single Succedent"

theory SingleSuccedent
imports "HOL-Library.Multiset"
begin

(* Has the empty formula O, which will mean we can have empty right-hand sides *)
(*>*)

text\<open>
\section{Single Succedent Calculi \label{isasingle}}
We must be careful when restricting sequents to single succedents.  If we have sequents as a pair of multisets, where the second is restricted to having size at most 1, then how does one extend the active part of $\implies{L}{}$ from \textbf{G3ip}?  The left premiss will be $\implies{A}{B} \Rightarrow A$, and the extension will be $\Gamma \Rightarrow C$.  The \texttt{extend} function must be able to correctly choose to discard the $C$.

Rather than taking this route, we instead restrict to single formulae in the succedents of sequents.  This raises its own problems, since now how does one represent the empty succedent?  We introduce a dummy formula \texttt{Em}, which will stand for the empty formula:
\<close>

datatype 'a form = At "nat"
                        | Compound "'a" "'a form list"
                        | ff
                        | Em
(*<*)
abbreviation multiset_abbrev ("\<LM> _  \<RM>" [75]75) where
   "\<LM> A \<RM> \<equiv> {# A #}"

abbreviation multiset_empty ("\<Empt>" 75) where
  "\<Empt> \<equiv> {#}"

datatype 'a sequent = Sequent "('a form) multiset" "('a form)" (" (_) \<Rightarrow>* (_)" [6,6] 5)

(* We have that any step in a rule, be it a primitive rule or an instance of a rule in a derivation
   can be represented as a list of premisses and a conclusion.  We need a list since a list is finite
   by definition *)
type_synonym 'a rule = "'a sequent list * 'a sequent"

type_synonym 'a deriv = "'a sequent * nat"

abbreviation
multiset_plus (infixl "\<oplus>" 80) where
   "(\<Gamma> :: 'a multiset) \<oplus> (A :: 'a) \<equiv> \<Gamma> + \<LM>A\<RM>"
abbreviation
multiset_minus (infixl "\<ominus>" 80) where
   "(\<Gamma> :: 'a multiset) \<ominus>  (A :: 'a) \<equiv> \<Gamma> - \<LM>A\<RM>"

consts
  (* extend a sequent by adding another one.  A form of weakening.  Is this overkill by adding a sequent? *)
  extend :: "'a sequent \<Rightarrow> 'a sequent \<Rightarrow> 'a sequent"
  extendRule :: "'a sequent \<Rightarrow> 'a rule \<Rightarrow> 'a rule"

  (* Unique conclusion Property *)
  uniqueConclusion :: "'a rule set \<Rightarrow> bool"

  (* Invertible definitions *)
  invertible :: "'a rule \<Rightarrow> 'a rule set \<Rightarrow> bool"
  invertible_set :: "'a rule set \<Rightarrow> bool"

  (* functions to get at components of sequents *)
primrec antec :: "'a sequent \<Rightarrow> 'a form multiset" where "antec (Sequent ant suc) = ant"
primrec succ :: "'a sequent \<Rightarrow> 'a form" where "succ (Sequent ant suc) = suc"
primrec mset :: "'a sequent \<Rightarrow> 'a form multiset" where "mset (Sequent ant suc) = ant \<oplus> suc"
primrec seq_size :: "'a sequent \<Rightarrow> nat" where "seq_size (Sequent ant suc) = size ant + size suc"

(* Extend a sequent, and then a rule by adding seq to all premisses and the conclusion *)

(*>*)
text\<open>
\noindent When we come to extend a sequent, say $\Gamma \Rightarrow C$, with another sequent, say $\Gamma' \Rightarrow C'$, we only ``overwrite'' the succedent if $C$ is the empty formula:
\<close>
overloading
  extend \<equiv> extend
  extendRule \<equiv> extendRule
begin

definition extend
  where "extend forms seq \<equiv>
    if (succ seq = Em)
    then (antec forms + antec seq) \<Rightarrow>* (succ forms)
    else (antec forms + antec seq \<Rightarrow>* succ seq)"

definition extendRule
  where "extendRule forms R \<equiv> (map (extend forms) (fst R), extend forms (snd R))"

end

(*<*)
(* The formulation of various rule sets *)

(* Ax is the set containing all identity RULES and LBot *)
inductive_set "Ax" where
   id[intro]: "([], \<LM> At i \<RM> \<Rightarrow>* At i) \<in> Ax"
|  Lbot[intro]: "([], \<LM> ff \<RM> \<Rightarrow>* Em) \<in> Ax"

(* upRules is the set of all rules which have a single conclusion.  This is akin to each rule having a
   single principal formula.  We don't want rules to have no premisses, hence the restriction
   that ps \<noteq> [] *)
inductive_set "upRules" where
   L[intro]: "\<lbrakk> c \<equiv> (\<LM> Compound R Fs \<RM> \<Rightarrow>* Em) ; ps \<noteq> [] \<rbrakk> \<Longrightarrow> (ps,c) \<in> upRules"
|  R[intro]: "\<lbrakk> c \<equiv> (\<Empt> \<Rightarrow>* Compound F Fs) ; ps \<noteq> [] \<rbrakk> \<Longrightarrow> (ps,c) \<in> upRules"

inductive_set extRules :: "'a rule set \<Rightarrow> 'a rule set"  ("_*")
  for R :: "'a rule set"
  where
   I[intro]: "r \<in> R \<Longrightarrow> extendRule seq r \<in> R*"

(* A formulation of what it means to be a principal formula for a rule.  Note that we have to build up from
   single conclusion rules.   *)

inductive leftPrincipal :: "'a rule \<Rightarrow> 'a form \<Rightarrow> bool"
  where
  up[intro]: "C = (\<LM>Compound F Fs\<RM> \<Rightarrow>* Em)  \<Longrightarrow>
                   leftPrincipal (Ps,C) (Compound F Fs)"

inductive rightPrincipal :: "'a rule \<Rightarrow> 'a form \<Rightarrow> bool"
  where
  up[intro]: "C = (\<Empt> \<Rightarrow>* Compound F Fs) \<Longrightarrow> rightPrincipal (Ps,C) (Compound F Fs)"

(* What it means to be a derivable sequent.  Can have this as a predicate or as a set.
   The two formation rules say that the supplied premisses are derivable, and the second says
   that if all the premisses of some rule are derivable, then so is the conclusion.  *)

inductive_set derivable :: "'a rule set \<Rightarrow> 'a deriv set"
  for R :: "'a rule set"
  where
   base[intro]: "\<lbrakk>([],C) \<in> R\<rbrakk> \<Longrightarrow> (C,0) \<in> derivable R"
|  step[intro]: "\<lbrakk> r \<in> R ; (fst r)\<noteq>[] ; \<forall> p \<in> set (fst r). \<exists> n \<le> m. (p,n) \<in> derivable R \<rbrakk>
                       \<Longrightarrow> (snd r,m + 1) \<in> derivable R"

(* When we don't care about height! *)
inductive_set derivable' :: "'a rule set \<Rightarrow> 'a sequent set"
   for R :: "'a rule set"
   where
    base[intro]: "\<lbrakk> ([],C) \<in> R \<rbrakk> \<Longrightarrow> C \<in> derivable' R"
|   step[intro]: "\<lbrakk> r \<in> R ; (fst r) \<noteq> [] ; \<forall> p \<in> set (fst r). p \<in> derivable' R \<rbrakk>
                       \<Longrightarrow> (snd r) \<in> derivable' R"

lemma deriv_to_deriv[simp]:
assumes "(C,n) \<in> derivable R"
shows "C \<in> derivable' R"
using assms by (induct) auto

lemma deriv_to_deriv2:
assumes "C \<in> derivable' R"
shows "\<exists> n. (C,n) \<in> derivable R"
using assms
proof (induct)
  case (base C)
  then have "(C,0) \<in> derivable R" by auto
  then show ?case by blast
next
  case (step r)
  then obtain ps c where "r = (ps,c)" and "ps \<noteq> []" by (cases r) auto
  then have aa: "\<forall> p \<in> set ps. \<exists> n. (p,n) \<in> derivable R" using step(3) by auto
  then have "\<exists> m. \<forall> p \<in> set ps. \<exists> n\<le>m. (p,n) \<in> derivable R"
  proof (induct ps)
    case Nil
    then show ?case  by auto
  next
    case (Cons a as)
    then have "\<exists> m. \<forall> p \<in> set as. \<exists> n\<le>m. (p,n) \<in> derivable R" by auto
    then obtain m where "\<forall> p \<in> set as. \<exists> n\<le>m. (p,n) \<in> derivable R" by auto
    moreover from \<open>\<forall> p \<in> set (a # as). \<exists> n. (p,n) \<in> derivable R\<close> have
      "\<exists> n. (a,n) \<in> derivable R" by auto
    then obtain m' where "(a,m') \<in> derivable R" by blast
    ultimately have "\<forall> p \<in> set (a # as). \<exists> n\<le>(max m m'). (p,n) \<in> derivable R" apply (auto simp add:Ball_def)
      apply (rule_tac x=m' in exI) apply simp
      apply (drule_tac x=x in spec) apply auto by (rule_tac x=n in exI) auto
    then show ?case by blast
  qed
  then obtain m where "\<forall> p \<in> set ps. \<exists> n\<le>m. (p,n) \<in> derivable R" by blast
  with \<open>r = (ps,c)\<close> and \<open>r \<in> R\<close> have "(c,m+1) \<in> derivable R" using \<open>ps \<noteq> []\<close> and
    derivable.step[where r="(ps,c)" and R=R and m=m] by auto
  then show ?case using \<open>r = (ps,c)\<close> by auto
qed

(* definition of invertible rule and invertible set of rules.  It's a bit nasty, but all it really says is
   If a rule is in the given set, and if any extension of that rule is derivable at n, then the
   premisses of the extended rule are derivable at height at most n.  *)
overloading
  invertible \<equiv> invertible
  invertible_set \<equiv> invertible_set
begin

definition invertible
  where "invertible r R \<equiv>
    \<forall> n S. (r \<in> R \<and> (snd (extendRule S r),n) \<in> derivable R*) \<longrightarrow>
    (\<forall> p \<in> set (fst (extendRule S r)). \<exists> m \<le> n. (p,m) \<in> derivable R*)"

definition invertible_set
  where "invertible_set R \<equiv> \<forall> (ps,c) \<in> R. invertible (ps,c) R"

end

(* Characterisation of a sequent *)
lemma characteriseSeq:
shows "\<exists> A B. (C :: 'a sequent) = (A \<Rightarrow>* B)"
apply (rule_tac x="antec C" in exI, rule_tac x="succ C" in exI) by (cases C) (auto)

(* Helper function for later *)
lemma nonEmptySet:
shows "A \<noteq> [] \<longrightarrow> (\<exists> a. a \<in> set A)"
by (auto simp add:neq_Nil_conv)

(* Lemma which comes in helpful ALL THE TIME *)
lemma midMultiset:
  assumes "\<Gamma> \<oplus> A = \<Gamma>' \<oplus> B" and "A \<noteq> B"
  shows "\<exists> \<Gamma>''. \<Gamma> = \<Gamma>'' \<oplus> B \<and> \<Gamma>' = \<Gamma>'' \<oplus> A"
proof-
  from assms have "A \<in># \<Gamma>'"
      proof-
      from assms have "set_mset (\<Gamma> \<oplus> A) = set_mset (\<Gamma>' \<oplus> B)" by auto
      then have "set_mset \<Gamma> \<union> {A} = set_mset \<Gamma>' \<union> {B}" by auto
      then have "set_mset \<Gamma> \<union> {A} \<subseteq> set_mset \<Gamma>' \<union> {B}" by simp
      then have "A \<in> set_mset \<Gamma>'" using assms by auto
      thus "A \<in># \<Gamma>'" by simp
      qed
  then have "\<Gamma>' \<ominus> A \<oplus> A = \<Gamma>'" by (auto simp add:multiset_eq_iff)
  then have "\<exists> \<Gamma>''. \<Gamma>' = \<Gamma>'' \<oplus> A" apply (rule_tac x="\<Gamma>' \<ominus> A" in exI) by auto
  then obtain \<Gamma>'' where eq1:"\<Gamma>' = \<Gamma>'' \<oplus> A" by blast
  from \<open>\<Gamma> \<oplus> A = \<Gamma>' \<oplus> B\<close> eq1 have "\<Gamma> \<oplus> A = \<Gamma>'' \<oplus> A \<oplus> B" by auto
  then have "\<Gamma> = \<Gamma>'' \<oplus> B" by auto
  thus ?thesis using eq1 by blast
qed

(* Lemma which says that if we have extended an identity rule, then the propositional variable is
   contained in the extended multisets *)
lemma extendID:
assumes "extend S (\<LM> At i \<RM> \<Rightarrow>* At i) = (\<Gamma> \<Rightarrow>* \<Delta>)"
shows "At i \<in># \<Gamma>"
using assms
proof-
  from assms have "\<exists> \<Gamma>'. \<Gamma> = \<Gamma>' \<oplus> At i"
     using extend_def[where forms=S and seq="\<LM> At i \<RM> \<Rightarrow>* At i"]
     by (rule_tac x="antec S" in exI) auto
  then show ?thesis by auto
qed

lemma extendFalsum:
assumes "extend S (\<LM> ff \<RM> \<Rightarrow>* Em) = (\<Gamma> \<Rightarrow>* \<Delta>)"
shows "ff \<in># \<Gamma>"
proof-
  from assms have "\<exists> \<Gamma>'. \<Gamma> = \<Gamma>' \<oplus> ff"
     using extend_def[where forms=S and seq="\<LM>ff \<RM> \<Rightarrow>* Em"]
     by (rule_tac x="antec S" in exI) auto
  then show ?thesis by auto
qed

(* Lemma that says if a propositional variable is in both the antecedent and succedent of a sequent,
   then it is derivable from idupRules *)
lemma containID:
assumes a:"At i \<in># \<Gamma>"
    and b:"Ax \<subseteq> R"
shows "(\<Gamma> \<Rightarrow>* At i,0) \<in> derivable R*"
proof-
from a have "\<Gamma> = \<Gamma> \<ominus> At i \<oplus> At i" by auto
then have "extend ((\<Gamma> \<ominus> At i) \<Rightarrow>* Em) (\<LM> At i \<RM> \<Rightarrow>* At i) = (\<Gamma> \<Rightarrow>* At i)"
     using extend_def[where forms="\<Gamma> \<ominus> At i \<Rightarrow>* Em" and seq="\<LM>At i\<RM> \<Rightarrow>* At i"] by auto
moreover
have "([],\<LM> At i \<RM> \<Rightarrow>* At i) \<in> R" using b by auto
ultimately
have "([],\<Gamma> \<Rightarrow>* At i) \<in> R*"
     using extRules.I[where R=R and r="([],  \<LM>At i\<RM> \<Rightarrow>* At i)" and seq="\<Gamma> \<ominus> At i \<Rightarrow>* Em"]
       and extendRule_def[where forms="\<Gamma> \<ominus> At i \<Rightarrow>* Em" and R="([],  \<LM>At i\<RM> \<Rightarrow>* At i)"] by auto
then show ?thesis using derivable.base[where R="R*" and C="\<Gamma> \<Rightarrow>* At i"] by auto
qed

lemma containFalsum:
assumes a: "ff \<in># \<Gamma>"
   and  b: "Ax \<subseteq> R"
shows "(\<Gamma> \<Rightarrow>* C,0) \<in> derivable R*"
proof-
from a have "\<Gamma> = \<Gamma> \<ominus> ff \<oplus> ff" by auto
then have "extend (\<Gamma> \<ominus> ff \<Rightarrow>* C) (\<LM>ff\<RM> \<Rightarrow>* Em) = (\<Gamma> \<Rightarrow>* C)"
     using extend_def[where forms="\<Gamma> \<ominus> ff \<Rightarrow>* C" and seq="\<LM>ff\<RM> \<Rightarrow>* Em"] by auto
moreover
have "([],\<LM>ff\<RM> \<Rightarrow>* Em) \<in> R" using b by auto
ultimately have "([],\<Gamma> \<Rightarrow>* C) \<in> R*"
     using extRules.I[where R=R and r="([],  \<LM>ff\<RM> \<Rightarrow>* Em)" and seq="\<Gamma> \<ominus> ff \<Rightarrow>* C"]
       and extendRule_def[where forms="\<Gamma> \<ominus> ff \<Rightarrow>* C" and R="([],  \<LM>ff\<RM> \<Rightarrow>* Em)"] by auto
then show ?thesis using derivable.base[where R="R*" and C="\<Gamma> \<Rightarrow>* C"] by auto
qed

(* Lemma which says that if r is an identity rule, then r is of the form
   ([], P \<Rightarrow>* P) *)
lemma characteriseAx:
shows "r \<in> Ax \<Longrightarrow> r = ([],\<LM> ff \<RM> \<Rightarrow>* Em) \<or> (\<exists> i. r = ([], \<LM> At i \<RM> \<Rightarrow>* At i))"
apply (cases r) by (rule Ax.cases) auto

(* A lemma about the last rule used in a derivation, i.e. that one exists *)
lemma characteriseLast:
assumes "(C,m+1) \<in> derivable R"
shows "\<exists> Ps. Ps \<noteq> [] \<and>
             (Ps,C) \<in> R \<and>
             (\<forall> p \<in> set Ps. \<exists> n\<le>m. (p,n) \<in> derivable R)"
using assms
by (cases) auto

lemma upRuleCharacterise:
assumes "(Ps,C) \<in> upRules"
shows "\<exists> F Fs. C = (\<Empt> \<Rightarrow>* Compound F Fs) \<or> C = (\<LM>Compound F Fs\<RM> \<Rightarrow>* Em)"
using assms by (cases) auto

lemma extendEmpty:
shows "extend (\<Empt> \<Rightarrow>* Em) C = C"
apply (auto simp add:extend_def) apply (cases C) apply auto by (cases C) auto

lemma extendContain:
assumes "r = (ps,c)"
    and "(Ps,C) = extendRule S r"
    and "p \<in> set ps"
shows "extend S p \<in> set Ps"
proof-
from \<open>p \<in> set ps\<close> have "extend S p \<in> set (map (extend S) ps)" by auto
moreover from \<open>(Ps,C) = extendRule S r\<close> and \<open>r = (ps,c)\<close> have "map (extend S) ps = Ps" by (simp add:extendRule_def)
ultimately show ?thesis by auto
qed

lemma nonPrincipalID:
fixes A :: "'a form"
assumes "r \<in> Ax"
shows "\<not> rightPrincipal r A \<and> \<not> leftPrincipal r A"
proof-
from assms obtain i where r1:"r = ([], \<LM> ff \<RM> \<Rightarrow>* Em) \<or> r = ([], \<LM> At i \<RM> \<Rightarrow>* At i)"
     using characteriseAx[where r=r] by auto
{ assume "rightPrincipal r A" then obtain Ps where r2:"r = (Ps, \<Empt> \<Rightarrow>* A)" by (cases r) auto
  with r1 have "False" by simp
}
then have "\<not> rightPrincipal r A" by auto
moreover
{ assume "leftPrincipal r A" then obtain Ps' F Fs where r3:"r = (Ps', \<LM>Compound F Fs\<RM> \<Rightarrow>* Em)" by (cases r) auto
  with r1 have "False" by auto
}
then have "\<not> leftPrincipal r A" by auto
ultimately show ?thesis by simp
qed

lemma extended_Ax_prems_empty:
assumes "r \<in> Ax"
shows "fst (extendRule S r) = []"
using assms apply (cases r) by (rule Ax.cases) (auto simp add:extendRule_def)

(* ---------------------------------------------------
   ---------------------------------------------------
   ---------------------------------------------------
   ---------------------------------------------------
                THIS IS NOW
                SingleWeakening.thy
   ---------------------------------------------------
   ---------------------------------------------------
   ---------------------------------------------------
   --------------------------------------------------- *)

(* Constructing the rule set we will use.  It contains all axioms, but only a subset
   of the possible logical rules. *)
lemma ruleSet:
assumes "R' \<subseteq> upRules"
    and "R = Ax \<union> R'"
    and "(Ps,C) \<in> R*"
shows "\<exists> S r. extendRule S r = (Ps,C) \<and> (r \<in> R' \<or> r \<in> Ax)"
proof-
from \<open>(Ps,C) \<in> R*\<close> have "\<exists> S r. extendRule S r = (Ps,C) \<and> r \<in> R" by (cases) auto
then obtain S r where "(Ps,C) = extendRule S r" and "r \<in> R" apply auto
                by (drule_tac x=S in meta_spec,drule_tac x=a in meta_spec, drule_tac x=b in meta_spec) auto
moreover from \<open>r \<in> R\<close> and \<open>R = Ax \<union> R'\<close> have "r \<in> Ax \<or> r \<in> R'" by blast
ultimately show ?thesis by (rule_tac x=S in exI,rule_tac x=r in exI) (auto)
qed

lemma dpWeak:
assumes a:"(\<Gamma> \<Rightarrow>* E,n) \<in> derivable R*"
   and  b: "R' \<subseteq> upRules"
   and  c: "R = Ax \<union> R'"
shows "(\<Gamma> + \<Gamma>' \<Rightarrow>* E,n) \<in> derivable R*"
using a
proof (induct n arbitrary: \<Gamma> E rule:nat_less_induct)
case (1 n \<Gamma> E)
then have IH: "\<forall>m<n. \<forall> \<Gamma> E. ( \<Gamma> \<Rightarrow>* E, m) \<in> derivable R* \<longrightarrow> ( \<Gamma> + \<Gamma>' \<Rightarrow>* E, m) \<in> derivable R*"
      and a': "( \<Gamma> \<Rightarrow>* E, n) \<in> derivable R*" by auto
show ?case
proof (cases n)
case 0
 then have "(\<Gamma> \<Rightarrow>* E,0) \<in> derivable R*" using a' by simp
 then have "([], \<Gamma> \<Rightarrow>* E) \<in> R*" by (cases) auto
 then obtain  r S where "r \<in> R" and split:"extendRule S r = ([],\<Gamma> \<Rightarrow>* E)"
      by (rule extRules.cases) auto
 then obtain c where "r = ([],c)" by (cases r) (auto simp add:extendRule_def)
 with \<open>r \<in> R\<close> have "r \<in> Ax \<or> r \<in> upRules" using b c by auto
 with \<open>r = ([],c)\<close> have "r \<in> Ax" by (auto) (rule upRules.cases,auto)
 with \<open>r = ([],c)\<close> obtain i where "c = (\<LM>At i\<RM> \<Rightarrow>* At i) \<or> c = (\<LM>ff\<RM> \<Rightarrow>* Em)"
      using characteriseAx[where r=r] by auto
 moreover
    {assume "c = (\<LM>At i\<RM> \<Rightarrow>* At i)"
     then have "extend S (\<LM>At i\<RM> \<Rightarrow>* At i) = (\<Gamma> \<Rightarrow>* At i)" and "At i = E" using split and \<open>r = ([],c)\<close>
          by (auto simp add:extendRule_def extend_def)
     then have "At i \<in># \<Gamma>" using extendID by auto
     then have "At i \<in># \<Gamma> + \<Gamma>'" by auto
     then have "(\<Gamma> + \<Gamma>' \<Rightarrow>* E,0) \<in> derivable R*"
          using c and containID[where \<Gamma>="\<Gamma>+\<Gamma>'" and R=R and i=i] and \<open>At i = E\<close> by auto
    }
 moreover
    {assume "c = (\<LM>ff\<RM> \<Rightarrow>* Em)"
     then have "extend S (\<LM>ff\<RM> \<Rightarrow>* Em) = (\<Gamma> \<Rightarrow>* E)" using split and \<open>r = ([],c)\<close>
          by (auto simp add:extendRule_def extend_def)
     then have "ff \<in># \<Gamma>" using extendFalsum by auto
     then have "ff \<in># \<Gamma> + \<Gamma>'" by auto
     then have "(\<Gamma> + \<Gamma>' \<Rightarrow>* E,0) \<in> derivable R*"
          using c and containFalsum[where \<Gamma>="\<Gamma>+\<Gamma>'" and R=R] by auto
    }
 ultimately show "(\<Gamma> + \<Gamma>' \<Rightarrow>* E,n) \<in> derivable R*" using \<open>n=0\<close> by auto
next
case (Suc n')
 then have "(\<Gamma> \<Rightarrow>* E, n'+1) \<in> derivable R*" using a' by simp
 then obtain Ps where f:"Ps \<noteq> []"
                  and g:"(Ps, \<Gamma> \<Rightarrow>* E) \<in> R*"
                  and h:"\<forall> p \<in> set Ps. \<exists> m\<le>n'. (p,m) \<in> derivable R*"
      using characteriseLast[where C="\<Gamma> \<Rightarrow>* E" and m=n' and R="R*"] by auto
 from g c obtain S r where "r \<in> R" and "(r \<in> Ax \<or> r \<in> R') \<and> extendRule S r = (Ps, \<Gamma> \<Rightarrow>* E)" by (cases) auto
 with b have as: "(r \<in> Ax \<or> r \<in> upRules) \<and> extendRule S r = (Ps, \<Gamma> \<Rightarrow>* E)" by auto
 from as f have "fst r \<noteq> []" by (auto simp add:extendRule_def map_is_Nil_conv)
 with as have "r \<in> upRules" apply (cases r,auto) by (rule Ax.cases) auto
 moreover obtain ps c where "r = (ps,c)" by (cases r) auto
 ultimately have "(ps,c) \<in> upRules" by simp
 obtain \<Gamma>1 \<delta> where "S = (\<Gamma>1 \<Rightarrow>* \<delta>)" by (cases S) auto
 with h as \<open>r = (ps,c)\<close> have pms: "\<forall> p \<in> set ps. \<exists> m\<le>n'. (extend (\<Gamma>1 \<Rightarrow>* \<delta>) p,m) \<in> derivable R*"
      by(auto simp add:extendRule_def)
 have "\<forall> p \<in> set ps. \<exists> m\<le>n'. (extend (\<Gamma>1 + \<Gamma>' \<Rightarrow>* \<delta>) p,m) \<in> derivable R*"
      proof-
      {fix p
       assume "p \<in> set ps"
       with pms obtain m where "m\<le>n'" and aa: "(extend (\<Gamma>1 \<Rightarrow>* \<delta>) p,m) \<in> derivable R*" by auto
       moreover obtain \<Gamma>2 \<delta>' where eq:"p = (\<Gamma>2 \<Rightarrow>* \<delta>')" by (cases p) auto
       have "\<delta>' = Em \<or> \<delta>' \<noteq> Em" by blast
       moreover
          {assume "\<delta>' = Em"
           then have "extend (\<Gamma>1 \<Rightarrow>* \<delta>) p = (\<Gamma>1 + \<Gamma>2 \<Rightarrow>* \<delta>)" using eq by (auto simp add:extend_def)
           then have "(\<Gamma>1 + \<Gamma>2 \<Rightarrow>* \<delta>,m) \<in> derivable R*" using aa by auto
           then have "(\<Gamma>1 + \<Gamma>2 + \<Gamma>' \<Rightarrow>* \<delta>, m) \<in> derivable R*" using IH and \<open>n = Suc n'\<close> and \<open>m\<le>n'\<close>
                apply- apply (drule_tac x=m in spec) by auto
           then have "(extend (\<Gamma>1 + \<Gamma>' \<Rightarrow>* \<delta>) p,m) \<in> derivable R*" using eq and \<open>\<delta>' = Em\<close>
                by (auto simp add:extend_def union_ac)
          }
       moreover
          {assume "\<delta>' \<noteq> Em"
           then have "extend (\<Gamma>1 \<Rightarrow>* \<delta>) p = (\<Gamma>1 + \<Gamma>2 \<Rightarrow>* \<delta>')" using eq by (auto simp add:extend_def)
           then have "(\<Gamma>1 + \<Gamma>2 \<Rightarrow>* \<delta>',m) \<in> derivable R*" using aa by auto
           then have "(\<Gamma>1 + \<Gamma>2 + \<Gamma>' \<Rightarrow>* \<delta>', m) \<in> derivable R*" using IH and \<open>n = Suc n'\<close> and \<open>m\<le>n'\<close>
                apply- apply (drule_tac x=m in spec) by auto
           then have "(extend (\<Gamma>1 + \<Gamma>' \<Rightarrow>* \<delta>) p,m) \<in> derivable R*" using eq and \<open>\<delta>' \<noteq> Em\<close>
                by (auto simp add:extend_def union_ac)
          }
       ultimately have "(extend (\<Gamma>1 + \<Gamma>' \<Rightarrow>* \<delta>) p,m) \<in> derivable R*" by blast
       then have "\<exists> m\<le>n'. (extend (\<Gamma>1 + \<Gamma>' \<Rightarrow>* \<delta>) p,m) \<in> derivable R*" using \<open>m\<le>n'\<close> by auto
       }
       then show ?thesis by auto
       qed
 then have "\<forall> p \<in> set (fst (extendRule (\<Gamma>1 + \<Gamma>' \<Rightarrow>* \<delta>) r)).
            \<exists> m\<le>n'. (p,m) \<in> derivable R*" using \<open>r = (ps,c)\<close> by (auto simp add:extendRule_def)
 moreover have "extendRule (\<Gamma>1 + \<Gamma>' \<Rightarrow>* \<delta>) r \<in> R*"
          using \<open>r \<in> upRules\<close> and \<open>r \<in> R\<close> by auto
 moreover from \<open>S = (\<Gamma>1 \<Rightarrow>* \<delta>)\<close> and as have "extend (\<Gamma>1 + \<Gamma>' \<Rightarrow>* \<delta>) (snd r) = (\<Gamma> + \<Gamma>' \<Rightarrow>* E)"
          by (auto simp add:extendRule_def extend_def union_ac)
 ultimately have "(\<Gamma> + \<Gamma>' \<Rightarrow>* E,n'+1) \<in> derivable R*"
          using derivable.step[where r="extendRule (\<Gamma>1 + \<Gamma>' \<Rightarrow>* \<delta>) r" and R="R*" and m="n'"]
          and \<open>fst r \<noteq> []\<close> by (cases r) (auto simp add:map_is_Nil_conv extendRule_def)
 then show "( \<Gamma> + \<Gamma>' \<Rightarrow>* E, n) \<in> derivable R*" using \<open>n = Suc n'\<close> by auto
 qed
qed

(*>*)
text\<open>
\noindent Given this, it is possible to have right weakening, where we overwrite the empty formula if it appears as the succedent of the root of a derivation:
\<close>
lemma dpWeakR:
assumes (*<*)a:(*>*)"(\<Gamma> \<Rightarrow>* Em,n) \<in> derivable R*"
and  (*<*)b:(*>*) "R' \<subseteq> upRules"
and  (*<*)c:(*>*) "R = Ax \<union> R'"
shows "(\<Gamma> \<Rightarrow>* C,n) \<in> derivable R*"   \<comment> \<open>Proof omitted\<close>
(*<*)
using a
proof (induct n arbitrary: \<Gamma> rule:nat_less_induct)
case (1 n \<Gamma>)
then have IH: "\<forall>m<n. \<forall> \<Gamma>. ( \<Gamma> \<Rightarrow>* Em, m) \<in> derivable R* \<longrightarrow> ( \<Gamma> \<Rightarrow>* C, m) \<in> derivable R*"
      and a': "( \<Gamma> \<Rightarrow>* Em, n) \<in> derivable R*" by auto
show ?case
proof (cases n)
case 0
 then have "(\<Gamma> \<Rightarrow>* Em,0) \<in> derivable R*" using a' by simp
 then have "([], \<Gamma> \<Rightarrow>* Em) \<in> R*" by (cases) auto
 then obtain  r S where "r \<in> R" and split:"extendRule S r = ([],\<Gamma> \<Rightarrow>* Em)"
      by (rule extRules.cases) auto
 then obtain c where "r = ([],c)" by (cases r) (auto simp add:extendRule_def)
 with \<open>r \<in> R\<close> have "r \<in> Ax \<or> r \<in> upRules" using b c by auto
 with \<open>r = ([],c)\<close> have "r \<in> Ax" by (auto) (rule upRules.cases,auto)
 with \<open>r = ([],c)\<close> obtain i where "c = (\<LM>At i\<RM> \<Rightarrow>* At i) \<or> c = (\<LM>ff\<RM> \<Rightarrow>* Em)"
      using characteriseAx[where r=r] by auto
 moreover
    {assume "c = (\<LM>At i\<RM> \<Rightarrow>* At i)"
     with split and \<open>r = ([],c)\<close> have "(\<Gamma> \<Rightarrow>* C,0) \<in> derivable R*" by (auto simp add:extendRule_def extend_def)
    }
 moreover
    {assume "c = (\<LM>ff\<RM> \<Rightarrow>* Em)"
     then have "extend S (\<LM>ff\<RM> \<Rightarrow>* Em) = (\<Gamma> \<Rightarrow>* Em)" using split and \<open>r = ([],c)\<close>
          by (auto simp add:extendRule_def extend_def)
     then have "ff \<in># \<Gamma>" using extendFalsum by auto
     then have "(\<Gamma> \<Rightarrow>* C,0) \<in> derivable R*"
          using c and containFalsum[where \<Gamma>=\<Gamma> and R=R] by auto
    }
 ultimately show "(\<Gamma> \<Rightarrow>* C,n) \<in> derivable R*" using \<open>n=0\<close> by auto
next
case (Suc n')
 then have "(\<Gamma> \<Rightarrow>* Em, n'+1) \<in> derivable R*" using a' by simp
 then obtain Ps where f:"Ps \<noteq> []"
                  and g:"(Ps, \<Gamma> \<Rightarrow>* Em) \<in> R*"
                  and h:"\<forall> p \<in> set Ps. \<exists> m\<le>n'. (p,m) \<in> derivable R*"
      using characteriseLast[where C="\<Gamma> \<Rightarrow>* Em" and m=n' and R="R*"] by auto
 from g c obtain S r where "r \<in> R" and split: "(r \<in> Ax \<or> r \<in> R') \<and> extendRule S r = (Ps, \<Gamma> \<Rightarrow>* Em)" by (cases) auto
 with b have as: "(r \<in> Ax \<or> r \<in> upRules) \<and> extendRule S r = (Ps, \<Gamma> \<Rightarrow>* Em)" by auto
 from as f have "fst r \<noteq> []" by (auto simp add:extendRule_def map_is_Nil_conv)
 with as have "r \<in> upRules" apply (cases r,auto) by (rule Ax.cases) auto
 moreover obtain ps c where "r = (ps,c)" by (cases r) auto
 ultimately have "(ps,c) \<in> upRules" by simp
 then obtain F Fs where "c = (\<LM>Compound F Fs\<RM> \<Rightarrow>* Em) \<or> c = (\<Empt> \<Rightarrow>* Compound F Fs)" by (rule upRules.cases) auto
 moreover
    {assume "c = (\<Empt> \<Rightarrow>* Compound F Fs)"
     with \<open>r = (ps,c)\<close> and split have "(\<Gamma> \<Rightarrow>* C,n'+1) \<in> derivable R*" by (auto simp add:extendRule_def extend_def)
    }
 moreover
    {assume "c = (\<LM> Compound F Fs \<RM> \<Rightarrow>* Em)"
     moreover obtain \<Gamma>1 \<delta> where "S = (\<Gamma>1 \<Rightarrow>* \<delta>)" by (cases S) auto
     ultimately have "\<delta> = Em" using split and \<open>r= (ps,c)\<close> by (auto simp add:extendRule_def extend_def)
     then have "S = (\<Gamma>1 \<Rightarrow>* Em)" using \<open>S = (\<Gamma>1 \<Rightarrow>* \<delta>)\<close> by simp
     with h as \<open>r = (ps,c)\<close> have pms: "\<forall> p \<in> set ps. \<exists> m\<le>n'. (extend (\<Gamma>1 \<Rightarrow>* Em) p,m) \<in> derivable R*"
          by(auto simp add:extendRule_def)
     have "\<forall> p \<in> set ps. \<exists> m\<le>n'. (extend (\<Gamma>1  \<Rightarrow>* C) p,m) \<in> derivable R*"
          proof-
          {fix p
           assume "p \<in> set ps"
           with pms obtain m where "m\<le>n'" and aa: "(extend (\<Gamma>1 \<Rightarrow>* Em) p,m) \<in> derivable R*" by auto
           moreover obtain \<Gamma>2 \<delta>' where eq:"p = (\<Gamma>2 \<Rightarrow>* \<delta>')" by (cases p) auto
           have "\<delta>' = Em \<or> \<delta>' \<noteq> Em" by blast
           moreover
              {assume "\<delta>' = Em"
               then have "extend (\<Gamma>1 \<Rightarrow>* Em) p = (\<Gamma>1 + \<Gamma>2 \<Rightarrow>* Em)" using eq by (auto simp add:extend_def)
               then have "(\<Gamma>1 + \<Gamma>2 \<Rightarrow>* Em,m) \<in> derivable R*" using aa by auto
               then have "(\<Gamma>1 + \<Gamma>2 \<Rightarrow>* C, m) \<in> derivable R*" using IH and \<open>n = Suc n'\<close> and \<open>m\<le>n'\<close>
                    apply- apply (drule_tac x=m in spec) by auto
               then have "(extend (\<Gamma>1  \<Rightarrow>* C) p,m) \<in> derivable R*" using eq and \<open>\<delta>' = Em\<close>
                    by (auto simp add:extend_def union_ac)
              }
           moreover
              {assume "\<delta>' \<noteq> Em"
               then have "extend (\<Gamma>1 \<Rightarrow>* Em) p = (\<Gamma>1 + \<Gamma>2 \<Rightarrow>* \<delta>')" using eq by (auto simp add:extend_def)
               then have "(\<Gamma>1 + \<Gamma>2 \<Rightarrow>* \<delta>',m) \<in> derivable R*" using aa by auto
               moreover have "extend (\<Gamma>1 \<Rightarrow>* C) p = (\<Gamma>1 + \<Gamma>2 \<Rightarrow>* \<delta>')" using eq and \<open>\<delta>' \<noteq> Em\<close> by (auto simp add:extend_def)
               ultimately have "(extend (\<Gamma>1 \<Rightarrow>* C) p,m) \<in> derivable R*" by simp
              }
           ultimately have "(extend (\<Gamma>1  \<Rightarrow>* C) p,m) \<in> derivable R*" by blast
           then have "\<exists> m\<le>n'. (extend (\<Gamma>1  \<Rightarrow>* C) p,m) \<in> derivable R*" using \<open>m\<le>n'\<close> by auto
           }
           then show ?thesis by auto
           qed
     then have "\<forall> p \<in> set (fst (extendRule (\<Gamma>1  \<Rightarrow>* C) r)).
                \<exists> m\<le>n'. (p,m) \<in> derivable R*" using \<open>r = (ps,c)\<close> by (auto simp add:extendRule_def)
     moreover have "extendRule (\<Gamma>1  \<Rightarrow>* C) r \<in> R*"
              using \<open>r \<in> upRules\<close> and \<open>r \<in> R\<close> by auto
     moreover from \<open>S = (\<Gamma>1 \<Rightarrow>* Em)\<close> and as have "extend (\<Gamma>1  \<Rightarrow>* C) (snd r) = (\<Gamma> \<Rightarrow>* C)"
              by (auto simp add:extendRule_def extend_def union_ac)
     ultimately have "(\<Gamma> \<Rightarrow>* C,n'+1) \<in> derivable R*"
              using derivable.step[where r="extendRule (\<Gamma>1 \<Rightarrow>* C) r" and R="R*" and m="n'"]
              and \<open>fst r \<noteq> []\<close> by (cases r) (auto simp add:map_is_Nil_conv extendRule_def)
    }
 ultimately show "( \<Gamma> \<Rightarrow>* C, n) \<in> derivable R*" using \<open>n = Suc n'\<close> by auto
 qed
qed

(* ---------------------------------------------------
   ---------------------------------------------------
   ---------------------------------------------------
   ---------------------------------------------------
                THIS IS NOW
                SingleInvertible.thy
   ---------------------------------------------------
   ---------------------------------------------------
   ---------------------------------------------------
   --------------------------------------------------- *)
(*>*)
text\<open>
\noindent Of course, if $C = Em$, then the above lemma is trivial.  The burden is on the user not to ``use'' the empty formula as a normal formula.  An invertibility lemma can then be formalised:
\<close>

lemma rightInvertible:
(*<*)fixes \<Gamma> :: "'a form multiset"(*>*)

assumes (*<*)rules:(*>*) "R' \<subseteq> upRules \<and> R = Ax \<union> R'"
and   (*<*)a:(*>*) "(\<Gamma> \<Rightarrow>* Compound F Fs,n) \<in> derivable R*"
and   (*<*)b:(*>*) "\<forall> r' \<in> R. rightPrincipal r' (Compound F Fs) \<longrightarrow> (\<Gamma>' \<Rightarrow>* E) \<in> set (fst r')"
and (*<*)nonEm:(*>*) "E \<noteq> Em"
shows "\<exists> m\<le>n. (\<Gamma> +\<Gamma>' \<Rightarrow>* E,m) \<in> derivable R*"

(*<*)
using assms
proof (induct n arbitrary:\<Gamma> rule:nat_less_induct)
 case (1 n \<Gamma>)
 then have IH:"\<forall>m<n. \<forall>\<Gamma>. ( \<Gamma> \<Rightarrow>* Compound F Fs, m) \<in> derivable R* \<longrightarrow>
              (\<forall>r' \<in> R. rightPrincipal r' (Compound F Fs) \<longrightarrow> ( \<Gamma>' \<Rightarrow>* E) \<in> set (fst r')) \<longrightarrow>
              (\<exists>m'\<le>m. ( \<Gamma> + \<Gamma>' \<Rightarrow>* E, m') \<in> derivable R*)"
     and a': "(\<Gamma> \<Rightarrow>* Compound F Fs,n) \<in> derivable R*"
     and b': "\<forall> r' \<in> R. rightPrincipal r' (Compound F Fs) \<longrightarrow> (\<Gamma>' \<Rightarrow>* E) \<in> set (fst r')"
       by auto
 show ?case
 proof (cases n)
     case 0
     then have "(\<Gamma> \<Rightarrow>* Compound F Fs,0) \<in> derivable R*" using a' by simp
     then have "([],\<Gamma> \<Rightarrow>* Compound F Fs) \<in> R*" by (cases) (auto)
     then have "\<exists> r S. extendRule S r = ([],\<Gamma> \<Rightarrow>* Compound F Fs) \<and> (r \<in> Ax \<or> r \<in> R')"
          using rules and ruleSet[where R'=R' and R=R and Ps="[]" and C="\<Gamma> \<Rightarrow>* Compound F Fs"] by auto
     then obtain r S where "extendRule S r = ([],\<Gamma> \<Rightarrow>* Compound F Fs)" and "r \<in> Ax \<or> r \<in> R'" by auto
      moreover
      {assume "r \<in> Ax"
       then have "r = ([], \<LM> ff \<RM> \<Rightarrow>* Em)"
            using characteriseAx[where r=r] and \<open>extendRule S r = ([],\<Gamma> \<Rightarrow>* Compound F Fs)\<close>
            by (auto simp add:extendRule_def extend_def)
       with \<open>extendRule S r = ([],\<Gamma> \<Rightarrow>* Compound F Fs)\<close>
            have "extend S (\<LM> ff \<RM> \<Rightarrow>* Em) = (\<Gamma> \<Rightarrow>* Compound F Fs)"
            using extendRule_def[where R="([],\<LM>ff\<RM>\<Rightarrow>* Em)" and forms=S] by auto
       then have "ff \<in># \<Gamma>" using extendFalsum[where S=S and \<Gamma>=\<Gamma> and \<Delta>="Compound F Fs"] by auto
       then have "ff \<in># \<Gamma> + \<Gamma>'" by auto
       then have "(\<Gamma> + \<Gamma>' \<Rightarrow>* E,0) \<in> derivable R*" using rules
            and containFalsum[where \<Gamma>="\<Gamma> + \<Gamma>'" and R=R] by auto
       then have "(\<Gamma> + \<Gamma>' \<Rightarrow>* E,0) \<in> derivable R*" by blast
      }
      moreover
      {assume "r \<in> R'"
       then have "r \<in> upRules" using rules by auto
       then have "\<exists> Ps C. Ps \<noteq> [] \<and> r = (Ps,C)"
            proof-
            obtain x y where "r = (x,y)" by (cases r)
            with \<open>r \<in> upRules\<close> have "(x,y) \<in> upRules" by simp
            then obtain Ps where "(Ps :: 'a sequent list) \<noteq> []" and "x=Ps" by (cases) (auto)
            with \<open>r = (x,y)\<close> have "r = (Ps, y)" by simp
            then show "\<exists> Ps C. Ps \<noteq> [] \<and> r = (Ps,C)" using \<open>Ps \<noteq> []\<close> by blast
            qed
       then obtain Ps C where "Ps \<noteq> []" and "r = (Ps,C)" by auto
       moreover from \<open>extendRule S r = ([], \<Gamma> \<Rightarrow>* Compound F Fs)\<close> have "\<exists> S. r = ([],S)"
            using extendRule_def[where forms=S and R=r] by (cases r) (auto)
       then obtain S where "r = ([],S)" by blast
       ultimately have "(\<Gamma> + \<Gamma>' \<Rightarrow>* E,0) \<in> derivable R*" using rules by simp
       }
       ultimately show "\<exists> m\<le>n. (\<Gamma> + \<Gamma>' \<Rightarrow>* E,m) \<in> derivable R*" using \<open>n=0\<close> by blast
 next
     case (Suc n')
     then have "(\<Gamma> \<Rightarrow>* Compound F Fs,n'+1) \<in> derivable R*" using a' by simp
     then obtain Ps where "(Ps, \<Gamma> \<Rightarrow>* Compound F Fs) \<in> R*" and
                          "Ps \<noteq> []" and
                          derv: "\<forall> p \<in> set Ps. \<exists> n\<le>n'. (p,n) \<in> derivable R*"
          using characteriseLast[where C="\<Gamma> \<Rightarrow>* Compound F Fs" and m=n' and R="R*"] by auto
     then have "\<exists> r S. (r \<in> Ax \<or> r \<in> R') \<and> extendRule S r = (Ps, \<Gamma> \<Rightarrow>* Compound F Fs)"
          using rules and ruleSet[where R'=R' and R=R and Ps=Ps and C="\<Gamma> \<Rightarrow>* Compound F Fs"] by auto
     then obtain r S where "r \<in> Ax \<or> r \<in> R'" and ext: "extendRule S r = (Ps, \<Gamma> \<Rightarrow>* Compound F Fs)" by auto
     moreover
        {assume "r \<in> Ax"
         then have "fst r = []" apply (cases r) by (rule Ax.cases) auto
         moreover obtain x y where "r = (x,y)" by (cases r)
         then have "x \<noteq> []" using \<open>Ps \<noteq> []\<close> and ext
                            and extendRule_def[where forms=S and R=r]
                            and extend_def[where forms=S and seq="snd r"] by auto
         ultimately have "\<exists> m\<le>n. (\<Gamma> + \<Gamma>' \<Rightarrow>* E,m) \<in> derivable R*"
              using \<open>r=(x,y)\<close> by auto
        }
     moreover
        {assume "r \<in> R'"
         obtain ps c where "r = (ps,c)" by (cases r) auto
         then have "r \<in> upRules" using rules and \<open>r \<in> R'\<close> by auto
         then have "\<exists> T Ts. c = (\<LM>Compound T Ts\<RM> \<Rightarrow>* Em) \<or> c = (\<Empt> \<Rightarrow>* Compound T Ts)" using \<open>r=(ps,c)\<close>
              and upRuleCharacterise[where Ps=ps and C=c] by auto
         then obtain T Ts where "c = (\<LM>Compound T Ts\<RM> \<Rightarrow>* Em) \<or> c = (\<Empt> \<Rightarrow>* Compound T Ts)" by blast
         moreover
            {assume "c = (\<Empt> \<Rightarrow>* Compound T Ts)"
             with ext have "Compound T Ts = Compound F Fs"
                  using \<open>r = (ps,c)\<close> by (auto simp add:extendRule_def extend_def)
             then have "rightPrincipal r (Compound F Fs)" using \<open>c = (\<Empt> \<Rightarrow>* Compound T Ts)\<close> and \<open>r = (ps,c)\<close>
                  by auto
             then have "(\<Gamma>' \<Rightarrow>* E) \<in> set ps" using b' and \<open>r = (ps,c)\<close> and \<open>r \<in> R'\<close> and rules
                  by auto
             then have "extend S (\<Gamma>' \<Rightarrow>* E) \<in> set Ps" using \<open>extendRule S r = (Ps,\<Gamma> \<Rightarrow>* Compound F Fs)\<close>
                  and \<open>r = (ps,c)\<close> by (simp add:extendContain)
             moreover from \<open>rightPrincipal r (Compound F Fs)\<close> have "c = (\<Empt> \<Rightarrow>* Compound F Fs)"
                  using \<open>r = (ps,c)\<close> by (cases) auto
             with ext have "antec S = \<Gamma>"
                  using \<open>r = (ps,c)\<close> by (auto simp add:extendRule_def extend_def)
             ultimately have "(\<Gamma> + \<Gamma>' \<Rightarrow>* E) \<in> set Ps" using nonEm by (simp add:extend_def)
             then have "\<exists> m\<le>n'. (\<Gamma> + \<Gamma>' \<Rightarrow>* E,m) \<in> derivable R*"
                  using \<open>\<forall> p \<in> set Ps. \<exists> n\<le>n'. (p,n) \<in> derivable R*\<close> by auto
             then have "\<exists> m\<le>n. (\<Gamma> + \<Gamma>' \<Rightarrow>* E,m) \<in> derivable R*" using \<open>n = Suc n'\<close>
                  by (auto,rule_tac x=m in exI) (simp)
            }
         moreover
            {assume "c = (\<LM>Compound T Ts\<RM> \<Rightarrow>* Em)"
             with ext and \<open>r = (ps,c)\<close>
                  have "Compound T Ts \<in># \<Gamma>" by (auto simp add:extendRule_def extend_def)
             then have "\<exists> \<Gamma>1. \<Gamma> = \<Gamma>1 \<oplus> Compound T Ts"
                  by (rule_tac x="\<Gamma> \<ominus> Compound T Ts" in exI) (auto simp add:multiset_eq_iff)
             then obtain \<Gamma>1 where "\<Gamma> = \<Gamma>1 \<oplus> Compound T Ts" by auto
             moreover from \<open>c = (\<LM>Compound T Ts\<RM> \<Rightarrow>* Em)\<close> and \<open>r = (ps,c)\<close> and ext
                  have "succ S = Compound F Fs"
                  by (auto simp add:extendRule_def extend_def)
             ultimately have "S = (\<Gamma>1 \<Rightarrow>* Compound F Fs)" using ext
                  and \<open>r = (ps,c)\<close> and \<open>c = (\<LM>Compound T Ts\<RM> \<Rightarrow>* Em)\<close> apply (auto simp add:extendRule_def extend_def)
                  by (cases S) auto
             with derv have pms: "\<forall> p \<in> set ps. \<exists> m\<le>n'. (extend (\<Gamma>1 \<Rightarrow>* Compound F Fs) p,m) \<in> derivable R*" using ext
                  and \<open>r= (ps,c)\<close> by (auto simp add:extendRule_def)
             have "\<forall> p \<in> set ps. \<exists> m\<le>n'. (extend (\<Gamma>1 + \<Gamma>' \<Rightarrow>* E) p,m) \<in> derivable R*"
                 proof-
                 {fix p
                  assume "p \<in> set ps"
                  obtain \<Gamma>i \<delta>i where p: "p = (\<Gamma>i \<Rightarrow>* \<delta>i)" by (cases p) auto
                  have "\<delta>i = Em \<or> \<delta>i \<noteq> Em" by blast
                  moreover
                     {assume "\<delta>i = Em"
                      then have "extend (\<Gamma>1 \<Rightarrow>* Compound F Fs) p = (\<Gamma>1 + \<Gamma>i \<Rightarrow>* Compound F Fs)" using p
                           by (auto simp add:extend_def)
                      with pms obtain m where "m \<le>n'" and "(\<Gamma>1 + \<Gamma>i \<Rightarrow>* Compound F Fs,m) \<in> derivable R*"
                           using \<open>p \<in> set ps\<close> by auto
                      with IH and \<open>n = Suc n'\<close> and b' have "\<exists> m'\<le>m. (\<Gamma>1 + \<Gamma>i + \<Gamma>' \<Rightarrow>* E,m') \<in> derivable R*"
                           by auto
                      then have "\<exists> m\<le>n'. (extend (\<Gamma>1 + \<Gamma>' \<Rightarrow>* E) p,m) \<in> derivable R*" using \<open>m\<le>n'\<close>
                           and p and \<open>\<delta>i = Em\<close> apply (auto simp add:extend_def union_ac)
                           by (rule_tac x="m'" in exI) auto
                     }
                  moreover
                     {assume "\<delta>i \<noteq> Em"
                      then have "extend (\<Gamma>1 \<Rightarrow>* Compound F Fs) p = (\<Gamma>1 + \<Gamma>i \<Rightarrow>* \<delta>i)" using p
                           by (auto simp add:extend_def)
                      with pms obtain m where "m\<le>n'" and "(\<Gamma>1 + \<Gamma>i \<Rightarrow>* \<delta>i,m) \<in> derivable R*"
                           using \<open>p \<in> set ps\<close> by auto
                      then have "(\<Gamma>1 + \<Gamma>i + \<Gamma>' \<Rightarrow>* \<delta>i,m) \<in> derivable R*" using rules
                           and dpWeak[where \<Gamma>="\<Gamma>1 + \<Gamma>i" and E="\<delta>i" and n=m and R=R and R'=R'] by auto
                      then have "\<exists> m\<le>n'. (extend (\<Gamma>1 + \<Gamma>' \<Rightarrow>* E) p,m) \<in> derivable R*" using \<open>m\<le>n'\<close>
                           and p and \<open>\<delta>i \<noteq> Em\<close> by (auto simp add:extend_def union_ac)
                     }
                  ultimately have "\<exists> m\<le>n'. (extend (\<Gamma>1 + \<Gamma>' \<Rightarrow>* E) p, m) \<in> derivable R*" by blast
                 }
                 thus ?thesis by auto
                 qed
             then have "\<forall> p \<in> set (fst (extendRule (\<Gamma>1 + \<Gamma>' \<Rightarrow>* E) r)).
                          \<exists> m\<le>n'. (p,m) \<in> derivable R*" using \<open>r = (ps,c)\<close> by (auto simp add:extendRule_def)
             moreover have "extendRule (\<Gamma>1 + \<Gamma>' \<Rightarrow>* E) r \<in> R*" using \<open>r \<in> R'\<close> and rules by auto
             moreover from \<open>S = (\<Gamma>1 \<Rightarrow>* Compound F Fs)\<close> and ext and \<open>c = (\<LM>Compound T Ts\<RM> \<Rightarrow>* Em)\<close>
                 and \<open>\<Gamma> = \<Gamma>1 \<oplus> Compound T Ts\<close> and \<open>r = (ps,c)\<close>
                 have "extend (\<Gamma>1 + \<Gamma>' \<Rightarrow>* E) (snd r) = (\<Gamma> + \<Gamma>' \<Rightarrow>* E)" by (auto simp add:extend_def union_ac)
             moreover from ext and \<open>r = (ps,c)\<close> and \<open>Ps \<noteq> []\<close> have "fst r \<noteq> []" by (auto simp add:extendRule_def)
             ultimately have "(\<Gamma> + \<Gamma>' \<Rightarrow>* E,n'+1) \<in> derivable R*" using
                 derivable.step[where r="extendRule (\<Gamma>1 + \<Gamma>' \<Rightarrow>* E) r" and m="n'" and R="R*"]
                 by (cases r) (auto simp add:map_is_Nil_conv extendRule_def)
             then have "\<exists> m\<le>n. (\<Gamma> + \<Gamma>' \<Rightarrow>* E,m) \<in> derivable R*" using \<open>n = Suc n'\<close> by auto
            }
         ultimately have "\<exists> m\<le>n. (\<Gamma> + \<Gamma>' \<Rightarrow>* E,m) \<in> derivable R*" by blast
        }
      ultimately show "\<exists> m\<le>n. (\<Gamma> + \<Gamma>' \<Rightarrow>* E,m) \<in> derivable R*" by blast
   qed
qed
(*>*)

lemma leftInvertible:
(*<*)fixes \<Gamma> :: "'a form multiset"(*>*)

assumes (*<*)rules:(*>*) "R' \<subseteq> upRules \<and> R = Ax \<union> R'"
and   (*<*)a:(*>*) "(\<Gamma> \<oplus> Compound F Fs \<Rightarrow>* \<delta>,n) \<in> derivable R*"
and   (*<*)b:(*>*) "\<forall> r' \<in> R. leftPrincipal r' (Compound F Fs) \<longrightarrow> (\<Gamma>' \<Rightarrow>* Em) \<in> set (fst r')"
shows "\<exists> m\<le>n. (\<Gamma> +\<Gamma>' \<Rightarrow>* \<delta>,m) \<in> derivable R*"
 (*<*)
using assms
proof (induct n arbitrary:\<Gamma> \<delta> rule:nat_less_induct)
 case (1 n \<Gamma> \<delta>)
 then have IH:"\<forall>m<n. \<forall>\<Gamma> \<delta>. ( \<Gamma> \<oplus> Compound F Fs \<Rightarrow>* \<delta>, m) \<in> derivable R* \<longrightarrow>
              (\<forall>r' \<in> R. leftPrincipal r' (Compound F Fs) \<longrightarrow> ( \<Gamma>' \<Rightarrow>* Em) \<in> set (fst r')) \<longrightarrow>
              (\<exists>m'\<le>m. ( \<Gamma> + \<Gamma>' \<Rightarrow>* \<delta>, m') \<in> derivable R*)"
     and a': "(\<Gamma> \<oplus> Compound F Fs \<Rightarrow>* \<delta>,n) \<in> derivable R*"
     and b': "\<forall> r' \<in> R. leftPrincipal r' (Compound F Fs) \<longrightarrow> (\<Gamma>' \<Rightarrow>* Em) \<in> set (fst r')"
       by auto
 show ?case
 proof (cases n)
     case 0
     then have "(\<Gamma> \<oplus> Compound F Fs \<Rightarrow>* \<delta>, 0) \<in> derivable R*" using a' by simp
     then have "([],\<Gamma> \<oplus> Compound F Fs \<Rightarrow>* \<delta>) \<in> R*" by (cases) (auto)
     then have "\<exists> r S. extendRule S r = ([],\<Gamma> \<oplus> Compound F Fs \<Rightarrow>* \<delta>) \<and> (r \<in> Ax \<or> r \<in> R')"
          using rules and ruleSet[where R'=R' and R=R and Ps="[]" and C="\<Gamma> \<oplus> Compound F Fs \<Rightarrow>* \<delta>"] by auto
     then obtain r S where "extendRule S r = ([],\<Gamma> \<oplus> Compound F Fs \<Rightarrow>* \<delta>)" and "r \<in> Ax \<or> r \<in> R'" by auto
     moreover
      {assume "r \<in> Ax"
       then obtain i where "r = ([], \<LM> ff \<RM> \<Rightarrow>* Em) \<or> r = ([], \<LM>At i\<RM> \<Rightarrow>* At i)"
            using characteriseAx[where r=r] and \<open>extendRule S r = ([],\<Gamma> \<oplus> Compound F Fs \<Rightarrow>* \<delta>)\<close>
            by (auto simp add:extendRule_def extend_def)
       moreover
          {assume "r = ([], \<LM>ff\<RM> \<Rightarrow>* Em)"
           with \<open>extendRule S r = ([],\<Gamma> \<oplus> Compound F Fs \<Rightarrow>* \<delta>)\<close>
                have "extend S (\<LM> ff \<RM> \<Rightarrow>* Em) = (\<Gamma> \<oplus> Compound F Fs \<Rightarrow>* \<delta>)"
                using extendRule_def[where R="([],\<LM>ff\<RM>\<Rightarrow>* Em)" and forms=S] by auto
           then have "ff \<in># \<Gamma> \<oplus> Compound F Fs"
                using extendFalsum[where S=S and \<Gamma>="\<Gamma>\<oplus> Compound F Fs" and \<Delta>=\<delta>] by auto
           then have "ff \<in># \<Gamma>" by auto
           then have "ff \<in># \<Gamma> + \<Gamma>'" by auto
           then have "(\<Gamma> + \<Gamma>' \<Rightarrow>* \<delta>,0) \<in> derivable R*" using rules
                and containFalsum[where \<Gamma>="\<Gamma> + \<Gamma>'" and R=R] by auto
          }
       moreover
          {assume "r = ([], \<LM>At i\<RM> \<Rightarrow>* At i)"
           with \<open>extendRule S r = ([], \<Gamma> \<oplus> Compound F Fs \<Rightarrow>* \<delta>)\<close>
                have "extend S (\<LM> At i\<RM> \<Rightarrow>* At i) = (\<Gamma> \<oplus> Compound F Fs \<Rightarrow>* \<delta>)"
                using extendRule_def[where R="([], \<LM>At i \<RM> \<Rightarrow>* At i)" and forms=S] by auto
           then have "At i \<in># \<Gamma> \<oplus> Compound F Fs" and eq: "\<delta> = At i"
                using extendID[where S=S and \<Gamma>="\<Gamma> \<oplus> Compound F Fs" and \<Delta>=\<delta> and i=i] by (auto simp add:extend_def)
           then have "At i \<in># \<Gamma>" by auto
           then have "At i \<in># \<Gamma> + \<Gamma>'" by auto
           with eq have "(\<Gamma> + \<Gamma>' \<Rightarrow>* \<delta>,0) \<in> derivable R*" using rules
                and containID[where i=i and \<Gamma>="\<Gamma> + \<Gamma>'" and R=R] by auto
          }
       ultimately have "(\<Gamma> + \<Gamma>' \<Rightarrow>* \<delta>, 0) \<in> derivable R*" by blast
      }
   moreover
      {assume "r \<in> R'"
       then have "r \<in> upRules" using rules by auto
       then have "\<exists> Ps C. Ps \<noteq> [] \<and> r = (Ps,C)"
            proof-
            obtain x y where "r = (x,y)" by (cases r)
            with \<open>r \<in> upRules\<close> have "(x,y) \<in> upRules" by simp
            then obtain Ps where "(Ps :: 'a sequent list) \<noteq> []" and "x=Ps" by (cases) (auto)
            with \<open>r = (x,y)\<close> have "r = (Ps, y)" by simp
            then show "\<exists> Ps C. Ps \<noteq> [] \<and> r = (Ps,C)" using \<open>Ps \<noteq> []\<close> by blast
            qed
       then obtain Ps C where "Ps \<noteq> []" and "r = (Ps,C)" by auto
       moreover from \<open>extendRule S r = ([], \<Gamma> \<oplus> Compound F Fs \<Rightarrow>* \<delta>)\<close> have "\<exists> S. r = ([],S)"
            using extendRule_def[where forms=S and R=r] by (cases r) (auto)
       then obtain S where "r = ([],S)" by blast
       ultimately have "(\<Gamma> + \<Gamma>' \<Rightarrow>* \<delta>,0) \<in> derivable R*" using rules by simp
       }
    ultimately show "\<exists> m\<le>n. (\<Gamma> + \<Gamma>' \<Rightarrow>* \<delta>,m) \<in> derivable R*" using \<open>n=0\<close> by blast
 next
     case (Suc n')
     then have "(\<Gamma> \<oplus> Compound F Fs \<Rightarrow>* \<delta>,n'+1) \<in> derivable R*" using a' by simp
     then obtain Ps where "(Ps, \<Gamma> \<oplus> Compound F Fs \<Rightarrow>* \<delta>) \<in> R*" and
                          "Ps \<noteq> []" and
                          derv: "\<forall> p \<in> set Ps. \<exists> n\<le>n'. (p,n) \<in> derivable R*"
          using characteriseLast[where C="\<Gamma> \<oplus> Compound F Fs \<Rightarrow>* \<delta>" and m=n' and R="R*"] by auto
     then have "\<exists> r S. (r \<in> Ax \<or> r \<in> R') \<and> extendRule S r = (Ps, \<Gamma> \<oplus> Compound F Fs \<Rightarrow>* \<delta>)"
          using rules and ruleSet[where R'=R' and R=R and Ps=Ps and C="\<Gamma> \<oplus> Compound F Fs \<Rightarrow>* \<delta>"] by auto
     then obtain r S where "r \<in> Ax \<or> r \<in> R'" and ext: "extendRule S r = (Ps, \<Gamma> \<oplus> Compound F Fs \<Rightarrow>* \<delta>)" by auto
     moreover
        {assume "r \<in> Ax"
         then have "fst r = []" apply (cases r) by (rule Ax.cases) auto
         moreover obtain x y where "r = (x,y)" by (cases r)
         then have "x \<noteq> []" using \<open>Ps \<noteq> []\<close> and ext
                            and extendRule_def[where forms=S and R=r]
                            and extend_def[where forms=S and seq="snd r"] by auto
         ultimately have "\<exists> m\<le>n. (\<Gamma> + \<Gamma>' \<Rightarrow>* \<delta>,m) \<in> derivable R*"
              using \<open>r=(x,y)\<close> by auto
        }
     moreover
        {assume "r \<in> R'"
         obtain ps c where "r = (ps,c)" by (cases r) auto
         then have "r \<in> upRules" using rules and \<open>r \<in> R'\<close> by auto
         then have "\<exists> T Ts. c = (\<LM>Compound T Ts\<RM> \<Rightarrow>* Em) \<or> c = (\<Empt> \<Rightarrow>* Compound T Ts)" using \<open>r=(ps,c)\<close>
              and upRuleCharacterise[where Ps=ps and C=c] by auto
         then obtain T Ts where "c = (\<LM>Compound T Ts\<RM> \<Rightarrow>* Em) \<or> c = (\<Empt> \<Rightarrow>* Compound T Ts)" by blast
         moreover
            {assume "c = (\<Empt> \<Rightarrow>* Compound T Ts)"
             with ext have "antec S = \<Gamma> \<oplus> Compound F Fs" and del: "Compound T Ts = \<delta>"
                  using \<open>r = (ps,c)\<close> by (auto simp add:extendRule_def extend_def)
             then obtain \<delta>' where "S = (\<Gamma> \<oplus> Compound F Fs \<Rightarrow>* \<delta>')" by (cases S) auto
             with derv have pms: "\<forall> p \<in> set ps. \<exists> m\<le>n'. (extend (\<Gamma> \<oplus> Compound F Fs \<Rightarrow>* \<delta>') p,m) \<in> derivable R*"
                  using ext and \<open>r = (ps,c)\<close> by (auto simp add:extendRule_def)
             have "\<forall> p \<in> set ps. \<exists> m\<le>n'. (extend (\<Gamma> + \<Gamma>' \<Rightarrow>* \<delta>') p,m) \<in> derivable R*"
                 proof-
                 {fix p
                  assume "p \<in> set ps"
                  obtain \<Gamma>i \<delta>i where p: "p = (\<Gamma>i \<Rightarrow>* \<delta>i)" by (cases p) auto
                  have "\<delta>i = Em \<or> \<delta>i \<noteq> Em" by blast
                  moreover
                     {assume "\<delta>i = Em"
                      then have "extend (\<Gamma> \<oplus> Compound F Fs \<Rightarrow>* \<delta>') p = (\<Gamma> + \<Gamma>i \<oplus> Compound F Fs \<Rightarrow>* \<delta>')" using p
                           by (auto simp add:extend_def union_ac)
                      with pms obtain m where "m \<le>n'" and "(\<Gamma> + \<Gamma>i \<oplus> Compound F Fs \<Rightarrow>* \<delta>',m) \<in> derivable R*"
                           using \<open>p \<in> set ps\<close> by auto
                      with IH and \<open>n = Suc n'\<close> and b' have "\<exists> m'\<le>m. (\<Gamma> + \<Gamma>i + \<Gamma>' \<Rightarrow>* \<delta>',m') \<in> derivable R*"
                           by auto
                      then have "\<exists> m\<le>n'. (extend (\<Gamma> + \<Gamma>' \<Rightarrow>* \<delta>') p,m) \<in> derivable R*" using \<open>m\<le>n'\<close>
                           and p and \<open>\<delta>i = Em\<close> apply (auto simp add:extend_def union_ac)
                           by (rule_tac x="m'" in exI) auto
                     }
                  moreover
                     {assume "\<delta>i \<noteq> Em"
                      then have "extend (\<Gamma> \<oplus> Compound F Fs \<Rightarrow>* \<delta>') p = (\<Gamma> + \<Gamma>i \<oplus> Compound F Fs \<Rightarrow>* \<delta>i)" using p
                           by (auto simp add:extend_def union_ac)
                      with pms obtain m where "m\<le>n'" and "(\<Gamma> + \<Gamma>i \<oplus> Compound F Fs \<Rightarrow>* \<delta>i,m) \<in> derivable R*"
                           using \<open>p \<in> set ps\<close> by auto
                      then have "\<exists> m\<le>n'. (\<Gamma> + \<Gamma>i + \<Gamma>' \<Rightarrow>* \<delta>i,m) \<in> derivable R*" using \<open>n = Suc n'\<close> and b'
                           and IH
                           apply auto apply (drule_tac x=m in spec) apply auto
                           apply (drule_tac x="\<Gamma> + \<Gamma>i" in spec) apply (drule_tac x=\<delta>i in spec)
                           apply (auto simp add:union_ac) apply (rule_tac x="m'" in exI) by auto
                      then have "\<exists> m\<le>n'. (extend (\<Gamma> + \<Gamma>' \<Rightarrow>* \<delta>') p,m) \<in> derivable R*" using \<open>m\<le>n'\<close>
                           and p and \<open>\<delta>i \<noteq> Em\<close> by (auto simp add:extend_def union_ac)
                     }
                  ultimately have "\<exists> m\<le>n'. (extend (\<Gamma> + \<Gamma>' \<Rightarrow>* \<delta>') p, m) \<in> derivable R*" by blast
                 }
                 thus ?thesis by auto
                 qed
             then have "\<forall> p \<in> set (fst (extendRule (\<Gamma> + \<Gamma>' \<Rightarrow>* \<delta>') r)).
                          \<exists> m\<le>n'. (p,m) \<in> derivable R*" using \<open>r = (ps,c)\<close> by (auto simp add:extendRule_def)
             moreover have "extendRule (\<Gamma> + \<Gamma>' \<Rightarrow>* \<delta>') r \<in> R*" using \<open>r \<in> R'\<close> and rules by auto
             moreover from \<open>S = (\<Gamma> \<oplus> Compound F Fs \<Rightarrow>* \<delta>')\<close> and ext and \<open>c = (\<Empt> \<Rightarrow>* Compound T Ts)\<close>
                 and \<open>r = (ps,c)\<close>
                 have "extend (\<Gamma> + \<Gamma>' \<Rightarrow>* \<delta>') (snd r) = (\<Gamma> + \<Gamma>' \<Rightarrow>* Compound T Ts)" by (auto simp add:extend_def union_ac)
             moreover from ext and \<open>r = (ps,c)\<close> and \<open>Ps \<noteq> []\<close> have "fst r \<noteq> []" by (auto simp add:extendRule_def)
             ultimately have "(\<Gamma> + \<Gamma>' \<Rightarrow>* Compound T Ts ,n'+1) \<in> derivable R*" using
                 derivable.step[where r="extendRule (\<Gamma> + \<Gamma>' \<Rightarrow>* \<delta>') r" and m="n'" and R="R*"]
                 by (cases r) (auto simp add:map_is_Nil_conv extendRule_def)
             then have "\<exists> m\<le>n. (\<Gamma> + \<Gamma>' \<Rightarrow>* \<delta>,m) \<in> derivable R*" using \<open>n = Suc n'\<close> and del by auto
            }
         moreover
            {assume r: "c = (\<LM>Compound T Ts\<RM> \<Rightarrow>* Em)"
             have "Compound F Fs = Compound T Ts \<or> Compound F Fs \<noteq> Compound T Ts" by blast
             moreover
                {assume "Compound F Fs = Compound T Ts"
                 then have "leftPrincipal r (Compound F Fs)" using r and \<open>r = (ps,c)\<close> by auto
                 then have "(\<Gamma>' \<Rightarrow>* Em) \<in> set ps" using b' and \<open>r = (ps,c)\<close> and \<open>r \<in> R'\<close> and rules
                      by auto
                 then have "extend S (\<Gamma>' \<Rightarrow>* Em) \<in> set Ps" using \<open>extendRule S r = (Ps,\<Gamma> \<oplus> Compound F Fs \<Rightarrow>* \<delta>)\<close>
                      and \<open>r = (ps,c)\<close> by (simp add:extendContain)
                 moreover from r and \<open>Compound F Fs = Compound T Ts\<close> have "c = (\<LM>Compound F Fs\<RM> \<Rightarrow>* Em)" by auto
                 with ext have "S = (\<Gamma> \<Rightarrow>* \<delta>)"
                      using \<open>r = (ps,c)\<close> apply (auto simp add:extendRule_def extend_def) by (cases S) auto
                 ultimately have "(\<Gamma> + \<Gamma>' \<Rightarrow>* \<delta>) \<in> set Ps" by (simp add:extend_def)
                 then have "\<exists> m\<le>n'. (\<Gamma> + \<Gamma>' \<Rightarrow>* \<delta>,m) \<in> derivable R*"
                      using \<open>\<forall> p \<in> set Ps. \<exists> n\<le>n'. (p,n) \<in> derivable R*\<close> by auto
                 then have "\<exists> m\<le>n. (\<Gamma> + \<Gamma>' \<Rightarrow>* \<delta> ,m) \<in> derivable R*" using \<open>n = Suc n'\<close>
                      by (auto,rule_tac x=m in exI) (simp)
                }
             moreover
                {assume "Compound F Fs \<noteq> Compound T Ts"
                 obtain \<Gamma>'' \<delta>' where "S = (\<Gamma>'' \<Rightarrow>* \<delta>')" by (cases S) auto
                 with ext and r and \<open>r = (ps,c)\<close> have "\<delta> = \<delta>'" by (auto simp add:extendRule_def extend_def)
                 then have "S = (\<Gamma>'' \<Rightarrow>* \<delta>)" using \<open>S = (\<Gamma>'' \<Rightarrow>* \<delta>')\<close> by simp
                 with r and \<open>r = (ps,c)\<close> and ext have "\<Gamma> \<oplus> Compound F Fs = \<Gamma>'' \<oplus> Compound T Ts"
                      by (auto simp add:extendRule_def extend_def)
                 with \<open>Compound F Fs \<noteq> Compound T Ts\<close> obtain \<Gamma>1 where
                      gam1: "\<Gamma> = \<Gamma>1 \<oplus> Compound T Ts" and
                      gam2: "\<Gamma>'' = \<Gamma>1 \<oplus> Compound F Fs"
                      using midMultiset[where \<Gamma>=\<Gamma> and \<Gamma>'=\<Gamma>'' and A="Compound F Fs" and B="Compound T Ts"] by auto
                 with \<open>S = (\<Gamma>'' \<Rightarrow>* \<delta>)\<close> have "S = (\<Gamma>1 \<oplus> Compound F Fs \<Rightarrow>* \<delta>)" by simp
                 with derv have pms: "\<forall> p \<in> set ps. \<exists> m\<le>n'. (extend (\<Gamma>1 \<oplus> Compound F Fs \<Rightarrow>* \<delta>) p,m) \<in> derivable R*"
                      using ext and \<open>r= (ps,c)\<close> by (auto simp add:extendRule_def)
                 have "\<forall> p \<in> set ps. \<exists> m\<le>n'. (extend (\<Gamma>1 + \<Gamma>' \<Rightarrow>* \<delta>) p,m) \<in> derivable R*"
                     proof-
                     {fix p
                      assume "p \<in> set ps"
                      obtain \<Gamma>i \<delta>i where p: "p = (\<Gamma>i \<Rightarrow>* \<delta>i)" by (cases p) auto
                      have "\<delta>i = Em \<or> \<delta>i \<noteq> Em" by blast
                      moreover
                         {assume "\<delta>i = Em"
                          then have "extend (\<Gamma>1 \<oplus> Compound F Fs \<Rightarrow>* \<delta>) p = (\<Gamma>1 + \<Gamma>i \<oplus> Compound F Fs \<Rightarrow>* \<delta>)" using p
                               by (auto simp add:extend_def union_ac)
                          with pms obtain m where "m \<le>n'" and "(\<Gamma>1 + \<Gamma>i \<oplus> Compound F Fs \<Rightarrow>* \<delta>,m) \<in> derivable R*"
                               using \<open>p \<in> set ps\<close> by auto
                          with IH and \<open>n = Suc n'\<close> and b' have "\<exists> m'\<le>m. (\<Gamma>1 + \<Gamma>i + \<Gamma>' \<Rightarrow>* \<delta>,m') \<in> derivable R*"
                               by auto
                          then have "\<exists> m\<le>n'. (extend (\<Gamma>1 + \<Gamma>' \<Rightarrow>* \<delta>) p,m) \<in> derivable R*" using \<open>m\<le>n'\<close>
                               and p and \<open>\<delta>i = Em\<close> apply (auto simp add:extend_def union_ac)
                               by (rule_tac x="m'" in exI) auto
                         }
                      moreover
                         {assume "\<delta>i \<noteq> Em"
                          then have "extend (\<Gamma>1 \<oplus> Compound F Fs \<Rightarrow>* \<delta>) p = (\<Gamma>1 + \<Gamma>i \<oplus> Compound F Fs \<Rightarrow>* \<delta>i)" using p
                               by (auto simp add:extend_def union_ac)
                          with pms obtain m where "m\<le>n'" and "(\<Gamma>1 + \<Gamma>i \<oplus> Compound F Fs \<Rightarrow>* \<delta>i,m) \<in> derivable R*"
                               using \<open>p \<in> set ps\<close> by auto
                          with IH and \<open>n = Suc n'\<close> and b' have "\<exists> m'\<le>m. (\<Gamma>1 + \<Gamma>i + \<Gamma>' \<Rightarrow>* \<delta>i,m') \<in> derivable R*"
                               by auto
                          then have "\<exists> m\<le>n'. (extend (\<Gamma>1 + \<Gamma>' \<Rightarrow>* \<delta>) p,m) \<in> derivable R*" using \<open>m\<le>n'\<close>
                               and p and \<open>\<delta>i \<noteq> Em\<close> and \<open>n = Suc n'\<close> apply (auto simp add:extend_def union_ac)
                               apply (rule_tac x=m' in exI) by auto
                         }
                      ultimately have "\<exists> m\<le>n'. (extend (\<Gamma>1 + \<Gamma>' \<Rightarrow>* \<delta>) p, m) \<in> derivable R*" by blast
                     }
                     thus ?thesis by auto
                     qed
                 then have "\<forall> p \<in> set (fst (extendRule (\<Gamma>1 + \<Gamma>' \<Rightarrow>* \<delta>) r)).
                              \<exists> m\<le>n'. (p,m) \<in> derivable R*" using \<open>r = (ps,c)\<close> by (auto simp add:extendRule_def)
                 moreover have "extendRule (\<Gamma>1 + \<Gamma>' \<Rightarrow>* \<delta>) r \<in> R*" using \<open>r \<in> R'\<close> and rules by auto
                 moreover from \<open>S = (\<Gamma>1 \<oplus> Compound F Fs \<Rightarrow>* \<delta>)\<close> and ext and \<open>c = (\<LM>Compound T Ts\<RM> \<Rightarrow>* Em)\<close>
                     and gam1 and \<open>r = (ps,c)\<close>
                     have "extend (\<Gamma>1 + \<Gamma>' \<Rightarrow>* \<delta>) (snd r) = (\<Gamma> + \<Gamma>' \<Rightarrow>* \<delta>)" by (auto simp add:extend_def union_ac)
                 moreover from ext and \<open>r = (ps,c)\<close> and \<open>Ps \<noteq> []\<close> have "fst r \<noteq> []" by (auto simp add:extendRule_def)
                 ultimately have "(\<Gamma> + \<Gamma>' \<Rightarrow>* \<delta>,n'+1) \<in> derivable R*" using
                     derivable.step[where r="extendRule (\<Gamma>1 + \<Gamma>' \<Rightarrow>* \<delta>) r" and m="n'" and R="R*"]
                     by (cases r) (auto simp add:map_is_Nil_conv extendRule_def)
                 then have "\<exists> m\<le>n. (\<Gamma> + \<Gamma>' \<Rightarrow>* \<delta>,m) \<in> derivable R*" using \<open>n = Suc n'\<close> by auto
                }
            ultimately have "\<exists> m\<le>n. (\<Gamma> + \<Gamma>' \<Rightarrow>* \<delta>, m) \<in> derivable R*" by blast
           }
       ultimately have "\<exists> m\<le>n. (\<Gamma> + \<Gamma>' \<Rightarrow>* \<delta>, m) \<in> derivable R*" by blast
      }
   ultimately show "\<exists> m\<le>n. (\<Gamma> + \<Gamma>' \<Rightarrow>* \<delta>, m) \<in> derivable R*" by blast
   qed
qed

(* ---------------------------------------------------
   ---------------------------------------------------
   ---------------------------------------------------
   ---------------------------------------------------
                THIS IS NOW
                G3ip.thy
   ---------------------------------------------------
   ---------------------------------------------------
   ---------------------------------------------------
   --------------------------------------------------- *)

datatype cdi = con | dis | imp

type_synonym cdi_form = "cdi form"

abbreviation con_form (infixl "\<and>*" 80) where
   "p \<and>* q \<equiv> Compound con [p,q]"

abbreviation dis_form (infixl "\<or>*" 80) where
   "p \<or>* q \<equiv> Compound dis [p,q]"

abbreviation imp_form (infixl "\<supset>" 80) where
   "p \<supset> q  \<equiv> Compound imp [p,q]"
(*>*)
text\<open>
\noindent \textbf{G3ip} can be expressed in this formalism:
\<close>
inductive_set "g3ip"
where
   conL(*<*)[intro](*>*):  "([\<LM> A \<RM> + \<LM> B \<RM> \<Rightarrow>* Em], \<LM> A \<and>* B \<RM> \<Rightarrow>* Em) \<in> g3ip"
|  conR(*<*)[intro](*>*):  "([\<Empt> \<Rightarrow>* A, \<Empt> \<Rightarrow>* B], \<Empt> \<Rightarrow>* (A \<and>* B)) \<in> g3ip"
|  disL(*<*)[intro](*>*):  "([\<LM> A \<RM> \<Rightarrow>* Em, \<LM> B \<RM> \<Rightarrow>* Em], \<LM> A \<or>* B\<RM> \<Rightarrow>* Em) \<in> g3ip"
|  disR1(*<*)[intro](*>*): "([\<Empt> \<Rightarrow>* A], \<Empt> \<Rightarrow>* (A \<or>* B)) \<in> g3ip"
|  disR2(*<*)[intro](*>*): "([\<Empt> \<Rightarrow>* B], \<Empt> \<Rightarrow>* (A \<or>* B)) \<in> g3ip"
|  impL(*<*)[intro](*>*):  "([\<LM> A \<supset> B \<RM> \<Rightarrow>* A, \<LM> B \<RM> \<Rightarrow>* Em], \<LM> (A \<supset> B) \<RM> \<Rightarrow>* Em) \<in> g3ip"
|  impR(*<*)[intro](*>*):  "([\<LM> A \<RM> \<Rightarrow>* B], \<Empt> \<Rightarrow>* (A \<supset> B)) \<in> g3ip"

(*<*)
lemma g3ip_upRules:
shows "g3ip \<subseteq> upRules"
proof-
  {fix r
   assume "r \<in> g3ip"
   then have "r \<in> upRules" apply (cases r) by (rule g3ip.cases) auto
  }
  then show "g3ip \<subseteq> upRules" by auto
qed
(*>*)

text\<open>\noindent As expected, $\implies{R}{}$ can be shown invertible:\<close>

lemma impRInvert:
assumes "(\<Gamma> \<Rightarrow>* (A \<supset> B), n) \<in> derivable (Ax \<union> g3ip)*" and "B \<noteq> Em"
shows "\<exists> m\<le>n. (\<Gamma> \<oplus> A \<Rightarrow>* B, m) \<in> derivable (Ax \<union> g3ip)*"
proof-
  have "\<forall> r \<in> (Ax \<union> g3ip). rightPrincipal r (A \<supset> B) \<longrightarrow>
                           (\<LM>A\<RM> \<Rightarrow>* B) \<in> set (fst r)"
  proof-  \<comment> \<open>Showing that $A \Rightarrow B$ is a premiss of every rule with $\implies{A}{B}$ principal\<close>
   {fix r
    assume "r \<in> (Ax \<union> g3ip)"
    moreover assume "rightPrincipal r (A \<supset> B)"
    ultimately have "r \<in> g3ip" (*<*)apply auto apply (rule rightPrincipal.cases) apply auto (*>*)by(*<*) (rule Ax.cases) (*>*) auto  \<comment> \<open>If $\implies{A}{B}$ was principal, then $r \notin Ax$\<close>
    from \<open>rightPrincipal r (A \<supset> B)\<close> have "snd r = (\<Empt> \<Rightarrow>* (A \<supset> B))" by(*<*) (rule rightPrincipal.cases)(*>*) auto
    with \<open>r \<in> g3ip\<close> and \<open>rightPrincipal r (A \<supset> B)\<close>
        have "r = ([\<LM>A\<RM> \<Rightarrow>* B], \<Empt> \<Rightarrow>* (A\<supset>B))" (*<*) apply (cases r)(*>*) by (rule g3ip.cases) auto
    then have "(\<LM>A\<RM> \<Rightarrow>* B) \<in> set (fst r)" by auto
   }
   thus ?thesis by auto
   qed
  with assms (*<*)and g3ip_upRules(*>*) show ?thesis using rightInvertible(*<*)[where R'="g3ip" and R="Ax \<union> g3ip" and \<Gamma>=\<Gamma> and n=n
                            and \<Gamma>'="\<LM>A\<RM>" and E=B and F="imp" and Fs="[A,B]"](*>*) by auto
qed

(*<*)
end
(*>*)


theory step_rel
imports memory_model trans_sim
begin

locale step_rel = memory_model
 where free_set = "free_set :: 'memory \<Rightarrow> 'loc set"
    and can_read = "can_read :: 'memory \<Rightarrow> 'thread \<Rightarrow> 'loc \<Rightarrow> 'val set"
    and update_mem=
        "update_mem::'memory \<Rightarrow> ('thread, 'loc, 'val) access set \<Rightarrow> 'memory \<Rightarrow> bool"
    and start_mem = "start_mem:: 'memory"
  for free_set and can_read and update_mem and start_mem +
  fixes step_rel::"'thread \<Rightarrow> ('node, 'edge_type, 'instr) flowgraph \<Rightarrow> 'memory \<Rightarrow> 'config \<Rightarrow>
  ('thread, 'loc, 'val) access set \<Rightarrow> 'config \<Rightarrow> bool"
  and start_state::"('thread \<rightharpoonup> ('node, 'edge_type, 'instr) flowgraph)
                                       \<Rightarrow> ('thread \<rightharpoonup> 'config) \<Rightarrow> 'memory \<Rightarrow> bool"
  and get_point::"'config \<Rightarrow> 'node"
  and instr_edges::"'instr \<Rightarrow> ('edge_type \<Rightarrow> nat) set"
  and Seq::'edge_type
  assumes start_points [simp]: "start_state CFGs S m
         \<Longrightarrow> (\<lambda> x . case S x of Some a \<Rightarrow> (\<lambda>C. Some (get_point C)) a
                              | None \<Rightarrow> None) = start_points CFGs"
      and step_along_edge: "\<lbrakk>step_rel t G m C ops C'; is_flowgraph G Seq instr_edges; get_point C \<in> Nodes G\<rbrakk> \<Longrightarrow>
    \<exists>ty. (get_point C, get_point C', ty) \<in> Edges (G::('node, 'edge_type, 'instr) flowgraph)"

begin

lemma step_safe: "\<lbrakk>step_rel t G m C ops C'; is_flowgraph G Seq instr_edges; get_point C \<in> Nodes G\<rbrakk> \<Longrightarrow>
    get_point C' \<in> Nodes G"
by (drule step_along_edge, simp+, simp add: is_flowgraph_def flowgraph_def pointed_graph_def)

abbreviation "well_formed G \<equiv> is_flowgraph G Seq instr_edges"

inductive one_step where
step_single [intro!]: "\<lbrakk>step_rel t G mem C ops C'; update_mem mem ops mem'\<rbrakk> \<Longrightarrow>
  one_step t G (C, mem) (C', mem')"

lemma one_step_safe: "\<lbrakk>one_step t G (C, mem) (C', mem'); well_formed G; get_point C \<in> Nodes G\<rbrakk> \<Longrightarrow>
  get_point C' \<in> Nodes G"
by (erule one_step.cases, rule step_safe, simp+)

lemma one_step_along_edge: "\<lbrakk>one_step t G (C, m) (C', m'); is_flowgraph G Seq instr_edges;
  get_point C \<in> Nodes G\<rbrakk> \<Longrightarrow> \<exists>ty. (get_point C, get_point C', ty) \<in> Edges G"
by (erule one_step.cases, rule step_along_edge, simp+)

inductive conc_step where
step_thread [intro]: "\<lbrakk>CFGs t = Some G; states t = Some C; step_rel t G mem C ops C';
  update_mem mem ops mem'\<rbrakk> \<Longrightarrow> conc_step CFGs (states, mem) (states(t \<mapsto> C'), mem')"

abbreviation "get_points (S::'thread \<rightharpoonup> 'config) \<equiv>
                  (\<lambda> x . case S x of Some a \<Rightarrow> (\<lambda>C. Some (get_point C)) a
                              | None \<Rightarrow> None)"

lemma one_step_conc_step: "\<lbrakk>one_step t G (C, m) (C', m'); CFGs t = Some G; states t = Some C\<rbrakk> \<Longrightarrow>
  conc_step CFGs (states, m) (states(t \<mapsto> C'), m')"
by (erule one_step.cases, rule step_thread, auto)

lemma conc_step_safe: "\<lbrakk>conc_step CFGs (states, mem) (states', mem'); tCFG CFGs instr_edges Seq;
  safe_points CFGs (get_points states)\<rbrakk> \<Longrightarrow>
  safe_points CFGs (get_points states')"
apply (erule conc_step.cases, clarsimp simp add: safe_points_def)
apply (case_tac "t = t", clarsimp)
apply (rule step_safe, simp+)
apply (erule tCFG.CFGs, simp)
apply force
apply (force simp add: map_comp_def)
done

lemma conc_steps_safe: "\<lbrakk>(conc_step CFGs)^** (states, mem) (states', mem'); tCFG CFGs instr_edges Seq;
  safe_points CFGs (get_points states)\<rbrakk> \<Longrightarrow>
  safe_points CFGs (get_points states')"
by (drule_tac P="\<lambda>(states, mem) (states', mem'). safe_points CFGs (get_points states) \<longrightarrow>
  safe_points CFGs (get_points states')" in rtranclp.induct, auto intro: conc_step_safe)

definition "run_prog CFGs C \<equiv> \<exists>C0 mem0. start_state CFGs C0 mem0 \<and> (conc_step CFGs)^** (C0, mem0) C"

lemma run_progI [intro]: "\<lbrakk>start_state CFGs C0 mem0; (conc_step CFGs)^** (C0, mem0) C\<rbrakk> \<Longrightarrow>
  run_prog CFGs C"
by (force simp add: run_prog_def)

lemma run_prog_conc_step [intro]: "\<lbrakk>run_prog CFGs C; conc_step CFGs C C'\<rbrakk> \<Longrightarrow> run_prog CFGs C'"
by (force simp add: run_prog_def)

lemma run_prog_conc_steps [intro]: "\<lbrakk>run_prog CFGs C; (conc_step CFGs)^** C C'\<rbrakk> \<Longrightarrow> run_prog CFGs C'"
by (force simp add: run_prog_def)

lemma run_prog_induct [elim]: "\<lbrakk>run_prog CFGs C; \<And>C0 mem0. start_state CFGs C0 mem0 \<Longrightarrow> P (C0, mem0);
 \<And>C C'. run_prog CFGs C \<Longrightarrow> P C \<Longrightarrow> conc_step CFGs C C' \<Longrightarrow> P C'\<rbrakk> \<Longrightarrow> P C"
apply (clarsimp simp add: run_prog_def)
apply (drule_tac P="\<lambda>C C'. start_state CFGs (fst C) (snd C) \<longrightarrow> P C'" in rtranclp.induct, auto)
by (metis (mono_tags))

lemma run_prog_one_step: "\<lbrakk>run_prog CFGs (S, mem); S t = Some s; CFGs t = Some G;
 one_step t G (s, mem) (s', mem')\<rbrakk> \<Longrightarrow> run_prog CFGs (S(t \<mapsto> s'), mem')"
by (erule run_prog_conc_step, erule one_step.cases, auto)

lemma run_prog_one_steps: "\<lbrakk>run_prog CFGs (S, mem); S t = Some s; CFGs t = Some G;
 (one_step t G)^** (s, mem) (s', mem')\<rbrakk> \<Longrightarrow> run_prog CFGs (S(t \<mapsto> s'), mem')"
apply (drule_tac P="\<lambda>(s, mem) (s', mem'). run_prog CFGs (S, mem) \<and> S t = Some s \<and> CFGs t = Some G \<longrightarrow>
  run_prog CFGs (S(t \<mapsto> s'), mem')" in rtranclp.induct, auto simp add: map_upd_triv)
apply (drule_tac mem=ba in run_prog_one_step, simp+, force, simp+)
done

lemma run_prog_step: "\<lbrakk>run_prog CFGs (S, mem); S t = Some s; CFGs t = Some G;
 step_rel t G mem s ops s'; update_mem mem ops mem'\<rbrakk> \<Longrightarrow> run_prog CFGs (S(t \<mapsto> s'), mem')"
by (erule run_prog_one_step, auto)

lemma run_prog_safe: "\<lbrakk>run_prog CFGs (S, mem); tCFG CFGs instr_edges Seq\<rbrakk> \<Longrightarrow>
  safe_points CFGs (get_points S)"
proof - assume "tCFG CFGs instr_edges Seq" then interpret tCFG .
show "\<lbrakk>run_prog CFGs (S, mem); tCFG CFGs instr_edges Seq\<rbrakk> \<Longrightarrow>
  safe_points CFGs (get_points S)"
by (clarsimp simp add: run_prog_def, rule conc_steps_safe, simp+)
qed

(* paths *)
lemma step_increment_path: "\<lbrakk>step_rel t G m C a C'; tCFG CFGs instr_edges Seq; CFGs t = Some G;
  l \<in> pre_tCFG.Paths CFGs ps; p = get_point C; p' = get_point C'; ps t = Some p'; p \<in> Nodes G\<rbrakk> \<Longrightarrow>
  [ps(t \<mapsto> p)] \<frown> l \<in> pre_tCFG.Paths CFGs (ps(t \<mapsto> p))"
proof - assume "tCFG CFGs instr_edges Seq" then interpret tCFG .
show "\<lbrakk>step_rel t G m C a C'; tCFG CFGs instr_edges Seq; CFGs t = Some G;
  l \<in> pre_tCFG.Paths CFGs ps; p = get_point C; p' = get_point C'; ps t = Some p'; p \<in> Nodes G\<rbrakk> \<Longrightarrow>
  [ps(t \<mapsto> p)] \<frown> l \<in> pre_tCFG.Paths CFGs (ps(t \<mapsto> p))"
apply (rule pre_tCFG.path_incremental_gen, unfold_locales, simp)
apply (frule step_along_edge)
apply (erule tCFG.CFGs, simp+)
done
qed

lemma step_increment_rpath: "\<lbrakk>step_rel t G m C a C'; tCFG CFGs instr_edges Seq; CFGs t = Some G;
  l \<in> pre_tCFG.RPaths CFGs ps; p0 = get_point C; p = get_point C'; ps t = Some p0; p0 \<in> Nodes G\<rbrakk> \<Longrightarrow>
 [ps(t \<mapsto> p)] \<frown> l \<in> pre_tCFG.RPaths CFGs (ps(t \<mapsto> p))"
proof - assume "tCFG CFGs instr_edges Seq" then interpret tCFG .
show "\<lbrakk>step_rel t G m C a C'; tCFG CFGs instr_edges Seq; CFGs t = Some G;
  l \<in> pre_tCFG.RPaths CFGs ps; p0 = get_point C; p = get_point C'; ps t = Some p0; p0 \<in> Nodes G\<rbrakk> \<Longrightarrow>
 [ps(t \<mapsto> p)] \<frown> l \<in> pre_tCFG.RPaths CFGs (ps(t \<mapsto> p))"
apply (rule rpath_incremental_gen, simp+, clarsimp)
apply (frule step_along_edge)
apply (erule tCFG.CFGs, simp+)
done
qed

lemma one_step_increment_path: "\<lbrakk>one_step t G (C, m) (C', m'); tCFG CFGs instr_edges Seq; CFGs t = Some G;
  l \<in> pre_tCFG.Paths CFGs ps; p = get_point C; p' = get_point C'; ps t = Some p'; p \<in> Nodes G\<rbrakk> \<Longrightarrow>
  [ps(t \<mapsto> p)] \<frown> l \<in> pre_tCFG.Paths CFGs (ps(t \<mapsto> p))"
by (erule one_step.cases, rule step_increment_path, simp+)

lemma one_step_increment_rpath: "\<lbrakk>one_step t G (C, m) (C', m'); tCFG CFGs instr_edges Seq; CFGs t = Some G;
  l \<in> pre_tCFG.RPaths CFGs ps; p0 = get_point C; p = get_point C'; ps t = Some p0; p0 \<in> Nodes G\<rbrakk> \<Longrightarrow>
 [ps(t \<mapsto> p)] \<frown> l \<in> pre_tCFG.RPaths CFGs (ps(t \<mapsto> p))"
by (erule one_step.cases, rule step_increment_rpath, simp+)

lemma conc_step_increment_path: "\<lbrakk>conc_step CFGs C C'; tCFG CFGs instr_edges Seq;
  l \<in> pre_tCFG.Paths CFGs (get_points (fst C')); safe_points CFGs (get_points (fst C))\<rbrakk> \<Longrightarrow>
 [get_points (fst C)] \<frown> l \<in> pre_tCFG.Paths CFGs (get_points (fst C))"
apply (auto elim!: conc_step.cases)
apply (frule_tac ps="get_points (states(t \<mapsto> C'a))" in step_increment_path, auto simp add: safe_points_def)
apply force
apply (subgoal_tac "get_points (states(t \<mapsto> C'a))(t \<mapsto> get_point Ca) = get_points states", simp)
apply (rule ext, clarsimp simp add: map_comp_def)
done

lemma conc_steps_path: "\<lbrakk>(conc_step CFGs)^** (states, mem) (states', mem'); tCFG CFGs instr_edges Seq;
  l \<in> pre_tCFG.Paths CFGs (get_points states'); safe_points CFGs (get_points states)\<rbrakk> \<Longrightarrow>
 \<exists>l'. hd (l' @ [l 0]) = get_points states \<and> l' \<frown> l \<in> pre_tCFG.Paths CFGs (get_points states)"
proof - assume "tCFG CFGs instr_edges Seq" then interpret tCFG .
show "\<lbrakk>(conc_step CFGs)^** (states, mem) (states', mem'); tCFG CFGs instr_edges Seq;
  l \<in> pre_tCFG.Paths CFGs (get_points states'); safe_points CFGs (get_points states)\<rbrakk> \<Longrightarrow>
 \<exists>l'. hd (l' @ [l 0]) = get_points states \<and> l' \<frown> l \<in> pre_tCFG.Paths CFGs (get_points states)"
apply (drule_tac P="\<lambda>(states, mem) (states', mem'). \<forall>l. l \<in> pre_tCFG.Paths CFGs (get_points states') \<and>
  safe_points CFGs (get_points states) \<longrightarrow> (\<exists>l'. hd (l' @ [l 0]) = get_points states \<and>
  l' \<frown> l \<in> pre_tCFG.Paths CFGs (get_points states))" in rtranclp.induct, auto)
apply (rule_tac x="[]" in exI, simp)
apply (drule conc_step_increment_path, simp+)
apply (drule conc_steps_safe, simp+)
by (metis append_is_Nil_conv hd_append2 i_append_assoc i_append_nth_Cons_0 not_Cons_self2)
qed

lemma run_prog_path: "\<lbrakk>run_prog CFGs C; tCFG CFGs instr_edges Seq\<rbrakk> \<Longrightarrow>
  \<exists>C0 mem0. start_state CFGs C0 mem0 \<and> (\<exists>l\<in>pre_tCFG.Paths CFGs (start_points CFGs). \<exists>i. l i = get_points (fst C))"
proof - assume "tCFG CFGs instr_edges Seq" then interpret tCFG .
show "\<lbrakk>run_prog CFGs C; tCFG CFGs instr_edges Seq\<rbrakk> \<Longrightarrow>
  \<exists>C0 mem0. start_state CFGs C0 mem0 \<and> (\<exists>l\<in>pre_tCFG.Paths CFGs (start_points CFGs). \<exists>i. l i = get_points (fst C))"
apply (clarsimp simp add: run_prog_def)
apply (cut_tac q="get_points (fst C)" in exists_path, clarsimp)
apply (case_tac C, clarsimp)
apply (drule conc_steps_path, simp+)
apply clarsimp
apply (rule conjI, force)
apply (rule_tac x="l' \<frown> l" in bexI, simp_all)
apply (rule_tac x="length l'" in exI, simp)
done
qed

(* The step-star relation as inducing a list of intermediate states. *)
lemma conc_step_star_steps: "(conc_step CFGs)^** C C' \<Longrightarrow>
 \<exists>l. hd (l @ [C']) = C \<and> (\<forall>i<length l. conc_step CFGs (l ! i) ((l @ [C']) ! Suc i))"
apply (induct rule: rtranclp_induct, auto)
apply (rule_tac x="[]" in exI, simp)
apply (rule_tac x="l @ [(a, b)]" in exI, clarsimp)
apply (rule conjI, case_tac l, simp+)
apply clarsimp
apply (case_tac "i = length l", clarsimp simp add: nth_append)
apply (erule_tac x=i in allE, auto simp add: nth_append)
done

lemma step_star_path: "\<lbrakk>hd (l' @ [C']) = C; \<forall>i<length l'. conc_step CFGs (l' ! i) ((l' @ [C']) ! Suc i);
 l \<in> pre_tCFG.Paths CFGs (get_points (fst C')); safe_points CFGs (get_points (fst C)); tCFG CFGs instr_edges Seq\<rbrakk> \<Longrightarrow>
 map (get_points o fst) l' \<frown> l \<in> pre_tCFG.Paths CFGs (get_points (fst C))"
apply (induct l' arbitrary: C l, auto)
apply (case_tac l', auto)
apply (drule conc_step_increment_path, simp+)
apply (subgoal_tac "(get_points a # map (get_points \<circ> fst) list) \<frown> l \<in> pre_tCFG.Paths CFGs (get_points a)")
apply (erule_tac x=0 in allE, clarsimp)
apply (drule conc_step_increment_path, simp+)
apply (subgoal_tac "\<forall>i<Suc (length list). conc_step CFGs (((a, b) # list) ! i) ((list @ [C']) ! i)")
apply (subgoal_tac "safe_points CFGs (get_points a)", force)
apply (erule_tac x=0 in allE, clarsimp, rule conc_step_safe, auto)
done

lemma run_prog_steps: "\<lbrakk>run_prog CFGs C; tCFG CFGs instr_edges Seq\<rbrakk> \<Longrightarrow>
 \<exists>l C0 mem0. start_state CFGs C0 mem0 \<and>
 (\<forall>i<length l. conc_step CFGs (l ! i) ((l @ [C]) ! Suc i)) \<and>
 (\<exists>l'\<in>pre_tCFG.Paths CFGs (get_points (fst C)). map (get_points o fst) l \<frown> l' \<in> pre_tCFG.Paths CFGs (start_points CFGs))"
proof - assume "tCFG CFGs instr_edges Seq" then interpret tCFG .
show "\<lbrakk>run_prog CFGs C; tCFG CFGs instr_edges Seq\<rbrakk> \<Longrightarrow>
 \<exists>l C0 mem0. start_state CFGs C0 mem0 \<and>
 (\<forall>i<length l. conc_step CFGs (l ! i) ((l @ [C]) ! Suc i)) \<and>
 (\<exists>l'\<in>pre_tCFG.Paths CFGs (get_points (fst C)). map (get_points o fst) l \<frown> l' \<in> pre_tCFG.Paths CFGs (start_points CFGs))"
apply (clarsimp simp add: run_prog_def)
apply (drule conc_step_star_steps, clarsimp)
apply (cut_tac q="get_points (fst C)" in exists_path, clarsimp)
apply (frule step_star_path, simp+)
apply (rule conjI, force+)
done
qed

lemma conc_step_star_path2: "\<lbrakk>(conc_step CFGs)^** C C'; l \<in> pre_tCFG.Paths CFGs (get_points (fst C'));
 safe_points CFGs (get_points (fst C)); tCFG CFGs instr_edges Seq\<rbrakk> \<Longrightarrow>
 \<exists>l'. hd (l' @ [l 0]) = get_points (fst C) \<and> l' \<frown> l \<in> pre_tCFG.Paths CFGs (get_points (fst C)) \<and>
 (\<forall>i<length l'. \<exists>C''. l' ! i = get_points (fst C'') \<and> (conc_step CFGs)^** C C'' \<and> (conc_step CFGs)^** C'' C')"
proof - assume "tCFG CFGs instr_edges Seq" then interpret tCFG .
show "\<lbrakk>(conc_step CFGs)^** C C'; l \<in> pre_tCFG.Paths CFGs (get_points (fst C'));
 safe_points CFGs (get_points (fst C)); tCFG CFGs instr_edges Seq\<rbrakk> \<Longrightarrow>
 \<exists>l'. hd (l' @ [l 0]) = get_points (fst C) \<and> l' \<frown> l \<in> pre_tCFG.Paths CFGs (get_points (fst C)) \<and>
 (\<forall>i<length l'. \<exists>C''. l' ! i = get_points (fst C'') \<and> (conc_step CFGs)^** C C'' \<and> (conc_step CFGs)^** C'' C')"
apply (induct arbitrary: l rule: rtranclp_induct, auto)
apply (rule_tac x="[]" in exI, simp)
apply (frule conc_step_increment_path, simp+)
apply (case_tac C, rule conc_steps_safe, simp+)
apply (subgoal_tac "\<exists>l'. hd (l' @ [get_points a]) = get_points (fst C) \<and> l' \<frown> [get_points a] \<frown> l \<in>
 pre_tCFG.Paths CFGs (get_points (fst C)) \<and> (\<forall>i<length l'. \<exists>aa. l' ! i = get_points aa \<and> (\<exists>ba.
 (conc_step CFGs)^** C (aa, ba) \<and> (conc_step CFGs)^** (aa, ba) (a, b)))", clarsimp)
apply (rule_tac x="l' @ [get_points a]" in exI, clarsimp)
apply (rule conjI, case_tac l', simp+)
apply clarsimp
   apply (case_tac "i = length l'", clarsimp)
apply (rule_tac x=a in exI, simp, rule_tac x=b in exI, simp)
apply (erule_tac x=i in allE, clarsimp)
apply (rule_tac x=aaa in exI, simp add: nth_append)
apply (rule_tac x=baa in exI, simp)
by (metis i_append_nth_Cons_0)
qed

lemma run_prog_path2: "\<lbrakk>run_prog CFGs C; tCFG CFGs instr_edges Seq\<rbrakk> \<Longrightarrow>
  \<exists>C0 mem0. start_state CFGs C0 mem0 \<and> (\<exists>l\<in>pre_tCFG.Paths CFGs (start_points CFGs).
    \<exists>i. l i = get_points (fst C) \<and> (\<forall>j<i. \<exists>C'. run_prog CFGs C' \<and> l j = get_points (fst C')))"
proof - assume "tCFG CFGs instr_edges Seq" then interpret tCFG .
show "\<lbrakk>run_prog CFGs C; tCFG CFGs instr_edges Seq\<rbrakk> \<Longrightarrow>
  \<exists>C0 mem0. start_state CFGs C0 mem0 \<and> (\<exists>l\<in>pre_tCFG.Paths CFGs (start_points CFGs).
    \<exists>i. l i = get_points (fst C) \<and> (\<forall>j<i. \<exists>C'. run_prog CFGs C' \<and> l j = get_points (fst C')))"
apply (clarsimp simp add: run_prog_def)
apply (cut_tac q="get_points (fst C)" in exists_path, clarsimp)
apply (drule conc_step_star_path2, simp+)
apply clarsimp
apply (rule conjI, force)
apply (rule_tac x="l' \<frown> l" in bexI, simp_all)
apply (rule_tac x="length l'" in exI, clarsimp)
by smt
qed

lemma run_prog_rpath: "\<lbrakk>run_prog CFGs C; tCFG CFGs instr_edges Seq\<rbrakk> \<Longrightarrow>
  \<exists>l. l \<in> pre_tCFG.RPaths CFGs (get_points (fst C))"
proof - assume "tCFG CFGs instr_edges Seq" then interpret tCFG .
show "\<lbrakk>run_prog CFGs C; tCFG CFGs instr_edges Seq\<rbrakk> \<Longrightarrow>
  \<exists>l. l \<in> pre_tCFG.RPaths CFGs (get_points (fst C))"
by (drule run_prog_path, simp, clarsimp, drule_tac i=i in reverse_path, simp, force)
qed

(* simulation relations and lifting *)
definition "lift_reach_sim_rel sim_rel CFGs CFGs' t C C' \<equiv>
 run_prog CFGs C \<and> run_prog CFGs' C' \<and> (case (C, C') of ((states, mem), (states', mem')) \<Rightarrow>
 (\<exists>s s' G G'. states t = Some s \<and> states' t = Some s' \<and> CFGs t = Some G \<and> CFGs' t = Some G' \<and>
 sim_rel G G' (s, mem) (s', mem')) \<and> (\<forall>t'. t' \<noteq> t \<longrightarrow> states t' = states' t'))"

definition "add_reach CFGs CFGs' t sim_rel G G' c c' \<equiv> \<exists>S S'. S t = Some (fst c) \<and>
 run_prog CFGs (S, snd c) \<and> S' t = Some (fst c') \<and> run_prog CFGs' (S', snd c') \<and> sim_rel G G' c c'"

lemma add_reach_sim_rel: "\<lbrakk>sim_rel G G' c c'; \<exists>S S'. S t = Some (fst c) \<and> run_prog CFGs (S, snd c) \<and>
  S' t = Some (fst c') \<and> run_prog CFGs' (S', snd c')\<rbrakk> \<Longrightarrow>
 add_reach CFGs CFGs' t sim_rel G G' c c'"
by (simp add: add_reach_def)

end

locale sim_base = step_rel
  where free_set = "free_set :: 'memory \<Rightarrow> 'loc set"
    and can_read = "can_read :: 'memory \<Rightarrow> 'thread \<Rightarrow> 'loc \<Rightarrow> 'val set"
    and start_state="start_state::('thread \<rightharpoonup> ('node, 'edge_type, 'instr) flowgraph) \<Rightarrow>
  ('thread \<rightharpoonup> 'config) \<Rightarrow> 'memory \<Rightarrow> bool"
    and update_mem=
        "update_mem::'memory \<Rightarrow> ('thread, 'loc, 'val) access set \<Rightarrow> 'memory \<Rightarrow> bool"
    and step_rel = "step_rel ::
          'thread
           \<Rightarrow> ('node, 'edge_type, 'instr) flowgraph
              \<Rightarrow> 'memory \<Rightarrow> 'config \<Rightarrow> ('thread, 'loc, 'val) access set \<Rightarrow> 'config \<Rightarrow> bool"
    and start_mem = "start_mem:: 'memory"
  and get_point="get_point::'config \<Rightarrow> 'node"
  and instr_edges="instr_edges::'instr \<Rightarrow> ('edge_type \<Rightarrow> nat) set"
  and Seq="Seq::'edge_type"+
  tCFG?: tCFG
   where CFGs="CFGs::('thread \<rightharpoonup> ('node, 'edge_type, 'instr) flowgraph)"
   and instr_edges="instr_edges::'instr \<Rightarrow> ('edge_type \<Rightarrow> nat) set"
  and Seq="Seq::'edge_type" +
  tCFG': tCFG
   where CFGs="CFGs'::('thread \<rightharpoonup> ('node, 'edge_type, 'instr) flowgraph)"
   and instr_edges="instr_edges::'instr \<Rightarrow> ('edge_type \<Rightarrow> nat) set"
  and Seq="Seq::'edge_type"
  for free_set can_read step_rel get_point instr_edges Seq start_state update_mem start_mem CFGs CFGs' +
  assumes step_read_ops: "\<lbrakk>step_rel t G mem C ops C'; CFGs t = Some G;
    \<forall>l\<in>get_ptrs ops. can_read mem t l = can_read mem' t l; free_set mem = free_set mem'\<rbrakk> \<Longrightarrow>
    step_rel t G mem' C ops C'"
      and ops_thread: "\<lbrakk>step_rel t G mem state ops state'; CFGs t = Some G; a \<in> ops\<rbrakk> \<Longrightarrow> get_thread a = t"
begin

lemma sim_by_reachable_thread_mem_obs [rule_format]:
"\<lbrakk>tCFG_sim (add_reach CFGs' CFGs t sim_rel G' G) (=) G' G (one_step t) obs (get_mem o snd);
 CFGs t = Some G; CFGs' t = Some G'; \<forall>t'. t' \<noteq> t \<longrightarrow> CFGs t' = CFGs' t'; \<forall>mem s mem' s'.
 sim_rel G' G (s, mem) (s', mem') \<longrightarrow> (\<forall>S. run_prog CFGs' (S, mem) \<longrightarrow> (free_set mem = free_set mem' \<and>
 (\<forall>t' ops s1 s2. run_prog CFGs' (S, mem) \<and> run_prog CFGs (S(t \<mapsto> s'), mem') \<and> S t = Some s \<and>
 S t' = Some s1 \<and> t' \<noteq> t \<and> t' \<in> dom CFGs \<longrightarrow> (step_rel t' (the (CFGs t')) mem s1 ops s2  \<longrightarrow>
 (\<forall>l\<in>get_ptrs ops. can_read mem t' l = can_read mem' t' l)) \<and>
 (step_rel t' (the (CFGs t')) mem' s1 ops s2  \<longrightarrow> (\<forall>mem2. update_mem mem ops mem2 \<and> t \<notin> get_thread ` ops \<longrightarrow>
 (\<exists>mem2'. update_mem mem' ops mem2' \<and> (\<forall>l\<in>obs. get_mem mem2' l = get_mem mem2 l) \<and> sim_rel G' G (s, mem2) (s', mem2')))))))\<rbrakk> \<Longrightarrow>
 tCFG_sim (lift_reach_sim_rel sim_rel CFGs' CFGs t) (=) CFGs' CFGs conc_step obs (get_mem o snd)"
apply (simp add: tCFG_sim_def, unfold_locales, clarsimp simp add: trsys_of_tCFG_def)
apply (rule conc_step.cases, simp+, clarsimp simp add: lift_reach_sim_rel_def)
apply (rule conjI, clarsimp)
apply (drule_tac sa="(C, mem)" and sb="(s', ba)" in simulation.simulation)
apply (clarsimp simp add: add_reach_def)
apply (rule_tac x=states in exI, simp, rule_tac x=aa in exI, simp)
apply (clarsimp simp add: trsys_of_tCFG_def)
apply (rule conjI, erule step_single, simp+)
apply (clarsimp simp add: trsys_of_tCFG_def add_reach_def)
apply (erule one_step.cases, clarsimp)
apply ((rule exI)+, rule context_conjI, rule_tac t=t in step_thread, simp add: dom_def, simp+)
apply (rule conjI, erule run_prog_step, simp+)
apply (erule run_prog_step, simp+)
apply clarsimp
apply (subgoal_tac "aa = states(t \<mapsto> s')", thin_tac "\<forall>t'. t' \<noteq> t \<longrightarrow> states t' = aa t'",
 clarsimp)
   apply (erule_tac x=ta in allE)
   apply (erule_tac x = mem in allE)
   apply (erule_tac x = s in allE)
   apply (erule_tac x = mem' in allE)
  apply (erule_tac x = s' in allE)
  apply (erule impE, simp)
apply (erule_tac x=states in allE, clarsimp)
apply (erule_tac x=ta in allE, erule_tac x=ops in allE, erule_tac x=C in allE, simp, erule impE,
  simp add: dom_def)
apply (erule_tac x=C' in allE, clarsimp)
apply (drule_tac mem=mem and mem'=ba in step_read_ops, simp+)
apply (erule_tac x=mem' in allE, clarsimp)
apply (erule impE, clarsimp)
apply (cut_tac t=ta in ops_thread, simp_all, simp+)
apply clarsimp
apply (rule exI, rule_tac x=mem2' in exI, rule context_conjI, rule_tac t=ta in step_thread,
 simp add: dom_def, simp+)
apply (rule conjI, erule run_prog_conc_step, simp+)
apply (rule conjI, erule run_prog_conc_step, simp+)
apply (clarsimp intro!: ext simp add: restrict_map_def)
apply (rule ext, simp)
done

(* Slightly reorganized other-threads hypothesis. *)
lemma sim_by_reachable_thread_obs [rule_format]:
"\<lbrakk>tCFG_sim (add_reach CFGs' CFGs t sim_rel G' G) (=) G' G (one_step t) obs (get_mem o snd);
 CFGs t = Some G; CFGs' t = Some G'; \<forall>t'. t' \<noteq> t \<longrightarrow> CFGs t' = CFGs' t';
 \<forall>mem s mem' s'. sim_rel G' G (s, mem) (s', mem') \<longrightarrow> (free_set mem = free_set mem' \<and>
 (\<forall>t' ops s1 s2 S. run_prog CFGs' (S, mem) \<and> run_prog CFGs (S(t \<mapsto> s'), mem') \<and>
 S t = Some s \<and> S t' = Some s1 \<and> t' \<noteq> t \<and> t' \<in> dom CFGs \<longrightarrow>
 (step_rel t' (the (CFGs t')) mem s1 ops s2  \<longrightarrow> (\<forall>l\<in>get_ptrs ops. can_read mem t' l = can_read mem' t' l)) \<and>
 (step_rel t' (the (CFGs t')) mem' s1 ops s2  \<longrightarrow> (\<forall>mem2. update_mem mem ops mem2 \<and> t \<notin> get_thread ` ops \<longrightarrow>
 (\<exists> mem2'. update_mem mem' ops mem2' \<and> (\<forall>l\<in>obs. get_mem mem2' l = get_mem mem2 l) \<and> sim_rel G' G (s, mem2) (s', mem2'))))))\<rbrakk> \<Longrightarrow>
 tCFG_sim (lift_reach_sim_rel sim_rel CFGs' CFGs t) (=) CFGs' CFGs conc_step obs (get_mem o snd)"
apply (rule sim_by_reachable_thread_mem_obs, simp+)
apply clarsimp
apply (erule_tac x=mem in allE, erule_tac x=s in allE, erule_tac x=mem' in allE,
  erule_tac x=s' in allE, erule impE, assumption, clarsimp)
apply (erule_tac x=t' in allE, erule_tac x=ops in allE, erule_tac x=s1 in allE, erule impE)
apply (rule_tac x=S in exI, force)
apply (erule_tac x=s2 in allE, force)
done

lemma sim_by_reachable_thread [rule_format]: "\<lbrakk>tCFG_sim (add_reach CFGs' CFGs t sim_rel G' G) (op =)
 G' G (one_step t) UNIV (get_mem o snd); CFGs t = Some G; CFGs' t = Some G';
 \<forall>t'. t' \<noteq> t \<longrightarrow> CFGs t' = CFGs' t'; \<forall>mem s mem' s'. sim_rel G' G (s, mem) (s', mem') \<longrightarrow>
 (free_set mem = free_set mem' \<and> (\<forall>t'. t' \<noteq> t \<longrightarrow> can_read mem t' = can_read mem' t') \<and>
 (\<forall>ops mem2. update_mem mem ops mem2 \<and> t \<notin> get_thread ` ops \<longrightarrow>
 (\<exists>mem2'. update_mem mem' ops mem2' \<and> get_mem mem2' = get_mem mem2 \<and> sim_rel G' G (s, mem2) (s', mem2'))))\<rbrakk> \<Longrightarrow>
 tCFG_sim (lift_reach_sim_rel sim_rel CFGs' CFGs t) (op =) CFGs' CFGs conc_step UNIV (get_mem o snd)"
apply (erule sim_by_reachable_thread_obs, auto simp add: fun_upd_def)
by (smt UNIV_I UNIV_eq_I domD domI)

lemma sim_no_mem [rule_format]: "\<lbrakk>tCFG_sim (add_reach CFGs' CFGs t sim_rel G' G) (op =)
 G' G (one_step t) UNIV (get_mem o snd); CFGs t = Some G; CFGs' t = Some G';
 \<forall>t'. t' \<noteq> t \<longrightarrow> CFGs t' = CFGs' t'; \<forall>mem s mem' s'. sim_rel G' G (s, mem) (s', mem') \<longrightarrow> mem = mem';
 \<forall>s s' mem ops mem'. sim_rel G' G (s, mem) (s', mem) \<and> t \<notin> get_thread ` ops \<and> update_mem mem ops mem' \<longrightarrow>
 sim_rel G' G (s, mem') (s', mem')\<rbrakk> \<Longrightarrow>
 tCFG_sim (lift_reach_sim_rel sim_rel CFGs' CFGs t) (op =) CFGs' CFGs conc_step UNIV (get_mem o snd)"
by (rule sim_by_reachable_thread, simp+, metis)

end

end


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

A trivial example of reasoning about an array of processes
*)

theory TimerArray imports "../UNITY_Main" begin

type_synonym 'a state = "nat * 'a"   (*second component allows new variables*)

definition count :: "'a state => nat"
  where "count s = fst s"

definition decr  :: "('a state * 'a state) set"
  where "decr = (UN n uu. {((Suc n, uu), (n,uu))})"

definition Timer :: "'a state program"
  where "Timer = mk_total_program (UNIV, {decr}, UNIV)"

declare Timer_def [THEN def_prg_Init, simp]

declare count_def [simp] decr_def [simp]

(*Demonstrates induction, but not used in the following proof*)
lemma Timer_leadsTo_zero: "Timer : UNIV leadsTo {s. count s = 0}"
apply (rule_tac f = count in lessThan_induct, simp)
apply (case_tac "m")
 apply (force intro!: subset_imp_leadsTo)
apply (unfold Timer_def, ensures_tac "decr")
done

lemma Timer_preserves_snd [iff]: "Timer : preserves snd"
apply (rule preservesI)
apply (unfold Timer_def, safety)
done

declare PLam_stable [simp]

lemma TimerArray_leadsTo_zero:
     "finite I
      ==> (plam i: I. Timer) : UNIV leadsTo {(s,uu). ALL i:I. s i = 0}"
apply (erule_tac A'1 = "%i. lift_set i ({0} <*> UNIV)"
       in finite_stable_completion [THEN leadsTo_weaken])
apply auto
(*Safety property, already reduced to the single Timer case*)
 prefer 2
 apply (simp add: Timer_def, safety)
(*Progress property for the array of Timers*)
apply (rule_tac f = "sub i o fst" in lessThan_induct)
apply (case_tac "m")
(*Annoying need to massage the conditions to have the form (... <*> UNIV)*)
apply (auto intro: subset_imp_leadsTo
        simp add: insert_absorb
                  lift_set_Un_distrib [symmetric] lessThan_Suc [symmetric]
               Times_Un_distrib1 [symmetric] Times_Diff_distrib1 [symmetric])
apply (rename_tac "n")
apply (rule PLam_leadsTo_Basis)
apply (auto simp add: lessThan_Suc [symmetric])
apply (unfold Timer_def mk_total_program_def, safety)
apply (rule_tac act = decr in totalize_transientI, auto)
done

end