(*
   Title: Psi-calculi
   Based on the AFP entry by Jesper Bengtson (jebe@itu.dk), 2012
*)
theory Close_Subst
  imports Agent Subst_Term
begin

context subst_psi
begin

definition close_subst :: "('b::fs_name \<times> ('a::fs_name, 'b, 'c::fs_name) psi \<times> ('a, 'b, 'c) psi) set \<Rightarrow> ('b \<times> ('a, 'b, 'c) psi \<times> ('a, 'b, 'c) psi) set"
where "close_subst Rel \<equiv> {(\<Psi>, P, Q) | \<Psi> P Q. (\<forall>\<sigma>. well_formed_subst \<sigma> \<longrightarrow> (\<Psi>, P[<\<sigma>>], Q[<\<sigma>>]) \<in> Rel)}"

lemma close_substI:
  fixes \<Psi> :: 'b
  and   P :: "('a, 'b, 'c) psi"
  and   Q :: "('a, 'b, 'c) psi"

  assumes "\<And>\<sigma>. well_formed_subst \<sigma> \<Longrightarrow> (\<Psi>, P[<\<sigma>>], Q[<\<sigma>>]) \<in> Rel"

  shows "(\<Psi>, P, Q) \<in> close_subst Rel"
using assms
by(unfold close_subst_def) auto

lemma close_substE:
  fixes \<Psi> :: 'b
  and   P :: "('a, 'b, 'c) psi"
  and   Q :: "('a, 'b, 'c) psi"
  and   \<sigma> :: "(name list \<times> 'a list) list"

  assumes "(\<Psi>, P, Q) \<in> close_subst Rel"
  and     "well_formed_subst \<sigma>"

  shows "(\<Psi>, P[<\<sigma>>], Q[<\<sigma>>]) \<in> Rel"
using assms
by(unfold close_subst_def) auto

lemma close_subst_closed:
  fixes \<Psi> :: 'b
  and   P :: "('a, 'b, 'c) psi"
  and   Q :: "('a, 'b, 'c) psi"
  and   p :: "name prm"

  assumes "eqvt Rel"
  and     "(\<Psi>, P, Q) \<in> close_subst Rel"

  shows "(p \<bullet> \<Psi>, p \<bullet> P, p \<bullet> Q) \<in> close_subst Rel"
proof(rule close_substI)
  fix \<sigma>
  assume "well_formed_subst(\<sigma>::(name list \<times> 'a list) list)"
  with `(\<Psi>, P, Q) \<in> close_subst Rel` `well_formed_subst \<sigma>`
  have "(\<Psi>, P[<(rev p \<bullet> \<sigma>)>], Q[<(rev p \<bullet> \<sigma>)>]) \<in> Rel"
    by(rule_tac close_substE) auto
  hence "(p \<bullet> \<Psi>, p \<bullet> (P[<(rev p \<bullet> \<sigma>)>]), p \<bullet> (Q[<(rev p \<bullet> \<sigma>)>])) \<in> Rel"
    by(drule_tac p=p in eqvtI[OF `eqvt Rel`]) (simp add: eqvts)
  thus "(p \<bullet> \<Psi>, (p \<bullet> P)[<\<sigma>>], (p \<bullet> Q)[<\<sigma>>]) \<in> Rel"
    by(simp del: seq_subs_def add: eqvts)
qed

lemma close_subst_eqvt:
  assumes "eqvt Rel"

  shows "eqvt(close_subst Rel)"
proof(auto simp add: eqvt_def)
  fix \<Psi> P Q p
  assume "(\<Psi>, P, Q) \<in> close_subst Rel"
  thus "((p::name prm) \<bullet> \<Psi>, p \<bullet> P, p \<bullet> Q) \<in> close_subst Rel"
    by(drule_tac p=p in close_subst_closed[OF `eqvt Rel`]) (simp add: eqvts)
qed

lemma close_subst_unfold:
  fixes \<Psi> :: 'b
  and   P :: "('a, 'b, 'c) psi"
  and   Q :: "('a, 'b, 'c) psi"
  and   \<sigma> :: "(name list \<times> 'a list) list"

  assumes "(\<Psi>, P, Q) \<in> close_subst Rel"
  and     "well_formed_subst \<sigma>"

  shows "(\<Psi>, P[<\<sigma>>], Q[<\<sigma>>]) \<in> close_subst Rel"
proof(rule close_substI)
  fix \<sigma>'::"(name list \<times> 'a list) list"
  assume "well_formed_subst \<sigma>'"
  with `well_formed_subst \<sigma>` have "well_formed_subst(\<sigma>@\<sigma>')" by simp
  with `(\<Psi>, P, Q) \<in> close_subst Rel` have "(\<Psi>, P[<(\<sigma>@\<sigma>')>], Q[<(\<sigma>@\<sigma>')>]) \<in> Rel"
    by(rule close_substE)
  thus "(\<Psi>, P[<\<sigma>>][<\<sigma>'>], Q[<\<sigma>>][<\<sigma>'>]) \<in> Rel"
    by simp
qed

end

end


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

theory SingleSuccedent
imports "~~/src/HOL/Library/Multiset"
begin

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

text{*
\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:
*}

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{*
\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:
*}
defs extend_def : "extend forms seq \<equiv> if (succ seq = Em)
                  then (antec forms + antec seq) \<Rightarrow>* (succ forms)
                  else (antec forms + antec seq \<Rightarrow>* succ seq)"

(*<*)
defs extendRule_def : "extendRule forms R \<equiv> (map (extend forms) (fst R), extend forms (snd R))"

(* 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 `\<forall> p \<in> set (a # as). \<exists> n. (p,n) \<in> derivable R` 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 `r = (ps,c)` and `r \<in> R` have "(c,m+1) \<in> derivable R" using `ps \<noteq> []` and
    derivable.step[where r="(ps,c)" and R=R and m=m] by auto
  then show ?case using `r = (ps,c)` 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.  *)
defs invertible_def : "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*)"

defs invertible_set_def : "invertible_set R \<equiv> \<forall> (ps,c) \<in> R. invertible (ps,c) R"

