(*
    Author:      David Sanan
    Maintainer:  David Sanan, sanan at ntu edu sg
    License:     LGPL
*)

(*  Title:      ActionSemantics.thy
    Author:     David Sanan, NTU

Copyright (C) 2015-2016 David Sanan
Some rights reserved, NTU
This library is free software; you can redistribute it and/or modify
it under the terms of the GNU Lesser General Public License as
published by the Free Software Foundation; either version 2.1 of the
License, or (at your option) any later version.

This library is distributed in the hope that it will be useful, but
WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
Lesser General Public License for more details.

You should have received a copy of the GNU Lesser General Public
License along with this library; if not, write to the Free Software
Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307
USA
*)
theory ActionsSemantics
imports Main "Sep_Prod_Instance" "Sep_Algebra.Sep_Heap_Instance"
        "Sep_Algebra.Sep_Tactics" "Separata.Separata"
begin
section {* State definition *}
text {*
The state is defined as a pair $(global variables\times local variables)$. Separation logic
functions over the state will restrict it to be of type sep\_algebra*}
type_synonym ('a,'b) action_state= "('a \<times> 'b)"
type_synonym ('a,'b) transition = "(('a,'b) action_state \<times> ('a,'b) action_state)"

section{* Separation logic operations over the compound state *}

definition the_set :: "('a \<Rightarrow> bool) \<Rightarrow>
                     ('a set)"  (* ("\<lfloor> _ \<rfloor>"  [60] 89) *)
where
"the_set a \<equiv> {\<sigma>. a \<sigma>}"

section{* Separation logic actions over transitions*}

definition after :: "(('a,'b) action_state \<Rightarrow>bool) \<Rightarrow>
                     (('a, 'b) action_state \<Rightarrow>bool) \<Rightarrow> (('a, 'b) transition \<Rightarrow> bool)"
 ("_ \<unrhd> _"  [60,20] 89)
where
"a \<unrhd> b \<equiv> (\<lambda>(\<sigma>,\<sigma>'). (a \<sigma>) \<and> (b \<sigma>'))"

lemma afterD: "(a \<unrhd> b) (\<sigma>1,\<sigma>2) \<Longrightarrow> (a \<sigma>1) \<and> (b \<sigma>2)"
by (auto simp add: after_def)

definition satis :: "(('a, 'b) action_state \<Rightarrow>bool) \<Rightarrow>
                     (('a, 'b) transition \<Rightarrow> bool)"  ("\<lceil> _ \<rceil>"  [60] 89)
where
"\<lceil> a \<rceil> \<equiv> (\<lambda>(\<sigma>,\<sigma>'). (\<sigma>=\<sigma>') \<and> (a \<sigma>))"

lemma satisD: "((\<lceil> a \<rceil>) (\<sigma>,\<sigma>')) = ((\<sigma>=\<sigma>') \<and> (a \<sigma>))"
by (simp add: satis_def)

lemma satisI: "\<sigma>=\<sigma>' \<Longrightarrow> a \<sigma> \<Longrightarrow> (\<lceil> a \<rceil>) (\<sigma>,\<sigma>')"
by (simp add: satisD)

definition Emp :: "('a::sep_algebra, 'b::sep_algebra) transition \<Rightarrow> bool"
where
"Emp \<equiv> (\<lambda>(a,b). (sep_empty \<unrhd> sep_empty) (a,b))"

lemma Emp_iff_sep_empty:"Emp = sep_empty"
unfolding Emp_def zero_prod_def sep_empty_def after_def by auto

definition tran_True :: "('a::sep_algebra, 'b::sep_algebra) transition \<Rightarrow> bool"
where
"tran_True \<equiv> sep_true \<unrhd> sep_true"

lemma tran_True_true: "tran_True = sep_true"
unfolding tran_True_def sep_empty_def after_def by auto

definition tran_Id :: "('a::sep_algebra, 'b::sep_algebra) transition \<Rightarrow> bool"
where
"tran_Id \<equiv> \<lceil> sep_true \<rceil>"

lemma tran_Id_eq:"tran_Id (y',y'') = (y' = y'')"
       by (simp add: satis_def tran_Id_def)

lemma tran_Id_idem:"tran_Id y \<Longrightarrow> tran_Id (y + (\<sigma>',\<sigma>'))"
proof -
     assume a1:"tran_Id y"
     obtain y1 y2 where y_val:"y = (y1,y2)"
       using surjective_pairing by blast
     then have "y1=y2" using a1 y_val tran_Id_eq by blast
     then have "y + (\<sigma>',\<sigma>') = ((y1 + \<sigma>'),(y1 + \<sigma>'))"
       using y_val plus_prod_def by fastforce
     then show "tran_Id (y + (\<sigma>',\<sigma>'))" by (simp add: tran_Id_eq)
qed

lemma sep_conj_train_Id:"G s \<Longrightarrow> (G\<and>*tran_Id) s"
by (metis sep_add_zero sep_conj_def sep_disj_zero tran_Id_eq zero_prod_def)

lemma sep_conj_train_True:"G s \<Longrightarrow> (G\<and>*tran_True) s"
proof -
  assume a1: "G s"
  have "\<forall>p. tran_True (p::('a \<times> 'b) \<times> _ \<times> _)"
    by (simp add: after_def tran_True_def)
  thus ?thesis
    using a1 by (meson pure_conj_sep_conj pure_split)
qed

definition Satis :: "(('a, 'b) transition \<Rightarrow> bool) \<Rightarrow>
                     (('a,'b) transition set)"  ("\<lfloor> _ \<rfloor>"  [60] 89)
where
"Satis a \<equiv> Collect a"

lemma dist_star_after:"\<forall>t. ((((p ** p') \<unrhd> (q ** q')) t) = (((p \<unrhd> q) ** (p' \<unrhd> q')) t))"
unfolding sep_conj_def after_def
apply (auto simp add:sep_disj_prod_def plus_prod_def)
by blast

lemma imp_after:"(\<forall>t. (p imp p') t) \<Longrightarrow>
                 (\<forall>t. (q imp q') t) \<Longrightarrow> (\<forall>t. ((p \<unrhd> q) imp (p' \<unrhd> q')) t)"
unfolding after_def
by blast

lemma or_after1: "((p or p') \<unrhd> q) = ((p \<unrhd> q) or (p' \<unrhd> q))"
unfolding after_def
by blast

lemma satis_after: "(\<forall>t. (\<lceil> p \<rceil>) t) \<Longrightarrow> (\<forall>t. (p \<unrhd> p) t)"
unfolding after_def satis_def
by blast

lemma satis_id: "\<forall>t. (\<lceil> p \<rceil>) t \<longrightarrow> tran_Id t"
unfolding satis_def tran_Id_def
by auto

lemma or_after2: "(p \<unrhd> (q or q')) = ((p \<unrhd> q) or (p \<unrhd> q'))"
unfolding after_def
by blast

lemma satis_emp: " (\<lceil> sep_empty \<rceil>) = Emp"
unfolding Emp_def sep_empty_def after_def  satis_def
by blast

lemma action_true: "a t \<Longrightarrow> tran_True t"
unfolding after_def tran_True_def
by blast

lemma or_sep: "(\<forall>t. (a\<^sub>1 imp a\<^sub>1') t) \<Longrightarrow> (\<forall>t. (a\<^sub>2 imp a\<^sub>2') t) \<Longrightarrow> (\<forall>t. ((a\<^sub>1 \<and>* a\<^sub>2) imp (a\<^sub>1' \<and>* a\<^sub>2')) t)"
unfolding sep_conj_def
by auto

lemma empty_neutral1: "(a \<and>* Emp) t \<Longrightarrow> a t"
by (simp_all add: Emp_iff_sep_empty)
(*unfolding  after_def sep_empty_def using Emp_iff_sep_empty
apply (simp only:Emp_iff_sep_empty)
by separata*)
(*unfolding Emp_def after_def sep_empty_def sep_conj_def
apply auto
by (metis sep_add_zero zero_prod_def)*)

lemma empty_neutral2: "a t \<Longrightarrow> (a \<and>* Emp) t"
by (simp_all add: Emp_iff_sep_empty)

(*unfolding  after_def sep_empty_def using Emp_iff_sep_empty
apply (simp only:Emp_iff_sep_empty)
by separata*)

(*proof -
  assume a1: "a t"
  have f2: "t ## (0, 0)"
    by (metis sep_disj_zero zero_prod_def)
  have "t = t + (0, 0)"
    by (metis sep_add_zero zero_prod_def)
  thus "\<exists>p pa. p ## pa \<and> t = p + pa \<and> a p \<and> (case pa of (p, pa) \<Rightarrow> case (p, pa) of (p, pa) \<Rightarrow> p = 0 \<and> pa = 0)"
    using f2 a1 by blast
qed*)

lemma empty_neutral': "(a \<and>* Emp) t = a t"
by (simp add: Emp_iff_sep_empty after_def)
(*by (fastforce intro: empty_neutral1 empty_neutral2)*)

lemma empty_neutral: "(a \<and>* Emp) = a"
by (auto simp add: empty_neutral')

lemma star_op_comm: "(a\<and>*a') = (a'\<and>*a)"
by separata
(*by (simp add: Separation_Algebra.sep.mult.commute)*)

lemma sep_conj_conj1:"((\<lambda>r. (Q r) \<and> (Q' r)) \<and>* P) h \<Longrightarrow>
                     (((\<lambda>r. Q r)  \<and>* P)  and ((\<lambda>r. Q' r) \<and>* P)) (h::'a::heap_sep_algebra)"
by separata
(*using  Separation_Algebra.sep_algebra_class.sep_conj_conj by auto*)

lemma "(a ** sep_true) h \<Longrightarrow> (h,h'\<triangleright>h'') \<Longrightarrow> (a ** sep_true) h''"
by separata

lemma id_pair_comb: "((x,x),(y,y)\<triangleright>(z,z')) \<Longrightarrow> z = z'"
using disj_union_dist2 tern_rel_def tern_rel_def
by metis

lemma tern_pair: "(\<sigma>1, \<sigma>'\<triangleright> \<sigma>1') \<Longrightarrow> (\<sigma>2, \<sigma>''\<triangleright> \<sigma>2') \<Longrightarrow>
  ((\<sigma>1,\<sigma>2),(\<sigma>',\<sigma>'')\<triangleright>(\<sigma>1',\<sigma>2'))"
using disj_union_dist2 tern_rel_def
proof -
  assume a1: "(\<sigma>1, \<sigma>'\<triangleright> \<sigma>1')"
  assume "(\<sigma>2, \<sigma>''\<triangleright> \<sigma>2')"
  then have "((\<sigma>1,\<sigma>2),(\<sigma>',\<sigma>'')\<triangleright>(\<sigma>1',\<sigma>2'))"
    using a1 by (metis disj_union_dist)
  then show ?thesis
    by (simp add: tern_rel_def)
qed

lemma tern_dist1: "((\<sigma>1, \<sigma>'\<triangleright> \<sigma>1') \<and> (\<sigma>2, \<sigma>''\<triangleright> \<sigma>2')) \<Longrightarrow>
  ((\<sigma>1,\<sigma>2),(\<sigma>',\<sigma>'')\<triangleright>(\<sigma>1',\<sigma>2'))"
using disj_union_dist2 tern_rel_def
by (simp add: tern_pair)

method comb_du_pair = (
match premises in P:"(?h1, ?h'\<triangleright> ?h1') \<and> (?h2, ?h''\<triangleright> ?h2')" \<Rightarrow>
  \<open>insert P, drule tern_dist1\<close>,
simp?
)

lemma
  "(a \<and>* tran_Id) (\<sigma>1,\<sigma>2) \<Longrightarrow>
   ((\<sigma>1,\<sigma>2),(\<sigma>',\<sigma>')\<triangleright>(\<sigma>1',\<sigma>2')) \<Longrightarrow>
   (a \<and>* tran_Id) (\<sigma>1',\<sigma>2')"
apply (simp add: tran_Id_def satis_def)
using id_pair_comb
apply separata
by separata

lemma conj_sep_id:
assumes a1: "(a \<and>* tran_Id) (\<sigma>1,\<sigma>2)"
assumes a2: "(\<sigma>1,\<sigma>'\<triangleright>\<sigma>1') \<and> (\<sigma>2,\<sigma>'\<triangleright>\<sigma>2')"
shows "(a \<and>* tran_Id) (\<sigma>1',\<sigma>2')"
proof -
  from a2 have "((\<sigma>1,\<sigma>2),(\<sigma>',\<sigma>')\<triangleright>(\<sigma>1',\<sigma>2'))"
    by (metis (full_types) tern_dist1)
  then show ?thesis using a1 id_pair_comb
    apply (simp add: tran_Id_def satis_def)
    by separata
qed

(*
lemma conj_sep_id: "(a \<and>* tran_Id) (\<sigma>1,\<sigma>2) \<Longrightarrow>
  (\<sigma>1 \<uplus>\<^sub>p \<sigma>') \<sigma>1' \<and> (\<sigma>2 \<uplus>\<^sub>p \<sigma>') \<sigma>2' \<Longrightarrow>
  (a \<and>* tran_Id) (\<sigma>1',\<sigma>2')"
unfolding sep_conj_def
proof -
  assume a1:"\<exists>x y. x ## y \<and> (\<sigma>1, \<sigma>2) = x + y \<and> a x \<and> tran_Id y"
  then obtain x y where
        unfold_pr:"x ## y \<and>
         (\<sigma>1, \<sigma>2) = x + y \<and>
         a x \<and> tran_Id y" by auto
  then have split_x_y:"(x \<uplus>\<^sub>p y) (\<sigma>1,\<sigma>2)" by (simp add: sep_split_def)
  assume a2:"(\<sigma>1 \<uplus>\<^sub>p \<sigma>') \<sigma>1' \<and> (\<sigma>2 \<uplus>\<^sub>p \<sigma>') \<sigma>2'"
  then have "((\<sigma>1,\<sigma>2) \<uplus>\<^sub>p (\<sigma>',\<sigma>')) (\<sigma>1',\<sigma>2')"
   by (simp add: disj_union_dist1)
  then have new_split:"(x  \<uplus>\<^sub>p (y + (\<sigma>',\<sigma>'))) (\<sigma>1',\<sigma>2')"
   using sep_split_assoc split_x_y by blast
  have tran_id_y: "tran_Id (y + (\<sigma>',\<sigma>'))"
  proof -
     obtain y1 y2 where y_val:"y = (y1,y2)"
       using surjective_pairing by blast
     then have "y1=y2" using unfold_pr y_val tran_Id_eq by blast
     then have "y + (\<sigma>',\<sigma>') = ((y1 + \<sigma>'),(y1 + \<sigma>'))"
       using y_val plus_prod_def by fastforce
     then show "tran_Id (y + (\<sigma>',\<sigma>'))" by (simp add: tran_Id_eq)
   qed
  thus "\<exists>x y. x ## y \<and> (\<sigma>1', \<sigma>2') = x + y \<and> a x \<and> tran_Id y"
    using new_split sep_split_def unfold_pr by metis
qed
*)

section {* Stability *}

text{*

 We define an assertion $p$ to be stable with regard an action $a$ if for each $(\sigma,\sigma')$,
$p\ \sigma$ and $a (\sigma,\sigma')$ then $p \sigma$

*}
(*definition Sta :: "(('a, 'b)action_state \<Rightarrow>bool)\<Rightarrow>
                   (('a::sep_algebra, 'b::sep_algebra) transition\<Rightarrow>bool) \<Rightarrow>bool"
where
"Sta p a \<equiv> (\<forall>\<sigma> \<sigma>'.
            ((p \<sigma>) \<and> (a (\<sigma>,\<sigma>'))) \<longrightarrow> (p \<sigma>'))" *)
definition Sta :: "(('a, 'b)action_state \<Rightarrow>bool)\<Rightarrow>
                   (('a::heap_sep_algebra, 'b::heap_sep_algebra) transition\<Rightarrow>bool) \<Rightarrow>bool"
where
"Sta p a \<equiv> (\<forall>\<sigma> \<sigma>'.
            ((p \<sigma>) \<and> (a (\<sigma>,\<sigma>'))) \<longrightarrow> (p \<sigma>'))"
text{*
We prove the following lemmas:
*}

lemma "\<forall>a b. (q \<and>* (\<lambda>s. \<not> (p \<longrightarrow>* (\<lambda>s. \<not> r s)) s \<and> \<box> s)) (a, b) \<longrightarrow> r (a, b) \<Longrightarrow>
       r (a, b) \<Longrightarrow> p (a, b) \<Longrightarrow> q (aa, ba) \<Longrightarrow> (0,0\<triangleright>0) \<Longrightarrow> ((a, b),0\<triangleright>(a, b)) \<Longrightarrow> (0,(a, b)\<triangleright>(a, b)) \<Longrightarrow> r (aa, ba)"
proof -
  assume a0:"\<forall>a b. (q \<and>* (\<lambda>s. \<not> (p \<longrightarrow>* (\<lambda>s. \<not> r s)) s \<and> \<box> s)) (a, b) \<longrightarrow> r (a, b)" and
         a1: "r (a, b)" and
         a2: "p (a, b)" and
         a3: "q (aa, ba)" and
         a4:"(0,0\<triangleright>0)" and
         a5:"((a, b),0\<triangleright>(a, b))" and
         a6:" (0,(a, b)\<triangleright>(a, b))"
 then have "(q \<and>* (\<lambda>s. \<not> (p \<longrightarrow>* (\<lambda>s. \<not> r s)) s \<and> \<box> s)) (aa, ba) \<longrightarrow> r (aa, ba)"
 using a0 by auto

 then show "r (aa, ba)"
 using a1 a2 a3 a4 a5 a6
 sorry
qed

lemma lem1: "r (a, b) \<Longrightarrow> p (a, b) \<Longrightarrow> q (aa, ba) \<Longrightarrow>
(q \<and>* (not (p \<longrightarrow>* (not r)) and \<box>)) ((aa::'a::heap_sep_algebra), (ba::'b::heap_sep_algebra))"
by separata

lemma
 "Sta r (p \<unrhd> q) =
 (\<forall>\<sigma>. ((((p  \<longrightarrow>\<oplus> r) and sep_empty) \<and>* q) imp r) \<sigma>)"
unfolding Sta_def after_def satis_def
apply auto
apply separata
by (auto simp add: lem1)

lemma
"Sta r ((p \<unrhd> q)\<and>*tran_Id) \<Longrightarrow>
  (((p \<longrightarrow>\<oplus> r) \<and>* q) imp r) \<sigma>"
unfolding Sta_def after_def satis_def tran_Id_def
proof auto
assume a1: "\<forall>a b aa ba. r (a, b) \<and> ((\<lambda>(\<sigma>, \<sigma>'). p \<sigma> \<and> q \<sigma>') \<and>* (\<lambda>(x, y). x = y)) ((a, b), aa, ba) \<longrightarrow> r (aa, ba)"
assume a2: " ((\<lambda>s. \<not> (p \<longrightarrow>* (\<lambda>s. \<not> r s)) s) \<and>* q) \<sigma>"
show "r \<sigma>" using a1 a2
  sorry
qed

lemma l1:
 "Sta r (p \<unrhd> q) =
 (\<forall>\<sigma>. ((((p  \<longrightarrow>\<oplus> r) and sep_empty) \<and>* q) imp r) \<sigma>)"
unfolding Sta_def after_def satis_def sep_conj_def sep_impl_def
apply auto
  apply (simp add: sep_empty_def)
by (metis (no_types, lifting) sep_add_zero_sym sep_disj_commuteI sep_disj_zero sep_empty_zero zero_prod_def)

lemma l2:
 "(\<forall>\<sigma>.(((p \<longrightarrow>\<oplus> r) \<and>* q) imp r) \<sigma>) \<Longrightarrow> Sta r (p \<unrhd> q) "
unfolding Sta_def after_def satis_def sep_conj_def sep_impl_def
apply auto
by (metis (no_types, lifting) sep_add_disjI2 sep_add_zero_sym sep_disj_zero  zero_prod_def)

lemma l31:
"Sta r ((p \<unrhd> q)\<and>*tran_Id) \<Longrightarrow>
  (\<forall>\<sigma>.(((p \<longrightarrow>\<oplus> r) \<and>* q) imp r) \<sigma>)"
unfolding Sta_def after_def satis_def sep_conj_def sep_impl_def tran_Id_def sep_disj_prod_def
proof auto
  fix a b aa ba ab bb ac bc
  assume a1: "q (ab, bb)"
  assume a2: "p (ac, bc)"
  assume a3: "aa ## ab"
  assume a4: "ba ## bb"
  assume a5: "aa ## ac"
  assume a6: "ba ## bc"
  assume a7: "\<forall>a b aa ba.
              r (a, b) \<and>
             (\<exists>ab bb ac bc ad.
                ab ## ad \<and>
                (\<exists>bd. bb ## bd \<and>
                      ac ## ad \<and>
                      bc ## bd \<and>
                      ((a, b), aa, ba) = ((ab, bb), ac, bc) + ((ad, bd), ad, bd) \<and>
                      p (ab, bb) \<and> q (ac, bc))) \<longrightarrow>
             r (aa, ba)"
  assume a8:"r ((aa, ba) + (ac, bc))"
  assume a9: "(a, b) = (aa, ba) + (ab, bb)"
  then have aa:"(a,b) = (aa + ab, ba + bb)" by (simp add: plus_prod_def)
  then have bb:"a = aa + ab \<and> b = ba + bb" by force
  have "(aa+ac, ba+bc) = (aa,ba)+(ac,bc)" by (simp add: plus_prod_def)
  then have "r (aa+ac, ba+bc)" using a8 by auto
  from a8 have na8:"r (aa + ac, ba + bc)" by (simp add: plus_prod_def)
  then have sum:"((aa+ac,ba+bc),aa + ab, ba + bb) =  ((ac,bc),ab,bb) + ((aa,ba),aa,ba)"
    proof -
      have f1: "ba + bc = bc + ba"
        by (metis a6 sep_add_commute)
      have f2: "ba + bb = bb + ba"
        by (metis a4 sep_add_commute)
      have f3: "aa + ac = ac + aa"
        by (metis a5 sep_add_commute)
      have "aa + ab = ab + aa"
        by (meson a3 sep_add_commute)
      thus ?thesis
        using f3 f2 f1 by (simp add: plus_prod_def)
    qed
  have "\<forall>f fa. \<not>f ## fa \<or> fa ## f"
    using sep_disj_commuteI by blast
  then have "r (aa + ab, ba + bb)"
    using na8 a7 a6 a5 a4 a3 a2 a1 sum by metis
  thus "r ((aa, ba) + (ab, bb))"
    by (simp add: `r (aa + ab, ba + bb)` plus_prod_def sep_add_commute)

qed

lemma l32:
  "(\<forall>\<sigma>.(((p \<longrightarrow>\<oplus> r) \<and>* q) imp r) \<sigma>) \<Longrightarrow>
     Sta r ((p \<unrhd> q)\<and>*tran_Id)"
unfolding Sta_def after_def satis_def sep_conj_def sep_impl_def tran_Id_def
proof (auto)
  fix a b aa ba ab bb ac bc ad bd
  assume a1: "p (ab, bb)"
  assume a2: "((ab, bb), ac, bc) ## ((ad, bd), ad, bd)"
  assume a3: "((a, b), aa, ba) = ((ab, bb), ac, bc) + ((ad, bd), ad, bd)"
  assume a4: "q (ac, bc)"
  assume a5: "\<forall>a b.
             (\<exists>aa ba ab bb. (aa, ba) ## (ab, bb) \<and>
                            (a, b) = (aa, ba) + (ab, bb) \<and>
                            (\<exists>a b. (aa, ba) ## (a, b) \<and>
                                   p (a, b) \<and> r ((aa, ba) + (a, b))) \<and>
                             q (ab, bb)) \<longrightarrow>
              r (a, b)"
  assume a6: "r (a, b)"
  have f7: "\<forall>p pa. \<not> (p::('a \<Rightarrow> 'b option) \<times> ('a \<Rightarrow> 'b option)) ## pa \<or> pa ## p"
    using sep_disj_commuteI by blast
  have "(a, b) = (ab, bb) + (ad, bd) \<and>
        (ab, bb) ## (ad, bd) \<and> (ac, bc) ## (ad, bd) \<and>
        (aa, ba) = (ac, bc) + (ad, bd)"
    using a3 a2 dis_sep by blast
  thus "r (aa, ba)"
    using f7 a6 a5 a4 a1 by (metis sep_add_commute sep_disj_commuteI)
qed

lemma l3:
 "Sta r ((p \<unrhd> q)\<and>*tran_Id) =
  (\<forall>\<sigma>.(((p \<longrightarrow>\<oplus> r) \<and>* q) imp r) \<sigma>)"
using l31 l32 by blast

section {* Fence *}
definition Fence::"(('a::heap_sep_algebra, 'b::heap_sep_algebra) action_state \<Rightarrow>bool) \<Rightarrow>
                     (('a, 'b) transition \<Rightarrow> bool) \<Rightarrow> bool"  ("_ \<bowtie> _"  [60] 89)
where
"I  \<bowtie> a \<equiv> \<forall>\<sigma>1 \<sigma>2. (\<lceil> I \<rceil> imp a)(\<sigma>1,\<sigma>2) \<and> (a imp (I \<unrhd> I))(\<sigma>1,\<sigma>2) \<and> (precise I)
"
lemma fenceD: "(I  \<bowtie> a) \<Longrightarrow> (\<sigma>1,\<sigma>2)=(\<sigma>1,\<sigma>2) \<Longrightarrow> (\<lceil> I \<rceil> imp a)(\<sigma>1,\<sigma>2) \<and> (a imp (I \<unrhd> I))(\<sigma>1,\<sigma>2) \<and> (precise I)"
using Fence_def by (metis (no_types))

lemma fence1: "precise I \<Longrightarrow> I  \<bowtie> \<lceil>I\<rceil>"
by (simp add: Fence_def after_def satis_def)

lemma fence2:"precise I \<Longrightarrow> I  \<bowtie> (I \<unrhd> I)"
by (simp add: Fence_def after_def satis_def)

lemma fence3: "I  \<bowtie> a \<Longrightarrow> I  \<bowtie> a' \<Longrightarrow> I  \<bowtie> (a or a')"
by (simp add: Fence_def)

lemma fence41: " I  \<bowtie> a \<Longrightarrow> I'  \<bowtie> a' \<Longrightarrow>precise (I \<and>* I')"
by (simp add: Fence_def precise_sep_conj)

lemma fence42:
assumes a1: " I  \<bowtie> a" and
        a2: "I' \<bowtie> a'"
 shows  "\<forall>\<sigma>1 \<sigma>2. ((a \<and>* a') imp ((I \<and>* I') \<unrhd> (I \<and>* I'))) (\<sigma>1,\<sigma>2)"
proof  (clarsimp)
  fix aa b aaa ba
  have a1e: "\<forall>\<sigma>1 \<sigma>2. (\<lceil> I \<rceil> imp a)(\<sigma>1,\<sigma>2) \<and> (a imp (I \<unrhd> I))(\<sigma>1,\<sigma>2) \<and> (precise I)"
    using a1 by (simp add: Fence_def)
  have a2e: "\<forall>\<sigma>1 \<sigma>2. (\<lceil> I' \<rceil> imp a')(\<sigma>1,\<sigma>2) \<and> (a' imp (I' \<unrhd> I'))(\<sigma>1,\<sigma>2) \<and> (precise I')"
    using a2 by (simp add: Fence_def)
  assume "(a \<and>* a') ((aa,b), (aaa,ba))"
  then obtain x y where sep_conji:"x ## y \<and> (((aa,b), (aaa,ba)) = x + y) \<and> a x \<and> a' y"
    using sep_conjD by metis
  then obtain x1 x2 y1 y2 where yv: "x=(x1,x2) \<and> y = (y1,y2)" using surjective_pairing by blast
  then have hpi: "(a imp (I \<unrhd> I)) (x1,x2)" using a1e sep_conji by blast
  then have hpi': "(a' imp (I' \<unrhd> I')) (y1,y2)" using a2e sep_conji yv by blast
  thus "((I \<and>* I') \<unrhd> (I \<and>* I')) ((aa,b), (aaa,ba))"
    using hpi' hpi sep_conji
    by (metis (no_types) dist_star_after sep_conjI yv)
qed

lemma fence43:
assumes a1: " I  \<bowtie> a" and
        a2: "I' \<bowtie> a'"
shows "\<forall>\<sigma>1 \<sigma>2.(\<lceil> (I \<and>* I') \<rceil> imp (a \<and>* a'))(\<sigma>1,\<sigma>2)"
proof  (clarsimp)
  fix aa b aaa ba
  have a1e: "\<forall>\<sigma>1 \<sigma>2. (\<lceil> I \<rceil> imp a)(\<sigma>1,\<sigma>2) \<and> (a imp (I \<unrhd> I))(\<sigma>1,\<sigma>2) \<and> (precise I)"
    using a1 by (simp add: Fence_def)
  have a2e: "\<forall>\<sigma>1 \<sigma>2. (\<lceil> I' \<rceil> imp a')(\<sigma>1,\<sigma>2) \<and> (a' imp (I' \<unrhd> I'))(\<sigma>1,\<sigma>2) \<and> (precise I')"
    using a2 by (simp add: Fence_def)
  assume ass1: "(\<lceil> (I \<and>* I') \<rceil>) ((aa, b), aaa, ba)"
  then obtain x y where pair_split:"(x,y) = ((aa, b), aaa, ba)"
    using surjective_pairing by blast
  then have ass1split: "(\<lceil> (I \<and>* I') \<rceil>) (x,y)" using ass1 by auto
  then have satis_I:"x = y \<and> (I \<and>* I') x" using satisD[of "(I \<and>* I')" x y]
    by fastforce
  then obtain x1 y1 where
  sep_conji:"x1 ## y1 \<and> (x = x1 + y1) \<and> I x1 \<and> I' y1"
    using sep_conjD by metis
  then have "(x,y) = (x1 + y1, x1 + y1)" using satis_I by blast
  then have xy_add:"(x,y) = (x1,x1)+(y1,y1)" by (simp add: plus_prod_def)
  have xy_disj:"(x1,x1)##(y1,y1)" using sep_conji by (simp add: sep_disj_prod_def)
  have "(\<lceil> I \<rceil>) (x1,x1) \<and> (\<lceil> I' \<rceil>) (y1,y1)"
    by (simp add: satisI sep_conji)
  then have "a (x1,x1) \<and> a' (y1,y1)" using a1e a2e by blast
  thus "(a \<and>* a') ((aa, b), aaa, ba)"
   using  xy_add xy_disj sep_conj_def pair_split by metis
qed

lemma fence4: " I  \<bowtie> a \<Longrightarrow> I'  \<bowtie> a' \<Longrightarrow> (I \<and>* I')  \<bowtie> (a \<and>* a')"
proof -
  assume a1:"I  \<bowtie> a"
  assume a2: "I'  \<bowtie> a'"
  have f1: "\<And>u v. (\<forall>a1 a2. u a1 a2) \<and> (\<forall>a1 a2. v a1 a2) \<Longrightarrow>  \<forall>a1 a2. u a1 a2 \<and> v a1 a2"
   by auto
  have "precise (I \<and>* I')" using a1 a2 fence41 by blast
  moreover have "\<forall>\<sigma>1 \<sigma>2. ((a \<and>* a') imp ((I \<and>* I') \<unrhd> (I \<and>* I'))) (\<sigma>1,\<sigma>2)"
    using a1 a2 fence42 by blast
  moreover have "\<forall>\<sigma>1 \<sigma>2.(\<lceil> (I \<and>* I') \<rceil> imp (a \<and>* a'))(\<sigma>1,\<sigma>2)"
    using a1 a2 fence43 by blast
  ultimately show "(I \<and>* I')  \<bowtie> (a \<and>* a')" using f1
  by (simp add: Fence_def)
qed

lemma "(\<exists>! x. P x) \<Longrightarrow> (P x \<Longrightarrow> (\<And>y. P y \<Longrightarrow> y = x))"
by metis

lemma "P x \<Longrightarrow> (\<And>y. P y \<Longrightarrow> y = x) \<Longrightarrow> (\<exists>! x. P x) "
by auto

lemma sub_state_fence_unique:"\<sigma>11 \<preceq> \<sigma> \<and> \<sigma>1 \<preceq> \<sigma> \<and> a (\<sigma>11,\<sigma>12) \<and> I \<sigma>1 \<and> I  \<bowtie> a \<Longrightarrow> \<sigma>1=\<sigma>11"
unfolding Fence_def
proof -
 assume a1:"\<sigma>11 \<preceq> \<sigma> \<and> \<sigma>1 \<preceq> \<sigma> \<and> a (\<sigma>11, \<sigma>12) \<and> I \<sigma>1 \<and>
          (\<forall>\<sigma>1 \<sigma>2.
            ((\<lceil> I \<rceil>) (\<sigma>1, \<sigma>2) \<longrightarrow> a (\<sigma>1, \<sigma>2)) \<and>
            (a (\<sigma>1, \<sigma>2) \<longrightarrow> (I \<unrhd> I) (\<sigma>1, \<sigma>2)) \<and>
            precise I)"
 then have "precise I" by auto
 then have "(I \<unrhd> I) (\<sigma>11, \<sigma>12)" using a1 by fastforce
 then have "I \<sigma>11"
   using  surjective_pairing by (simp add: after_def)
 thus "\<sigma>1=\<sigma>11" using a1 precise_def by metis
qed

lemma fence_tran_exists:
  "\<sigma>1##\<sigma>2 \<Longrightarrow> (a \<and>* a') (\<sigma>1+\<sigma>2,\<sigma>') \<Longrightarrow> I \<sigma>1 \<and> I  \<bowtie> a \<Longrightarrow>
   (\<exists>\<sigma>1' \<sigma>2'.((\<sigma>1', \<sigma>2' \<triangleright> \<sigma>') \<and> a (\<sigma>1,\<sigma>1') \<and> a'(\<sigma>2,\<sigma>2')))"
proof -
  assume a1:"\<sigma>1##\<sigma>2" and
         a2: "(a \<and>* a') (\<sigma>1+\<sigma>2,\<sigma>')" and
         a3: "I \<sigma>1 \<and> I  \<bowtie> a"
  obtain \<sigma>11 \<sigma>12 \<sigma>'1 \<sigma>'2
  where sep_split:"((\<sigma>11,\<sigma>'1)+(\<sigma>12,\<sigma>'2)) = (\<sigma>1+\<sigma>2,\<sigma>') \<and>
         (\<sigma>11,\<sigma>'1)##(\<sigma>12,\<sigma>'2) \<and> a (\<sigma>11,\<sigma>'1) \<and> a'(\<sigma>12,\<sigma>'2) "
  using a2
    by (metis sep_conjE surjective_pairing)
  then have split_sigma12:"\<sigma>11+\<sigma>12 = \<sigma>1+\<sigma>2 \<and> \<sigma>11##\<sigma>12"
    by (metis (no_types) dis_sep)
  then have "\<sigma>11 \<preceq> \<sigma>1+\<sigma>2 \<and> \<sigma>1 \<preceq> \<sigma>1+\<sigma>2"
    using sep_substate_def sep_split a1 by fastforce
  then have "\<sigma>11=\<sigma>1"
    using sep_split a3 sub_state_fence_unique by blast
  then have "\<sigma>12 = \<sigma>2"
    by (metis (no_types) split_sigma12 a1 sep_add_cancelD sep_add_commute sep_disj_commute)
  then have "(\<sigma>'1, \<sigma>'2\<triangleright> \<sigma>') \<and> a (\<sigma>1,\<sigma>'1) \<and> a'(\<sigma>2,\<sigma>'2)"
    by (metis (no_types) `\<sigma>11 = \<sigma>1` dis_sep sep_split tern_rel_def)
  thus "\<exists>\<sigma>1' \<sigma>2'.(\<sigma>1', \<sigma>2'\<triangleright> \<sigma>') \<and> a (\<sigma>1,\<sigma>1') \<and> a'(\<sigma>2,\<sigma>2')"
    by blast
qed

lemma fence_tran_exists1:
  "\<sigma>1##\<sigma>2 \<Longrightarrow> (a \<and>* a') (\<sigma>1+\<sigma>2,\<sigma>') \<Longrightarrow> I \<sigma>1 \<and> I  \<bowtie> a \<Longrightarrow>
   \<exists>\<sigma>1' \<sigma>2'.(\<sigma>1', \<sigma>2'\<triangleright> \<sigma>')"
proof -
  assume a1:"\<sigma>1##\<sigma>2" and
         a2: "(a \<and>* a') (\<sigma>1+\<sigma>2,\<sigma>')" and
         a3: "I \<sigma>1 \<and> I  \<bowtie> a"
  obtain \<sigma>11 \<sigma>12 \<sigma>'1 \<sigma>'2
  where sep_split:"((\<sigma>11,\<sigma>'1)+(\<sigma>12,\<sigma>'2)) = (\<sigma>1+\<sigma>2,\<sigma>') \<and>
         (\<sigma>11,\<sigma>'1)##(\<sigma>12,\<sigma>'2) \<and> a (\<sigma>11,\<sigma>'1) \<and> a'(\<sigma>12,\<sigma>'2) "
  using a2
    by (metis sep_conjE surjective_pairing)
  then have split_sigma12:"\<sigma>11+\<sigma>12 = \<sigma>1+\<sigma>2 \<and> \<sigma>11##\<sigma>12"
    by (metis (no_types) dis_sep)
  then have "\<sigma>11 \<preceq> \<sigma>1+\<sigma>2 \<and> \<sigma>1 \<preceq> \<sigma>1+\<sigma>2"
    using sep_substate_def sep_split a1 by fastforce
  then have "\<sigma>11=\<sigma>1"
    using sep_split a3 sub_state_fence_unique by blast
  then have "\<sigma>12 = \<sigma>2"
    by (metis (no_types) split_sigma12 a1 sep_add_cancelD sep_add_commute sep_disj_commute)
  then have "(\<sigma>'1, \<sigma>'2\<triangleright> \<sigma>') \<and> a (\<sigma>1,\<sigma>'1) \<and> a'(\<sigma>2,\<sigma>'2)"
    by (metis (no_types) `\<sigma>11 = \<sigma>1` dis_sep sep_split tern_rel_def)
  thus "\<exists>\<sigma>1' \<sigma>2'.(\<sigma>1',\<sigma>2'\<triangleright> \<sigma>')"
    by blast
qed

lemma fence_tran_unique:
  "(\<sigma>1 ## \<sigma>2) \<Longrightarrow> (a \<and>* a') (\<sigma>1+\<sigma>2,\<sigma>') \<Longrightarrow> I \<sigma>1 \<and> I  \<bowtie> a \<Longrightarrow>
   (\<exists>!\<sigma>1'. \<exists>!\<sigma>2'. ((\<sigma>1', \<sigma>2' \<triangleright> \<sigma>') \<and> a (\<sigma>1,\<sigma>1') \<and> a'(\<sigma>2,\<sigma>2')))"
  proof -
  assume a1:"\<sigma>1##\<sigma>2" and
     a2: "(a \<and>* a') (\<sigma>1+\<sigma>2,\<sigma>')"
  then obtain \<sigma>11 \<sigma>12 \<sigma>'1 \<sigma>'2
  where sep_split:"((\<sigma>11,\<sigma>'1)+(\<sigma>12,\<sigma>'2)) = (\<sigma>1+\<sigma>2,\<sigma>') \<and>
         (\<sigma>11,\<sigma>'1)##(\<sigma>12,\<sigma>'2) \<and> a (\<sigma>11,\<sigma>'1) \<and> a'(\<sigma>12,\<sigma>'2) "
    by (metis sep_conjE surjective_pairing)
  assume   a3: "I \<sigma>1 \<and> I  \<bowtie> a"
  then
  obtain \<sigma>1' \<sigma>2' where exists:"(\<sigma>1', \<sigma>2' \<triangleright> \<sigma>') \<and> a (\<sigma>1,\<sigma>1') \<and> a'(\<sigma>2,\<sigma>2')"
    using a1 a2 fence_tran_exists by blast
  then have k1:"(\<sigma>1' , \<sigma>2'\<triangleright> \<sigma>')" by (simp add: tern_rel_def)
  show "\<exists>!\<sigma>1'. \<exists>!\<sigma>2'. ((\<sigma>1', \<sigma>2' \<triangleright> \<sigma>') \<and> a (\<sigma>1,\<sigma>1') \<and> a'(\<sigma>2,\<sigma>2'))"
  proof (rule+)
         let ?\<sigma>1' = \<sigma>1'
         let ?\<sigma>2'2 = \<sigma>2'
         show "(?\<sigma>1', ?\<sigma>2'2\<triangleright> \<sigma>')" using k1 by blast
     next
         show "a (\<sigma>1, \<sigma>1') \<and> a' (\<sigma>2, \<sigma>2')" using exists by blast
     next
         fix \<sigma>2'a
         assume a11:"(\<sigma>1' , \<sigma>2'a\<triangleright> \<sigma>') \<and> a (\<sigma>1, \<sigma>1') \<and> a' (\<sigma>2, \<sigma>2'a)"
         then have "\<exists>!\<sigma>2'.(\<sigma>1' , \<sigma>2'\<triangleright> \<sigma>')"
           using unique_subheap k1 by blast
         then show" \<sigma>2'a = \<sigma>2'" using a11 k1 by auto
     next
         fix \<sigma>1'a
         have f1:"\<And>I a \<sigma>1 \<sigma>1'. I \<bowtie> a \<Longrightarrow>  a (\<sigma>1, \<sigma>1') \<Longrightarrow> I \<sigma>1 \<and> I \<sigma>1'"
           using Fence_def afterD by metis
         assume "\<exists>!\<sigma>2'. (\<sigma>1'a, \<sigma>2'\<triangleright> \<sigma>') \<and> a (\<sigma>1, \<sigma>1'a) \<and> a' (\<sigma>2, \<sigma>2')"
         then obtain \<sigma>2'1 where a12:"(\<sigma>1'a, \<sigma>2'1\<triangleright> \<sigma>') \<and> a (\<sigma>1, \<sigma>1'a) \<and> a' (\<sigma>2, \<sigma>2'1)"
           by auto
         then have prec1:"I \<sigma>1'a" using  a3 f1 by blast
         then have prec2:"I \<sigma>1'" using exists a3 f1 by blast
         have prec:"precise I" using a3 Fence_def
           by (simp add: Fence_def)
         have "\<sigma>1' \<preceq> \<sigma>' \<and> \<sigma>1'a \<preceq> \<sigma>'"
           using sep_split_substate exists a12 by blast
         then show  "\<sigma>1'a = \<sigma>1'"
             using precise_def  prec1 prec2 prec
             by (metis (no_types))
  qed
qed

corollary frame_property_a_star_id:
  "\<sigma>1 ## \<sigma>2 \<and> (a \<and>* tran_Id) (\<sigma>1+\<sigma>2,\<sigma>') \<Longrightarrow> I \<sigma>1 \<and> I  \<bowtie> a \<Longrightarrow>
   \<exists>\<sigma>1'.(\<sigma>1', \<sigma>2\<triangleright> \<sigma>') \<and> (\<sigma>1,\<sigma>1') \<in>\<lfloor>a\<rfloor>"
  proof -
   assume a1:"\<sigma>1 ## \<sigma>2 \<and> (a \<and>* tran_Id) (\<sigma>1+\<sigma>2,\<sigma>')" and
          a:" I \<sigma>1 \<and> I  \<bowtie> a"
   then
   have "\<exists>!\<sigma>1'. \<exists>! \<sigma>2'. (\<sigma>1', \<sigma>2'\<triangleright> \<sigma>') \<and> a (\<sigma>1, \<sigma>1') \<and> tran_Id (\<sigma>2, \<sigma>2')"
     using fence_tran_unique[of \<sigma>1 \<sigma>2 a tran_Id \<sigma>' I] a1 by fast
   then obtain \<sigma>1' \<sigma>2' where res:"(\<sigma>1', \<sigma>2'\<triangleright> \<sigma>') \<and> a (\<sigma>1, \<sigma>1') \<and> tran_Id (\<sigma>2, \<sigma>2')" by auto
   then have "\<sigma>2=\<sigma>2'" using tran_Id_def satisD by metis
   then show "\<exists>\<sigma>1'.(\<sigma>1', \<sigma>2\<triangleright> \<sigma>') \<and> (\<sigma>1,\<sigma>1') \<in>\<lfloor>a\<rfloor>" using Satis_def res  mem_Collect_eq
     by (metis (no_types))
qed

lemma sta_fence:
  "Sta p a \<and> Sta p' a' \<and> (\<forall>\<sigma>. (p imp I) \<sigma>)
 \<and> I  \<bowtie> a \<Longrightarrow> Sta (p \<and>* p') (a \<and>* a') "
  unfolding Sta_def
  proof -
    assume a1:"(\<forall>\<sigma> \<sigma>'. p \<sigma> \<and> a (\<sigma>, \<sigma>') \<longrightarrow> p \<sigma>') \<and>
            (\<forall>\<sigma> \<sigma>'. p' \<sigma> \<and> a' (\<sigma>, \<sigma>') \<longrightarrow> p' \<sigma>') \<and>
            (\<forall>\<sigma>. p \<sigma> \<longrightarrow> I \<sigma>) \<and> I \<bowtie> a"
    show "\<forall>\<sigma> \<sigma>'. (p \<and>* p') \<sigma> \<and> (a \<and>* a') (\<sigma>, \<sigma>') \<longrightarrow> (p \<and>* p') \<sigma>'"
    proof (rule+)
     fix \<sigma> \<sigma>'
     assume a2:"(p \<and>* p') \<sigma> \<and> (a \<and>* a') (\<sigma>, \<sigma>')"
     then obtain \<sigma>1 \<sigma>2  where split_p:"\<sigma>=\<sigma>1 + \<sigma>2 \<and> \<sigma>1##\<sigma>2 \<and> p \<sigma>1 \<and> p' \<sigma>2"
       using sep_conjD by blast
     then have split1: " \<sigma>1##\<sigma>2" by auto
     then have sig_sum:"(a \<and>* a') (\<sigma>1 + \<sigma>2,\<sigma>')" using split_p a2 by auto
     then have "I \<sigma>1 \<and> I \<bowtie> a" using a1 split_p by blast
     then have "\<exists>! \<sigma>1'. \<exists>! \<sigma>2'. (\<sigma>1', \<sigma>2'\<triangleright> \<sigma>') \<and> a (\<sigma>1,\<sigma>1') \<and> a'(\<sigma>2,\<sigma>2')"
        using  split1  sig_sum fence_tran_unique[of \<sigma>1 \<sigma>2 a a' \<sigma>' I]
        by fast
     then show "(p \<and>* p') \<sigma>'"
      by (metis (no_types) a1 sep_conjI tern_rel_def split_p)
   qed
qed

 lemma fence_G_id:
  assumes a0:"(I  \<bowtie> G)" and
          a1:"G (s,y)"
  shows "G (s,s)"
proof -
  have "case (s, y) of (p, pa) \<Rightarrow> I p \<and> I pa"
    using a0 a1
    unfolding Fence_def satis_def after_def
    by presburger
  hence "case (s, s) of (p, pa) \<Rightarrow> p = pa \<and> I p"
    by fastforce
  thus ?thesis
    using a0 unfolding Fence_def satis_def after_def by presburger
qed

lemma fence_I_id:
  assumes a0:"(I  \<bowtie> G)" and
          a1:"I s"
  shows "G (s,s)"
using a0 a1 unfolding Fence_def satis_def after_def by blast

lemma fence_I_id1:
  assumes a0:"(I  \<bowtie> G)" and
          a1:"\<forall>s t. (p imp I) (s,t)" and
          a2:"p s \<and> s=(s1,s2)"
  shows "G (s,s)"
using a0 a1 a2 fence_I_id by blast

lemma tran_True:"tran_True t"
unfolding tran_True_def after_def by auto

(* declare [[show_types]]
  declare [[show_sorts]]
  declare [[show_consts]] *)
lemma fence_p_I_G:
  assumes a0:"(\<forall>s t. (p imp (I\<and>*sep_true)) (s,t))" and
          a1:"(I \<bowtie> G)" and
          a2: "p s"
  shows "(G\<and>*tran_True) (s,s)"
proof-
  obtain sl sg where s:"s=(sl,sg)" using a2 by (meson surj_pair)
  then have I_true:"(I\<and>*sep_true) s" using a0 a2 by fastforce
  then obtain s\<^sub>1 s\<^sub>2 where sep: "s\<^sub>1 ## s\<^sub>2 \<and> s = s\<^sub>1 + s\<^sub>2 \<and> I s\<^sub>1 \<and> sep_true s\<^sub>2"
    using sep_conjD by blast
  then obtain sl\<^sub>1 sl\<^sub>2 sg\<^sub>1 sg\<^sub>2 where rel:"sl=sl\<^sub>1+sl\<^sub>2 \<and> sg = sg\<^sub>1 + sg\<^sub>2 \<and> s\<^sub>1=(sl\<^sub>1,sg\<^sub>1) \<and> s\<^sub>2=(sl\<^sub>2,sg\<^sub>2)"
    using s by (metis Pair_inject plus_prod_def surjective_pairing)
  then have "G ((sl\<^sub>1,sg\<^sub>1),(sl\<^sub>1,sg\<^sub>1))"
    using a1 sep fence_I_id by blast
  then have "G (s\<^sub>1, s\<^sub>1)" using rel by blast
  then have "(G\<and>*tran_Id)(s\<^sub>1, s\<^sub>1)" using sep_conj_train_Id by blast
  then have G:"(G\<and>*tran_Id)(s,s)" using s sep conj_sep_id unfolding tern_rel_def
    by fastforce
  then have "\<forall>s. tran_Id s \<longrightarrow> tran_True s" using tran_True by blast
  thus ?thesis  using G sep_conj_commute sep_conj_impl1 by (metis (no_types))
qed

end


section \<open>Base system E\<close>
(*<*)
theory cube
imports Main

begin
(*>*)

subsection \<open>Introduction\<close>

subsection \<open>Base System E\<close>

text \<open>We present an approach to meta-reasoning about dyadic deontic logics, and
apply it to verify the relative strengths of logics in the deontic cube. This one is still
under construction, and closer to a line at the moment. We introduce the
properties of the betterness relation, and their syntactical counterparts. We ask Isabelle/HOL to

(1) confirm known correspondance (established by pen and paper) under
different evaluation rules for the conditional obligation operator: max rule, opt rule, closure
maximality, and  Lewis rule.
(2) verify the asbsence of syntactical counterpart of some properties
(3) answer open problems regarding correspondance problems  (open in the sense of unsettled by
 pen and paper). \<close>

section \<open>Framework\<close>

text \<open>This is Aqvis's system E from the 2019 IfColog paper.\<close>

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 eimp :: "\<sigma>\<Rightarrow>\<sigma>\<Rightarrow>\<sigma>" (infixr"\<^bold>\<rightarrow>"49) where "\<phi>\<^bold>\<rightarrow>\<psi> \<equiv> \<lambda>w. \<phi>(w)\<longrightarrow>\<psi>(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)"
definition 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 "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 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 r v \<longrightarrow>  v 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>>"

lemma True nitpick[satisfy,user_axioms,expect=genuine] oops

lemma "\<odot><\<psi>|\<phi>> \<equiv> \<circle><\<psi>|\<phi>>" nitpick [show_all] (*countermodel found*) 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 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>>"

lemma True nitpick [satisfy,user_axioms,expect=genuine]
  oops

(*The standard properties*)
abbreviation reflexivity  where "reflexivity  \<equiv> (\<forall>x. x r x)"
abbreviation transitivity
  where "transitivity \<equiv> (\<forall>x y z. (x r y \<and> y r z) \<longrightarrow> x r z)"
abbreviation totalness
  where "totalness \<equiv> (\<forall>x y. (x r y \<or> y r x))"

(*4 versions of Lewis's limit assumption*)
abbreviation mlimitedness
  where "mlimitedness \<equiv> (\<forall>\<phi>. (\<exists>x. (\<phi>)x) \<longrightarrow> (\<exists>x. max<\<phi>>x))"
abbreviation msmoothness
  where "msmoothness \<equiv> (\<forall>\<phi> x. ((\<phi>)x \<longrightarrow>
                     (max<\<phi>>x \<or> (\<exists>y. (y r x \<and> \<not>(x r y) \<and> max<\<phi>>y)))))"
abbreviation olimitedness
  where "olimitedness \<equiv> (\<forall>\<phi>. (\<exists>x. (\<phi>)x) \<longrightarrow> (\<exists>x. opt<\<phi>>x))"
abbreviation osmoothness  where
   "osmoothness \<equiv> (\<forall>\<phi> x. ((\<phi>)x \<longrightarrow>
                      (opt<\<phi>>x \<or> (\<exists>y. (y r x \<and> \<not>(x r y) \<and> opt<\<phi>>y)))))"
definition transitive :: "\<alpha>\<Rightarrow>bool" where "transitive R \<equiv> \<forall>x y z. R x y \<and>  R y z \<longrightarrow> R x z"
definition sub_rel :: "\<alpha>\<Rightarrow>\<alpha>\<Rightarrow>bool" where "sub_rel R Q \<equiv> \<forall>u v. R u v \<longrightarrow> Q u v"
definition assfactor::"\<alpha>\<Rightarrow>\<alpha>" where "assfactor R \<equiv> \<lambda>u v. R u v \<and> \<not> R v u "
(*In HOL the transitive closure of a relation can be defined in a single line.*)
definition tc :: "\<alpha>\<Rightarrow>\<alpha>" where "tc R \<equiv> \<lambda>x y.\<forall>Q. transitive Q \<longrightarrow> (sub_rel R Q \<longrightarrow> Q x y)"
(* this is a first form of a-cyclicity. Cycles with one non-strict betterness are ruled out*)
abbreviation Suzumura
  where "Suzumura R \<equiv> \<forall>x y. (tc R x y \<longrightarrow> ( R y x \<longrightarrow> R x y))"
(* this is a second form of a-cyclicity. Cycles of non-strict betterness are ruled out*)
abbreviation loopfree
  where "loopfree R \<equiv> \<forall>x y. (tc (assfactor R) x y \<longrightarrow> ( R y x \<longrightarrow> R x y))"

(*Interval order condition is totalness plus Ferrers*)
abbreviation Ferrers
  where "Ferrers \<equiv> (\<forall>x y z u. ((x r u) \<and> (y r z)) \<longrightarrow> (x r z) \<or> (y r u))"
lemma assumes Ferrers reflexivity  (*fact overlooked in the literature*)
  shows totalness
  sledgehammer  (*proof found*)
  oops

(*max-Limitedness corresponds to D*)
lemma "\<lfloor>\<diamond>\<phi> \<^bold>\<rightarrow> (\<circle><\<psi>|\<phi>> \<^bold>\<rightarrow> P<\<psi>|\<phi>>)\<rfloor>"
  nitpick [show_all]  (* counterexample found *)
  oops

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

lemma "\<lfloor>\<circle><\<chi>|(\<phi>\<^bold>\<or>\<psi>)>\<^bold>\<rightarrow>((\<circle><\<chi>|\<phi>>)\<^bold>\<or>(\<circle><\<chi>|\<psi>>))\<rfloor>"
  nitpick (* counterexample found *)
  oops

(*max-Limitedness corresponds to D*)

lemma assumes "mlimitedness"
  shows  "D*": "\<lfloor>\<diamond>\<phi> \<^bold>\<rightarrow> \<circle><\<psi>|\<phi>> \<^bold>\<rightarrow> P<\<psi>|\<phi>>\<rfloor>"
  sledgehammer
  oops (*proof found*)

lemma assumes "D*": "\<lfloor>\<diamond>\<phi> \<^bold>\<rightarrow> \<^bold>\<not>(\<circle><\<psi>|\<phi>>\<^bold>\<and>\<circle><\<^bold>\<not>\<psi>|\<phi>>)\<rfloor>"
  shows "mlimitedness"
  sledgehammer (*all timed out*)
  nitpick [show_all] (* counterexample found *)
  oops

(*smoothness corresponds to cautious monotony *)
lemma assumes "msmoothness"
  shows  CM: "\<lfloor>(\<circle><\<psi>|\<phi>>\<^bold>\<and>\<circle><\<chi>|\<phi>>)\<^bold>\<rightarrow> \<circle><\<chi>|\<phi>\<^bold>\<and>\<psi>>\<rfloor>"
  sledgehammer (*proof found*)
  oops

lemma assumes CM: "\<lfloor>(\<circle><\<psi>|\<phi>>\<^bold>\<and>\<circle><\<chi>|\<phi>>)\<^bold>\<rightarrow> \<circle><\<chi>|\<phi>\<^bold>\<and>\<psi>>\<rfloor>"
  shows  "msmoothness"
  sledgehammer (* timed out*)
  nitpick [show_all] (* counterexample found *)
  oops

(*interval order (reflexivity plus Ferrers) corresponds to disjunctive rationality*)

lemma assumes "reflexivity"
     (* assumes "Ferrers"*)
  shows  DR: "\<lfloor>\<circle><\<chi>|(\<phi>\<^bold>\<or>\<psi>)>\<^bold>\<rightarrow>((\<circle><\<chi>|\<phi>>)\<^bold>\<or>(\<circle><\<chi>|\<psi>>))\<rfloor>"
  sledgehammer (* timed out*)
  nitpick (* counterexample found *)
  oops

lemma assumes "reflexivity" "Ferrers"
  shows  DR: "\<forall>\<phi> \<psi> \<chi>.\<lfloor>\<circle><\<chi>|(\<phi>\<^bold>\<or>\<psi>)>\<^bold>\<rightarrow>((\<circle><\<chi>|\<phi>>)\<^bold>\<or>(\<circle><\<chi>|\<psi>>))\<rfloor>"
  sledgehammer (* proof found *)
  nitpick (* no 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 "reflexivity"
  sledgehammer (* timed out*)
  nitpick [show_all] (* 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"
  sledgehammer (* timed out*)
  nitpick (* counterexample found *)
  oops

text \<open>Transitivity and totalness corresponds to the Spohn axiom (Sp)\<close>

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>"
  sledgehammer (* timed out *)
  nitpick (* counterexample for card i=5*)
  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>"
  sledgehammer (* timed out*)
  nitpick (* counterexample for card i=4*)
  oops

lemma assumes "transitivity" "totalness"
  shows  Sp: "\<lfloor>( P<\<psi>|\<phi>> \<^bold>\<and> \<circle><(\<psi>\<^bold>\<rightarrow>\<chi>)|\<phi>>) \<^bold>\<rightarrow> \<circle><\<chi>|(\<phi>\<^bold>\<and>\<psi>)>\<rfloor>"
  sledgehammer (* proof found *)
  nitpick (* no 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 "totalness"
  sledgehammer (* timed out*)
  nitpick (* counterexample found for card i=1*)
  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"
  sledgehammer (* timed out*)
  nitpick (* counterexample found for card =4*)
  oops

subsection \<open>Correspondance under the opt rule\<close>

text \<open>We move to the opt rule, and associate with it two news modal operators\<close>

text \<open>Here we redefine Lewis's limit assumption accordingly\<close>

text \<open>Correspondance\<close>

text \<open>opt-Limitedness corresponds to D\<close>

lemma assumes "olimitedness"
  shows  D: "\<lfloor>\<diamond>\<phi> \<^bold>\<rightarrow> \<odot><\<psi>|\<phi>> \<^bold>\<rightarrow> \
<\<psi>|\<phi>>\<rfloor>"
  sledgehammer (* proof found*)
  nitpick (* no counterexample found *)
  oops

lemma assumes D: "\<lfloor>\<diamond>\<phi> \<^bold>\<rightarrow> \<odot><\<psi>|\<phi>> \<^bold>\<rightarrow> \
<\<psi>|\<phi>>\<rfloor>"
  shows "olimitedness"
  sledgehammer (* timed out*)
  nitpick (* counterexample found *)
  oops

text \<open>Smoothness corresponds to CM\<close>

lemma assumes "osmoothness"
  shows  CM: "\<lfloor>(\<odot><\<psi>|\<phi>>\<^bold>\<and>\<odot><\<chi>|\<phi>>)\<^bold>\<rightarrow> \<odot><\<chi>|\<phi>\<^bold>\<and>\<psi>>\<rfloor>"
  sledgehammer (* proof found*)
  nitpick (* run out of time *)
  oops

lemma assumes CM: "\<lfloor>(\<odot><\<psi>|\<phi>>\<^bold>\<and>\<odot><\<chi>|\<phi>>)\<^bold>\<rightarrow> \<odot><\<chi>|\<phi>\<^bold>\<and>\<psi>>\<rfloor>"
  shows  "osmoothness"
  sledgehammer (* timed out*)
  nitpick (* counterexample found *)
  oops

(*transitivity*)

lemma assumes "transitivity"
  shows  Sp: "\<lfloor>( \
<\<psi>|\<phi>> \<^bold>\<and> \<odot><(\<psi>\<^bold>\<rightarrow>\<chi>)|\<phi>>) \<^bold>\<rightarrow> \<odot><\<chi>|(\<phi>\<^bold>\<and>\<psi>)>\<rfloor>"
  sledgehammer (* proof found *)
  nitpick (* no counterexample found *)
  oops

lemma 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>"
  sledgehammer (* proof found *)
  nitpick [show_all] (* no counterexample found *)
  oops

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"
  sledgehammer (* timed out*)
  nitpick (* counterexample found for card i =3*)
  oops

lemma assumes "totalness"
     (* assumes "Ferrers"*)
  shows  DR: "\<lfloor>\<odot><\<chi>|\<phi>\<^bold>\<or>\<psi>>\<^bold>\<rightarrow>(\<odot><\<chi>|\<phi>>\<^bold>\<or>\<odot><\<chi>|\<psi>>)\<rfloor>"
  sledgehammer (* timed out*)
  nitpick (* 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 "totalness"
   sledgehammer (* timed out*)
   nitpick (* 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"
  sledgehammer (* timed out*)
  nitpick (* counterexample found *)
  oops

subsection \<open>Lewis rule\<close>
text \<open>Under the Lewis rule, totalness corresponds to D \<close>

(*deontic explosion-max rule*)
lemma DEX: "\<lfloor>(\<diamond>\<phi>\<^bold>\<and>\<circle><\<psi>|\<phi>>\<^bold>\<and>\<circle><\<^bold>\<not>\<psi>|\<phi>>)\<^bold>\<rightarrow> \<circle><\<chi>|\<phi>>\<rfloor>"
  sledgehammer (*proof found*)
  oops

(*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>"
  sledgehammer (*timed out*)
  nitpick (*counter-model found for card i = 3*)
  oops

lemma assumes "mlimitedness"
  assumes "transitivity"
  assumes "totalness"
  shows "\<lfloor>\<circ><\<psi>|\<phi>>\<^bold>\<leftrightarrow>\<odot><\<psi>|\<phi>>\<rfloor>"
  sledgehammer (*proof found*)
  oops

lemma assumes "mlimitedness"
  assumes "transitivity"
  assumes "totalness"
 shows "\<lfloor>\<circ><\<psi>|\<phi>>\<^bold>\<leftrightarrow>\<circle><\<psi>|\<phi>>\<rfloor>"
  sledgehammer (*proof found*)
  oops

(*axioms of E holding if r transitive and totale*)

lemma D: "\<lfloor>\<diamond>\<phi> \<^bold>\<rightarrow> (\<circ><\<psi>|\<phi>> \<^bold>\<rightarrow> \<integral><\<psi>|\<phi>>)\<rfloor>"
  nitpick (*countermodel*)
  oops

lemma
 assumes "totalness"
 shows D: "\<lfloor>\<diamond>\<phi> \<^bold>\<rightarrow> (\<circ><\<psi>|\<phi>> \<^bold>\<rightarrow> \<integral><\<psi>|\<phi>>)\<rfloor>"
  sledgehammer (*proof found*)
  oops

lemma  Sp: "\<lfloor>( \<integral><\<psi>|\<phi>> \<^bold>\<and> \<circ><(\<psi>\<^bold>\<rightarrow>\<chi>)|\<phi>>) \<^bold>\<rightarrow> \<circ><\<chi>|(\<phi>\<^bold>\<and>\<psi>)>\<rfloor>"
  nitpick (*countermodel*)
  oops

lemma
 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>"
  sledgehammer (*proof found*)
  oops

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 (*countermodel*)
  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 (*countermodel*)
  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 (*countermodel*)
  oops

lemma
  assumes "transitivity"
  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>"
  sledgehammer (*proof found*)
  oops

lemma CM: "\<lfloor>(\<circ><\<psi>|\<phi>>\<^bold>\<and>\<circ><\<chi>|\<phi>>)\<^bold>\<rightarrow> \<circ><\<chi>|\<phi>\<^bold>\<and>\<psi>>\<rfloor>"
  nitpick (*countermodel*)
  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 (*countermodel*)
  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 (*countermodel*)
  oops

lemma
  assumes "transitivity"
  assumes "totalness"
  shows CM: "\<lfloor>(\<circ><\<psi>|\<phi>>\<^bold>\<and>\<circ><\<chi>|\<phi>>)\<^bold>\<rightarrow> \<circ><\<chi>|\<phi>\<^bold>\<and>\<psi>>\<rfloor>"
  sledgehammer (*proof found*)
  oops

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

lemma Abs:"\<lfloor>\<circ><\<psi>|\<phi>> \<^bold>\<rightarrow> \<box>\<circ><\<psi>|\<phi>>\<rfloor>"
  sledgehammer (*proof found*)
  oops

lemma Nec:"\<lfloor>\<box>\<psi> \<^bold>\<rightarrow> \<circ><\<psi>|\<phi>>\<rfloor>"
  sledgehammer (*proof found*)
  oops

lemma 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>"
  sledgehammer (*proof found*)
  oops

lemma Id:"\<lfloor>\<circ><\<phi>|\<phi>>\<rfloor>"
  sledgehammer (*proof found*)
  oops

lemma 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>"
  sledgehammer (*proof found*)
  oops

  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>

lemma assumes "transitivity"
  shows  Sp: "\<lfloor>( \
<\<psi>|\<phi>> \<^bold>\<and> \<odot><(\<psi>\<^bold>\<rightarrow>\<chi>)|\<phi>>) \<^bold>\<rightarrow> \<odot><\<chi>|(\<phi>\<^bold>\<and>\<psi>)>\<rfloor>"
  sledgehammer (* proof found *)
  nitpick (* no counterexample found *)
  oops

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>"
  sledgehammer (* proof found *)
  nitpick (* no counterexample found *)
  oops

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> \
<\<xi>|\<psi>\<^bold>\<or>\<xi>>)\<^bold>\<rightarrow>\
<\<xi>|\<phi>\<^bold>\<or>\<xi>>\<rfloor>"
      shows "transitivity"
  sledgehammer (* timed out*)
  nitpick (* counterexample found *)
  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>