(*  Title:      Containers/Lexicographic_Order.thy
    Author:     Andreas Lochbihler, KIT *)

theory Lexicographic_Order imports
  List_Fusion
  "HOL-Library.Char_ord"
begin

hide_const (open) List.lexordp

section \<open>List fusion for lexicographic order\<close>

context linorder begin

lemma lexordp_take_index_conv:
  "lexordp xs ys \<longleftrightarrow>
   (length xs < length ys \<and> take (length xs) ys = xs) \<or>
   (\<exists>i < min (length xs) (length ys). take i xs = take i ys \<and> xs ! i < ys ! i)"
  (is "?lhs = ?rhs")
proof
  assume ?lhs thus ?rhs
    by induct (auto 4 3 del: disjCI intro: disjI2 exI[where x="Suc i" for i])
next
  assume ?rhs (is "?prefix \<or> ?less") thus ?lhs
  proof
    assume "?prefix"
    hence "ys = xs @ hd (drop (length xs) ys) # tl (drop (length xs) ys)"
      by (metis append_Nil2 append_take_drop_id less_not_refl list.collapse)
    thus ?thesis unfolding lexordp_iff by blast
  next
    assume "?less"
    then obtain i where "i < min (length xs) (length ys)"
      and "take i xs = take i ys" and nth: "xs ! i < ys ! i" by blast
    hence "xs = take i xs @ xs ! i # drop (Suc i) xs" "ys = take i xs @ ys ! i # drop (Suc i) ys"
      by -(subst append_take_drop_id[symmetric, of _ i], simp_all add: Cons_nth_drop_Suc)
    with nth show ?thesis unfolding lexordp_iff by blast
  qed
qed

\<comment> \<open>lexord is extension of partial ordering List.lex\<close>
lemma lexordp_lex: "(xs, ys) \<in> lex {(xs, ys). xs < ys} \<longleftrightarrow> lexordp xs ys \<and> length xs = length ys"
proof(induct xs arbitrary: ys)
  case Nil thus ?case by clarsimp
next
  case Cons thus ?case by(cases ys)(simp_all, safe, simp)
qed

end

subsection \<open>Setup for list fusion\<close>

context ord begin

definition lexord_fusion :: "('a, 's1) generator \<Rightarrow> ('a, 's2) generator \<Rightarrow> 's1 \<Rightarrow> 's2 \<Rightarrow> bool"
where [code del]: "lexord_fusion g1 g2 s1 s2 = lexordp (list.unfoldr g1 s1) (list.unfoldr g2 s2)"

definition lexord_eq_fusion :: "('a, 's1) generator \<Rightarrow> ('a, 's2) generator \<Rightarrow> 's1 \<Rightarrow> 's2 \<Rightarrow> bool"
where [code del]: "lexord_eq_fusion g1 g2 s1 s2 = lexordp_eq (list.unfoldr g1 s1) (list.unfoldr g2 s2)"