(* 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 :# \<Gamma>'"
      proof-
      from assms have "set_of (\<Gamma> \<oplus> A) = set_of (\<Gamma>' \<oplus> B)" by auto
      then have "set_of \<Gamma> \<union> {A} = set_of \<Gamma>' \<union> {B}" by auto
      then have "set_of \<Gamma> \<union> {A} \<subseteq> set_of \<Gamma>' \<union> {B}" by simp
      then have "A \<in> set_of \<Gamma>'" using assms by auto
      thus "A :# \<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 `\<Gamma> \<oplus> A = \<Gamma>' \<oplus> B` eq1 have "\<Gamma> \<oplus> A = \<Gamma>'' \<oplus> A \<oplus> B" by auto
  then have "\<Gamma> = \<Gamma>'' \<oplus> B" by (auto simp add:multiset_eq_iff)
  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 :# \<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 :# \<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 :# \<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 :# \<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 `p \<in> set ps` have "extend S p \<in> set (map (extend S) ps)" by auto
moreover from `(Ps,C) = extendRule S r` and `r = (ps,c)` 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 `(Ps,C) \<in> R*` 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 `r \<in> R` and `R = Ax \<union> R'` 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 `r \<in> R` have "r \<in> Ax \<or> r \<in> upRules" using b c by auto
 with `r = ([],c)` have "r \<in> Ax" by (auto) (rule upRules.cases,auto)
 with `r = ([],c)` 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 `r = ([],c)`
          by (auto simp add:extendRule_def extend_def)
     then have "At i :# \<Gamma>" using extendID by auto
     then have "At i :# \<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 `At i = E` 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 `r = ([],c)`
          by (auto simp add:extendRule_def extend_def)
     then have "ff :# \<Gamma>" using extendFalsum by auto
     then have "ff :# \<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 `n=0` 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 `r = (ps,c)` 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 `n = Suc n'` and `m\<le>n'`
                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 `\<delta>' = Em`
                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 `n = Suc n'` and `m\<le>n'`
                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 `\<delta>' \<noteq> Em`
                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 `m\<le>n'` 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 `r = (ps,c)` by (auto simp add:extendRule_def)
 moreover have "extendRule (\<Gamma>1 + \<Gamma>' \<Rightarrow>* \<delta>) r \<in> R*"
          using `r \<in> upRules` and `r \<in> R` by auto
 moreover from `S = (\<Gamma>1 \<Rightarrow>* \<delta>)` 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 `fst r \<noteq> []` by (cases r) (auto simp add:map_is_Nil_conv extendRule_def)
 then show "( \<Gamma> + \<Gamma>' \<Rightarrow>* E, n) \<in> derivable R*" using `n = Suc n'` by auto
 qed
qed

(*>*)
text{*
\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:
*}
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*"   -- "Proof omitted"
(*<*)
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 `r \<in> R` have "r \<in> Ax \<or> r \<in> upRules" using b c by auto
 with `r = ([],c)` have "r \<in> Ax" by (auto) (rule upRules.cases,auto)
 with `r = ([],c)` 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 `r = ([],c)` 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 `r = ([],c)`
          by (auto simp add:extendRule_def extend_def)
     then have "ff :# \<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 `n=0` 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 `r = (ps,c)` 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 `r= (ps,c)` by (auto simp add:extendRule_def extend_def)
     then have "S = (\<Gamma>1 \<Rightarrow>* Em)" using `S = (\<Gamma>1 \<Rightarrow>* \<delta>)` by simp
     with h as `r = (ps,c)` 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 `n = Suc n'` and `m\<le>n'`
                    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 `\<delta>' = Em`
                    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 `\<delta>' \<noteq> Em` 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 `m\<le>n'` 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 `r = (ps,c)` by (auto simp add:extendRule_def)
     moreover have "extendRule (\<Gamma>1  \<Rightarrow>* C) r \<in> R*"
              using `r \<in> upRules` and `r \<in> R` by auto
     moreover from `S = (\<Gamma>1 \<Rightarrow>* Em)` 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 `fst r \<noteq> []` by (cases r) (auto simp add:map_is_Nil_conv extendRule_def)
    }
 ultimately show "( \<Gamma> \<Rightarrow>* C, n) \<in> derivable R*" using `n = Suc n'` by auto
 qed
qed

(* ---------------------------------------------------
   ---------------------------------------------------
   ---------------------------------------------------
   ---------------------------------------------------
                THIS IS NOW
                SingleInvertible.thy
   ---------------------------------------------------
   ---------------------------------------------------
   ---------------------------------------------------
   --------------------------------------------------- *)