lemma lexord_fusion_code:
  "lexord_fusion g1 g2 s1 s2 \<longleftrightarrow>
  (if list.has_next g1 s1 then
     if list.has_next g2 s2 then
       let (x, s1') = list.next g1 s1;
           (y, s2') = list.next g2 s2
       in x < y \<or> \<not> y < x \<and> lexord_fusion g1 g2 s1' s2'
     else False
   else list.has_next g2 s2)"
unfolding lexord_fusion_def
by(subst (1 2) list.unfoldr.simps)(auto split: prod.split_asm)

lemma lexord_eq_fusion_code:
  "lexord_eq_fusion g1 g2 s1 s2 \<longleftrightarrow>
  (list.has_next g1 s1 \<longrightarrow>
   list.has_next g2 s2 \<and>
   (let (x, s1') = list.next g1 s1;
        (y, s2') = list.next g2 s2
    in x < y \<or> \<not> y < x \<and> lexord_eq_fusion g1 g2 s1' s2'))"
unfolding lexord_eq_fusion_def
by(subst (1 2) list.unfoldr.simps)(auto split: prod.split_asm)

end

lemmas [code] =
  lexord_fusion_code ord.lexord_fusion_code
  lexord_eq_fusion_code ord.lexord_eq_fusion_code

lemmas [symmetric, code_unfold] =
  lexord_fusion_def ord.lexord_fusion_def
  lexord_eq_fusion_def ord.lexord_eq_fusion_def

end


(*<*)
(* Author : Peter Chapman *)
(* License: LGPL *)
section "Rule Set Transformations"

theory SRCTransforms
imports "HOL-Library.Multiset"
begin

datatype 'a form = At "nat"
                 | Compound "'a" "'a form list"
                 | ff

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

abbreviation multiset_abbrev ("\<LM> _  \<RM>" [75]75) where
   "\<LM> A \<RM> \<equiv> {# A #}"

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

(* 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 multiset" where "succ (Sequent ant suc) = suc"
primrec mset :: "'a sequent \<Rightarrow> 'a form multiset" where "mset (Sequent ant suc) = ant + 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 *)
overloading
  extend \<equiv> extend
  extendRule \<equiv> extendRule
  uniqueConclusion \<equiv> uniqueConclusion
begin

definition extend
  where "extend forms seq \<equiv> (antec forms + antec seq) \<Rightarrow>* (succ forms + succ seq)"

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

(* The unique conclusion property.  A set of rules has unique conclusion property if for any pair of rules,
   the conclusions being the same means the rules are the same*)
definition uniqueConclusion :: "'a rule set \<Rightarrow> bool"
  where "uniqueConclusion R \<equiv> \<forall> r1 \<in> R. \<forall> r2 \<in> R. (snd r1 = snd r2) \<longrightarrow> (r1 =r2)"

end

primrec max_list :: "nat list \<Rightarrow> nat" where
  "max_list [] = 0"
| "max_list (n # ns) = max n (max_list ns)"

(* The depth of a formula.  Will be useful in later files. *)
fun depth :: "'a form \<Rightarrow> nat"
where
   "depth (At i) = 0"
|  "depth (Compound f fs) = (max_list (map depth fs)) + 1"
|  "depth (ff) = 0"

(* 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>* \<LM> At i \<RM>) \<in> Ax"
|  Lbot[intro]: "([], \<LM> ff \<RM> \<Rightarrow>* \<Empt>) \<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
   I[intro]: "\<lbrakk> mset c \<equiv> \<LM> Compound R Fs \<RM> ; 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>* \<Empt>)  \<Longrightarrow>
                   leftPrincipal (Ps,C) (Compound F Fs)"

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

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

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

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

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

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

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

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

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

end

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

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

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

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

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

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

lemma containFalsum:
assumes a: "ff \<in># \<Gamma>"
   and  b: "Ax \<subseteq> R"
shows "(\<Gamma> \<Rightarrow>* \<Delta>,0) \<in> derivable R*"
proof-
  from a have "\<Gamma> = \<Gamma> \<ominus> ff \<oplus> ff" by auto
  then have "extend (\<Gamma> \<ominus> ff \<Rightarrow>* \<Delta>) (\<LM>ff\<RM> \<Rightarrow>* \<Empt>) = (\<Gamma> \<Rightarrow>* \<Delta>)"
    using extend_def[where forms="\<Gamma> \<ominus> ff \<Rightarrow>* \<Delta>" and seq="\<LM>ff\<RM> \<Rightarrow>* \<Empt>"] by auto
  moreover
  have "([],\<LM>ff\<RM> \<Rightarrow>* \<Empt>) \<in> R" using b by auto
  ultimately have "([],\<Gamma> \<Rightarrow>* \<Delta>) \<in> R*"
    using extRules.I[where R=R and r="([],  \<LM>ff\<RM> \<Rightarrow>* \<Empt>)" and seq="\<Gamma> \<ominus> ff \<Rightarrow>* \<Delta>"]
      and extendRule_def[where forms="\<Gamma> \<ominus> ff \<Rightarrow>* \<Delta>" and R="([],  \<LM>ff\<RM> \<Rightarrow>* \<Empt>)"] by auto
  then show ?thesis using derivable.base[where R="R*" and C="\<Gamma> \<Rightarrow>* \<Delta>"] 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>* \<Empt>) \<or> (\<exists> i. r = ([], \<LM> At i \<RM> \<Rightarrow>* \<LM> At i \<RM>))"
  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 which says that if rule is an upRule, then the succedent is either empty, or a single formula *)
lemma succ_upRule:
assumes "(Ps,\<Phi> \<Rightarrow>* \<Psi>) \<in> upRules"
shows "\<Psi> = \<Empt> \<or> (\<exists> A. \<Psi> = \<LM>A\<RM>)"
using assms
proof (cases)
    case (I R Rs)
    then show "\<Psi> = \<Empt> \<or> (\<exists> A. \<Psi> = \<LM>A\<RM>)" using mset.simps[where ant=\<Phi> and suc=\<Psi>]
         and union_is_single[where M=\<Phi> and N=\<Psi> and a="Compound R Rs"] by (simp,elim disjE) (auto)
qed

(* Equivalent, but the antecedent *)
lemma antec_upRule:
assumes "(Ps,\<Phi> \<Rightarrow>* \<Psi>) \<in> upRules"
shows "\<Phi> = \<Empt> \<or> (\<exists> A. \<Phi> = \<LM>A\<RM>)"
using assms
proof (cases)
    case (I R Rs)
    then show "\<Phi> = \<Empt> \<or> (\<exists> A. \<Phi> = \<LM>A\<RM>)" using mset.simps[where ant=\<Phi> and suc=\<Psi>]
         and union_is_single[where M=\<Phi> and N=\<Psi> and a="Compound R Rs"] by (simp,elim disjE) (auto)
qed

lemma upRule_Size:
assumes "r \<in> upRules"
shows "seq_size (snd r) = 1"
using assms
proof-
    obtain Ps C where "r = (Ps,C)" by (cases r)
    then have "(Ps,C) \<in> upRules" using assms by simp
    then show ?thesis
       proof (cases)
          case (I R Rs)
          obtain G H where "C = (G \<Rightarrow>* H)" by (cases C) (auto)
          then have "G + H = \<LM>Compound R Rs\<RM>" using mset.simps and \<open>mset C \<equiv> \<LM>Compound R Rs\<RM>\<close> by auto
          then have "size (G+H) = 1" by auto
          then have "size G + size H = 1" by auto
          then have "seq_size C = 1" using seq_size.simps[where ant=G and suc=H] and \<open>C = (G \<Rightarrow>* H)\<close> by auto
          moreover have "snd r = C" using \<open>r = (Ps,C)\<close> by simp
          ultimately show "seq_size (snd r) = 1" by simp
       qed
qed

lemma upRuleCharacterise:
assumes "(Ps,C) \<in> upRules"
shows "\<exists> F Fs. C = (\<Empt> \<Rightarrow>* \<LM>Compound F Fs\<RM>) \<or> C = (\<LM>Compound F Fs\<RM> \<Rightarrow>* \<Empt>)"
using assms
proof (cases)
  case (I F Fs)
  then obtain \<Gamma> \<Delta> where "C = (\<Gamma> \<Rightarrow>* \<Delta>)" using characteriseSeq[where C=C] by auto
  then have "(Ps,\<Gamma> \<Rightarrow>* \<Delta>) \<in> upRules" using assms by simp
  then show "\<exists> F Fs. C = (\<Empt> \<Rightarrow>* \<LM>Compound F Fs\<RM>) \<or> C = (\<LM>Compound F Fs\<RM> \<Rightarrow>* \<Empt>)"
    using \<open>mset C \<equiv> \<LM>Compound F Fs\<RM>\<close> and \<open>C = (\<Gamma> \<Rightarrow>* \<Delta>)\<close>
      and mset.simps[where ant=\<Gamma> and suc=\<Delta>] and union_is_single[where M=\<Gamma> and N=\<Delta> and a="Compound F Fs"]
    by auto
qed

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

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

lemma nonPrincipalID:
fixes A :: "'a form"
assumes "r \<in> Ax"
shows "\<not> rightPrincipal r A \<and> \<not> leftPrincipal r A"
proof-
from assms obtain i where r1:"r = ([], \<LM> ff \<RM> \<Rightarrow>* \<Empt>) \<or> r = ([], \<LM> At i \<RM> \<Rightarrow>* \<LM> At i\<RM>)"
     using characteriseAx[where r=r] by auto
{ assume "rightPrincipal r A" then obtain Ps where r2:"r = (Ps, \<Empt> \<Rightarrow>* \<LM> A \<RM>)" 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>* \<Empt>)" 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 extendCommute:
shows "(extend S) (extend R c) = (extend R) (extend S c)"
by (auto simp add:extend_def union_ac)

lemma mapCommute:
shows "map (extend S) (map (extend R) c) = map (extend R) (map (extend S) c)"
by (induct_tac c) (auto simp add:extendCommute)

lemma extendAssoc:
shows "(extend S) (extend R c) = extend (extend S R) c"
by (auto simp add:extend_def union_ac)

lemma mapAssoc:
shows "map (extend S) (map (extend R) c) = map (extend (extend S R)) c"
by (induct_tac c) (auto simp add:extendAssoc)

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)

inductive lastRule :: "'a deriv \<Rightarrow> 'a rule \<Rightarrow> 'a rule set \<Rightarrow> bool"
  where
  base[intro]: "\<lbrakk> r \<in> Ax; Ax \<subseteq> R ; snd (extendRule S r) = (\<Gamma> \<Rightarrow>* \<Delta>)\<rbrakk>
                 \<Longrightarrow> lastRule (\<Gamma> \<Rightarrow>* \<Delta>,0) r R"
|    I[intro]:  "\<lbrakk> r\<in>R ; r \<notin> Ax ; snd (extendRule S r) = (\<Gamma> \<Rightarrow>* \<Delta>) ;
                \<forall> p \<in> set (fst (extendRule S r)). \<exists> m\<le>n. (p,m) \<in> derivable R* \<rbrakk>
                 \<Longrightarrow> lastRule (\<Gamma> \<Rightarrow>* \<Delta>,n+1) r R"

lemma obv:
fixes a :: "('a * 'b)"
shows "a = (fst a, snd a)" by auto

lemma getLast:
assumes "lastRule (\<Gamma> \<Rightarrow>* \<Delta>,n+1) r R"
shows "\<exists> S Ps. extendRule S r = (Ps, \<Gamma> \<Rightarrow>* \<Delta>) \<and> (\<forall> p \<in> set Ps. \<exists> m\<le>n. (p,m) \<in> derivable R*) \<and> r \<in> R \<and> r \<notin> Ax"
proof-
  from assms show ?thesis apply (rule lastRule.cases) apply simp apply simp
  apply (rule_tac x=S in exI) apply (rule_tac x="fst (extendRule S r)" in exI) apply simp
  apply auto
  apply (subgoal_tac "extendRule S (a,b) = (fst (extendRule S (a,b)),snd (extendRule S (a,b)))")
  apply simp by (rule obv)
qed

lemma getAx:
assumes "lastRule (\<Gamma> \<Rightarrow>* \<Delta>,0) r R"
shows "r \<in> Ax \<and> (\<exists> S. extendRule S r = ([],\<Gamma> \<Rightarrow>* \<Delta>))"
proof-
  from assms have "r \<in> Ax \<and> (\<exists> S. snd (extendRule S r) = (\<Gamma> \<Rightarrow>* \<Delta>))"
       by (rule lastRule.cases) auto
  then obtain S where "r \<in> Ax" and "snd (extendRule S r) = (\<Gamma> \<Rightarrow>* \<Delta>)" by auto
  from \<open>r \<in> Ax\<close> have "fst r = []" apply (cases r) by (rule Ax.cases) auto
  then have "fst (extendRule S r) = []" by (auto simp add:extendRule_def)
  with \<open>snd (extendRule S r) = (\<Gamma> \<Rightarrow>* \<Delta>)\<close> and \<open>r \<in> Ax\<close> show ?thesis apply auto
       apply (rule_tac x=S in exI)
       apply (subgoal_tac "extendRule S r = (fst (extendRule S r),snd (extendRule S r))") apply simp
       by (rule obv)
qed

(* Has the usual set-up: takes a subset of the upRules, combines with all the axioms, blah blah *)

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

lemma dpWeak:
assumes a:"(\<Gamma> \<Rightarrow>* \<Delta>,n) \<in> derivable R*"
   and  b: "R' \<subseteq> upRules"
   and  c: "R = Ax \<union> R'"
shows "(\<Gamma> + \<Gamma>' \<Rightarrow>* \<Delta> + \<Delta>',n) \<in> derivable R*"
using a
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> \<Rightarrow>* \<Delta>, m) \<in> derivable R* \<longrightarrow> ( \<Gamma> + \<Gamma>' \<Rightarrow>* \<Delta> + \<Delta>', m) \<in> derivable R*"
      and a': "( \<Gamma> \<Rightarrow>* \<Delta>, n) \<in> derivable R*" by auto
show ?case
proof (cases n)
case 0
 then have "(\<Gamma> \<Rightarrow>* \<Delta>,0) \<in> derivable R*" using a' by simp
 then have "([], \<Gamma> \<Rightarrow>* \<Delta>) \<in> R*" by (cases) auto
 then obtain  r S where "r \<in> R" and split:"extendRule S r = ([],\<Gamma> \<Rightarrow>* \<Delta>)"
      by (rule extRules.cases) auto
 then obtain c where "r = ([],c)" by (cases r) (auto simp add:extendRule_def)
 with \<open>r \<in> R\<close> have "r \<in> Ax \<or> r \<in> upRules" using b c by auto
 with \<open>r = ([],c)\<close> have "r \<in> Ax" by (auto) (rule upRules.cases,auto)
 with \<open>r = ([],c)\<close> obtain i where "c = (\<LM>At i\<RM> \<Rightarrow>* \<LM>At i\<RM>) \<or> c = (\<LM>ff\<RM> \<Rightarrow>* \<Empt>)"
      using characteriseAx[where r=r] by auto
 moreover
    {assume "c = (\<LM>At i\<RM> \<Rightarrow>* \<LM>At i\<RM>)"
     then have "extend S (\<LM>At i\<RM> \<Rightarrow>*\<LM>At i\<RM>) = (\<Gamma> \<Rightarrow>* \<Delta>)" using split and \<open>r = ([],c)\<close>
          by (auto simp add:extendRule_def)
     then have "At i \<in># \<Gamma> \<and> At i \<in># \<Delta>" using extendID by auto
     then have "At i \<in># \<Gamma> + \<Gamma>' \<and> At i \<in># \<Delta> + \<Delta>'" by auto
     then have "(\<Gamma> + \<Gamma>' \<Rightarrow>* \<Delta> + \<Delta>',0) \<in> derivable R*"
          using c and containID[where \<Gamma>="\<Gamma>+\<Gamma>'" and \<Delta>="\<Delta>+\<Delta>'" and R=R and i=i] by auto
    }
 moreover
    {assume "c = (\<LM>ff\<RM> \<Rightarrow>* \<Empt>)"
     then have "extend S (\<LM>ff\<RM> \<Rightarrow>*\<Empt>) = (\<Gamma> \<Rightarrow>* \<Delta>)" using split and \<open>r = ([],c)\<close>
          by (auto simp add:extendRule_def)
     then have "ff \<in># \<Gamma>" using extendFalsum by auto
     then have "ff \<in># \<Gamma> + \<Gamma>'" by auto
     then have "(\<Gamma> + \<Gamma>' \<Rightarrow>* \<Delta> + \<Delta>',0) \<in> derivable R*"
          using c and containFalsum[where \<Gamma>="\<Gamma>+\<Gamma>'" and \<Delta>="\<Delta>+\<Delta>'" and R=R] by auto
    }
 ultimately show "(\<Gamma> + \<Gamma>' \<Rightarrow>* \<Delta> + \<Delta>',n) \<in> derivable R*" using \<open>n=0\<close> by auto
next
case (Suc n')
 then have "(\<Gamma> \<Rightarrow>* \<Delta>, n'+1) \<in> derivable R*" using a' by simp
 then obtain Ps where f:"Ps \<noteq> []"
                  and g:"(Ps, \<Gamma> \<Rightarrow>* \<Delta>) \<in> R*"
                  and h:"\<forall> p \<in> set Ps. \<exists> m\<le>n'. (p,m) \<in> derivable R*"
      using characteriseLast[where C="\<Gamma> \<Rightarrow>* \<Delta>" 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>* \<Delta>)" by (cases) auto
 with b have as: "(r \<in> Ax \<or> r \<in> upRules) \<and> extendRule S r = (Ps, \<Gamma> \<Rightarrow>* \<Delta>)" by auto
 then have eq:"map (extend (\<Gamma>' \<Rightarrow>* \<Delta>')) Ps = fst (extendRule (extend S (\<Gamma>' \<Rightarrow>* \<Delta>')) r)"
       using mapCommute[where S="\<Gamma>'\<Rightarrow>*\<Delta>'" and R=S and c="fst r"]
       by (auto simp add:extendRule_def extend_def mapAssoc simp del: map_map)
 from as have eq2: "(\<Gamma> + \<Gamma>' \<Rightarrow>* \<Delta> + \<Delta>') = snd (extendRule (extend S (\<Gamma>' \<Rightarrow>* \<Delta>')) r)"
       by (auto simp add:extendRule_def extend_def union_ac)
 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
 have "\<forall> p' \<in> set (map (extend (\<Gamma>' \<Rightarrow>* \<Delta>')) Ps). \<exists> m\<le>n'. (p',m) \<in> derivable R*"
      proof-
      {fix p
       assume "p \<in> set (map (extend (\<Gamma>' \<Rightarrow>* \<Delta>')) Ps)"
       then obtain p' where t:"p' \<in> set Ps \<and> p = extend (\<Gamma>' \<Rightarrow>* \<Delta>') p'" by auto
       with h obtain m where "m\<le>n'" and "(p',m) \<in> derivable R*" by auto
       moreover obtain \<Phi> \<Psi> where eq:"p' = (\<Phi> \<Rightarrow>* \<Psi>)" by (cases p') auto
       then have "p = (\<Phi> + \<Gamma>' \<Rightarrow>* \<Psi> + \<Delta>')" using t by (auto simp add:extend_def union_ac)
       ultimately have "(p,m) \<in> derivable R*" using IH and \<open>n = Suc n'\<close> and eq
            apply- by (drule_tac x=m in spec) simp
       then have "\<exists> m\<le>n'. (p,m) \<in> derivable R*" using \<open>m\<le>n'\<close> by auto
       }
       then show ?thesis by auto
       qed
 then have "\<forall> p' \<in> set (fst (extendRule (extend S (\<Gamma>' \<Rightarrow>* \<Delta>')) r)).
            \<exists> m\<le>n'. (p',m) \<in> derivable R*" using eq by auto
 moreover have "extendRule (extend S (\<Gamma>' \<Rightarrow>* \<Delta>')) r \<in> R*"
          using \<open>r \<in> upRules\<close> and \<open>r \<in> R\<close> by auto
 ultimately have "(\<Gamma> + \<Gamma>' \<Rightarrow>* \<Delta> + \<Delta>',n'+1) \<in> derivable R*"
          using derivable.step[where r="extendRule (extend S (\<Gamma>' \<Rightarrow>* \<Delta>')) r" and R="R*" and m="n'"]
          and \<open>fst r \<noteq> []\<close> and eq2 by (cases r) (auto simp add:map_is_Nil_conv extendRule_def)
 then show "( \<Gamma> + \<Gamma>' \<Rightarrow>* \<Delta> + \<Delta>', n) \<in> derivable R*" using \<open>n = Suc n'\<close> by auto
 qed
qed
(*>*)
text\<open>
\section{Manipulating Rule Sets \label{isaSRC}}
The removal of superfluous and redundant rules \cite{AL01} will not be harmful to invertibility: removing rules means that the conditions of earlier sections are more likely to be fulfilled.  Here, we formalise the results that the removal of such rules from a calculus $\mathcal{L}$ will create a new calculus $\mathcal{L}'$ which is equivalent.  In other words, if a sequent is derivable in $\mathcal{L}$, then it is derivable in $\mathcal{L}'$.
The results formalised in this section are for \SC multisuccedent calculi.

When dealing with lists of premisses, a rule $R$ with premisses $P$ will be redundant given a rule $R'$ with premisses $P'$ if there exists some $p$ such that $P = p \# P'$.  There are other ways in which a rule could be redundant; say if $P = Q @ P'$, or if $P = P' @ Q$, and so on.  The order of the premisses is not really important, since the formalisation operates on the finite set based upon the list.  The more general ``append'' lemma could be proved from the lemma we give; we prove the inductive step case in the proof of such an append lemma.  This is a height preserving transformation.  Some of the proof is shown:
\<close>

lemma removeRedundant:
assumes (*<*)a:(*>*) "r1 = (p#ps,c) \<and> r1 \<in> upRules"
and     (*<*)b:(*>*) "r2 = (ps,c) \<and> r2 \<in> upRules"
and     (*<*)c:(*>*) "R1 \<subseteq> upRules \<and> R = Ax \<union> R1"
and     (*<*)d:(*>*) "(T,n) \<in> derivable (R \<union> {r1} \<union> {r2})*"
shows   "\<exists> m\<le>n. (T,m) \<in> derivable (R \<union> {r2})*"
 (*<*)
using assms (*>*)
proof (induct n (*<*)arbitrary: T (*>*)rule:nat_less_induct)
 (*<*)case (1 n T)
    then have IH: " \<forall>m<n. \<forall> x. (r1 = (p # ps, c) \<and> r1 \<in> upRules \<longrightarrow>
                         r2 = (ps, c) \<and> r2 \<in> upRules \<longrightarrow>
                         R1 \<subseteq> upRules \<and> R = Ax \<union> R1 \<longrightarrow>
                         (x, m) \<in> derivable (R \<union> {r1} \<union> {r2})* \<longrightarrow>
                         (\<exists> m'\<le>m. (x, m') \<in> derivable (R \<union> {r2})*))" and
             prm: "(T,n) \<in> derivable (R \<union> {r1} \<union> {r2})*" by auto
    show ?case
 proof (cases n) (*>*)
 case 0
  (*<*) with prm (*>*) have "(T,0) \<in> derivable (R \<union> {r1} \<union> {r2})*" by simp
   then have "([],T) \<in> (R \<union> {r1} \<union> {r2})*" by (cases) auto
   then obtain S r where ext: "extendRule S r = ([],T)" and
        "r \<in> (R \<union> {r1} \<union> {r2})" by (rule extRules.cases) auto
   then have "r \<in> R \<or> r = r1 \<or> r = r2" using c by auto