(*>*)
text{*
\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:
*}

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 `extendRule S r = ([],\<Gamma> \<Rightarrow>* Compound F Fs)`
            by (auto simp add:extendRule_def extend_def)
       with `extendRule S r = ([],\<Gamma> \<Rightarrow>* Compound F Fs)`
            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 :# \<Gamma>" using extendFalsum[where S=S and \<Gamma>=\<Gamma> and \<Delta>="Compound F Fs"] by auto
       then have "ff :# \<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 `r \<in> upRules` have "(x,y) \<in> upRules" by simp
            then obtain Ps where "(Ps :: 'a sequent list) \<noteq> []" and "x=Ps" by (cases) (auto)
            with `r = (x,y)` have "r = (Ps, y)" by simp
            then show "\<exists> Ps C. Ps \<noteq> [] \<and> r = (Ps,C)" using `Ps \<noteq> []` by blast
            qed
       then obtain Ps C where "Ps \<noteq> []" and "r = (Ps,C)" by auto
       moreover from `extendRule S r = ([], \<Gamma> \<Rightarrow>* Compound F Fs)` 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 `n=0` 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 `Ps \<noteq> []` 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 `r=(x,y)` 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 `r \<in> R'` by auto
         then have "\<exists> T Ts. c = (\<LM>Compound T Ts\<RM> \<Rightarrow>* Em) \<or> c = (\<Empt> \<Rightarrow>* Compound T Ts)" using `r=(ps,c)`
              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 `r = (ps,c)` by (auto simp add:extendRule_def extend_def)
             then have "rightPrincipal r (Compound F Fs)" using `c = (\<Empt> \<Rightarrow>* Compound T Ts)` and `r = (ps,c)`
                  by auto
             then have "(\<Gamma>' \<Rightarrow>* E) \<in> set ps" using b' and `r = (ps,c)` and `r \<in> R'` and rules
                  by auto
             then have "extend S (\<Gamma>' \<Rightarrow>* E) \<in> set Ps" using `extendRule S r = (Ps,\<Gamma> \<Rightarrow>* Compound F Fs)`
                  and `r = (ps,c)` by (simp add:extendContain)
             moreover from `rightPrincipal r (Compound F Fs)` have "c = (\<Empt> \<Rightarrow>* Compound F Fs)"
                  using `r = (ps,c)` by (cases) auto
             with ext have "antec S = \<Gamma>"
                  using `r = (ps,c)` 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 `\<forall> p \<in> set Ps. \<exists> n\<le>n'. (p,n) \<in> derivable R*` by auto
             then have "\<exists> m\<le>n. (\<Gamma> + \<Gamma>' \<Rightarrow>* E,m) \<in> derivable R*" using `n = Suc n'`
                  by (auto,rule_tac x=m in exI) (simp)
            }
         moreover
            {assume "c = (\<LM>Compound T Ts\<RM> \<Rightarrow>* Em)"
             with ext and `r = (ps,c)`
                  have "Compound T Ts :# \<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 `c = (\<LM>Compound T Ts\<RM> \<Rightarrow>* Em)` and `r = (ps,c)` 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 `r = (ps,c)` and `c = (\<LM>Compound T Ts\<RM> \<Rightarrow>* Em)` 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 `r= (ps,c)` 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 `p \<in> set ps` by auto
                      with IH and `n = Suc n'` 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 `m\<le>n'`
                           and p and `\<delta>i = Em` 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 `p \<in> set ps` 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 `m\<le>n'`
                           and p and `\<delta>i \<noteq> Em` 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 `r = (ps,c)` by (auto simp add:extendRule_def)
             moreover have "extendRule (\<Gamma>1 + \<Gamma>' \<Rightarrow>* E) r \<in> R*" using `r \<in> R'` and rules by auto
             moreover from `S = (\<Gamma>1 \<Rightarrow>* Compound F Fs)` and ext and `c = (\<LM>Compound T Ts\<RM> \<Rightarrow>* Em)`
                 and `\<Gamma> = \<Gamma>1 \<oplus> Compound T Ts` and `r = (ps,c)`
                 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 `r = (ps,c)` and `Ps \<noteq> []` 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 `n = Suc n'` 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 `extendRule S r = ([],\<Gamma> \<oplus> Compound F Fs \<Rightarrow>* \<delta>)`
            by (auto simp add:extendRule_def extend_def)
       moreover
          {assume "r = ([], \<LM>ff\<RM> \<Rightarrow>* Em)"
           with `extendRule S r = ([],\<Gamma> \<oplus> Compound F Fs \<Rightarrow>* \<delta>)`
                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 :# \<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 :# \<Gamma>" by auto
           then have "ff :# \<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 `extendRule S r = ([], \<Gamma> \<oplus> Compound F Fs \<Rightarrow>* \<delta>)`
                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 :# \<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 :# \<Gamma>" by auto
           then have "At i :# \<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 `r \<in> upRules` have "(x,y) \<in> upRules" by simp
            then obtain Ps where "(Ps :: 'a sequent list) \<noteq> []" and "x=Ps" by (cases) (auto)
            with `r = (x,y)` have "r = (Ps, y)" by simp
            then show "\<exists> Ps C. Ps \<noteq> [] \<and> r = (Ps,C)" using `Ps \<noteq> []` by blast
            qed
       then obtain Ps C where "Ps \<noteq> []" and "r = (Ps,C)" by auto
       moreover from `extendRule S r = ([], \<Gamma> \<oplus> Compound F Fs \<Rightarrow>* \<delta>)` 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 `n=0` 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 `Ps \<noteq> []` 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 `r=(x,y)` 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 `r \<in> R'` by auto
         then have "\<exists> T Ts. c = (\<LM>Compound T Ts\<RM> \<Rightarrow>* Em) \<or> c = (\<Empt> \<Rightarrow>* Compound T Ts)" using `r=(ps,c)`
              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 `r = (ps,c)` 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 `r = (ps,c)` 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 `p \<in> set ps` by auto
                      with IH and `n = Suc n'` and b' have "\<exists> m'\<le>m. (\<Gamma> + \<Gamma>i + \<Gamma>' \<Rightarrow>* \<delta>',m') \<in> derivable R*"
                           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>'" in spec)
                           by (auto simp add:union_ac)
                      then have "\<exists> m\<le>n'. (extend (\<Gamma> + \<Gamma>' \<Rightarrow>* \<delta>') p,m) \<in> derivable R*" using `m\<le>n'`
                           and p and `\<delta>i = Em` 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 `p \<in> set ps` by auto
                      then have "\<exists> m\<le>n'. (\<Gamma> + \<Gamma>i + \<Gamma>' \<Rightarrow>* \<delta>i,m) \<in> derivable R*" using `n = Suc n'` 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 `m\<le>n'`
                           and p and `\<delta>i \<noteq> Em` 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 `r = (ps,c)` by (auto simp add:extendRule_def)
             moreover have "extendRule (\<Gamma> + \<Gamma>' \<Rightarrow>* \<delta>') r \<in> R*" using `r \<in> R'` and rules by auto
             moreover from `S = (\<Gamma> \<oplus> Compound F Fs \<Rightarrow>* \<delta>')` and ext and `c = (\<Empt> \<Rightarrow>* Compound T Ts)`
                 and `r = (ps,c)`
                 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 `r = (ps,c)` and `Ps \<noteq> []` 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 `n = Suc n'` 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 `r = (ps,c)` by auto
                 then have "(\<Gamma>' \<Rightarrow>* Em) \<in> set ps" using b' and `r = (ps,c)` and `r \<in> R'` and rules
                      by auto
                 then have "extend S (\<Gamma>' \<Rightarrow>* Em) \<in> set Ps" using `extendRule S r = (Ps,\<Gamma> \<oplus> Compound F Fs \<Rightarrow>* \<delta>)`
                      and `r = (ps,c)` by (simp add:extendContain)
                 moreover from r and `Compound F Fs = Compound T Ts` have "c = (\<LM>Compound F Fs\<RM> \<Rightarrow>* Em)" by auto
                 with ext have "S = (\<Gamma> \<Rightarrow>* \<delta>)"
                      using `r = (ps,c)` 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 `\<forall> p \<in> set Ps. \<exists> n\<le>n'. (p,n) \<in> derivable R*` by auto
                 then have "\<exists> m\<le>n. (\<Gamma> + \<Gamma>' \<Rightarrow>* \<delta> ,m) \<in> derivable R*" using `n = Suc n'`
                      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 `r = (ps,c)` have "\<delta> = \<delta>'" by (auto simp add:extendRule_def extend_def)
                 then have "S = (\<Gamma>'' \<Rightarrow>* \<delta>)" using `S = (\<Gamma>'' \<Rightarrow>* \<delta>')` by simp
                 with r and `r = (ps,c)` and ext have "\<Gamma> \<oplus> Compound F Fs = \<Gamma>'' \<oplus> Compound T Ts"
                      by (auto simp add:extendRule_def extend_def)
                 with `Compound F Fs \<noteq> Compound T Ts` 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 `S = (\<Gamma>'' \<Rightarrow>* \<delta>)` 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 `r= (ps,c)` 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 `p \<in> set ps` by auto
                          with IH and `n = Suc n'` and b' have "\<exists> m'\<le>m. (\<Gamma>1 + \<Gamma>i + \<Gamma>' \<Rightarrow>* \<delta>,m') \<in> derivable R*"
                               apply auto apply (drule_tac x=m in spec) apply auto
                               apply (drule_tac x="\<Gamma>1 + \<Gamma>i" in spec) apply (drule_tac x=\<delta> in spec)
                               by (auto simp add:union_ac)
                          then have "\<exists> m\<le>n'. (extend (\<Gamma>1 + \<Gamma>' \<Rightarrow>* \<delta>) p,m) \<in> derivable R*" using `m\<le>n'`
                               and p and `\<delta>i = Em` 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 `p \<in> set ps` by auto
                          with IH and `n = Suc n'` and b' have "\<exists> m'\<le>m. (\<Gamma>1 + \<Gamma>i + \<Gamma>' \<Rightarrow>* \<delta>i,m') \<in> derivable R*"
                               apply auto apply (drule_tac x=m in spec) apply auto
                               apply (drule_tac x="\<Gamma>1 + \<Gamma>i" in spec) apply (drule_tac x=\<delta>i in spec)
                               by (auto simp add:union_ac)
                          then have "\<exists> m\<le>n'. (extend (\<Gamma>1 + \<Gamma>' \<Rightarrow>* \<delta>) p,m) \<in> derivable R*" using `m\<le>n'`
                               and p and `\<delta>i \<noteq> Em` and `n = Suc n'` 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 `r = (ps,c)` by (auto simp add:extendRule_def)
                 moreover have "extendRule (\<Gamma>1 + \<Gamma>' \<Rightarrow>* \<delta>) r \<in> R*" using `r \<in> R'` and rules by auto
                 moreover from `S = (\<Gamma>1 \<oplus> Compound F Fs \<Rightarrow>* \<delta>)` and ext and `c = (\<LM>Compound T Ts\<RM> \<Rightarrow>* Em)`
                     and gam1 and `r = (ps,c)`
                     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 `r = (ps,c)` and `Ps \<noteq> []` 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 `n = Suc n'` 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{*
\noindent \textbf{G3ip} can be expressed in this formalism:
*}
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{* \noindent As expected, $\implies{R}{}$ can be shown invertible: *}

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-  -- {*Showing that $A \Rightarrow B$ is a premiss of every rule with $\implies{A}{B}$ principal*}
   {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  -- {* If $\implies{A}{B}$ was principal, then $r \notin Ax$ *}
    from `rightPrincipal r (A \<supset> B)` have "snd r = (\<Empt> \<Rightarrow>* (A \<supset> B))" by(*<*) (rule rightPrincipal.cases)(*>*) auto
    with `r \<in> g3ip` and `rightPrincipal r (A \<supset> B)`
        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 Extended_Assertion
  imports Setup
begin

subsection \<open>Assertion Tree\<close>

datatype ('k, 'v, 'ki, 'vi) assn_tree =
  ATEmpty |
  ATBranch
  (color: color)
  (key: 'k)
  (val: 'v)
  (ll_color: "8 word")
  (ll_left: "('ki, 'vi) rbti")
  (ll_key: 'ki)
  (ll_val: 'vi)
  (ll_right: "('ki, 'vi) rbti")
  (left: "('k, 'v, 'ki, 'vi) assn_tree")
  (right: "('k, 'v, 'ki, 'vi) assn_tree")

subsubsection \<open>rbt of\<close>

fun rbt_of :: "('k, 'v, 'ki, 'vi) assn_tree \<Rightarrow> ('k, 'v) rbt"  where
  "rbt_of ATEmpty = rbt.Empty" |
  "rbt_of (ATBranch c k v _ _ _ _ _ l r) =
    (rbt.Branch c (rbt_of l) k v (rbt_of r))"

declare rbt_of.elims[where y=rbt.Empty, simplified, elim!]
lemma rbt_of_branchE [elim!]:
  assumes
    "rbt_of t = rbt.Branch c l k v r"
  shows
    "\<lbrakk>\<And>al ar. rbt_of al = l \<Longrightarrow> rbt_of ar = r  \<Longrightarrow> (\<And>ci li ki vi ri. t = ATBranch c k v ci li ki vi ri al ar \<Longrightarrow> P)\<rbrakk> \<Longrightarrow> P"
  using assms
  by (blast elim: rbt_of.elims)

lemma rbt_of_branchI [intro!]:
  assumes
    "rbt_of l = l'"
    "rbt_of r = r'"
  shows
    "rbt_of (ATBranch c k v ci li ki vi ri l r) = rbt.Branch c l' k v r'"
  using assms by simp

lemma rbt_of_emptyI [intro!]:
  "rbt_of ATEmpty = rbt.Empty"
  by simp

lemma rbt_of_reorient_branch [simp]:
  "(Branch c l k v r = rbt_of t) = (rbt_of t = Branch c l k v r)" by auto

lemma rbt_of_reorient_empty [simp]:
  "(rbt.Empty = rbt_of t) = (rbt_of t = rbt.Empty)" by auto

subsection \<open>Assertion\<close>

fun assn_unless (infixl "unless" 40) where
  "assn_unless assn b = (if b then \<box> else assn)"
declare assn_unless.simps[simp del]

lemma assn_unless_True [simp]:
  "(assn unless False) = assn"
  by (simp add: assn_unless.simps)

lemma assn_unless_False [simp]:
  "(assn unless True) = \<box>"
  by (simp add: assn_unless.simps)

context rbt_impl
begin
interpretation rbt_impl_deps .

fun rbt_assn_ext :: "('k, 'v, 'ki, 'vi) assn_tree \<Rightarrow> 'k set \<Rightarrow> ('ki, 'vi) rbti \<Rightarrow> ll_assn" where
  "rbt_assn_ext ATEmpty ex p = \<up>(p = null)"
| "rbt_assn_ext (ATBranch c k v ci li ki vi ri l r) ex p =
    (
      \<upharpoonleft>ll_bpto (RBT_NODE ci li ki vi ri) p **
      color_assn c ci **
      rbt_assn_ext l ex li **
      \<upharpoonleft>key_assn k ki **
      \<upharpoonleft>value_assn v vi unless k \<in> ex **
      rbt_assn_ext r ex ri
    )"
declare rbt_assn_ext.simps(2)[simp del]
lemmas rbt_assn_ext_unfold = rbt_assn_ext.simps(2)

lemma rbt_assn_ext_null [simp]:
  "rbt_assn_ext t ex null = \<up>(t =  ATEmpty)"
  apply (cases t)
  using rbt_assn_ext_unfold apply auto
  done

lemma rbt_assn_ext_empty_set_null [simp]:
  "rbt_assn_ext t {} null = \<up>(t  = ATEmpty)" by simp

subsection \<open>Load Rules\<close>

lemma load_rbt [vcg_rules]:
  "
    llvm_htriple
    (rbt_assn_ext (ATBranch c k v ci li ki vi ri l r) ex ti)
    (ll_load ti)
    (\<lambda>res.
      rbt_assn_ext (ATBranch c k v ci li ki vi ri l r) ex ti **
      \<up>(res = RBT_NODE ci li ki vi ri)
    )
  "
  unfolding rbt_assn_ext_unfold
  apply vcg
  done

lemma load_rbt_ext_non_null [vcg_rules]:
  "
    llvm_htriple
    (rbt_assn_ext t {} ti ** \<up>(ti \<noteq> null))
    (ll_load ti)
    (\<lambda>res.
      EXS ci li ki vi ri c l k v r.
      rbt_assn_ext t {} ti **
      \<up>(t = (ATBranch c k v ci li ki vi ri l r)) **
      \<up>(res = RBT_NODE ci li ki vi ri)
    )
  "
  apply vcg
  apply (cases t)
  subgoal by simp (*contradiction*)
  subgoal by vcg
  done

subsection \<open>Reduction Rules\<close>

lemma unfold_rbt_assn_ext_red_rule_1 [fri_red_rules]:
  "
    is_sep_red
    (\<upharpoonleft>ll_bpto (RBT_NODE ci li ki vi ri) ti)
    (
        \<upharpoonleft>ll_bpto (RBT_NODE ci li ki vi ri) ti **
        color_assn c ci **
        rbt_assn_ext l ex li **
        \<upharpoonleft>key_assn k ki **
        \<upharpoonleft>value_assn v vi unless k \<in> ex **
        rbt_assn_ext r ex ri
    )
    (\<upharpoonleft>ll_bpto (RBT_NODE ci li ki vi ri) ti)
    (rbt_assn_ext (ATBranch c k v ci li ki vi ri l r) ex ti)
  "
  apply (rule is_sep_redI)
  unfolding rbt_assn_ext_unfold
  apply simp
  done
thm is_sep_red_def
lemma rbt_assn_ext_key_assn_unfold [fri_red_rules]:
  "
    is_sep_red
    (
      \<upharpoonleft>ll_bpto (RBT_NODE ci li ki vi ri) ti \<and>*
      color_assn c ci \<and>*
      rbt_assn_ext l ex li \<and>*
      \<upharpoonleft>value_assn v vi unless k\<in>ex\<and>*
      rbt_assn_ext r ex ri)
    \<box>
    (rbt_assn_ext (ATBranch c k v ci li ki vi ri l r) ex ti)
    (\<upharpoonleft>key_assn k ki)
  "
  apply (rule is_sep_redI)
  unfolding rbt_assn_ext_unfold
  apply simp
  subgoal premises prems
    apply (sep isep_dest: prems)
    done
  done

lemma rbt_assn_ext_color_assn_unfold [fri_red_rules]:
  "
    is_sep_red
    (
      \<upharpoonleft>ll_bpto (RBT_NODE ci li ki vi ri) ti \<and>*
      rbt_assn_ext l {} li \<and>*
      \<upharpoonleft>key_assn k ki **
      \<upharpoonleft>value_assn v vi \<and>*
      rbt_assn_ext r {} ri)
    \<box>
    (rbt_assn_ext (ATBranch c k v ci li ki vi ri l r) {} ti)
    (color_assn c ci)
  "
  apply (rule is_sep_redI)
  unfolding rbt_assn_ext_unfold
  apply simp
  subgoal premises prems
    apply (sep isep_dest: prems)
    done
  done

lemma rbt_assn_ext_pto_assn_unfold [fri_red_rules]:
  "
    is_sep_red
    (
      color_assn c ci **
      rbt_assn_ext l {} li \<and>*
      \<upharpoonleft>key_assn k ki **
      \<upharpoonleft>value_assn v vi \<and>*
      rbt_assn_ext r {} ri)
    \<box>
    (rbt_assn_ext (ATBranch c k v ci li ki vi ri l r) {} ti)
    (\<upharpoonleft>ll_bpto (RBT_NODE ci li ki vi ri) ti)
  "
  apply (rule is_sep_redI)
  unfolding rbt_assn_ext_unfold
  apply simp
  subgoal premises prems
    apply (sep isep_dest: prems)
    done
  done

lemma rbt_assn_ext_left_assn_unfold [fri_red_rules]:
  "
    is_sep_red
    (
      \<upharpoonleft>ll_bpto (RBT_NODE ci li ki vi ri) ti **
      color_assn c ci **
      \<upharpoonleft>key_assn k ki **
      \<upharpoonleft>value_assn v vi unless k \<in> ex \<and>*
      rbt_assn_ext r ex ri)
    \<box>
    (rbt_assn_ext (ATBranch c k v ci li ki vi ri l r) ex ti)
    (rbt_assn_ext l ex li)
  "
  apply (rule is_sep_redI)
  unfolding rbt_assn_ext_unfold
  apply simp
  subgoal premises prems
    apply (sep isep_dest: prems)
    done
  done

lemma rbt_assn_ext_right_assn_unfold [fri_red_rules]:
  "
    is_sep_red
    (
      \<upharpoonleft>ll_bpto (RBT_NODE ci li ki vi ri) ti **
      color_assn c ci **
      rbt_assn_ext l ex li **
      \<upharpoonleft>key_assn k ki **
      \<upharpoonleft>value_assn v vi unless k \<in> ex
    )
    \<box>
    (rbt_assn_ext (ATBranch c k v ci li ki vi ri l r) ex ti)
    (rbt_assn_ext r ex ri)
  "
  apply (rule is_sep_redI)
  unfolding rbt_assn_ext_unfold
  apply simp
  subgoal premises prems
    apply (sep isep_dest: prems)
    done
  done

subsection \<open>Empty Constructor\<close>

lemma empty_correct_ext [vcg_rules]:
  "llvm_htriple
   \<box>
   empty
   (\<lambda>ti_res. rbt_assn_ext ATEmpty {} ti_res)"
  unfolding empty_def
  by vcg

end

end


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

theory HaskellLemmaBucket
imports
  HaskellLib_H
  NonDetMonadLemmaBucket
begin

lemma map_bits_to_bl:
  "map (op !! x) [0..<size x] = reverse (to_bl x)"
  by (simp add: map_bits_rev_to_bl)

lemma not_orList_is_replicate:
  "\<not> orList ls \<Longrightarrow> ls = replicate (length ls) False"
proof (induct ls rule: rev_induct)
  case Nil thus ?case unfolding orList_def by simp
next
  case (snoc l ls)

  from snoc.prems have ol: "\<not> orList ls" and nl: "\<not> l" unfolding orList_def by auto
  have "ls = replicate (length ls) False" by (rule snoc.hyps [OF ol])
  thus ?case
    by (rule ssubst) (simp add: nl replicate_app_Cons_same [where xs = "[]", simplified])
qed

lemma andList_Cons:
  assumes al: "andList $ map P (y # ys)"
  shows   "P y"
  using al unfolding andList_def
  by simp (induct rule: rev_induct, simp+)

lemma andList_mapE:
  assumes al: "andList $ map P xs"
  and     xv: "x \<in> set xs"
  shows   "P x"
  using al xv
proof (induct xs arbitrary: x rule: rev_induct)
  case Nil thus ?case by simp
next
  case (snoc y ys)

  show ?case
  proof (cases "x = y")
    case True
    with snoc.prems show ?thesis by (simp add: andList_def)
  next
    case False
    with snoc.prems show ?thesis
      by (auto simp: andList_def intro!: snoc.hyps)
  qed
qed

lemma andList_to_aligned:
  assumes al: "andList $ map (\<lambda>x. x && mask pageBits = 0) xs"
  and     xv: "x \<in> set xs"
  shows   "is_aligned x pageBits"
proof (subst is_aligned_mask)
  from al show "x && mask pageBits = 0" by (rule andList_mapE) fact
qed

(* minimum/maximum *)

lemma maximum_ge: "x \<in> set b \<Longrightarrow> x \<le> maximum b"
  unfolding maximum_def by (auto intro: Max_ge)

lemma less_minimum_not_in:
  "\<lbrakk> ls \<noteq> []; x < minimum ls \<rbrakk> \<Longrightarrow> x \<notin> set ls"
  unfolding minimum_def by auto

lemma minimum_le_member:
  "\<lbrakk> x \<in> set ls; ls \<noteq> []\<rbrakk> \<Longrightarrow> minimum ls \<le> x"
  unfolding minimum_def
  apply (rule Min_le)
    apply simp
   apply simp
  done

lemma minimum_map_distrib:
  fixes f :: "('a :: linorder) \<Rightarrow> 'a" and ls :: "'a list"
  assumes minf: "\<And>x y. \<lbrakk>x \<in> set ls; y \<in> set ls\<rbrakk> \<Longrightarrow> min (f x) (f y) = f (min x y)"
  and      lsn: "ls \<noteq> []"
  shows "minimum (map f ls) = f (minimum ls)"
  unfolding minimum_def
  apply simp
  apply (rule Min_image_distrib)
    apply (erule (1) minf)
   apply simp
  apply (simp add: lsn)
  done

lemma minimum_enum_upto:
  fixes x :: "'a::len word"
  assumes le: "x \<le> y"
  shows   "minimum [x .e. y] = x"
  unfolding minimum_def using le by (auto intro!: MinI)

lemma break_subsetsD:
  "break f xs = (ys, zs) \<Longrightarrow> set ys \<subseteq> set xs \<and> set zs \<subseteq> set xs"
  apply (induct xs arbitrary: ys zs)
   apply simp
  apply (case_tac "break f xs")
  apply (elim meta_allE, drule(1) meta_mp)
  apply (fastforce simp: split_def split: if_split_asm)
  done

lemma distinct_prop_breakD:
  "\<lbrakk> distinct_prop P xs; break f xs = (ys, zs) \<rbrakk>
    \<Longrightarrow> \<forall>y \<in> set ys. \<forall>z \<in> set zs. P y z"
  apply (induct xs arbitrary: ys zs)
   apply simp
  apply (simp add: split_def split: if_split_asm)
  apply (case_tac "break f xs")
  apply (elim meta_allE, drule(1) meta_mp)
  apply (frule break_subsetsD)
  apply fastforce
  done

lemma stateAssert_wp:
  "\<lbrace>\<lambda>s. P s \<longrightarrow> Q () s\<rbrace> stateAssert P e \<lbrace>Q\<rbrace>"
  by (clarsimp simp: stateAssert_def) wp

lemma haskell_assert_wp:
  "\<lbrace>\<lambda>s. Q \<longrightarrow> P s\<rbrace> haskell_assert Q xs \<lbrace>\<lambda>_. P\<rbrace>"
  by simp wp

lemma init_append_last:
  "xs \<noteq> [] \<Longrightarrow> init xs @ [last xs] = xs"
  apply (induct xs rule: rev_induct)
   apply simp
  apply (simp add: init_def)
  done

lemma no_fail_stateAssert:
  "no_fail P (stateAssert P xs)"
  apply (simp add: stateAssert_def)
  apply (rule no_fail_pre, wp no_fail_bind)
  apply simp
  done

lemma empty_fail_stateAssert:
  "empty_fail (stateAssert P s)"
  by (simp add: stateAssert_def assert_def empty_fail_get)

lemma haskell_fail_wp:
  "\<lbrace>\<top>\<rbrace> haskell_fail x \<lbrace>P\<rbrace>"
  by simp

lemma no_fail_haskell_fail [simp, wp]:
  "no_fail \<bottom> (haskell_fail xs)"
  by simp

lemma in_assocs_is_fun:
  "(x \<in> set (assocs f)) = (f (fst x) = snd x)"
  by (cases x) (auto simp add: assocs_def)

lemma fun_is_in_assocs:
  "(f x = y) = ((x,y) \<in> set (assocs f))"
  by (simp add: in_assocs_is_fun)

lemma empty_set_is_null:
  "(set xs = {}) = null xs"
  by (clarsimp simp: null_def)

lemma assert_into_when:
  "(assert P) = (when (\<not> P) (haskell_fail []))"
  by (simp add: assert_def when_def)

lemma const_apply:
  "const x y = x"
  by (simp add: const_def)

lemma const_None_empty:
  "const None = empty"
  by (rule ext, simp add: const_apply)

lemma headM_tailM_Cons:
  "headM (x # xs) = return x"
  "tailM (x # xs) = return xs"
  by (simp add: headM_def tailM_def)+

lemma replicateM_mapM:
  "replicateM n f = mapM (\<lambda>x. f) (replicate n ())"
  by (simp add: replicateM_def mapM_def)

lemma orList_False:
  "(\<not> orList bs) = (set bs \<subseteq> {False})"
  apply (induct bs)
  apply (simp_all add: orList_def foldl_True)
  apply (case_tac a)
  apply (simp_all add: orList_def foldl_True)
  done

lemma Cons_eq_tails:
  "((xs # xxs) = tails ys) = (ys = xs \<and> xxs = tl (tails ys))"
  by (case_tac ys, auto)

lemma findM_on_outcome':
  assumes x: "\<And>x xs. \<lbrace>\<lambda>s. Q None s \<and> x \<in> fn s \<and> set xs \<subseteq> fn s\<rbrace> f x
                     \<lbrace>\<lambda>rv s. (rv \<longrightarrow> Q (Some x) s) \<and> (\<not> rv \<longrightarrow> Q None s \<and> set xs \<subseteq> fn s)\<rbrace>"
  shows      "\<lbrace>\<lambda>s. Q None s \<and> set xs \<subseteq> fn s\<rbrace> findM f xs \<lbrace>Q\<rbrace>"
  apply (induct xs)
   apply (simp, wp)
  apply (simp, wp)
   apply (rule x)
  apply simp
  done

lemma findM_on_outcome:
  assumes x: "\<And>x ys. x \<in> set xs \<Longrightarrow> \<lbrace>Q None and I\<rbrace> f x \<lbrace>\<lambda>rv s. (rv \<longrightarrow> Q (Some x) s) \<and> (\<not> rv \<longrightarrow> Q None s \<and> I s)\<rbrace>"
  shows      "\<lbrace>Q None and I\<rbrace> findM f xs \<lbrace>Q\<rbrace>"
  apply (rule hoare_vcg_precond_imp)
   apply (rule findM_on_outcome' [where fn="\<lambda>s. if I s then set xs else {}"])
   apply (case_tac "x \<notin> set xs")
    apply simp
   apply (simp cong: rev_conj_cong)
   apply (case_tac "\<not> set xsa \<subseteq> set xs")
    apply simp
   apply simp
   apply (rule hoare_vcg_precond_imp)
    apply (rule hoare_post_imp [OF _ x])
     apply clarsimp
    apply assumption
   apply simp
  apply simp
  done

lemma in_set_tailsD: "xs \<in> set (tails ys) \<Longrightarrow> set xs \<subseteq> set ys"
  apply (induct ys)
   apply simp
  apply simp
  apply (erule disjE)
   apply simp
  apply simp
  apply blast
  done

lemma notin_set_tails_set:
  "x \<notin> set xs \<Longrightarrow> \<forall>xs' \<in> set (tails xs). \<forall>x' \<in> set xs'. x \<noteq> x'"
  by (fastforce dest!: in_set_tailsD)

lemma set_tails_set: "(set (tails v) \<subseteq> {x. set x \<subseteq> S}) = (set v \<subseteq> S)"
  apply (induct v, simp_all)
  done

lemma filter_assocs_Cons:
  fixes v :: "('a :: len) word" shows
  "\<lbrakk> f (v, g v); \<forall>x < v. \<not> f (x, g x) \<rbrakk> \<Longrightarrow>
     filter f (assocs g) = (v, g v) # tl (filter f (assocs g))"
  apply (simp add: assocs_def)
  apply (cut_tac v=v in enum_word_div)
  apply clarsimp
  apply (subst map_cong [OF _ refl], assumption)+
  apply (simp(no_asm))
  apply simp
  done

lemma snd_stateAssert_after:
  "\<not> snd ((do _ \<leftarrow> f; stateAssert R vs od) s) \<Longrightarrow>
  \<not>snd (f s) \<and> (\<forall>(rv, s') \<in> fst (f s). R s')"
  apply (clarsimp simp: bind_def stateAssert_def get_def assert_def
      return_def fail_def split_def split: if_split_asm)
  done

lemma oblivious_stateAssert [simp]:
  "oblivious f (stateAssert g xs) = (\<forall>s. g (f s) = g s)"
  apply (simp add: oblivious_def stateAssert_def exec_get
                   assert_def return_def fail_def split: if_split)
  apply auto
  done

lemma stateAssert_def2:
  "stateAssert f xs = do v \<leftarrow> gets f; if v then return () else fail od"
  by (simp add: stateAssert_def gets_def assert_def)

lemma findM_is_mapME:
  "(findM f xs >>= g)
   = liftM (\<lambda>_. ())
      (doE ys \<leftarrow> mapME_x (\<lambda>x. do v \<leftarrow> f x;
                             if v then do g (Some x); throwError () od
                             else returnOk () od) xs;
              liftE (g None) odE)"
  apply (induct xs)
   apply (simp add: mapME_x_def sequenceE_x_def liftM_def returnOk_bind)
   apply (simp add: liftE_def)
  apply (simp add: mapME_x_Cons bindE_assoc liftE_bindE[symmetric]
                   liftM_def cong: if_cong)
  apply (simp add: liftE_bindE bind_assoc)
  apply (rule bind_cong[OF refl])
  apply (simp add: bindE_assoc split: if_split)
  apply (simp add: liftE_bindE bind_assoc throwError_bind)
  done

end


theory StoreByteList

imports Main "hoare/Hoare"

begin

lemma word_of_nat [simp] : "word_of_int (int (unat x)) = x"
  by (metis uint_nat word_of_int_uint)

fun store_byte_list_memory_old  :: "w256 \<Rightarrow> byte list \<Rightarrow> memory \<Rightarrow> memory"  where
 " store_byte_list_memory_old pos [] orig = orig"
|" store_byte_list_memory_old pos (h # t) orig = (
     store_byte_list_memory_old (pos +((word_of_int 1) ::  256 word)) t
       (\<lambda> p .  if pos = p then h else orig p))"

lemma find_mod :
  "uint (word_of_int x::w256) = (x::int) mod 2^256"
apply (auto simp:uint_word_of_int)
done

lemma unat_mod [simp]:
  "unat (word_of_int (int x)::w256) = x mod 2^256"
apply (simp add: find_mod unat_def)
  by (metis (mono_tags, hide_lams) Divides.transfer_int_nat_functions(2) nat_int.Rep_inverse' of_nat_numeral)

lemma simp_take :
 "n > 0 \<Longrightarrow>
  take n (a # lst) = a#take (n-1) lst"
using List.take_Suc_Cons [of "n-1" a lst]
apply auto
done

lemma take_index [simp] :
  "i < n \<Longrightarrow>
   i < length lst \<Longrightarrow>
  index (take n lst) i = Some (lst!i)"
apply(simp)
done

lemma minus_one_large :
   "(-1::int) mod 2^256 = 2^256-1"
apply auto
done

lemma minus_one_word :
   "uint (-1::w256) = 2^256-1"
proof -
  have "uint ((word_of_int (-1))::w256) = (-1) mod 2^256"
   using find_mod
   by blast
  then have "uint ((-1)::w256) = (-1) mod 2^256" by auto
  then show ?thesis using minus_one_large by auto
qed

lemma minus_one_word_nat :
   "unat (-1::w256) = 2^256-1"
using minus_one_word
  by (simp add: unat_def)

lemma split_new :
 "n < 2^256 \<Longrightarrow>
  store_byte_list_memory w
     (a # take n lst) mem x =
  store_byte_list_memory (w+1) (take n lst)
    (\<lambda>p. if w = p then a else mem p) x"
apply (auto simp add:store_byte_list_memory_def)
apply (cases "unat (-1) < n")
apply (auto simp: minus_one_word_nat)
apply (cases "unat (x - w) \<le> n")
apply (cases "unat (x - w) \<le> length lst")
apply auto
apply (cases "unat (x - (w+1)) < n")
apply (cases "unat (x - (w+1)) < length lst")
apply auto
subgoal
proof -
  assume a1: "w \<noteq> x"
  assume a2: "unat (x - (w + 1)) < n"
  have "x - w \<noteq> 0"
    using a1 by auto
  then have "lst ! unat (x - (1 + w)) = take n lst ! (unat (x - w) - 1) \<and> 0 \<noteq> unat (x - w)"
    using a2 by (simp add: add.commute diff_add_eq_diff_diff_swap unat_eq_zero unat_minus_one)
  then show "(a # take n lst) ! unat (x - w) = lst ! unat (x - (w + 1))"
    by (simp add: add.commute)
qed
subgoal proof -
  assume a1: "w \<noteq> x"
  assume a2: "unat (x - w) \<le> length lst"
  assume a3: "\<not> unat (x - (w + 1)) < length lst"
  have f4: "\<forall>n. (0::nat) + (n - 0) = n"
    using linordered_semidom_class.add_diff_inverse by blast
  have f5: "(0::nat) + 0 = 0"
    by blast
  have f6: "\<forall>w wa. (w::256 word) + (wa - w) = wa"
    by auto
  have f7: "\<forall>w wa. (w::256 word) + wa - w = wa"
  by simp
  have f8: "\<forall>w. unat ((w::256 word) - 1) < unat w \<or> 0 = w"
    using f5 f4 by (metis (no_types) One_nat_def diff_is_0_eq' diff_less lessI not_le unat_eq_zero unat_minus_one)
  have f9: "\<forall>n. (0::nat) + n = n"
    by linarith
  have "\<forall>n. unat (x - w) - (n + length lst) = 0"
  using a2 by force
  then have "length lst = unat (x - (1 + w)) \<or> x - w = 0"
    using f9 a3 by (metis (no_types) add.commute diff_diff_add linordered_semidom_class.add_diff_inverse unat_minus_one)
  then show "(a # lst) ! unat (x - w) = mem x"
    using f8 f7 f6 a2 a1 by (metis (no_types) diff_add_eq_diff_diff_swap not_le right_minus_eq)
qed
  apply (metis (mono_tags, hide_lams) add.left_neutral cancel_ab_semigroup_add_class.diff_right_commute diff_add_cancel diff_add_eq_diff_diff_swap less_le_trans measure_unat)

apply (cases "unat (x - (w+1)) < n")
apply (cases "unat (x - (w+1)) < length lst")
apply auto
subgoal proof -
  assume a1: "\<not> unat (x - w) \<le> length lst"
  assume "unat (x - (w + 1)) < length lst"
  then have f2: "Suc (unat (x - (w + 1))) \<le> length lst"
    by (metis Suc_leI)
  have "\<forall>n. \<not> n \<le> length lst \<or> unat (of_nat n::256 word) = n"
    using a1 by (metis (no_types) le_unat_uoi less_imp_le not_less)
  then show "mem x = lst ! unat (x - (w + 1))"
    using f2 a1 by fastforce
qed
apply (cases "unat (x - (w+1)) < n")
apply (cases "unat (x - (w+1)) < length lst")
apply auto
proof -
  assume a1: "w \<noteq> x"
  assume a2: "\<not> unat (x - w) \<le> n"
  assume a3: "unat (x - (w + 1)) < n"
  have "\<forall>n. n + 1 = Suc n"
    by presburger
  then have f4: "\<forall>n. n \<le> 0 \<or> Suc (n - 1) = n"
    by (metis (no_types) One_nat_def not_less_eq_eq ordered_cancel_comm_monoid_diff_class.diff_add)
  have f5: "Suc (unat (x - (w + 1))) \<le> n"
    using a3 by auto
  have "\<not> unat (x - w) \<le> 0"
    using a2 by linarith
  then have "x - w = 0"
    using f5 f4 a2 by (metis (no_types) diff_diff_add unat_minus_one)
  then show "mem x = lst ! unat (x - (w + 1))"
    using a1 by (metis right_minus_eq)
  qed

lemma funext : "(\<forall>x. f x = g x) \<Longrightarrow> f = g"
apply auto
done

lemma store_byte_list_eq :
  "n \<le> 2^256 \<Longrightarrow>
   store_byte_list_memory_old w (take n lst) mem =
   store_byte_list_memory w (take n lst) mem"
apply (induction lst arbitrary: w n mem)
apply (auto)
apply (rule funext)
apply (simp add:store_byte_list_memory_def)
apply (rule funext)
apply (auto)
subgoal for a lst w n mem x
apply (cases "n > 0")
defer
apply auto
apply (simp add:store_byte_list_memory_def)
apply (simp add:simp_take)
using split_new
apply force
done
done

end


theory ListReversal
  imports LinkedList Syntax
begin

record rev_list =
  i :: nat
  j :: nat
  k :: nat

no_notation pmult_one_class.pmult_one ("1")

lemma "\<lbrakk>llist xs i, llist (rev xs) j\<rbrakk> \<le>
      `j := 0;
      while `i \<noteq> 0 do
        `k := @(`i + 1);
        @(`i + 1) := `j;
        `j := `i;
        `i := `k
      od"
proof -
  have "\<lbrakk>llist xs i, llist (rev xs) j\<rbrakk> \<le>
      `j := 0;
      \<lbrakk>EXS A B. llist A i * llist B j * \<langle>rev xs = (rev A) @ B\<rangle>, llist (rev xs) j\<rbrakk>"
      by morgan (sep_auto, auto)
  also have "... \<le>
      `j := 0;
      while `i \<noteq> 0 do
        \<lbrakk>EXS A B. llist A i * llist B j * \<langle>rev xs = (rev A) @ B\<rangle> * \<langle>`i \<noteq> 0\<rangle>,
         EXS A B. llist A i * llist B j * \<langle>rev xs = (rev A) @ B\<rangle>\<rbrakk>
      od"
      by morgan sep_auto+
  also have "... \<le>
      `j := 0;
      while `i \<noteq> 0 do
        \<lbrakk>EXS A B a k. (i \<mapsto> $a, $k) * llist A $k * llist B j * \<langle>rev xs = (rev (a#A)) @ B\<rangle> * \<langle>`i \<noteq> 0\<rangle>,
         EXS A B. llist A i * llist B j * \<langle>rev xs = (rev A) @ B\<rangle>\<rbrakk>
      od"
      by morgan (sep_safe, sep_auto)
  also have "... \<le>
      `j := 0;
      while `i \<noteq> 0 do
        `k := @(`i + 1);
        \<lbrakk>EXS A B a. (i \<mapsto> $a, k) * llist A k * llist B j * \<langle>rev xs = (rev (a#A)) @ B\<rangle> * \<langle>`i \<noteq> 0\<rangle>,
         EXS A B. llist A i * llist B j * \<langle>rev xs = (rev A) @ B\<rangle>\<rbrakk>
      od"
      by morgan sep_auto+
  also have "... \<le>
      `j := 0;
      while `i \<noteq> 0 do
        `k := @(`i + 1);
        @(`i + 1) := `j;
        \<lbrakk>EXS A B a. (i \<mapsto> $a, j) * llist A k * llist B j * \<langle>rev xs = (rev (a#A)) @ B\<rangle> * \<langle>`i \<noteq> 0\<rangle>,
         EXS A B. llist A i * llist B j * \<langle>rev xs = (rev A) @ B\<rangle>\<rbrakk>
      od"
    by morgan
    also have "... \<le>
      `j := 0;
      while `i \<noteq> 0 do
        `k := @(`i + 1);
        @(`i + 1) := `j;
        \<lbrakk>EXS A B. llist A k * llist B i * \<langle>rev xs = (rev A) @ B\<rangle> * \<langle>`i \<noteq> 0\<rangle>,
         EXS A B. llist A i * llist B j * \<langle>rev xs = (rev A) @ B\<rangle>\<rbrakk>
      od"
      by morgan sep_auto+
    also have "... \<le>
      `j := 0;
      while `i \<noteq> 0 do
        `k := @(`i + 1);
        @(`i + 1) := `j;
        `j := `i;
        \<lbrakk>EXS A B. llist A k * llist B j * \<langle>rev xs = (rev A) @ B\<rangle> * \<langle>`j \<noteq> 0\<rangle>,
         EXS A B. llist A i * llist B j * \<langle>rev xs = (rev A) @ B\<rangle>\<rbrakk>
      od"
      by morgan sep_auto
    also have "... \<le>
      `j := 0;
      while `i \<noteq> 0 do
        `k := @(`i + 1);
        @(`i + 1) := `j;
        `j := `i;
        `i := `k
      od"
      by morgan sep_auto
    finally show ?thesis .
qed

lemma "\<turnstile> \<lbrace> list_seg (x#xs) i k \<rbrace>
      `j := @(`i + 1);
      dispose `i;
      dispose (`i + 1);
      `i := `j
    \<lbrace> list_seg xs i k \<rbrace>"
 by hoare sep_auto+

lemma exsI: "(x, y) \<in> (EXS xa xb xc x. P x \<inter> Q xa xb xc x) \<Longrightarrow> (x, y) \<in> (EXS x. P x \<inter> (EXS xa xb xc. Q xa xb xc x))"
  by auto

lemma deallocI [intro]: "(x, y) \<in> {(s, h). i s \<noteq> 0} \<Longrightarrow>
              (x, y) \<in> llist xa i \<Longrightarrow>
              (x, y) \<in> (EXS x. ((\<lambda>s. i (s\<lparr>j := i s\<rparr>) + 1) \<mapsto> (\<lambda>s. x)) * true \<inter> (EXS xa xb xc. ((\<lambda>s. j (s\<lparr>j := i s, i := x\<rparr>)) \<mapsto> (\<lambda>s. xa)) * (((\<lambda>s. j (s\<lparr>j := i s, i := x\<rparr>) + 1) \<mapsto> (\<lambda>s. xb)) * llist xc (\<lambda>s. i (s\<lparr>j := i s, i := x\<rparr>)))))"
  apply (rule exsI)
  apply safe
  apply (drule llist_cons) back
  apply assumption
  apply auto
  apply (rule_tac x="hd xa" in exI)
  apply (rule_tac x=j in exI)
  apply (rule_tac x="tl xa" in exI)
  apply (rule_tac x=j in exI)
  apply auto
by (metis (no_types, lifting) bbi.Sup.qisol bbi.mult.left_commute contra_subsetD top_greatest)

lemma "\<turnstile> \<lbrace> llist xs i \<rbrace>
      while `i \<noteq> 0
      inv EXS ys. llist ys i
      do
        `j := `i;
        `i := @(`i + 1);
        dispose `j;
        dispose (`j + 1)
      od
    \<lbrace> emp \<rbrace>"
by hoare (sep_safe, (rule deallocI, auto | sep_auto))+

declare sl_frame [sl]

lemma "\<turnstile> \<lbrace> llist xs i \<rbrace>
      `j := 0;
      while `i \<noteq> 0
      inv EXS as bs. (llist as i * llist bs j) * \<langle>rev xs = rev as @ bs\<rangle>
      do
        \<lbrace> EXS A B a k. (i \<mapsto> $a, $k) * llist A $k * llist B j * \<langle>rev xs = (rev (a#A)) @ B\<rangle> * \<langle>`i \<noteq> 0\<rangle> \<rbrace>
        `k := @(`i + 1);
        @(`i + 1) := `j
        \<lbrace> EXS A B a. (i \<mapsto> $a, j) * llist A k * llist B j * \<langle>rev xs = (rev (a#A)) @ B\<rangle> * \<langle>`i \<noteq> 0\<rangle> \<rbrace>;
        `j := `i;
        `i := `k
      od
      \<lbrace> llist (rev xs) j \<rbrace>"
by (hoare; sep_safe) sep_auto+

end