txt\<open>\noindent It cannot be the case that $r=r_{1}$ or $r=r_{2}$, since those are \SC rules, whereas anything with an empty set of premisses
must be an axiom.  Since $\mathcal{R}$ contains the set of axioms, so will $\mathcal{R} \cup r_{2}$:\<close>
 (*<*)   moreover from ext obtain d where "r = ([],d)" by (cases r) (auto simp add:extendRule_def)
   ultimately have "r \<in> R \<or> r = r2" using c a ext by (auto simp add:extendRule_def) (*>*)
   then have "r \<in> (R \<union> {r2})" using c by auto
 (*<*)  then have "([],T) \<in> (R \<union> {r2})*" using \<open>extendRule S r = ([],T)\<close>
          and extRules.I[where r=r and R="R \<union> {r2}" and seq=S] by auto (*>*)
  then have "(T,0) \<in> derivable (R \<union> {r2})*" by auto
  then show "\<exists> m\<le>n. (T,m) \<in> derivable (R \<union> {r2})*" using \<open>n=0\<close> by auto
next
 case (Suc n')
 (*<*) with prm (*>*)have "(T,n'+1) \<in> derivable (R \<union> {r1} \<union> {r2})*" by simp
  then obtain Ps where e: "Ps \<noteq> []"
         and   f: "(Ps,T) \<in> (R \<union> {r1} \<union> {r2})*"
         and   g: "\<forall> P \<in> set Ps. \<exists> m\<le>n'. (P,m) \<in> derivable (R \<union> {r1} \<union> {r2})*"
        (*<*) using characteriseLast[where C=T and m=n' and R="(R \<union> {r1} \<union> {r2})*"](*>*) by auto
  have g': "\<forall> P \<in> set Ps. \<exists> m\<le>n'. (P,m) \<in> derivable (R \<union> {r2})*"
  (*<*)       proof-
              {fix P
               assume "P \<in> set Ps"
               with g obtain m where "(P,m) \<in> derivable (R \<union> {r1} \<union> {r2})*" and "m\<le>n'" by auto
               with IH have "\<exists> m'\<le>m. (P,m') \<in> derivable (R \<union> {r2})*" using a b c and \<open>n = Suc n'\<close>
                    by auto
               then have "\<exists> m\<le>n'. (P,m) \<in> derivable (R \<union> {r2})*" using \<open>m\<le>n'\<close> apply auto
                    by (rule_tac x=m' in exI) auto
              }
              then show ?thesis by auto
         qed  (*>*)
   from f obtain S r where ext: "extendRule S r = (Ps,T)"
        and "r \<in> (R \<union> {r1} \<union> {r2})" by (rule extRules.cases) auto
    then have "r \<in> (R \<union> {r2}) \<or> r = r1" by auto
txt\<open>\noindent Either $r$ is in the new rule set or $r$ is the redundant rule.  In the former case, there is nothing to do:\<close>
 (*<*)moreover
    {(*>*) assume "r \<in> (R \<union> {r2})"
     then have "(Ps,T) \<in> (R \<union> {r2})*" (*<*)using ext and extRules.I[where r=r and R="R \<union> {r2}" and seq=S](*>*) by auto
     with g' have "(T,n) \<in> derivable (R \<union> {r2})*" using \<open>n = Suc n'\<close> (*<*)and e and
       derivable.step[where r="(Ps,T)" and R="(R \<union> {r2})*" and m=n'](*>*) by auto
   (*<*) }
 moreover
    { (*>*)
txt\<open>\noindent In the latter case, the last inference was redundant.  Therefore the premisses, which are derivable at a lower height than the conclusion,
contain the premisses of $r_{2}$ (these premisses are \texttt{extend S ps}).  This completes the proof:\<close>
     assume "r = r1"
     with ext have "map (extend S) (p # ps) = Ps" using a by (auto(*<*) simp add:extendRule_def(*>*))
     then have "\<forall> P \<in> set (map (extend S) (p#ps)).
                   \<exists> m\<le>n'. (P,m) \<in> derivable (R \<union> {r2})*"
         using g' by simp
     then have h: "\<forall> P \<in> set (map (extend S) ps).
                      \<exists> m\<le>n'. (P,m) \<in> derivable (R \<union> {r2})*" by auto

 (*<*)    have "extendRule S r2 = (map (extend S) ps, T)" using b and a and ext and \<open>r = r1\<close>
           by (auto simp add:extendRule_def)
     then have i: "(map (extend S) ps,T) \<in> (R \<union> {r2})*" using extRules.I(*<*)[where r=r2 and R="(R \<union> {r2})" and seq=S](*>*)
               by auto
    have "ps = [] \<or> ps \<noteq> []" by blast
   moreover
       {assume "ps = []"
         with i have "([],T) \<in> (R \<union> {r2})*" by auto
         then have "(T,0) \<in> derivable (R \<union> {r2})*" by auto
         then have "\<exists> m\<le>n. (T,m) \<in> derivable (R \<union> {r2})*" by auto
       }
       moreover
          {assume "ps \<noteq> []"
           then have "map (extend S) ps \<noteq> []" by auto
            with i and h have "(T,n'+1) \<in> derivable (R \<union> {r2})*"
                  using derivable.step[where r="(map (extend S) ps,T)" and R="(R \<union> {r2})*" and m=n'] by auto
           with \<open>n = Suc n'\<close> have "\<exists> m\<le>n. (T,m) \<in> derivable (R \<union> {r2})*" by auto
           }
       ultimately have "\<exists> m\<le>n. (T,m) \<in> derivable (R \<union> {r2})*" by blast
     }
  ultimately show "\<exists> m\<le>n. (T,m) \<in> derivable (R \<union> {r2})*" by blast
  qed
qed(*>*)
text\<open>
\noindent Recall that to remove superfluous rules, we must know that Cut is admissible in the original calculus \cite{AL01}.  Again, we add the two distinguished premisses at the head of the premiss list; general results about permutation of lists will achieve a more general result.  Since one uses Cut in the proof, this will in general not be height-preserving:
\<close>

lemma removeSuperfluous:
assumes (*<*)a:(*>*) "r1 = ((\<Empt> \<Rightarrow>* \<LM>A\<RM>) # ((\<LM>A\<RM> \<Rightarrow>* \<Empt>) # ps),c) \<and> r1 \<in> upRules"
and     (*<*)b:(*>*) "R1 \<subseteq> upRules \<and> R = Ax \<union> R1"
and     "(T,n) \<in> derivable (R \<union> {r1})*"
and     CA: "\<forall> \<Gamma> \<Delta> A. ((\<Gamma> \<Rightarrow>* \<Delta> \<oplus> A) \<in> derivable' R* \<longrightarrow>
             (\<Gamma> \<oplus> A \<Rightarrow>* \<Delta>) \<in> derivable' R*) \<longrightarrow>
             (\<Gamma> \<Rightarrow>* \<Delta>) \<in> derivable' R*"
shows   "T \<in> derivable' R*"
(*<*)
using assms
proof (induct n arbitrary: T rule: nat_less_induct)
  case (1 n T)
  then have IH: "\<forall>m<n. r1 = (( \<Empt> \<Rightarrow>* \<LM>A\<RM>) # ( \<LM>A\<RM> \<Rightarrow>* \<Empt>) # ps, c) \<and> r1 \<in> upRules \<longrightarrow>
    R1 \<subseteq> upRules \<and> R = Ax \<union> R1 \<longrightarrow>
    (\<forall> T. (T, m) \<in> derivable (R \<union> {r1})* \<longrightarrow>
    (\<forall> \<Gamma> \<Delta> B.
    ((\<Gamma> \<Rightarrow>* \<Delta> \<oplus> B) \<in> derivable' R* \<longrightarrow> (\<Gamma> \<oplus> B \<Rightarrow>* \<Delta>) \<in> derivable' R*) \<longrightarrow>
    (\<Gamma> \<Rightarrow>* \<Delta>) \<in> derivable' R*) \<longrightarrow>
    T \<in> derivable' R*)" by blast
  from 1 have prm: "(T,n) \<in> derivable (R \<union> {r1})*" by blast
  show ?case
  proof (cases n)
    case 0
    with prm have "(T,0) \<in> derivable (R \<union> {r1})*" by simp
    then have "([],T) \<in> (R \<union> {r1})*" by (rule derivable.cases) auto
    then obtain S r where ext: "extendRule S r = ([],T)" and "r \<in> (R \<union> {r1})" by (rule extRules.cases) auto
    then have "r \<in> R \<or> r = r1" by auto
    with a have "r \<in> R" using ext by (auto simp add:extendRule_def)
    then have "([],T) \<in> R*" using ext and extRules.I[where r=r and R=R and seq=S] by auto
    then show "T \<in> derivable' R*" by auto
  next
    case (Suc n')
    with prm have prm': "(T,n'+1) \<in> derivable (R \<union> {r1})*" by auto
    then obtain Ps where ne: "Ps \<noteq> []"
      and   ex: "(Ps,T) \<in> (R \<union> {r1})*"
      and   "\<forall> P \<in> set Ps. \<exists> m\<le>n'. (P,m) \<in> derivable (R \<union> {r1})*"
      using characteriseLast[where C=T and m=n' and R="(R \<union> {r1})*"] by auto
    with IH have e: "\<forall> P \<in> set Ps. P \<in> derivable' R*" using a b and prm' and \<open>n = Suc n'\<close>
      apply (auto simp only:Ball_def) apply (drule_tac x=x in spec) apply auto
      apply (drule_tac x=m in spec) apply auto apply (drule_tac x=x in spec) apply simp
      apply (insert CA[simplified]) apply (subgoal_tac "R = Ax \<union> R1") apply blast apply (insert b) by blast
    from ex obtain S r where ext: "extendRule S r = (Ps,T)" and "r \<in> (R \<union> {r1})" by (rule extRules.cases) auto
    then have "r \<in> R \<or> r = r1" by blast
    moreover
    {assume "r \<in> R"
      with ext have "(Ps,T) \<in> R*" using extRules.I[where r=r and R=R and seq=S] by auto
      with e have "T \<in> derivable' R*" using ne and
        derivable'.step[where r="(Ps,T)" and R="R*"] by auto
    }
    moreover
    {assume "r = r1"
      with e and a and ext have "(extend S (\<LM>A\<RM> \<Rightarrow>* \<Empt>)) \<in> derivable' R*"
        and  "(extend S (\<Empt> \<Rightarrow>* \<LM>A\<RM>)) \<in> derivable' R*"
        by (auto simp add:extendRule_def)
      then have "S \<in> derivable' R*" using CA apply-
        apply (drule_tac x="antec S" in spec) apply (drule_tac x="succ S" in spec) apply (drule_tac x=A in spec)
        apply (simp add:extend_def) by (cases S) auto
      then obtain s where "(S,s) \<in> derivable R*" using deriv_to_deriv2 by auto
      then have "(extend S c,s) \<in> derivable R*"
        using dpWeak[where R=R and R'=R1 and \<Gamma>="antec S" and \<Delta>="succ S"
          and \<Gamma>'="antec c" and \<Delta>'="succ c" and n=s] and b
        apply (auto simp add:extend_def union_ac) by (cases S) auto
      with ext have "(T,s) \<in> derivable R*" using \<open>r = r1\<close> and a by (auto simp add:extendRule_def)
      then have "T \<in> derivable' R*" by auto
    }
    ultimately show "T \<in> derivable' R*" by blast
  qed
qed
(*>*)

text\<open>
\noindent \textit{Combinable rules} can also be removed.  We encapsulate the combinable criterion by saying that if $(p \# P,T)$ and $(q \# P, T)$ are rules in a calculus, then we get an equivalent calculus by replacing these two rules by $((\textrm{extend } p \ q) \# P, T)$.  Since the \texttt{extend} function is commutative, the order of $p$ and $q$ in the new rule is not important.  This transformation is height preserving:
\<close>

lemma removeCombinable:
assumes a: "r1 = (p # ps,c) \<and> r1 \<in> upRules"
and     b: "r2 = (q # ps,c) \<and> r2 \<in> upRules"
and     c: "r3 = (extend p q # ps, c) \<and> r3 \<in> upRules"
and     d: "R1 \<subseteq> upRules \<and> R = Ax \<union> R1"
and     "(T,n) \<in> derivable (R \<union> {r1} \<union> {r2})*"
shows   "(T,n) \<in> derivable (R \<union> {r3})*"
(*<*)
using assms
proof (induct n arbitrary:T rule:nat_less_induct)
case (1 n T)
    then have IH: "\<forall>m<n. \<forall> T. (r1 = (p # ps, c) \<and> r1 \<in> upRules \<longrightarrow>
                               r2 = (q # ps, c) \<and> r2 \<in> upRules \<longrightarrow>
                               r3 = (extend p q # ps, c) \<and> r3 \<in> upRules \<longrightarrow>
                               R1 \<subseteq> upRules \<and> R = Ax \<union> R1 \<longrightarrow>
                              (T, m) \<in> derivable (R \<union> {r1} \<union> {r2})* \<longrightarrow>
                              (T, m) \<in> derivable (R \<union> {r3})*)" and
             prm: "(T, n) \<in> derivable (R \<union> {r1} \<union> {r2})*" by auto
    show ?case
    proof (cases n)
    case 0
        with prm have "(T,0) \<in> derivable (R \<union> {r1} \<union> {r2})*" by simp
        then have "([],T) \<in> (R \<union> {r1} \<union> {r2})*" by (rule derivable.cases) auto
        then obtain S r where ext: "extendRule S r = ([],T)" and "r \<in> (R \<union> {r1} \<union> {r2})" by (rule extRules.cases) auto
        then have "r \<in> R \<or> r = r1 \<or> r = r2" by blast
        with ext and a and b have "r \<in> R" by (auto simp add:extendRule_def)
        then have "r \<in> (R \<union> {r3})" by simp
        with ext have "([],T) \<in> (R \<union> {r3})*" using extRules.I[where r=r and R="R \<union> {r3}" and seq=S] by auto
        then have "(T,0) \<in> derivable (R \<union> {r3})*" by auto
        then show "(T,n) \<in> derivable (R \<union> {r3})*" using \<open>n=0\<close> by auto
    next
    case (Suc n')
        with prm have prm': "(T,n'+1) \<in> derivable (R \<union> {r1} \<union> {r2})*" by simp
        then obtain Ps where ne: "Ps \<noteq> []"
                       and   ex: "(Ps,T) \<in> (R \<union> {r1} \<union> {r2})*"
                       and   "\<forall> P \<in> set Ps. \<exists> m\<le>n'. (P,m) \<in> derivable (R \<union> {r1} \<union> {r2})*"
             using characteriseLast[where C=T and m=n' and R="(R \<union> {r1} \<union> {r2})*"] by auto
        with IH have e: "\<forall> P \<in> set Ps. \<exists> m\<le>n'. (P,m) \<in> derivable (R \<union> {r3})*" using a b c d and prm' and \<open>n = Suc n'\<close>
             apply (auto simp add:Ball_def) by (drule_tac x=x in spec) auto
        from ex obtain S r where ext: "extendRule S r = (Ps,T)" and "r \<in> (R \<union> {r1} \<union> {r2})" by (rule extRules.cases) auto
        then have "r \<in> R \<or> r = r1 \<or> r = r2" by blast
        moreover
           {assume "r \<in> R"
            then have "r \<in> (R \<union> {r3})" by simp
            with ext have "(Ps,T) \<in> (R \<union> {r3})*" using extRules.I[where r=r and R="R \<union> {r3}" and seq=S] by auto
            with e have "(T,n'+1) \<in> derivable (R \<union> {r3})*" using ne and
                 derivable.step[where r="(Ps,T)" and R="(R \<union> {r3})*" and m=n'] by auto
           }
        moreover
           {assume "r = r1"
            with e and a and ext have "\<exists> m\<le>n'. (extend S p,m) \<in> derivable (R \<union> {r3})*"
                 by (auto simp add:extendRule_def)
            then have "\<exists> m\<le>n'. (extend S (extend q p),m) \<in> derivable (R \<union> {r3})*"
                 using dpWeak[where R="R \<union> {r3}" and R'="R1 \<union> {r3}" and \<Gamma>="antec S + antec p" and \<Delta>="succ S + succ p"
                              and \<Gamma>'="antec q" and \<Delta>'="succ q"] and d c by (auto simp add:extend_def union_ac)
            moreover from e and ext and \<open>r = r1\<close> and a
                 have "\<forall> P \<in> set (map (extend S) ps). \<exists> m\<le>n'. (P,m) \<in> derivable (R \<union> {r3})*"
                 by (auto simp add:extendRule_def)
            ultimately have "\<forall> P \<in> set (map (extend S) (extend q p # ps)). \<exists> m\<le>n'. (P,m) \<in> derivable (R \<union> {r3})*"
                 by auto
            moreover have "extend q p = extend p q" by (auto simp add:extend_def union_ac)
            ultimately have pm: "\<forall> P \<in> set (fst (extendRule S r3)). \<exists> m\<le>n'. (P,m) \<in> derivable (R \<union> {r3})*"
                 using c by (auto simp add:extendRule_def)
            from ext and a and c and \<open>r = r1\<close> have con: "snd (extendRule S r3) = T" by (auto simp add:extendRule_def)
            have "r3 \<in> (R \<union> {r3})" by simp
            then have "extendRule S r3 \<in> (R \<union> {r3})*" by auto
            with pm and con and c have "(T,n'+1) \<in> derivable (R \<union> {r3})*"
                 using derivable.step[where r="extendRule S r3" and R="(R \<union> {r3})*" and m=n']
                 by (auto simp add:extendRule_def)
           }
        moreover
           {assume "r = r2"
            with e and b and ext have "\<exists> m\<le>n'. (extend S q,m) \<in> derivable (R \<union> {r3})*"
                 by (auto simp add:extendRule_def)
            then have "\<exists> m\<le>n'. (extend S (extend p q),m) \<in> derivable (R \<union> {r3})*"
                 using dpWeak[where R="R \<union> {r3}" and R'="R1 \<union> {r3}" and \<Gamma>="antec S + antec q" and \<Delta>="succ S + succ q"
                              and \<Gamma>'="antec p" and \<Delta>'="succ p"] and d c by (auto simp add:extend_def union_ac)
            moreover from e and ext and \<open>r = r2\<close> and b
                 have "\<forall> P \<in> set (map (extend S) ps). \<exists> m\<le>n'. (P,m) \<in> derivable (R \<union> {r3})*"
                 by (auto simp add:extendRule_def)
            ultimately have "\<forall> P \<in> set (map (extend S) (extend p q # ps)). \<exists> m\<le>n'. (P,m) \<in> derivable (R \<union> {r3})*"
                 by auto
            then have pm: "\<forall> P \<in> set (fst (extendRule S r3)). \<exists> m\<le>n'. (P,m) \<in> derivable (R \<union> {r3})*"
                 using c by (auto simp add:extendRule_def)
            from ext and b and c and \<open>r = r2\<close> have con: "snd (extendRule S r3) = T" by (auto simp add:extendRule_def)
            have "r3 \<in> (R \<union> {r3})" by simp
            then have "extendRule S r3 \<in> (R \<union> {r3})*" by auto
            with pm and con and c have "(T,n'+1) \<in> derivable (R \<union> {r3})*"
                 using derivable.step[where r="extendRule S r3" and R="(R \<union> {r3})*" and m=n']
                 by (auto simp add:extendRule_def)
           }
        ultimately show "(T,n) \<in> derivable (R \<union> {r3})*" using \<open>n = Suc n'\<close> by auto
    qed
qed
(*>*)
text\<open>
\section{Conclusions}

Only a portion of the formalisation was shown; a variety of intermediate lemmata were not made explicit.  This was necessary, for the \textit{Isabelle} theory files run to almost 8000 lines.  However, these files do not have to be replicated for each new calculus.  It takes very little effort to define a new calculus.  Furthermore, proving invertibility is now a quick process; less than 25 lines of proof in most cases.
\<close>
(*<*)
end(*>*)


theory Rules
  imports Interference
begin

chapter \<open>Rules\<close>

text \<open>Define the rely/guarantee rules for a concurrent program.\<close>

locale rules = interference

context rules
begin

section \<open>Global Rules\<close>

text \<open>Establish the rules of the logic, similar to standard Hoare-logic\<close>
inductive rules :: "'b rpred \<Rightarrow> 'b rpred \<Rightarrow> 'b set \<Rightarrow> ('a,'b) com \<Rightarrow> 'b set \<Rightarrow> bool"
  ("_,_ \<turnstile> _ {_} _" [65,0,0,0,65] 65)
  where
  basic[intro]:   "R,G \<turnstile>\<^sub>A P {\<alpha>} Q \<Longrightarrow> R,G \<turnstile> P { Basic \<alpha> } Q" |
  nil[intro]:     "stable R P \<Longrightarrow> R,G \<turnstile> P { Nil } P" |
  seq[intro]:     "R,G \<turnstile> Q { c\<^sub>2 } M \<Longrightarrow> R,G \<turnstile> P { c\<^sub>1 } Q \<Longrightarrow> R,G \<turnstile> P { c\<^sub>1 ;\<^sub>w c\<^sub>2 } M" |
  choice[intro]:  "\<forall>l. R,G \<turnstile> P { S l } Q \<Longrightarrow> R,G \<turnstile> P { Choice S } Q" |
  loop[intro]:    "stable R P \<Longrightarrow> R,G \<turnstile> P { c } P \<Longrightarrow> R,G \<turnstile> P { c*\<^sub>w } P" |
  thread[intro]:  "R,G \<turnstile> P { c } Q \<Longrightarrow> rif R G c \<Longrightarrow> R,G \<turnstile> P { Thread c } Q" |
  par[intro]:     "R\<^sub>1,G\<^sub>1 \<turnstile> P\<^sub>1 { c\<^sub>1 } Q\<^sub>1 \<Longrightarrow> R\<^sub>2,G\<^sub>2 \<turnstile> P\<^sub>2 { c\<^sub>2 } Q\<^sub>2 \<Longrightarrow> G\<^sub>2 \<subseteq> R\<^sub>1 \<Longrightarrow> G\<^sub>1 \<subseteq> R\<^sub>2 \<Longrightarrow>
                    R\<^sub>1 \<inter> R\<^sub>2,G\<^sub>1 \<union> G\<^sub>2 \<turnstile> P\<^sub>1 \<inter> P\<^sub>2 { c\<^sub>1 || c\<^sub>2 } (Q\<^sub>1 \<inter> Q\<^sub>2)" |
  conseq[intro]:  "R,G \<turnstile> P { c } Q \<Longrightarrow> P' \<subseteq> P \<Longrightarrow> R' \<subseteq> R \<Longrightarrow> G \<subseteq> G' \<Longrightarrow> Q \<subseteq> Q' \<Longrightarrow>
                    R',G' \<turnstile> P' { c } Q'"  |
  inv[intro]:     "R,G \<turnstile> P {c} Q \<Longrightarrow> stable R' I \<Longrightarrow> G \<subseteq> R' \<Longrightarrow> R \<inter> R',G \<turnstile> (P \<inter> I) {c} (Q \<inter> I)" |
  capture[intro]: "uncapRely R,uncapGuar G \<turnstile> pushpred s P {c} pushpredAll Q \<Longrightarrow>
                    R,G \<turnstile> P {Capture s c} Q"

subsection \<open>Properties\<close>

lemma nilE [elim!]:
  assumes "R,G \<turnstile> P {Nil} Q"
  obtains M where "stable R M" "P \<subseteq> M" "M \<subseteq> Q"
  using assms
  by (induct R G P "Nil :: ('a,'b) com" Q) blast+

lemma nilE2:
  assumes "R,G \<turnstile> P {Nil} Q"
  shows "stabilise R P \<subseteq> Q"
  using assms
proof (induct R G P "Nil :: ('a,'b) com" Q)
  case (nil R P G)
  then show ?case
    by (simp add: stabilise_stable)
next
  case (conseq R G P Q P' R' G' Q')
  then show ?case
    by (meson dual_order.trans stabilise_mono_RP)
next
  case (inv R G P Q R' I)
  then show ?case
    by (metis Int_commute inf_mono order_refl stabilise_inter_RP stabilise_stable subset_trans)
qed

lemma basicE [elim!]:
  assumes "R,G \<turnstile> P {Basic \<beta>} Q"
  obtains Q' where "R,G \<turnstile>\<^sub>A stabilise R P {\<beta>} Q'" "Q' \<subseteq> Q"
  using assms
proof (induct R G P "Basic \<beta> :: ('a,'b) com" Q arbitrary: \<beta>)
  case (basic R G P \<alpha> Q)
  then show ?case using stabilise_atomic by fast
next
  case (conseq R G P Q P' R' G' Q')
  show ?case
  proof (rule conseq(2), goal_cases)
    case (1 Q')
    thus ?case using conseq
    by (meson atomic_conseqI atomic_pre dual_order.trans stabilise_mono_RP stable_stabilise)
  qed
next
  case (inv R G P Q R' I)
  show ?case
  proof (rule inv(2), goal_cases)
    case (1 Q')
    thus ?case using inv(3,4) inv(5)[of "Q' \<inter> I"] atomic_invI
      by (smt (verit, best) Int_greatest atomic_pre dual_order.eq_iff dual_order.trans
                            le_infE stabilise_inter_RP stabilise_stable stable_stabilise)
  qed
qed

lemma seqE [elim]:
  assumes "R,G \<turnstile> P {c\<^sub>1 ;\<^sub>w c\<^sub>2} Q"
  obtains M  where "R,G \<turnstile> P {c\<^sub>1} M" "R,G \<turnstile> M {c\<^sub>2} Q"
  using assms by (induct R G P "c\<^sub>1 ;\<^sub>w c\<^sub>2" Q arbitrary: c\<^sub>1 c\<^sub>2) blast+

lemma captureE:
  assumes "R,G \<turnstile> P {Capture s c} Q"
  shows "uncapRely R,uncapGuar G \<turnstile> uncapPred s P {c} pushpredAll Q"
using assms
proof (induct R G P "Capture s c" Q arbitrary: s c)
  case (conseq R G P Q P' R' G' Q')
  thus ?case using rules.conseq by force
next
  case (capture R G s P c Q)
  thus ?case by simp
next
  case (inv R G P Q R' I)
  have "pushrelSame R,pushrelAll G \<turnstile> pushpred s P {c} pushpredAll Q"
    using inv(2) by auto
  moreover have "pushrelAll G \<subseteq> pushrelAll R'"
    using inv by (intro pushrelAll_mono)
  moreover have
    "stable (pushrelAll R') (pushpredAll I)"
    using inv by (intro stable_pushrelAll)
  ultimately have
    "pushrelSame R \<inter> pushrelAll R',pushrelAll G
      \<turnstile> pushpred s P \<inter> pushpredAll I {c} pushpredAll Q \<inter> pushpredAll I"
    by (intro rules.inv)
  hence
    "pushrelSame R \<inter> pushrelAll R',pushrelAll G
      \<turnstile> pushpred s (P \<inter> I) {c} pushpredAll (Q \<inter> I)"
    by (simp add: pushpred_inter_pushpredAll pushpredAll_inter)
  hence
    "pushrelSame (R \<inter> R'),pushrelAll G
      \<turnstile> pushpred s (P \<inter> I) {c} pushpredAll (Q \<inter> I)"
    using pushrelSame_in_pushrelAll by auto
  thus ?case.
qed

text \<open>In fact, we can rephrase a judgement with an explicit stabilisation.\<close>
lemma stable_preE':
  assumes "R,G \<turnstile> P {c} Q"
  shows "R,G \<turnstile> stabilise R P {c} Q"
using assms
proof (induct)
  case (basic R G P \<alpha> Q)
  thus ?case using stabilise_atomic by (intro rules.basic, simp)
next
  case (nil R P G)
  thus ?case by (simp add: rules.nil stabilise_stable)
next
  case (loop R P G c)
  thus ?case by (simp add: rules.loop stabilise_stable)
next
  case (par R\<^sub>1 G\<^sub>1 P\<^sub>1 c\<^sub>1 Q\<^sub>1 R\<^sub>2 G\<^sub>2 P\<^sub>2 c\<^sub>2 Q\<^sub>2)
  hence "R\<^sub>1 \<inter> R\<^sub>2, G\<^sub>1 \<union> G\<^sub>2 \<turnstile> stabilise R\<^sub>1 P\<^sub>1 \<inter> stabilise R\<^sub>2 P\<^sub>2 {c\<^sub>1 || c\<^sub>2} Q\<^sub>1 \<inter> Q\<^sub>2"
    by (intro rules.par)
  thus ?case using stabilise_inter_RP by (rule conseq; simp)
next
  case (conseq R G P c Q P' R' G' Q')
  thus ?case using stabilise_mono_RP[of R' R P' P] by blast
next
  case (inv R G P c Q R' I)
  hence "R \<inter> R',G \<turnstile> stabilise R P \<inter> I {c} Q \<inter> I" by (intro rules.inv)
  hence "R \<inter> R',G \<turnstile> stabilise R P \<inter> stabilise R' I {c} Q \<inter> I"
    using inv stabilise_stable[of R' I] by simp
  thus ?case using stabilise_inter_RP by (rule conseq; simp)
next
  case (capture R G s P c Q)
  thus ?case by (intro rules.capture, auto simp add: stabilise_pushrel)
qed auto

text \<open>It is always possible to rephrase a judgement in terms of a stable precondition\<close>
lemma stable_preE:
  assumes "R,G \<turnstile> P {c} Q"
  shows "\<exists>P'. P \<subseteq> P' \<and> stable R P' \<and> R,G \<turnstile> P' {c} Q"
  using assms stabilise_supset stable_stabilise stable_preE'
  by metis

text \<open>Universal quantification of top-most stack frame\<close>
lemma univ_captureI:
  assumes "\<forall>l. pushrelSame R,pushrelAll G \<turnstile> pushpred l P {c} pushpredAll Q"
  shows "R,G \<turnstile> P {\<forall>\<^sub>c c} Q"
  using assms by (intro choice allI capture) simp

(*
lemma falseI:
  "local c \<Longrightarrow> \<forall>\<beta> \<in> obs c. guar\<^sub>\<alpha> \<beta> G \<Longrightarrow> R,G \<turnstile> {} {c} {}"
proof (induct c arbitrary: R G)
  case (Basic x)
  thus ?case by (intro basic) (auto simp: atomic_rule_def guar_def wp_def)
next
  case (Choice x)
  thus ?case
    by (intro choice allI Choice(1)) auto
next
  case (Seq c1 w c2)
  hence "R,G \<turnstile> {} {c1} {}" "R,G \<turnstile> {} {c2} {}" by auto
  then show ?case by auto
next
  case (Capture s c)
  hence "\<forall>\<beta>\<in>overbasic c. \<forall>s s'. guar\<^sub>\<alpha> (popbasic s s' \<beta>) G" by fastforce
  hence "\<forall>\<beta>\<in>overbasic c. guar\<^sub>\<alpha> \<beta> (uncapGuar G)" using guar_mix by force
  thus ?case using Capture(2) by (intro capture, simp, intro Capture(1) ballI; simp)
qed (auto) *)

end

end


section \<open>Prefixes on Coinductive Lists\<close>

theory LList_Prefixes
imports
  Word_Prefixes
  "../Extensions/Coinductive_List_Extensions"
begin

  lemma unfold_stream_siterate_smap: "unfold_stream f g = smap f \<circ> siterate g"
    by (rule, coinduction, auto) (metis unfold_stream_eq_SCons)+

  lemma lappend_stream_of_llist:
    assumes "lfinite u"
    shows "stream_of_llist (u $ v) = list_of u @- stream_of_llist v"
    using assms unfolding stream_of_llist_def by induct auto

  lemma llist_of_inf_llist_prefix[intro]: "u \<le>\<^sub>F\<^sub>I v \<Longrightarrow> llist_of u \<le> llist_of_stream v"
    by (metis lappend_llist_of_stream_conv_shift le_llist_conv_lprefix lprefix_lappend prefix_fininfE)
  lemma prefix_llist_of_inf_llist[intro]: "lfinite u \<Longrightarrow> u \<le> v \<Longrightarrow> list_of u \<le>\<^sub>F\<^sub>I stream_of_llist v"
    by (metis lappend_stream_of_llist le_llist_conv_lprefix lprefix_conv_lappend prefix_fininfI)

  lemma lproject_prefix_limit_chain:
    assumes "chain w" "\<And> k. lproject A (llist_of (w k)) \<le> x"
    shows "lproject A (llist_of_stream (limit w)) \<le> x"
  proof (rule lproject_prefix_limit')
    fix k
    obtain l where 1: "k < length (w l)" using assms(1) by rule
    show "\<exists> v \<le> llist_of_stream (limit w). enat k < llength v \<and> lproject A v \<le> x"
    proof (intro exI conjI)
      show "llist_of (w l) \<le> llist_of_stream (limit w)"
        using llist_of_inf_llist_prefix chain_prefix_limit assms(1) by this
      show "enat k < llength (llist_of (w l))" using 1 by simp
      show "lproject A (llist_of (w l)) \<le> x" using assms(2) by this
    qed
  qed
  lemma lproject_eq_limit_chain:
    assumes "chain u" "chain v" "\<And> k. project A (u k) = project A (v k)"
    shows "lproject A (llist_of_stream (limit u)) = lproject A (llist_of_stream (limit v))"
  proof (rule antisym)
    show "lproject A (llist_of_stream (limit u)) \<le> lproject A (llist_of_stream (limit v))"
    proof (rule lproject_prefix_limit_chain)
      show "chain u" using assms(1) by this
    next
      fix k
      have "lproject A (llist_of (u k)) = lproject A (llist_of (v k))" using assms(3) by simp
      also have "\<dots> \<le> lproject A (llist_of_stream (limit v))" using chain_prefix_limit assms(2) by blast
      finally show "lproject A (llist_of (u k)) \<le> lproject A (llist_of_stream (limit v))" by this
    qed
    show "lproject A (llist_of_stream (limit v)) \<le> lproject A (llist_of_stream (limit u))"
    proof (rule lproject_prefix_limit_chain)
      show "chain v" using assms(2) by this
    next
      fix k
      have "lproject A (llist_of (v k)) = lproject A (llist_of (u k))" using assms(3) by simp
      also have "\<dots> \<le> lproject A (llist_of_stream (limit u))" using chain_prefix_limit assms(1) by blast
      finally show "lproject A (llist_of (v k)) \<le> lproject A (llist_of_stream (limit u))" by this
    qed
  qed

end


theory Relational_CSP

imports
 Main
 List
begin

section {* Type Definitions*}

datatype 'a tr = tick | symbol 'a

type_synonym 'a trace = "'a list"
type_synonym 'a failure = "('a list * 'a set)"
type_synonym 'a state = "('a failure) option"
type_synonym 'a prel = "('a state * 'a state) set"

text {* In Failures-Divergences a CSP process is denoted by a pair of
        failures (set of failures) and divergences (set of traces).*}

type_synonym 'a process = "('a failure) set \<times> ('a trace) set"

section {* Healthiness Conditions *}

definition tracesbot :: "'a process \<Rightarrow> ('a trace) set" ("traces\<^sub>\<bottom>'(_')")
 where "tracesbot P = {s. \<exists>X. (s, X) \<in> fst P} \<union> snd P"

text {* F1: tracesbot is non-empty and prefix-closed *}

definition F1 :: "'a process \<Rightarrow> bool"
 where "F1 P \<equiv> traces\<^sub>\<bottom>(P) \<noteq> {} \<and> (\<forall>t. t \<in> traces\<^sub>\<bottom>(P) \<longrightarrow> (\<exists>s a. t=s @ a \<and> s \<in> traces\<^sub>\<bottom>(P)))"

text {* F2: Failures are subset-closed. *}

definition F2 :: "'a process \<Rightarrow> bool"
 where "F2 P \<equiv> \<forall>s X Y. (s, X) \<in> (fst P) \<and> Y \<subseteq> X \<longrightarrow> (s, Y) \<in> (fst P)"

text {* F3: When a process refuses $x$ it also refuses all events that
            it can never perform after the same trace. *}

definition F3 :: "'a process \<Rightarrow> bool"
 where "F3 P \<equiv> \<forall>s X Y. ((s, X) \<in> (fst P) \<and> (snd P) \<inter> {x. (s@x) \<in> traces\<^sub>\<bottom>(P)} = {}) \<longrightarrow> (s, X \<union> Y) \<in> (fst P)"

text {* There's no way to define F4 because we do not treat 'tick' here. *}

definition D1 :: "'a process \<Rightarrow> bool"
 where "D1 P \<equiv> \<forall>s t. s \<in> (snd P) \<longrightarrow> (s@t) \<in> (snd P)"

definition D2 :: "'a process \<Rightarrow> bool"
 where "D2 P \<equiv> \<forall>s X. s \<in> (snd P) \<longrightarrow> (s, X) \<in> (fst P)"

definition trace :: "'a failure \<Rightarrow> 'a trace"
 where "trace f = fst f"

definition fd2r :: "('a failure) set \<Rightarrow> ('a trace) set \<Rightarrow> 'a prel"
 where "fd2r F D = { (s,s'). {the s,the s'} \<subseteq> F \<and> s \<noteq> None \<and> s' \<noteq> None
                             \<and> (\<exists>a. trace (the s') = (trace (the s) @ a))
                             }
                   \<union> { (s,s'). trace (the s) \<in> D \<and>
                               (s'=None \<or> (\<exists>a. trace (the s') = trace (the s) @ a)) } \<union> { (None,None) }"

definition fdP2r :: "'a process \<Rightarrow> 'a prel"
 where "fdP2r P = fd2r (fst P) (snd P)"

definition divFailureStrict :: "('a failure) set \<Rightarrow> ('a trace) set \<Rightarrow> ('a failure) set"
 where "divFailureStrict F D = F \<union> {(s,X). s \<in> D}"

definition divStrict :: "('a trace) set \<Rightarrow> ('a trace) set"
 where "divStrict D = D \<union> {s'. \<exists>s a. s' = s @ a \<and> s \<in> D}"

definition F2f :: "('a failure) set \<Rightarrow> bool"
 where "F2f F \<equiv> \<forall>s X Y. (s, X) \<in> F \<and> Y \<subseteq> X \<longrightarrow> (s, Y) \<in> F"

section {* Relational model*}

subsection {* Healthiness Conditions*}

text {* In a predicative style *}

text {* Prefix closure *}

definition CR1H :: "'a prel \<Rightarrow> bool"
 where "CR1H R = (\<forall>s s'. ((s,s') \<in> R \<and> s\<noteq>None \<and> s'\<noteq>None) \<longrightarrow> (\<exists>t. trace (the s') = trace (the s) @ t))"

text {* Divergence strictness*}

definition CR2H :: "'a prel \<Rightarrow> bool"
 where "CR2H R = (\<forall>s s'. ((s,None) \<in> R \<and> s \<noteq> None \<and> s' \<noteq> None
                  \<and> trace (the s) = trace (the s')) \<longrightarrow> (s',None) \<in> R)"

text {* None to None *}

definition CR3H :: "'a prel \<Rightarrow> bool"
 where "CR3H R = (\<forall>s. s \<noteq> None \<and> (None,s) \<notin> R \<and> (None,None) \<in> R)"

text {* Or in a fixed-point style *}

definition R1H :: "'a prel \<Rightarrow> 'a prel"
 where "R1H R = { (s,s'). \<exists>t.(s,s') \<in> R \<and> s \<noteq> None \<and> trace (the s') = trace (the s) @ t }"

definition R2H :: "'a prel \<Rightarrow> 'a prel"
 where "R2H R = { (s,s'). \<exists>t. (s,None) \<in> R \<and> s \<noteq> None \<and> trace(the s') = trace (the s) @ t \<or> (s,s') \<in> R }"

definition R3H :: "'a prel \<Rightarrow> 'a prel"
 where "R3H R = R \<union> {(None,None)}"

subsection {* Linking from the relational model *}

text {* From a relation to a set of failures. *}

definition r2f :: "'a prel \<Rightarrow> ('a failure) set"
 where "r2f R = { f. \<exists>s s'. (s,s') \<in> R \<and> f = the s' \<and> s \<noteq> None \<and> s' \<noteq> None}"

text {* From a relation to a set of divergences. *}

definition r2d :: "'a prel \<Rightarrow> ('a trace) set"
 where "r2d R = { t. \<exists>s. (s,None) \<in> R \<and> t = trace (the s) \<and> s \<noteq> None}"

text {* From a relation to a CSP process. *}

definition r2P :: "'a prel \<Rightarrow> 'a process"
 where "r2P R = (r2f R, r2d R)"

lemma "CR1H(fd2r F D)"
 apply (simp add:CR1H_def fd2r_def trace_def)
 by auto

lemma "CR2H(fd2r F D)"
 apply (simp add:fd2r_def CR2H_def trace_def)
 by auto

lemma
 assumes "CR3H R" "CR2H R" "CR1H R"
 shows "fd2r (r2f R) (r2d R) = R"
 using assms
 apply (simp add:CR3H_def CR2H_def CR1H_def r2f_def r2d_def fd2r_def trace_def)
 by blast

lemma r2fd_is_F1:
 assumes "CR3H R" "CR2H R" "CR1H R"
 shows "F1((r2f R),(r2d R))"
 using assms unfolding CR1H_def CR2H_def CR3H_def
 by blast

lemma r2fd_is_F2:
 assumes "CR3H R" "CR2H R" "CR1H R"
 shows "F2((r2f R),(r2d R))"
 using assms unfolding CR1H_def CR2H_def CR3H_def
 by blast

lemma r2fd_is_F3:
 assumes "CR3H R" "CR2H R" "CR1H R"
 shows "F3((r2f R),(r2d R))"
 using assms unfolding CR1H_def CR2H_def CR3H_def
 by blast

lemma r2fd_is_D1:
 assumes "CR3H R" "CR2H R" "CR1H R"
 shows "D1((r2f R),(r2d R))"
 using assms unfolding CR1H_def CR2H_def CR3H_def
 by blast

lemma r2fd_is_D2:
 assumes "CR3H R" "CR2H R" "CR1H R"
 shows "D2((r2f R),(r2d R))"
 using assms unfolding CR1H_def CR2H_def CR3H_def
 by blast

lemma r2f_fd2r:
assumes "divStrict D = D" and "divFailureStrict F D = F"
shows "r2f (fd2r F D) = F"
apply auto
apply (simp add:fd2r_def r2f_def trace_def)
apply auto
using assms unfolding divStrict_def divFailureStrict_def
apply (simp add:fd2r_def r2f_def)
apply blast
using assms unfolding divStrict_def divFailureStrict_def
apply (simp add:fd2r_def r2f_def)
by (metis (no_types, lifting) append_Nil2 option.sel)

lemma r2d_fd2r: "r2d (fd2r F D) = D"
apply auto
apply (simp add:fd2r_def r2d_def)
apply blast
apply (simp add:fd2r_def r2d_def)
by (metis option.sel prod.sel(1) trace_def)

lemma D1_is_divStrict:
 shows "D1(P) = (divStrict (snd P) = (snd P))"
 apply (simp add:divStrict_def D1_def)
 by blast

lemma D2_is_divFailureStrict:
 shows "D2(P) = (divFailureStrict (fst P) (snd P) = (fst P))"
 apply (simp add:divFailureStrict_def D2_def)
 by blast

lemma r2P_fdP2r:
 assumes "D1(P)" "D2(P)"
 shows "r2P (fdP2r P) = P"
 apply (simp add:r2P_def fdP2r_def)
 using assms
 by (simp add: D1_is_divStrict D2_is_divFailureStrict r2d_fd2r r2f_fd2r)

lemma fdP2r_r2P:
 assumes "CR3H R"
 shows "fdP2r (r2P R) = R"
 using CR3H_def and assms by blast

end


(* This Isabelle theory is produced using the TIP tool offered at the following website:
     https://github.com/tip-org/tools
   This file was originally provided as part of TIP benchmark at the following website:
     https://github.com/tip-org/benchmarks
   Yutaka Nagashima at CIIRC, CTU changed the TIP output theory file slightly
   to make it compatible with Isabelle2017.
\:w
   Some proofs were added by Yutaka Nagashima.*)
  theory TIP_weird_nat_add3acc_assoc1
imports "../../Test_Base"
begin

datatype Nat = Z | S "Nat"

fun add3acc :: "Nat => Nat => Nat => Nat" where
"add3acc (Z) (Z) z = z"
| "add3acc (Z) (S x3) z = add3acc Z x3 (S z)"
| "add3acc (S x2) y z = add3acc x2 (S y) z"

theorem property0 :
  "((add3acc (add3acc x1 x2 x3) x4 x5) =
      (add3acc x1 x2 (add3acc x3 x4 x5)))"
  oops

end


theory DDLcube imports Main

begin

(*** We introduce Aqvist's system E from the 2019 IfColog paper ***)

typedecl i (* Possible worlds *)
type_synonym \<sigma> = "(i\<Rightarrow>bool)"
type_synonym \<alpha> = "i\<Rightarrow>\<sigma>" (* Type of betterness relation between worlds *)
type_synonym \<tau> = "\<sigma>\<Rightarrow>\<sigma>"

consts aw::i (* Actual world *)
abbreviation etrue  :: "\<sigma>" ("\<^bold>\<top>") where "\<^bold>\<top> \<equiv> \<lambda>w. True"
abbreviation efalse :: "\<sigma>" ("\<^bold>\<bottom>")  where "\<^bold>\<bottom> \<equiv> \<lambda>w. False"
abbreviation enot :: "\<sigma>\<Rightarrow>\<sigma>" ("\<^bold>\<not>_"[52]53)  where "\<^bold>\<not>\<phi> \<equiv> \<lambda>w. \<not>\<phi>(w)"
abbreviation eand :: "\<sigma>\<Rightarrow>\<sigma>\<Rightarrow>\<sigma>" (infixr"\<^bold>\<and>"51) where "\<phi>\<^bold>\<and>\<psi> \<equiv> \<lambda>w. \<phi>(w)\<and>\<psi>(w)"
abbreviation eor  :: "\<sigma>\<Rightarrow>\<sigma>\<Rightarrow>\<sigma>" (infixr"\<^bold>\<or>"50) where "\<phi>\<^bold>\<or>\<psi> \<equiv> \<lambda>w. \<phi>(w)\<or>\<psi>(w)"
abbreviation eimpf :: "\<sigma>\<Rightarrow>\<sigma>\<Rightarrow>\<sigma>" (infixr"\<^bold>\<rightarrow>"49) where "\<phi>\<^bold>\<rightarrow>\<psi> \<equiv> \<lambda>w. \<phi>(w)\<longrightarrow>\<psi>(w)"
abbreviation eimpb :: "\<sigma>\<Rightarrow>\<sigma>\<Rightarrow>\<sigma>" (infixr"\<^bold>\<leftarrow>"49) where "\<phi>\<^bold>\<leftarrow>\<psi> \<equiv> \<lambda>w. \<psi>(w)\<longrightarrow>\<phi>(w)"
abbreviation eequ :: "\<sigma>\<Rightarrow>\<sigma>\<Rightarrow>\<sigma>" (infixr"\<^bold>\<leftrightarrow>"48) where "\<phi>\<^bold>\<leftrightarrow>\<psi> \<equiv> \<lambda>w. \<phi>(w)\<longleftrightarrow>\<psi>(w)"

abbreviation ebox :: "\<sigma>\<Rightarrow>\<sigma>" ("\<box>") where "\<box> \<equiv> \<lambda>\<phi> w.  \<forall>v. \<phi>(v)"
abbreviation ddediomond  :: "\<sigma>\<Rightarrow>\<sigma>" ("\<diamond>") where "\<diamond>\<phi> \<equiv> \<lambda>w. \<exists>v. \<phi>(v)"

abbreviation evalid :: "\<sigma>\<Rightarrow>bool" ("\<lfloor>_\<rfloor>"[8]109)  (* Global validity *)
  where "\<lfloor>p\<rfloor> \<equiv> \<forall>w. p w"
abbreviation ecjactual :: "\<sigma>\<Rightarrow>bool" ("\<lfloor>_\<rfloor>\<^sub>l"[7]105) (* Local validity — in world aw *)
  where "\<lfloor>p\<rfloor>\<^sub>l \<equiv> p(aw)"

consts r :: "\<alpha>" (infixr "\<^bold>r" 70) (* Betterness relation *)

abbreviation esubset :: "\<sigma>\<Rightarrow>\<sigma>\<Rightarrow>bool" (infix "\<^bold>\<subseteq>" 53)
  where "\<phi> \<^bold>\<subseteq> \<psi> \<equiv> \<forall>x. \<phi> x \<longrightarrow> \<psi> x"

abbreviation eopt  :: "\<sigma>\<Rightarrow>\<sigma>" ("opt<_>")  (* opt rule*)
  where "opt<\<phi>> \<equiv> (\<lambda>v. ( (\<phi>)(v) \<and> (\<forall>x. ((\<phi>)(x) \<longrightarrow> v \<^bold>r x) )) )"
abbreviation econdopt :: "\<sigma>\<Rightarrow>\<sigma>\<Rightarrow>\<sigma>" ("\<odot><_|_>")
  where "\<odot><\<psi>|\<phi>> \<equiv>  \<lambda>w. opt<\<phi>> \<^bold>\<subseteq> \<psi>"
abbreviation eperm :: "\<sigma>\<Rightarrow>\<sigma>\<Rightarrow>\<sigma>" ("\
<_|_>")
  where "\
<\<psi>|\<phi>> \<equiv> \<^bold>\<not>\<odot><\<^bold>\<not>\<psi>|\<phi>>"

abbreviation emax  :: "\<sigma>\<Rightarrow>\<sigma>" ("max<_>")      (* Max rule *)
  where "max<\<phi>> \<equiv> (\<lambda>v. ( (\<phi>)(v) \<and> (\<forall>x. ((\<phi>)(x) \<longrightarrow> (x \<^bold>r v \<longrightarrow>  v \<^bold>r x)) )) )"
abbreviation econd  :: "\<sigma>\<Rightarrow>\<sigma>\<Rightarrow>\<sigma>" ("\<circle><_|_>")
  where "\<circle><\<psi>|\<phi>> \<equiv>  \<lambda>w. max<\<phi>> \<^bold>\<subseteq> \<psi>"
abbreviation euncobl :: "\<sigma>\<Rightarrow>\<sigma>" ("\<^bold>\<circle><_>")
  where "\<^bold>\<circle><\<phi>> \<equiv> \<circle><\<phi>|\<^bold>\<top>>"
abbreviation ddeperm :: "\<sigma>\<Rightarrow>\<sigma>\<Rightarrow>\<sigma>" ("P<_|_>")
  where "P<\<psi>|\<phi>> \<equiv>\<^bold>\<not>\<circle><\<^bold>\<not>\<psi>|\<phi>>"

(* Settings for model finder Nitpick *)

nitpick_params [user_axioms,show_all,expect=genuine]

(*** First consistency check ***)

lemma True
  nitpick [satisfy] (* model found *)
  oops

(*** The max-rule and opt-rule don't coincide ***)

lemma "\<odot><\<psi>|\<phi>> \<equiv> \<circle><\<psi>|\<phi>>"
  nitpick [card i=1] (* counterexample found for card i=1 *)
  oops

(* David Lewis's evaluation rule for the conditional *)

abbreviation lewcond :: "\<sigma>\<Rightarrow>\<sigma>\<Rightarrow>\<sigma>"  ("\<circ><_|_>")
  where "\<circ><\<psi>|\<phi>> \<equiv> \<lambda>v. (\<not>(\<exists>x. (\<phi>)(x))\<or>
        (\<exists>x. ((\<phi>)(x)\<and>(\<psi>)(x) \<and> (\<forall>y. ((y \<^bold>r x) \<longrightarrow> (\<phi>)(y)\<longrightarrow>(\<psi>)(y))))))"
abbreviation lewperm :: "\<sigma>\<Rightarrow>\<sigma>\<Rightarrow>\<sigma>" ("\<integral><_|_>")
  where "\<integral><\<psi>|\<phi>> \<equiv>\<^bold>\<not>\<circ><\<^bold>\<not>\<psi>|\<phi>>"

(* Kratzer evaluation rule for the conditional *)

abbreviation kratcond :: "\<sigma>\<Rightarrow>\<sigma>\<Rightarrow>\<sigma>"  ("\<ominus><_|_>")
  where "\<ominus><\<psi>|\<phi>> \<equiv> \<lambda>v. ((\<forall>x. ((\<phi>)(x) \<longrightarrow>
     (\<exists>y. ((\<phi>)(y)\<and>(y \<^bold>r x) \<and> ((\<forall>z. ((z \<^bold>r y) \<longrightarrow> (\<phi>)(z) \<longrightarrow> (\<psi>)(z)))))))))"
abbreviation kratperm :: "\<sigma>\<Rightarrow>\<sigma>\<Rightarrow>\<sigma>" ("\<times><_|_>")
  where "\<times><\<psi>|\<phi>> \<equiv>\<^bold>\<not>\<ominus><\<^bold>\<not>\<psi>|\<phi>>"

(****************
Properties
******************)

(* The standard properties of the betterness relation *)

abbreviation "reflexivity  \<equiv> (\<forall>x. x \<^bold>r x)"
abbreviation "transitivity \<equiv> (\<forall>x y z. (x \<^bold>r y \<and> y \<^bold>r z) \<longrightarrow> x \<^bold>r z)"
abbreviation "totalness \<equiv> (\<forall>x y. (x \<^bold>r y \<or> y \<^bold>r x))"

(* 4 versions of Lewis's limit assumption *)

abbreviation "mlimitedness \<equiv> (\<forall>\<phi>. (\<exists>x. (\<phi>)x) \<longrightarrow> (\<exists>x. max<\<phi>>x))"
abbreviation "msmoothness \<equiv>
   (\<forall>\<phi> x. ((\<phi>)x \<longrightarrow> (max<\<phi>>x \<or> (\<exists>y. (y \<^bold>r x \<and> \<not>(x \<^bold>r y) \<and> max<\<phi>>y)))))"
abbreviation "olimitedness \<equiv> (\<forall>\<phi>. (\<exists>x. (\<phi>)x) \<longrightarrow> (\<exists>x. opt<\<phi>>x))"
abbreviation "osmoothness \<equiv>
   (\<forall>\<phi> x. ((\<phi>)x \<longrightarrow> (opt<\<phi>>x \<or> (\<exists>y. (y \<^bold>r x \<and> \<not>(x \<^bold>r y) \<and> opt<\<phi>>y)))))"

(* Weaker forms of transitivity--they require the notion of
transitive closure*)

definition transitive :: "\<alpha>\<Rightarrow>bool"
  where "transitive Rel \<equiv> \<forall>x y z. Rel x y \<and>  Rel y z \<longrightarrow> Rel x z"
definition sub_rel :: "\<alpha>\<Rightarrow>\<alpha>\<Rightarrow>bool"
  where "sub_rel Rel1 Rel2 \<equiv> \<forall>u v. Rel1 u v \<longrightarrow> Rel2 u v"
definition assfactor::"\<alpha>\<Rightarrow>\<alpha>"
  where "assfactor Rel \<equiv> \<lambda>u v. Rel u v \<and> \<not>Rel v u "

(* In HOL the transitive closure of a relation can be defined in a single line; here
   we apply the construction to betterness relation \<^bold>r and for its strict
   variant (\<lambda>u v. u \<^bold>r v \<and> \<not>v \<^bold>r u) *)
definition tcr
  where "tcr \<equiv> \<lambda>x y. \<forall>Q. transitive Q \<longrightarrow> (sub_rel r Q \<longrightarrow> Q x y)"

definition tcr_strict
  where "tcr_strict \<equiv> \<lambda>x y. \<forall>Q. transitive Q \<longrightarrow> (sub_rel (\<lambda>u v. u \<^bold>r v \<and> \<not>v \<^bold>r u) Q \<longrightarrow> Q x y)"

(* First weakening is quasi-transitivity: the strict betterness
relation is transitive*)
abbreviation Quasitransit
  where "Quasitransit  \<equiv> \<forall>x y z. (assfactor r x y \<and>
                    assfactor r y z) \<longrightarrow> assfactor r x z"

(* Second weakening is called Suzumura consistency: cycles with one
non-strict betterness are ruled out*)
abbreviation Suzumura
  where "Suzumura \<equiv> \<forall>x y. tcr x y \<longrightarrow> (y \<^bold>r x \<longrightarrow> x \<^bold>r y)"

theorem T1: "Suzumura \<equiv> \<forall>x y. tcr x y \<longrightarrow> \<not> (y \<^bold>r x \<and> \<not>x \<^bold>r y)" by simp

(* Second weakening is called a-cyclicity: cycles of non-strict
betterness are ruled out*)

abbreviation loopfree
  where "loopfree \<equiv> \<forall>x y. tcr_strict x y \<longrightarrow> (y \<^bold>r x \<longrightarrow> x \<^bold>r y)"

(* 3nd weakening: Interval order (reflexivity + Ferrers) *)

abbreviation Ferrers
  where "Ferrers \<equiv> (\<forall>x y z u. (x \<^bold>r u \<and> y \<^bold>r z) \<longrightarrow> (x \<^bold>r z \<or> y \<^bold>r u))"

theorem T2:
  assumes Ferrers and reflexivity  (*fact overlooked in the literature*)
  shows totalness
  by (simp add: assms(1) assms(2))  (* proof found *)

(*their relationships*)

theorem T3:
  assumes transitivity
  shows "Suzumura"
  by (metis assms sub_rel_def tcr_def transitive_def)

theorem T4:
  assumes transitivity
  shows Quasitransit
  by (metis assfactor_def assms)

theorem T5:
  assumes Suzumura
  shows loopfree
  by (metis (no_types, lifting) assms sub_rel_def tcr_def tcr_strict_def)

theorem T6:
  assumes Quasitransit
  shows loopfree
  by (smt (verit) assfactor_def assms sub_rel_def tcr_strict_def transitive_def)

theorem T7:
  assumes reflexivity and Ferrers
  shows Quasitransit
  by (metis assfactor_def assms)

(****************
Correspondance under the max rule
******************)

(* Max-Limitedness corresponds to D *)

lemma "\<lfloor>\<diamond>\<phi> \<^bold>\<rightarrow> (\<circle><\<psi>|\<phi>> \<^bold>\<rightarrow> P<\<psi>|\<phi>>)\<rfloor>"
  nitpick [card i=3]  (* counterexample found for card i=3 *)
  oops

lemma "\<lfloor>(\<circle><\<psi>|\<phi>> \<^bold>\<and> \<circle><\<chi>|\<phi>>) \<^bold>\<rightarrow> \<circle><\<chi>|\<phi>\<^bold>\<and>\<psi>>\<rfloor>"
  nitpick [card i=3]  (* counterexample found *)
  oops

lemma "\<lfloor>\<circle><\<chi>|(\<phi>\<^bold>\<or>\<psi>)> \<^bold>\<rightarrow> ((\<circle><\<chi>|\<phi>>) \<^bold>\<or> (\<circle><\<chi>|\<psi>>))\<rfloor>"
  nitpick [card i=3]  (* counterexample found *)
  oops

theorem T8:
  assumes mlimitedness
  shows  "D*": "\<lfloor>\<diamond>\<phi> \<^bold>\<rightarrow> \<circle><\<psi>|\<phi>> \<^bold>\<rightarrow> P<\<psi>|\<phi>>\<rfloor>"
  by (metis assms)

lemma
  assumes "D*": "\<lfloor>\<diamond>\<phi> \<^bold>\<rightarrow> \<^bold>\<not>(\<circle><\<psi>|\<phi>> \<^bold>\<and> \<circle><\<^bold>\<not>\<psi>|\<phi>>)\<rfloor>"
  shows mlimitedness
  nitpick [card i=3]  (* counterexample found *)
  oops

(* Smoothness corresponds to cautious monotony *)

theorem T9:
  assumes msmoothness
  shows CM: "\<lfloor>(\<circle><\<psi>|\<phi>> \<^bold>\<and> \<circle><\<chi>|\<phi>>) \<^bold>\<rightarrow> \<circle><\<chi>|\<phi>\<^bold>\<and>\<psi>>\<rfloor>"
  using assms by force

lemma
  assumes CM: "\<lfloor>(\<circle><\<psi>|\<phi>> \<^bold>\<and> \<circle><\<chi>|\<phi>>) \<^bold>\<rightarrow> \<circle><\<chi>|\<phi>\<^bold>\<and>\<psi>>\<rfloor>"
  shows  msmoothness
  nitpick [card i=3]  (* counterexample found *)
  oops

(*Interval order corresponds to disjunctive rationality*)

lemma
  assumes reflexivity
  shows  DR: "\<lfloor>\<circle><\<chi>|\<phi>\<^bold>\<or>\<psi>> \<^bold>\<rightarrow> (\<circle><\<chi>|\<phi>> \<^bold>\<or> \<circle><\<chi>|\<psi>>)\<rfloor>"
  nitpick [card i=3]  (* counterexample found *)
  oops

theorem T10:
  assumes reflexivity and Ferrers
  shows  DR: "\<lfloor>\<circle><\<chi>|(\<phi>\<^bold>\<or>\<psi>)> \<^bold>\<rightarrow> (\<circle><\<chi>|\<phi>> \<^bold>\<or> \<circle><\<chi>|\<psi>>)\<rfloor>"
  by (metis assms)

lemma
  assumes DR: "\<lfloor>\<circle><\<chi>|\<phi>\<^bold>\<or>\<psi>> \<^bold>\<rightarrow> (\<circle><\<chi>|\<phi>> \<^bold>\<or> \<circle><\<chi>|\<psi>>)\<rfloor>"
  shows reflexivity
  nitpick [card i=1]  (* counterexample found *)
  oops

lemma
  assumes DR: "\<lfloor>\<circle><\<chi>|\<phi>\<^bold>\<or>\<psi>>\<^bold>\<rightarrow>(\<circle><\<chi>|\<phi>> \<^bold>\<or> \<circle><\<chi>|\<psi>>)\<rfloor>"
  shows Ferrers
  nitpick [card i=2]  (* counterexample found *)
  oops

(*Transitivity and totalness corresponds to the Spohn axiom (Sp)*)

lemma
  assumes transitivity
  shows  Sp: "\<lfloor>( P<\<psi>|\<phi>> \<^bold>\<and> \<circle><(\<psi>\<^bold>\<rightarrow>\<chi>)|\<phi>>) \<^bold>\<rightarrow> \<circle><\<chi>|(\<phi>\<^bold>\<and>\<psi>)>\<rfloor>"
  nitpick [card i=3] (* counterexample found *)
  oops

lemma
  assumes totalness
  shows  Sp: "\<lfloor>( P<\<psi>|\<phi>> \<^bold>\<and> \<circle><(\<psi>\<^bold>\<rightarrow>\<chi>)|\<phi>>) \<^bold>\<rightarrow> \<circle><\<chi>|(\<phi>\<^bold>\<and>\<psi>)>\<rfloor>"
  nitpick [card i=3] (* counterexample *)
  oops

theorem T11:
  assumes transitivity and totalness
  shows  Sp: "\<lfloor>( P<\<psi>|\<phi>> \<^bold>\<and> \<circle><(\<psi>\<^bold>\<rightarrow>\<chi>)|\<phi>>) \<^bold>\<rightarrow> \<circle><\<chi>|(\<phi>\<^bold>\<and>\<psi>)>\<rfloor>"
  by (metis assms)

theorem T12:
  assumes transitivity and totalness
  shows  transit: "\<lfloor>( P<\<phi>|\<phi>\<^bold>\<or>\<psi>> \<^bold>\<and> P<\<psi>|\<psi>\<^bold>\<or>\<chi>>) \<^bold>\<rightarrow> P<\<phi>|(\<phi>\<^bold>\<or>\<chi>)>\<rfloor>"
  by (metis assms(1) assms(2))

lemma
  assumes  Sp: "\<lfloor>( P<\<psi>|\<phi>> \<^bold>\<and> \<circle><(\<psi>\<^bold>\<rightarrow>\<chi>)|\<phi>>) \<^bold>\<rightarrow> \<circle><\<chi>|(\<phi>\<^bold>\<and>\<psi>)>\<rfloor>"
  shows totalness
  nitpick [card i=1] (* counterexample found *)
  oops

lemma
  assumes  Sp: "\<lfloor>( P<\<psi>|\<phi>> \<^bold>\<and> \<circle><(\<psi>\<^bold>\<rightarrow>\<chi>)|\<phi>>) \<^bold>\<rightarrow> \<circle><\<chi>|(\<phi>\<^bold>\<and>\<psi>)>\<rfloor>"
  shows transitivity
  nitpick [card i=2] (* counterexample found *)
  oops

(****************
Correspondance under the opt rule
******************)

(*opt-Limitedness corresponds to D*)

theorem T13:
  assumes olimitedness
  shows  D: "\<lfloor>\<diamond>\<phi> \<^bold>\<rightarrow> \<odot><\<psi>|\<phi>> \<^bold>\<rightarrow> \
<\<psi>|\<phi>>\<rfloor>"
  by (simp add: assms)

lemma
  assumes D: "\<lfloor>\<diamond>\<phi> \<^bold>\<rightarrow> \<odot><\<psi>|\<phi>> \<^bold>\<rightarrow> \
<\<psi>|\<phi>>\<rfloor>"
  shows olimitedness
  nitpick [card i=1] (* counterexample found *)
  oops

(*Smoothness corresponds to cautious monotony*)

theorem T14:
  assumes osmoothness
  shows CM': "\<lfloor>( \<odot><\<psi>|\<phi>> \<^bold>\<and> \<odot><\<chi>|\<phi>> ) \<^bold>\<rightarrow> \<odot><\<chi>|\<phi>\<^bold>\<and>\<psi>>\<rfloor>"
  using assms by force

lemma
  assumes CM: "\<lfloor>( \<odot><\<psi>|\<phi>> \<^bold>\<and> \<odot><\<chi>|\<phi>> ) \<^bold>\<rightarrow> \<odot><\<chi>|\<phi>\<^bold>\<and>\<psi>>\<rfloor>"
  shows  osmoothness
  nitpick [card i=1] (* counterexample found  *)
  oops

(*transitivity*)

theorem T15:
  assumes transitivity
  shows  Sp': "\<lfloor>( \
<\<psi>|\<phi>> \<^bold>\<and> \<odot><(\<psi>\<^bold>\<rightarrow>\<chi>)|\<phi>>) \<^bold>\<rightarrow> \<odot><\<chi>|(\<phi>\<^bold>\<and>\<psi>)>\<rfloor>"
  by (metis assms)

theorem T16:
  assumes transitivity
  shows  Trans: "\<lfloor>( \
<\<phi>|\<phi>\<^bold>\<or>\<psi>> \<^bold>\<and> \
<\<psi>|\<psi>\<^bold>\<or>\<xi>> )\<^bold>\<rightarrow> \
<\<phi>|\<phi>\<^bold>\<or>\<xi>>\<rfloor>"
  by (metis assms)

lemma
  assumes Sp: "\<lfloor>( \
<\<psi>|\<phi>> \<^bold>\<and> \<odot><(\<psi>\<^bold>\<rightarrow>\<chi>)|\<phi>> ) \<^bold>\<rightarrow> \<odot><\<chi>|(\<phi>\<^bold>\<and>\<psi>)>\<rfloor>"
  assumes Trans: "\<lfloor>( \
<\<phi>|\<phi>\<^bold>\<or>\<psi>> \<^bold>\<and> \
<\<psi>|\<psi>\<^bold>\<or>\<xi>> ) \<^bold>\<rightarrow> \
<\<phi>|\<phi>\<^bold>\<or>\<xi>>\<rfloor>"
  shows transitivity
  nitpick [card i=2] (* counterexample found  *)
  oops

(*interval order corresponds to disjunctive rationality*)

lemma
  assumes reflexivity
     (* assumes "Ferrers"*)
  shows  DR': "\<lfloor>\<odot><\<chi>|\<phi>\<^bold>\<or>\<psi>> \<^bold>\<rightarrow> (\<odot><\<chi>|\<phi>> \<^bold>\<or> \<odot><\<chi>|\<psi>>)\<rfloor>"
  nitpick [card i=3] (* counterexample found *)
  oops

theorem T17:
  assumes reflexivity and Ferrers
  shows  DR': "\<lfloor>\<odot><\<chi>|\<phi>\<^bold>\<or>\<psi>> \<^bold>\<rightarrow> (\<odot><\<chi>|\<phi>> \<^bold>\<or> \<odot><\<chi>|\<psi>>)\<rfloor>"
  by (metis assms(2))

lemma
  assumes DR: "\<lfloor>\<odot><\<chi>|\<phi>\<^bold>\<or>\<psi>> \<^bold>\<rightarrow> (\<odot><\<chi>|\<phi>> \<^bold>\<or> \<odot><\<chi>|\<psi>>)\<rfloor>"
  shows reflexivity
  nitpick [card i=1] (* counterexample found *)
  oops

lemma
  assumes DR: "\<lfloor>\<odot><\<chi>|\<phi>\<^bold>\<or>\<psi>> \<^bold>\<rightarrow> (\<odot><\<chi>|\<phi>> \<^bold>\<or> \<odot><\<chi>|\<psi>>)\<rfloor>"
  shows Ferrers
  nitpick [card i=2] (* counterexample found  *)
  oops

(****************
Relationship Lewis rule and max/opt rule
*****************)

(* deontic explosion-max rule *)
theorem DEX: "\<lfloor>(\<diamond>\<phi> \<^bold>\<and> \<circle><\<psi>|\<phi>> \<^bold>\<and> \<circle><\<^bold>\<not>\<psi>|\<phi>>) \<^bold>\<rightarrow> \<circle><\<chi>|\<phi>>\<rfloor>"
  by blast

(* no-deontic explosion-lewis rule *)
lemma DEX: "\<lfloor>(\<diamond>\<phi> \<^bold>\<and> \<circ><\<psi>|\<phi>> \<^bold>\<and> \<circ><\<^bold>\<not>\<psi>|\<phi>>) \<^bold>\<rightarrow> \<circ><\<chi>|\<phi>>\<rfloor>"
  nitpick [card i=2] (* counterexample  found*)
  oops

theorem T18:
  assumes mlimitedness and transitivity and totalness
  shows "\<lfloor>\<circ><\<psi>|\<phi>>\<^bold>\<leftrightarrow>\<odot><\<psi>|\<phi>>\<rfloor>"
  by (smt (z3) assms)

theorem T19:
  assumes mlimitedness and transitivity and totalness
  shows "\<lfloor>\<circ><\<psi>|\<phi>>\<^bold>\<leftrightarrow>\<circle><\<psi>|\<phi>>\<rfloor>"
  by (smt (z3) assms)

(****************
Correspondance Lewis evaluation rule for the conditional
*****************)

(* axioms of E holding if \<^bold>r transitive and total *)
lemma D: "\<lfloor>\<diamond>\<phi> \<^bold>\<rightarrow> (\<circ><\<psi>|\<phi>> \<^bold>\<rightarrow> \<integral><\<psi>|\<phi>>)\<rfloor>"
  nitpick [card i=2] (* counterexample found *)
  oops

theorem T20:
  assumes totalness
  shows D': "\<lfloor>\<diamond>\<phi> \<^bold>\<rightarrow> (\<circ><\<psi>|\<phi>> \<^bold>\<rightarrow> \<integral><\<psi>|\<phi>>)\<rfloor>"
  by (metis assms)

lemma Sp: "\<lfloor>( \<integral><\<psi>|\<phi>> \<^bold>\<and> \<circ><(\<psi>\<^bold>\<rightarrow>\<chi>)|\<phi>>) \<^bold>\<rightarrow> \<circ><\<chi>|(\<phi>\<^bold>\<and>\<psi>)>\<rfloor>"
  nitpick [card i=3] (* counterexample found *)
  oops

theorem T21:
  assumes transitivity
  shows Sp'': "\<lfloor>( \<integral><\<psi>|\<phi>> \<^bold>\<and> \<circ><(\<psi>\<^bold>\<rightarrow>\<chi>)|\<phi>>) \<^bold>\<rightarrow> \<circ><\<chi>|(\<phi>\<^bold>\<and>\<psi>)>\<rfloor>"
  using assms by blast

lemma COK:"\<lfloor>\<circ><(\<psi>\<^sub>1\<^bold>\<rightarrow>\<psi>\<^sub>2)|\<phi>> \<^bold>\<rightarrow> (\<circ><\<psi>\<^sub>1|\<phi>> \<^bold>\<rightarrow> \<circ><\<psi>\<^sub>2|\<phi>>)\<rfloor>"
  nitpick [card i=2] (* counterexample found *)
  oops

lemma
  assumes transitivity
  shows COK:"\<lfloor>\<circ><(\<psi>\<^sub>1\<^bold>\<rightarrow>\<psi>\<^sub>2)|\<phi>> \<^bold>\<rightarrow> (\<circ><\<psi>\<^sub>1|\<phi>> \<^bold>\<rightarrow> \<circ><\<psi>\<^sub>2|\<phi>>)\<rfloor>"
  nitpick [card i=2] (* counterexample found *)
  oops

lemma
  assumes totalness
  shows COK:"\<lfloor>\<circ><(\<psi>\<^sub>1\<^bold>\<rightarrow>\<psi>\<^sub>2)|\<phi>> \<^bold>\<rightarrow> (\<circ><\<psi>\<^sub>1|\<phi>> \<^bold>\<rightarrow> \<circ><\<psi>\<^sub>2|\<phi>>)\<rfloor>"
  nitpick [card i=3] (* counterexample found *)
  oops

theorem T22:
  assumes transitivity and totalness
  shows COK:"\<lfloor>\<circ><(\<psi>\<^sub>1\<^bold>\<rightarrow>\<psi>\<^sub>2)|\<phi>> \<^bold>\<rightarrow> (\<circ><\<psi>\<^sub>1|\<phi>> \<^bold>\<rightarrow> \<circ><\<psi>\<^sub>2|\<phi>>)\<rfloor>"
 by (smt (z3) assms)

lemma CM: "\<lfloor>(\<circ><\<psi>|\<phi>>\<^bold>\<and>\<circ><\<chi>|\<phi>>)\<^bold>\<rightarrow> \<circ><\<chi>|\<phi>\<^bold>\<and>\<psi>>\<rfloor>"
  nitpick [card i=2] (* counterexample found *)
  oops

lemma
  assumes transitivity
  shows CM: "\<lfloor>(\<circ><\<psi>|\<phi>>\<^bold>\<and>\<circ><\<chi>|\<phi>>)\<^bold>\<rightarrow> \<circ><\<chi>|\<phi>\<^bold>\<and>\<psi>>\<rfloor>"
  nitpick [card i=2] (* counterexample found *)
  oops

lemma
  assumes totalness
  shows CM: "\<lfloor>(\<circ><\<psi>|\<phi>>\<^bold>\<and>\<circ><\<chi>|\<phi>>)\<^bold>\<rightarrow> \<circ><\<chi>|\<phi>\<^bold>\<and>\<psi>>\<rfloor>"
  nitpick [card i=3] (* counterexample found *)
  oops

theorem T23:
  assumes transitivity and totalness
  shows CM'': "\<lfloor>(\<circ><\<psi>|\<phi>>\<^bold>\<and>\<circ><\<chi>|\<phi>>)\<^bold>\<rightarrow> \<circ><\<chi>|\<phi>\<^bold>\<and>\<psi>>\<rfloor>"
  by (metis assms)

lemma
  assumes transitivity
  shows  transit: "\<lfloor>(\<times><\<phi>|\<phi>\<^bold>\<or>\<psi>>\<^bold>\<and>\<times><\<psi>|\<psi>\<^bold>\<or>\<chi>>)\<^bold>\<rightarrow> \<times><\<phi>|\<phi>\<^bold>\<or>\<chi>>\<rfloor>"
  nitpick [card i=1] (* counterexample found *)
  oops

lemma
  assumes totalness
  shows  transit: "\<lfloor>(\<times><\<phi>|\<phi>\<^bold>\<or>\<psi>>\<^bold>\<and>\<times><\<psi>|\<psi>\<^bold>\<or>\<chi>>)\<^bold>\<rightarrow> \<times><\<phi>|\<phi>\<^bold>\<or>\<chi>>\<rfloor>"
  nitpick [card i=3] (* counterexample found *)
  oops

theorem T24:
  assumes transitivity and totalness
  shows  transit': "\<lfloor>(\<times><\<phi>|(\<phi>\<^bold>\<or>\<psi>)>\<^bold>\<and>\<times><\<psi>|(\<psi>\<^bold>\<or>\<chi>)>)\<^bold>\<rightarrow> \<times><\<phi>|(\<phi>\<^bold>\<or>\<chi>)>\<rfloor>"
 by (smt (z3) assms)

(*axioms of E holding irrespective of the properties of r*)

theorem Abs: "\<lfloor>\<circ><\<psi>|\<phi>> \<^bold>\<rightarrow> \<box>\<circ><\<psi>|\<phi>>\<rfloor>"
  by blast

theorem Nec: "\<lfloor>\<box>\<psi> \<^bold>\<rightarrow> \<circ><\<psi>|\<phi>>\<rfloor>"
  by blast

theorem Ext: "\<lfloor>\<box>(\<phi>\<^sub>1\<^bold>\<leftrightarrow>\<phi>\<^sub>2) \<^bold>\<rightarrow> (\<circ><\<psi>|\<phi>\<^sub>1> \<^bold>\<leftrightarrow> \<circ><\<psi>|\<phi>\<^sub>2>)\<rfloor>"
  by simp

theorem Id: "\<lfloor>\<circ><\<phi>|\<phi>>\<rfloor>"
  by auto

theorem  Sh: "\<lfloor>\<circ><\<psi>|\<phi>\<^sub>1\<^bold>\<and>\<phi>\<^sub>2> \<^bold>\<rightarrow> \<circ><(\<phi>\<^sub>2\<^bold>\<rightarrow>\<psi>)|\<phi>\<^sub>1>\<rfloor>"
  by blast

section \<open>Negative results\<close>

text \<open>Under the max and opt rules there is no formula corresponding to reflexivity\<close>

(*ToDO not sure how to do it--something like there is no A such that "reflexivity <\<Rightarrow> A"*)

text \<open>Under the max and opt rules there is no formula corresponding to totalness\<close>

(*ToDO*)

text \<open>Under the max rule there is no formula corresponding to transitivity\<close>

(*ToDO*)

text \<open>Under the max rule there is no formula corresponding to a-cyclicity\<close>

(*ToDO*)

text \<open>Under the max rule there is no formula corresponding to Suzumura consistency\<close>

(*ToDO*)

text \<open>Under the Lewis rule there is no formula corresponding to limitedness/smoothness\<close>

section \<open>Some open problems\<close>

text \<open>Under the opt rule transitivity alone is equivalent to Sp and Trans\<close>

theorem T25:
  assumes transitivity
  shows Sp''': "\<lfloor>( \
<\<psi>|\<phi>> \<^bold>\<and> \<odot><(\<psi>\<^bold>\<rightarrow>\<chi>)|\<phi>>) \<^bold>\<rightarrow> \<odot><\<chi>|(\<phi>\<^bold>\<and>\<psi>)>\<rfloor>"
  by (metis assms)

lemma
  assumes "transitivity"
  shows  Trans: "\<lfloor>(\
<\<phi>|\<phi>\<^bold>\<or>\<psi>> \<^bold>\<and> \
<\<xi>|\<psi>\<^bold>\<or>\<xi>>)\<^bold>\<rightarrow>\
<\<xi>|\<phi>\<^bold>\<or>\<xi>>\<rfloor>"
  nitpick [card i=2] (* counterexample found for card i=2 *)
  oops

lemma
  assumes Sp: "\<lfloor>( \
<\<psi>|\<phi>> \<^bold>\<and> \<odot><(\<psi>\<^bold>\<rightarrow>\<chi>)|\<phi>>) \<^bold>\<rightarrow> \<odot><\<chi>|(\<phi>\<^bold>\<and>\<psi>)>\<rfloor>"
          and  Trans: "\<lfloor>(\
<\<phi>|\<phi>\<^bold>\<or>\<psi>> \<^bold>\<and> \
<\<xi>|\<psi>\<^bold>\<or>\<xi>>)\<^bold>\<rightarrow>\
<\<xi>|\<phi>\<^bold>\<or>\<xi>>\<rfloor>"
  shows transitivity
  nitpick [card i=2] (* counterexample found for card i=2 *)
  oops

  text \<open>Under the opt rule quasi-transitivity, a-cyclicity and Suzumura consistent do not correspond to
any formula\<close>

(*to do*)

text \<open>Under the opt rule transitivity alone is equivalent to Sp and Trans\<close>
end