section\<open>Well-founded relation on names\<close>
theory FrecR imports Names Synthetic_Definition begin

lemmas sep_rules' = nth_0 nth_ConsI FOL_iff_sats function_iff_sats
  fun_plus_iff_sats omega_iff_sats FOL_sats_iff

text\<open>\<^term>\<open>frecR\<close> is the well-founded relation on names that allows
us to define forcing for atomic formulas.\<close>

(* MOVE THIS. absoluteness of higher-order composition *)
definition
  is_hcomp :: "[i\<Rightarrow>o,i\<Rightarrow>i\<Rightarrow>o,i\<Rightarrow>i\<Rightarrow>o,i,i] \<Rightarrow> o" where
  "is_hcomp(M,is_f,is_g,a,w) \<equiv> \<exists>z[M]. is_g(a,z) \<and> is_f(z,w)"

lemma (in M_trivial) hcomp_abs:
  assumes
    is_f_abs:"\<And>a z. M(a) \<Longrightarrow> M(z) \<Longrightarrow> is_f(a,z) \<longleftrightarrow> z = f(a)" and
    is_g_abs:"\<And>a z. M(a) \<Longrightarrow> M(z) \<Longrightarrow> is_g(a,z) \<longleftrightarrow> z = g(a)" and
    g_closed:"\<And>a. M(a) \<Longrightarrow> M(g(a))"
    "M(a)" "M(w)"
  shows
    "is_hcomp(M,is_f,is_g,a,w) \<longleftrightarrow> w = f(g(a))"
  unfolding is_hcomp_def using assms by simp

definition
  hcomp_fm :: "[i\<Rightarrow>i\<Rightarrow>i,i\<Rightarrow>i\<Rightarrow>i,i,i] \<Rightarrow> i" where
  "hcomp_fm(pf,pg,a,w) \<equiv> Exists(And(pg(succ(a),0),pf(0,succ(w))))"

lemma sats_hcomp_fm:
  assumes
    f_iff_sats:"\<And>a b z. a\<in>nat \<Longrightarrow> b\<in>nat \<Longrightarrow> z\<in>M \<Longrightarrow>
                 is_f(nth(a,Cons(z,env)),nth(b,Cons(z,env))) \<longleftrightarrow> sats(M,pf(a,b),Cons(z,env))"
    and
    g_iff_sats:"\<And>a b z. a\<in>nat \<Longrightarrow> b\<in>nat \<Longrightarrow> z\<in>M \<Longrightarrow>
                is_g(nth(a,Cons(z,env)),nth(b,Cons(z,env))) \<longleftrightarrow> sats(M,pg(a,b),Cons(z,env))"
    and
    "a\<in>nat" "w\<in>nat" "env\<in>list(M)"
  shows
    "sats(M,hcomp_fm(pf,pg,a,w),env) \<longleftrightarrow> is_hcomp(##M,is_f,is_g,nth(a,env),nth(w,env))"
proof -
  have "sats(M, pf(0, succ(w)), Cons(x, env)) \<longleftrightarrow> is_f(x,nth(w,env))" if "x\<in>M" "w\<in>nat" for x w
    using f_iff_sats[of 0 "succ(w)" x] that by simp
  moreover
  have "sats(M, pg(succ(a), 0), Cons(x, env)) \<longleftrightarrow> is_g(nth(a,env),x)" if "x\<in>M" "a\<in>nat" for x a
    using g_iff_sats[of "succ(a)" 0 x] that by simp
  ultimately
  show ?thesis unfolding hcomp_fm_def is_hcomp_def using assms by simp
qed

(* Preliminary *)
definition
  ftype :: "i\<Rightarrow>i" where
  "ftype \<equiv> fst"

definition
  name1 :: "i\<Rightarrow>i" where
  "name1(x) \<equiv> fst(snd(x))"

definition
  name2 :: "i\<Rightarrow>i" where
  "name2(x) \<equiv> fst(snd(snd(x)))"

definition
  cond_of :: "i\<Rightarrow>i" where
  "cond_of(x) \<equiv> snd(snd(snd((x))))"

lemma components_simp:
  "ftype(\<langle>f,n1,n2,c\<rangle>) = f"
  "name1(\<langle>f,n1,n2,c\<rangle>) = n1"
  "name2(\<langle>f,n1,n2,c\<rangle>) = n2"
  "cond_of(\<langle>f,n1,n2,c\<rangle>) = c"
  unfolding ftype_def name1_def name2_def cond_of_def
  by simp_all

definition eclose_n :: "[i\<Rightarrow>i,i] \<Rightarrow> i" where
  "eclose_n(name,x) = eclose({name(x)})"

definition
  ecloseN :: "i \<Rightarrow> i" where
  "ecloseN(x) = eclose_n(name1,x) \<union> eclose_n(name2,x)"

lemma components_in_eclose :
  "n1 \<in> ecloseN(\<langle>f,n1,n2,c\<rangle>)"
  "n2 \<in> ecloseN(\<langle>f,n1,n2,c\<rangle>)"
  unfolding ecloseN_def eclose_n_def
  using components_simp arg_into_eclose by auto

lemmas names_simp = components_simp(2) components_simp(3)

lemma ecloseNI1 :
  assumes "x \<in> eclose(n1) \<or> x\<in>eclose(n2)"
  shows "x \<in> ecloseN(\<langle>f,n1,n2,c\<rangle>)"
  unfolding ecloseN_def eclose_n_def
  using assms eclose_sing names_simp
  by auto

lemmas ecloseNI = ecloseNI1

lemma ecloseN_mono :
  assumes "u \<in> ecloseN(x)" "name1(x) \<in> ecloseN(y)" "name2(x) \<in> ecloseN(y)"
  shows "u \<in> ecloseN(y)"
proof -
  from \<open>u\<in>_\<close>
  consider (a) "u\<in>eclose({name1(x)})" | (b) "u \<in> eclose({name2(x)})"
    unfolding ecloseN_def  eclose_n_def by auto
  then
  show ?thesis
  proof cases
    case a
    with \<open>name1(x) \<in> _\<close>
    show ?thesis
      unfolding ecloseN_def  eclose_n_def
      using eclose_singE[OF a] mem_eclose_trans[of u "name1(x)" ] by auto
  next
    case b
    with \<open>name2(x) \<in> _\<close>
    show ?thesis
      unfolding ecloseN_def eclose_n_def
      using eclose_singE[OF b] mem_eclose_trans[of u "name2(x)"] by auto
  qed
qed

(* ftype(p) \<equiv> THE a. \<exists>b. p = \<langle>a, b\<rangle> *)

definition
  is_fst :: "(i\<Rightarrow>o)\<Rightarrow>i\<Rightarrow>i\<Rightarrow>o" where
  "is_fst(M,x,t) \<equiv> (\<exists>z[M]. pair(M,t,z,x)) \<or>
                       (\<not>(\<exists>z[M]. \<exists>w[M]. pair(M,w,z,x)) \<and> empty(M,t))"

definition
  fst_fm :: "[i,i] \<Rightarrow> i" where
  "fst_fm(x,t) \<equiv> Or(Exists(pair_fm(succ(t),0,succ(x))),
                   And(Neg(Exists(Exists(pair_fm(0,1,2 #+ x)))),empty_fm(t)))"

lemma sats_fst_fm :
  "\<lbrakk> x \<in> nat; y \<in> nat;env \<in> list(A) \<rbrakk>
    \<Longrightarrow> sats(A, fst_fm(x,y), env) \<longleftrightarrow>
        is_fst(##A, nth(x,env), nth(y,env))"
  by (simp add: fst_fm_def is_fst_def)

definition
  is_ftype :: "(i\<Rightarrow>o)\<Rightarrow>i\<Rightarrow>i\<Rightarrow>o" where
  "is_ftype \<equiv> is_fst"

definition
  ftype_fm :: "[i,i] \<Rightarrow> i" where
  "ftype_fm \<equiv> fst_fm"

lemma sats_ftype_fm :
  "\<lbrakk> x \<in> nat; y \<in> nat;env \<in> list(A) \<rbrakk>
    \<Longrightarrow> sats(A, ftype_fm(x,y), env) \<longleftrightarrow>
        is_ftype(##A, nth(x,env), nth(y,env))"
  unfolding ftype_fm_def is_ftype_def
  by (simp add:sats_fst_fm)

lemma is_ftype_iff_sats:
  assumes
    "nth(a,env) = aa" "nth(b,env) = bb" "a\<in>nat" "b\<in>nat" "env \<in> list(A)"
  shows
    "is_ftype(##A,aa,bb)  \<longleftrightarrow> sats(A,ftype_fm(a,b), env)"
  using assms
  by (simp add:sats_ftype_fm)

definition
  is_snd :: "(i\<Rightarrow>o)\<Rightarrow>i\<Rightarrow>i\<Rightarrow>o" where
  "is_snd(M,x,t) \<equiv> (\<exists>z[M]. pair(M,z,t,x)) \<or>
                       (\<not>(\<exists>z[M]. \<exists>w[M]. pair(M,z,w,x)) \<and> empty(M,t))"

definition
  snd_fm :: "[i,i] \<Rightarrow> i" where
  "snd_fm(x,t) \<equiv> Or(Exists(pair_fm(0,succ(t),succ(x))),
                   And(Neg(Exists(Exists(pair_fm(1,0,2 #+ x)))),empty_fm(t)))"

lemma sats_snd_fm :
  "\<lbrakk> x \<in> nat; y \<in> nat;env \<in> list(A) \<rbrakk>
    \<Longrightarrow> sats(A, snd_fm(x,y), env) \<longleftrightarrow>
        is_snd(##A, nth(x,env), nth(y,env))"
  by (simp add: snd_fm_def is_snd_def)

definition
  is_name1 :: "(i\<Rightarrow>o)\<Rightarrow>i\<Rightarrow>i\<Rightarrow>o" where
  "is_name1(M,x,t2) \<equiv> is_hcomp(M,is_fst(M),is_snd(M),x,t2)"

definition
  name1_fm :: "[i,i] \<Rightarrow> i" where
  "name1_fm(x,t) \<equiv> hcomp_fm(fst_fm,snd_fm,x,t)"

lemma sats_name1_fm :
  "\<lbrakk> x \<in> nat; y \<in> nat;env \<in> list(A) \<rbrakk>
    \<Longrightarrow> sats(A, name1_fm(x,y), env) \<longleftrightarrow>
        is_name1(##A, nth(x,env), nth(y,env))"
  unfolding name1_fm_def is_name1_def using sats_fst_fm sats_snd_fm
    sats_hcomp_fm[of A "is_fst(##A)" _ fst_fm "is_snd(##A)"] by simp

lemma is_name1_iff_sats:
  assumes
    "nth(a,env) = aa" "nth(b,env) = bb" "a\<in>nat" "b\<in>nat" "env \<in> list(A)"
  shows
    "is_name1(##A,aa,bb)  \<longleftrightarrow> sats(A,name1_fm(a,b), env)"
  using assms
  by (simp add:sats_name1_fm)

definition
  is_snd_snd :: "(i\<Rightarrow>o)\<Rightarrow>i\<Rightarrow>i\<Rightarrow>o" where
  "is_snd_snd(M,x,t) \<equiv> is_hcomp(M,is_snd(M),is_snd(M),x,t)"

definition
  snd_snd_fm :: "[i,i]\<Rightarrow>i" where
  "snd_snd_fm(x,t) \<equiv> hcomp_fm(snd_fm,snd_fm,x,t)"

lemma sats_snd2_fm :
  "\<lbrakk> x \<in> nat; y \<in> nat;env \<in> list(A) \<rbrakk>
    \<Longrightarrow> sats(A,snd_snd_fm(x,y), env) \<longleftrightarrow>
        is_snd_snd(##A, nth(x,env), nth(y,env))"
  unfolding snd_snd_fm_def is_snd_snd_def using sats_snd_fm
    sats_hcomp_fm[of A "is_snd(##A)" _ snd_fm "is_snd(##A)"] by simp

definition
  is_name2 :: "(i\<Rightarrow>o)\<Rightarrow>i\<Rightarrow>i\<Rightarrow>o" where
  "is_name2(M,x,t3) \<equiv> is_hcomp(M,is_fst(M),is_snd_snd(M),x,t3)"

definition
  name2_fm :: "[i,i] \<Rightarrow> i" where
  "name2_fm(x,t3) \<equiv> hcomp_fm(fst_fm,snd_snd_fm,x,t3)"

lemma sats_name2_fm :
  "\<lbrakk> x \<in> nat; y \<in> nat;env \<in> list(A) \<rbrakk>
    \<Longrightarrow> sats(A,name2_fm(x,y), env) \<longleftrightarrow>
        is_name2(##A, nth(x,env), nth(y,env))"
  unfolding name2_fm_def is_name2_def using sats_fst_fm sats_snd2_fm
    sats_hcomp_fm[of A "is_fst(##A)" _ fst_fm "is_snd_snd(##A)"] by simp

lemma is_name2_iff_sats:
  assumes
    "nth(a,env) = aa" "nth(b,env) = bb" "a\<in>nat" "b\<in>nat" "env \<in> list(A)"
  shows
    "is_name2(##A,aa,bb)  \<longleftrightarrow> sats(A,name2_fm(a,b), env)"
  using assms
  by (simp add:sats_name2_fm)

definition
  is_cond_of :: "(i\<Rightarrow>o)\<Rightarrow>i\<Rightarrow>i\<Rightarrow>o" where
  "is_cond_of(M,x,t4) \<equiv> is_hcomp(M,is_snd(M),is_snd_snd(M),x,t4)"

definition
  cond_of_fm :: "[i,i] \<Rightarrow> i" where
  "cond_of_fm(x,t4) \<equiv> hcomp_fm(snd_fm,snd_snd_fm,x,t4)"

lemma sats_cond_of_fm :
  "\<lbrakk> x \<in> nat; y \<in> nat;env \<in> list(A) \<rbrakk>
    \<Longrightarrow> sats(A,cond_of_fm(x,y), env) \<longleftrightarrow>
        is_cond_of(##A, nth(x,env), nth(y,env))"
  unfolding cond_of_fm_def is_cond_of_def using sats_snd_fm sats_snd2_fm
    sats_hcomp_fm[of A "is_snd(##A)" _ snd_fm "is_snd_snd(##A)"] by simp

lemma is_cond_of_iff_sats:
  assumes
    "nth(a,env) = aa" "nth(b,env) = bb" "a\<in>nat" "b\<in>nat" "env \<in> list(A)"
  shows
    "is_cond_of(##A,aa,bb)  \<longleftrightarrow> sats(A,cond_of_fm(a,b), env)"
  using assms
  by (simp add:sats_cond_of_fm)

lemma components_type[TC] :
  assumes "a\<in>nat" "b\<in>nat"
  shows
    "ftype_fm(a,b)\<in>formula"
    "name1_fm(a,b)\<in>formula"
    "name2_fm(a,b)\<in>formula"
    "cond_of_fm(a,b)\<in>formula"
  using assms
  unfolding ftype_fm_def fst_fm_def snd_fm_def snd_snd_fm_def name1_fm_def name2_fm_def
    cond_of_fm_def hcomp_fm_def
  by simp_all

lemmas sats_components_fm[simp] = sats_ftype_fm sats_name1_fm sats_name2_fm sats_cond_of_fm

lemmas components_iff_sats = is_ftype_iff_sats is_name1_iff_sats is_name2_iff_sats
  is_cond_of_iff_sats

lemmas components_defs = fst_fm_def ftype_fm_def snd_fm_def snd_snd_fm_def hcomp_fm_def
  name1_fm_def name2_fm_def cond_of_fm_def

definition
  is_eclose_n :: "[i\<Rightarrow>o,[i\<Rightarrow>o,i,i]\<Rightarrow>o,i,i] \<Rightarrow> o" where
  "is_eclose_n(N,is_name,en,t) \<equiv>
        \<exists>n1[N].\<exists>s1[N]. is_name(N,t,n1) \<and> is_singleton(N,n1,s1) \<and> is_eclose(N,s1,en)"

definition
  eclose_n1_fm :: "[i,i] \<Rightarrow> i" where
  "eclose_n1_fm(m,t) \<equiv> Exists(Exists(And(And(name1_fm(t#+2,0),singleton_fm(0,1)),
                                       is_eclose_fm(1,m#+2))))"

definition
  eclose_n2_fm :: "[i,i] \<Rightarrow> i" where
  "eclose_n2_fm(m,t) \<equiv> Exists(Exists(And(And(name2_fm(t#+2,0),singleton_fm(0,1)),
                                       is_eclose_fm(1,m#+2))))"

definition
  is_ecloseN :: "[i\<Rightarrow>o,i,i] \<Rightarrow> o" where
  "is_ecloseN(N,en,t) \<equiv> \<exists>en1[N].\<exists>en2[N].
                is_eclose_n(N,is_name1,en1,t) \<and> is_eclose_n(N,is_name2,en2,t)\<and>
                union(N,en1,en2,en)"

definition
  ecloseN_fm :: "[i,i] \<Rightarrow> i" where
  "ecloseN_fm(en,t) \<equiv> Exists(Exists(And(eclose_n1_fm(1,t#+2),
                            And(eclose_n2_fm(0,t#+2),union_fm(1,0,en#+2)))))"
lemma ecloseN_fm_type [TC] :
  "\<lbrakk> en \<in> nat ; t \<in> nat \<rbrakk> \<Longrightarrow> ecloseN_fm(en,t) \<in> formula"
  unfolding ecloseN_fm_def eclose_n1_fm_def eclose_n2_fm_def by simp

lemma sats_ecloseN_fm [simp]:
  "\<lbrakk> en \<in> nat; t \<in> nat ; env \<in> list(A) \<rbrakk>
    \<Longrightarrow> sats(A, ecloseN_fm(en,t), env) \<longleftrightarrow> is_ecloseN(##A,nth(en,env),nth(t,env))"
  unfolding ecloseN_fm_def is_ecloseN_def eclose_n1_fm_def eclose_n2_fm_def is_eclose_n_def
  using  nth_0 nth_ConsI sats_name1_fm sats_name2_fm
    is_singleton_iff_sats[symmetric]
  by auto

(* Relation of forces *)
definition
  frecR :: "i \<Rightarrow> i \<Rightarrow> o" where
  "frecR(x,y) \<equiv>
    (ftype(x) = 1 \<and> ftype(y) = 0
      \<and> (name1(x) \<in> domain(name1(y)) \<union> domain(name2(y)) \<and> (name2(x) = name1(y) \<or> name2(x) = name2(y))))
   \<or> (ftype(x) = 0 \<and> ftype(y) =  1 \<and> name1(x) = name1(y) \<and> name2(x) \<in> domain(name2(y)))"

lemma frecR_ftypeD :
  assumes "frecR(x,y)"
  shows "(ftype(x) = 0 \<and> ftype(y) = 1) \<or> (ftype(x) = 1 \<and> ftype(y) = 0)"
  using assms unfolding frecR_def by auto

lemma frecRI1: "s \<in> domain(n1) \<or> s \<in> domain(n2) \<Longrightarrow> frecR(\<langle>1, s, n1, q\<rangle>, \<langle>0, n1, n2, q'\<rangle>)"
  unfolding frecR_def by (simp add:components_simp)

lemma frecRI1': "s \<in> domain(n1) \<union> domain(n2) \<Longrightarrow> frecR(\<langle>1, s, n1, q\<rangle>, \<langle>0, n1, n2, q'\<rangle>)"
  unfolding frecR_def by (simp add:components_simp)

lemma frecRI2: "s \<in> domain(n1) \<or> s \<in> domain(n2) \<Longrightarrow> frecR(\<langle>1, s, n2, q\<rangle>, \<langle>0, n1, n2, q'\<rangle>)"
  unfolding frecR_def by (simp add:components_simp)

lemma frecRI2': "s \<in> domain(n1) \<union> domain(n2) \<Longrightarrow> frecR(\<langle>1, s, n2, q\<rangle>, \<langle>0, n1, n2, q'\<rangle>)"
  unfolding frecR_def by (simp add:components_simp)

lemma frecRI3: "\<langle>s, r\<rangle> \<in> n2 \<Longrightarrow> frecR(\<langle>0, n1, s, q\<rangle>, \<langle>1, n1, n2, q'\<rangle>)"
  unfolding frecR_def by (auto simp add:components_simp)

lemma frecRI3': "s \<in> domain(n2) \<Longrightarrow> frecR(\<langle>0, n1, s, q\<rangle>, \<langle>1, n1, n2, q'\<rangle>)"
  unfolding frecR_def by (auto simp add:components_simp)

lemma frecR_iff :
  "frecR(x,y) \<longleftrightarrow>
    (ftype(x) = 1 \<and> ftype(y) = 0
      \<and> (name1(x) \<in> domain(name1(y)) \<union> domain(name2(y)) \<and> (name2(x) = name1(y) \<or> name2(x) = name2(y))))
   \<or> (ftype(x) = 0 \<and> ftype(y) =  1 \<and> name1(x) = name1(y) \<and> name2(x) \<in> domain(name2(y)))"
  unfolding frecR_def ..

lemma frecR_D1 :
  "frecR(x,y) \<Longrightarrow> ftype(y) = 0 \<Longrightarrow> ftype(x) = 1 \<and>
      (name1(x) \<in> domain(name1(y)) \<union> domain(name2(y)) \<and> (name2(x) = name1(y) \<or> name2(x) = name2(y)))"
  using frecR_iff
  by auto

lemma frecR_D2 :
  "frecR(x,y) \<Longrightarrow> ftype(y) = 1 \<Longrightarrow> ftype(x) = 0 \<and>
      ftype(x) = 0 \<and> ftype(y) =  1 \<and> name1(x) = name1(y) \<and> name2(x) \<in> domain(name2(y))"
  using frecR_iff
  by auto

lemma frecR_DI :
  assumes "frecR(\<langle>a,b,c,d\<rangle>,\<langle>ftype(y),name1(y),name2(y),cond_of(y)\<rangle>)"
  shows "frecR(\<langle>a,b,c,d\<rangle>,y)"
  using assms unfolding frecR_def by (force simp add:components_simp)

(*
name1(x) \<in> domain(name1(y)) \<union> domain(name2(y)) \<and>
            (name2(x) = name1(y) \<or> name2(x) = name2(y))
          \<or> name1(x) = name1(y) \<and> name2(x) \<in> domain(name2(y))*)
definition
  is_frecR :: "[i\<Rightarrow>o,i,i] \<Rightarrow> o" where
  "is_frecR(M,x,y) \<equiv> \<exists> ftx[M]. \<exists> n1x[M]. \<exists>n2x[M]. \<exists>fty[M]. \<exists>n1y[M]. \<exists>n2y[M]. \<exists>dn1[M]. \<exists>dn2[M].
  is_ftype(M,x,ftx) \<and> is_name1(M,x,n1x)\<and> is_name2(M,x,n2x) \<and>
  is_ftype(M,y,fty) \<and> is_name1(M,y,n1y) \<and> is_name2(M,y,n2y)
          \<and> is_domain(M,n1y,dn1) \<and> is_domain(M,n2y,dn2) \<and>
          (  (number1(M,ftx) \<and> empty(M,fty) \<and> (n1x \<in> dn1 \<or> n1x \<in> dn2) \<and> (n2x = n1y \<or> n2x = n2y))
           \<or> (empty(M,ftx) \<and> number1(M,fty) \<and> n1x = n1y \<and> n2x \<in> dn2))"

schematic_goal sats_frecR_fm_auto:
  assumes
    "i\<in>nat" "j\<in>nat" "env\<in>list(A)" "nth(i,env) = a" "nth(j,env) = b"
  shows
    "is_frecR(##A,a,b) \<longleftrightarrow> sats(A,?fr_fm(i,j),env)"
  unfolding  is_frecR_def is_Collect_def
  by (insert assms ; (rule sep_rules' cartprod_iff_sats  components_iff_sats
        | simp del:sats_cartprod_fm)+)

synthesize "frecR_fm" from_schematic sats_frecR_fm_auto

(* Third item of Kunen observations about the trcl relation in p. 257. *)
lemma eq_ftypep_not_frecrR:
  assumes "ftype(x) = ftype(y)"
  shows "\<not> frecR(x,y)"
  using assms frecR_ftypeD by force

definition
  rank_names :: "i \<Rightarrow> i" where
  "rank_names(x) \<equiv> max(rank(name1(x)),rank(name2(x)))"

lemma rank_names_types [TC]:
  shows "Ord(rank_names(x))"
  unfolding rank_names_def max_def using Ord_rank Ord_Un by auto

definition
  mtype_form :: "i \<Rightarrow> i" where
  "mtype_form(x) \<equiv> if rank(name1(x)) < rank(name2(x)) then 0 else 2"

definition
  type_form :: "i \<Rightarrow> i" where
  "type_form(x) \<equiv> if ftype(x) = 0 then 1 else mtype_form(x)"

lemma type_form_tc [TC]:
  shows "type_form(x) \<in> 3"
  unfolding type_form_def mtype_form_def by auto

lemma frecR_le_rnk_names :
  assumes  "frecR(x,y)"
  shows "rank_names(x)\<le>rank_names(y)"
proof -
  obtain a b c d  where
    H: "a = name1(x)" "b = name2(x)"
    "c = name1(y)" "d = name2(y)"
    "(a \<in> domain(c)\<union>domain(d) \<and> (b=c \<or> b = d)) \<or> (a = c \<and> b \<in> domain(d))"
    using assms unfolding frecR_def by force
  then
  consider
    (m) "a \<in> domain(c) \<and> (b = c \<or> b = d) "
    | (n) "a \<in> domain(d) \<and> (b = c \<or> b = d)"
    | (o) "b \<in> domain(d) \<and> a = c"
    by auto
  then show ?thesis proof(cases)
    case m
    then
    have "rank(a) < rank(c)"
      using eclose_rank_lt  in_dom_in_eclose  by simp
    with \<open>rank(a) < rank(c)\<close> H m
    show ?thesis unfolding rank_names_def using Ord_rank max_cong max_cong2 leI by auto
  next
    case n
    then
    have "rank(a) < rank(d)"
      using eclose_rank_lt in_dom_in_eclose  by simp
    with \<open>rank(a) < rank(d)\<close> H n
    show ?thesis unfolding rank_names_def
      using Ord_rank max_cong2 max_cong max_commutes[of "rank(c)" "rank(d)"] leI by auto
  next
    case o
    then
    have "rank(b) < rank(d)" (is "?b < ?d") "rank(a) = rank(c)" (is "?a = _")
      using eclose_rank_lt in_dom_in_eclose  by simp_all
    with H
    show ?thesis unfolding rank_names_def
      using Ord_rank max_commutes max_cong2[OF leI[OF \<open>?b < ?d\<close>], of ?a] by simp
  qed
qed

definition
  \<Gamma> :: "i \<Rightarrow> i" where
  "\<Gamma>(x) = 3 ** rank_names(x) ++ type_form(x)"

lemma \<Gamma>_type [TC]:
  shows "Ord(\<Gamma>(x))"
  unfolding \<Gamma>_def by simp

lemma \<Gamma>_mono :
  assumes "frecR(x,y)"
  shows "\<Gamma>(x) < \<Gamma>(y)"
proof -
  have F: "type_form(x) < 3" "type_form(y) < 3"
    using ltI by simp_all
  from assms
  have A: "rank_names(x) \<le> rank_names(y)" (is "?x \<le> ?y")
    using frecR_le_rnk_names by simp
  then
  have "Ord(?y)" unfolding rank_names_def using Ord_rank max_def by simp
  note leE[OF \<open>?x\<le>?y\<close>]
  then
  show ?thesis
  proof(cases)
    case 1
    then
    show ?thesis unfolding \<Gamma>_def using oadd_lt_mono2 \<open>?x < ?y\<close> F by auto
  next
    case 2
    consider (a) "ftype(x) = 0 \<and> ftype(y) = 1" | (b) "ftype(x) = 1 \<and> ftype(y) = 0"
      using  frecR_ftypeD[OF \<open>frecR(x,y)\<close>] by auto
    then show ?thesis proof(cases)
      case b
      then
      have "type_form(y) = 1"
        using type_form_def by simp
      from b
      have H: "name2(x) = name1(y) \<or> name2(x) = name2(y) " (is "?\<tau> = ?\<sigma>' \<or> ?\<tau> = ?\<tau>'")
        "name1(x) \<in> domain(name1(y)) \<union> domain(name2(y))"
        (is "?\<sigma> \<in> domain(?\<sigma>') \<union> domain(?\<tau>')")
        using assms unfolding type_form_def frecR_def by auto
      then
      have E: "rank(?\<tau>) = rank(?\<sigma>') \<or> rank(?\<tau>) = rank(?\<tau>')" by auto
      from H
      consider (a) "rank(?\<sigma>) < rank(?\<sigma>')" |  (b) "rank(?\<sigma>) < rank(?\<tau>')"
        using eclose_rank_lt in_dom_in_eclose by force
      then
      have "rank(?\<sigma>) < rank(?\<tau>)" proof (cases)
        case a
        with \<open>rank_names(x) = rank_names(y) \<close>
        show ?thesis unfolding rank_names_def mtype_form_def type_form_def using max_D2[OF E a]
            E assms Ord_rank by simp
      next
        case b
        with \<open>rank_names(x) = rank_names(y) \<close>
        show ?thesis unfolding rank_names_def mtype_form_def type_form_def
          using max_D2[OF _ b] max_commutes E assms Ord_rank disj_commute by auto
      qed
      with b
      have "type_form(x) = 0" unfolding type_form_def mtype_form_def by simp
      with \<open>rank_names(x) = rank_names(y) \<close> \<open>type_form(y) = 1\<close> \<open>type_form(x) = 0\<close>
      show ?thesis
        unfolding \<Gamma>_def by auto
    next
      case a
      then
      have "name1(x) = name1(y)" (is "?\<sigma> = ?\<sigma>'")
        "name2(x) \<in> domain(name2(y))" (is "?\<tau> \<in> domain(?\<tau>')")
        "type_form(x) = 1"
        using assms unfolding type_form_def frecR_def by auto
      then
      have "rank(?\<sigma>) = rank(?\<sigma>')" "rank(?\<tau>) < rank(?\<tau>')"
        using  eclose_rank_lt in_dom_in_eclose by simp_all
      with \<open>rank_names(x) = rank_names(y) \<close>
      have "rank(?\<tau>') \<le> rank(?\<sigma>')"
        unfolding rank_names_def using Ord_rank max_D1 by simp
      with a
      have "type_form(y) = 2"
        unfolding type_form_def mtype_form_def using not_lt_iff_le assms by simp
      with \<open>rank_names(x) = rank_names(y) \<close> \<open>type_form(y) = 2\<close> \<open>type_form(x) = 1\<close>
      show ?thesis
        unfolding \<Gamma>_def by auto
    qed
  qed
qed

definition
  frecrel :: "i \<Rightarrow> i" where
  "frecrel(A) \<equiv> Rrel(frecR,A)"

lemma frecrelI :
  assumes "x \<in> A" "y\<in>A" "frecR(x,y)"
  shows "\<langle>x,y\<rangle>\<in>frecrel(A)"
  using assms unfolding frecrel_def Rrel_def by auto

lemma frecrelD :
  assumes "\<langle>x,y\<rangle> \<in> frecrel(A1\<times>A2\<times>A3\<times>A4)"
  shows "ftype(x) \<in> A1" "ftype(x) \<in> A1"
    "name1(x) \<in> A2" "name1(y) \<in> A2" "name2(x) \<in> A3" "name2(x) \<in> A3"
    "cond_of(x) \<in> A4" "cond_of(y) \<in> A4"
    "frecR(x,y)"
  using assms unfolding frecrel_def Rrel_def ftype_def by (auto simp add:components_simp)

lemma wf_frecrel :
  shows "wf(frecrel(A))"
proof -
  have "frecrel(A) \<subseteq> measure(A,\<Gamma>)"
    unfolding frecrel_def Rrel_def measure_def
    using \<Gamma>_mono by force
  then show ?thesis using wf_subset wf_measure by auto
qed

lemma core_induction_aux:
  fixes A1 A2 :: "i"
  assumes
    "Transset(A1)"
    "\<And>\<tau> \<theta> p.  p \<in> A2 \<Longrightarrow> \<lbrakk>\<And>q \<sigma>. \<lbrakk> q\<in>A2 ; \<sigma>\<in>domain(\<theta>)\<rbrakk> \<Longrightarrow> Q(0,\<tau>,\<sigma>,q)\<rbrakk> \<Longrightarrow> Q(1,\<tau>,\<theta>,p)"
    "\<And>\<tau> \<theta> p.  p \<in> A2 \<Longrightarrow> \<lbrakk>\<And>q \<sigma>. \<lbrakk> q\<in>A2 ; \<sigma>\<in>domain(\<tau>) \<union> domain(\<theta>)\<rbrakk> \<Longrightarrow> Q(1,\<sigma>,\<tau>,q) \<and> Q(1,\<sigma>,\<theta>,q)\<rbrakk> \<Longrightarrow> Q(0,\<tau>,\<theta>,p)"
  shows "a\<in>2\<times>A1\<times>A1\<times>A2 \<Longrightarrow> Q(ftype(a),name1(a),name2(a),cond_of(a))"
proof (induct a rule:wf_induct[OF wf_frecrel[of "2\<times>A1\<times>A1\<times>A2"]])
  case (1 x)
  let ?\<tau> = "name1(x)"
  let ?\<theta> = "name2(x)"
  let ?D = "2\<times>A1\<times>A1\<times>A2"
  assume "x \<in> ?D"
  then
  have "cond_of(x)\<in>A2"
    by (auto simp add:components_simp)
  from \<open>x\<in>?D\<close>
  consider (eq) "ftype(x)=0" | (mem) "ftype(x)=1"
    by (auto simp add:components_simp)
  then
  show ?case
  proof cases
    case eq
    then
    have "Q(1, \<sigma>, ?\<tau>, q) \<and> Q(1, \<sigma>, ?\<theta>, q)" if "\<sigma> \<in> domain(?\<tau>) \<union> domain(?\<theta>)" and "q\<in>A2" for q \<sigma>
    proof -
      from 1
      have A: "?\<tau>\<in>A1" "?\<theta>\<in>A1" "?\<tau>\<in>eclose(A1)" "?\<theta>\<in>eclose(A1)"
        using  arg_into_eclose by (auto simp add:components_simp)
      with  \<open>Transset(A1)\<close> that(1)
      have "\<sigma>\<in>eclose(?\<tau>) \<union> eclose(?\<theta>)"
        using in_dom_in_eclose  by auto
      then
      have "\<sigma>\<in>A1"
        using mem_eclose_subset[OF \<open>?\<tau>\<in>A1\<close>] mem_eclose_subset[OF \<open>?\<theta>\<in>A1\<close>]
          Transset_eclose_eq_arg[OF \<open>Transset(A1)\<close>]
        by auto
      with \<open>q\<in>A2\<close> \<open>?\<theta> \<in> A1\<close> \<open>cond_of(x)\<in>A2\<close> \<open>?\<tau>\<in>A1\<close>
      have "frecR(\<langle>1, \<sigma>, ?\<tau>, q\<rangle>, x)" (is "frecR(?T,_)")
        "frecR(\<langle>1, \<sigma>, ?\<theta>, q\<rangle>, x)" (is "frecR(?U,_)")
        using  frecRI1'[OF that(1)] frecR_DI  \<open>ftype(x) = 0\<close>
          frecRI2'[OF that(1)]
        by (auto simp add:components_simp)
      with \<open>x\<in>?D\<close> \<open>\<sigma>\<in>A1\<close> \<open>q\<in>A2\<close>
      have "\<langle>?T,x\<rangle>\<in> frecrel(?D)" "\<langle>?U,x\<rangle>\<in> frecrel(?D)"
        using frecrelI[of ?T ?D x]  frecrelI[of ?U ?D x] by (auto simp add:components_simp)
      with \<open>q\<in>A2\<close> \<open>\<sigma>\<in>A1\<close> \<open>?\<tau>\<in>A1\<close> \<open>?\<theta>\<in>A1\<close>
      have "Q(1, \<sigma>, ?\<tau>, q)" using 1 by (force simp add:components_simp)
      moreover from \<open>q\<in>A2\<close> \<open>\<sigma>\<in>A1\<close> \<open>?\<tau>\<in>A1\<close> \<open>?\<theta>\<in>A1\<close> \<open>\<langle>?U,x\<rangle>\<in> frecrel(?D)\<close>
      have "Q(1, \<sigma>, ?\<theta>, q)" using 1 by (force simp add:components_simp)
      ultimately
      show ?thesis using A by simp
    qed
    then show ?thesis using assms(3) \<open>ftype(x) = 0\<close> \<open>cond_of(x)\<in>A2\<close> by auto
  next
    case mem
    have "Q(0, ?\<tau>,  \<sigma>, q)" if "\<sigma> \<in> domain(?\<theta>)" and "q\<in>A2" for q \<sigma>
    proof -
      from 1 assms
      have "?\<tau>\<in>A1" "?\<theta>\<in>A1" "cond_of(x)\<in>A2" "?\<tau>\<in>eclose(A1)" "?\<theta>\<in>eclose(A1)"
        using  arg_into_eclose by (auto simp add:components_simp)
      with  \<open>Transset(A1)\<close> that(1)
      have "\<sigma>\<in> eclose(?\<theta>)"
        using in_dom_in_eclose  by auto
      then
      have "\<sigma>\<in>A1"
        using mem_eclose_subset[OF \<open>?\<theta>\<in>A1\<close>] Transset_eclose_eq_arg[OF \<open>Transset(A1)\<close>]
        by auto
      with \<open>q\<in>A2\<close> \<open>?\<theta> \<in> A1\<close> \<open>cond_of(x)\<in>A2\<close> \<open>?\<tau>\<in>A1\<close>
      have "frecR(\<langle>0, ?\<tau>, \<sigma>, q\<rangle>, x)" (is "frecR(?T,_)")
        using  frecRI3'[OF that(1)] frecR_DI  \<open>ftype(x) = 1\<close>
        by (auto simp add:components_simp)
      with \<open>x\<in>?D\<close> \<open>\<sigma>\<in>A1\<close> \<open>q\<in>A2\<close> \<open>?\<tau>\<in>A1\<close>
      have "\<langle>?T,x\<rangle>\<in> frecrel(?D)" "?T\<in>?D"
        using frecrelI[of ?T ?D x] by (auto simp add:components_simp)
      with \<open>q\<in>A2\<close> \<open>\<sigma>\<in>A1\<close> \<open>?\<tau>\<in>A1\<close> \<open>?\<theta>\<in>A1\<close> 1
      show ?thesis by (force simp add:components_simp)
    qed
    then show ?thesis using assms(2) \<open>ftype(x) = 1\<close> \<open>cond_of(x)\<in>A2\<close>  by auto
  qed
qed

lemma def_frecrel : "frecrel(A) = {z\<in>A\<times>A. \<exists>x y. z = \<langle>x, y\<rangle> \<and> frecR(x,y)}"
  unfolding frecrel_def Rrel_def ..

lemma frecrel_fst_snd:
  "frecrel(A) = {z \<in> A\<times>A .
            ftype(fst(z)) = 1 \<and>
        ftype(snd(z)) = 0 \<and> name1(fst(z)) \<in> domain(name1(snd(z))) \<union> domain(name2(snd(z))) \<and>
            (name2(fst(z)) = name1(snd(z)) \<or> name2(fst(z)) = name2(snd(z)))
          \<or> (ftype(fst(z)) = 0 \<and>
        ftype(snd(z)) = 1 \<and>  name1(fst(z)) = name1(snd(z)) \<and> name2(fst(z)) \<in> domain(name2(snd(z))))}"
  unfolding def_frecrel frecR_def
  by (intro equalityI subsetI CollectI; elim CollectE; auto)

end


theory PSC
  imports Main
begin

type_synonym ('a,'b) m = "'a \<Rightarrow> 'b"

section \<open>List Utilities\<close>

lemma post_preE:
  assumes "A @ [e] = s # B"
  obtains (empty) "A = []" "B = []" "e = s" |
          (mid) l where "A = s # l" "B = l @ [e]"
  using assms by (cases A) auto

lemma pre_postE:
  assumes "s # B = A @ [e]"
  obtains (empty) "A = []" "B = []" "e = s" |
          (mid) l where "A = s # l" "B = l @ [e]"
  using assms by (cases A) auto

subsection \<open>lastf\<close>

fun lastf
  where
    "lastf f [] = None" |
    "lastf f (e#l) = (case lastf f l of Some v \<Rightarrow> Some v | None \<Rightarrow> (if f e then Some e else None))"

lemma lastf_none [simp]:
  assumes "\<forall>x \<in> set l. \<not> f x"
  shows "lastf f l = None"
  using assms by (induct l) (auto)

lemma lastf_append [simp]:
  assumes "f a"
  shows "lastf f (p @ [a]) = Some a"
  using assms by (induct p) (auto)

lemma lastf_concat [simp]:
  "lastf f (p@l) = (case lastf f l of Some v \<Rightarrow> Some v  | None \<Rightarrow> lastf f p)"
  by (induct p) (auto split: option.splits)

lemma lastf_some [intro]:
  "lastf f l = Some a \<Longrightarrow> f a"
  by (induct l) (auto split: option.splits if_splits)

section \<open>Events\<close>

datatype ('a,'b) event =
  W "'a" "'b" |
  R "'a" "'b" |
  MF |
  FL "'a" |
  FO "'a" |
  RMW "'a" "'b" "'b" |
  RMF "'a" "'b"

section \<open>Persistent Buffer Events\<close>

datatype ('t,'b) pevent =
  PFO "'t" |
  PW "'b"

fun isPW :: "('t,'b) pevent \<Rightarrow> bool"
  where
    "isPW (PW _) = True" |
    "isPW _ = False"

fun isPFO :: "('t,'b) pevent \<Rightarrow> bool"
  where
    "isPFO (PFO _) = True" |
    "isPFO _ = False"

section \<open>State\<close>

record ('a,'t,'b) state =
  persistent :: "('a,'b) m"
  buffers :: "'a \<Rightarrow> ('t,'b) pevent list"

definition get :: "('a,'t,'b) state \<Rightarrow> 'a \<Rightarrow> 'b"
  where "get m a \<equiv> (case lastf isPW (buffers m a) of Some (PW v) \<Rightarrow> v | _ \<Rightarrow> persistent m a)"

abbreviation persistent_set :: "('a,'t,'b) state \<Rightarrow> 'a \<Rightarrow> 'b \<Rightarrow> ('a,'t,'b) state"
  ("_\<lbrakk>_ \<^sub>p= _\<rbrakk>" [900,0,0] 900)
  where "persistent_set m x v \<equiv> persistent_update (\<lambda>b. b(x := v)) m"

abbreviation buffer_set :: "('a,'t,'b) state \<Rightarrow> 'a \<Rightarrow> ('t,'b) pevent list \<Rightarrow> ('a,'t,'b) state"
  ("_\<lbrakk>_ \<^sub>b= _\<rbrakk>" [900,0,0] 900)
  where "buffer_set m x p \<equiv> buffers_update (\<lambda>b. b(x := p)) m"

abbreviation buffer_app :: "('a,'t,'b) state \<Rightarrow> 'a \<Rightarrow> ('t,'b) pevent \<Rightarrow> ('a,'t,'b) state"
  ("_\<lbrakk>_ \<^sub>@= _\<rbrakk>" [900,0,0] 900)
  where "buffer_app m x e \<equiv> m\<lbrakk>x \<^sub>b= (buffers m x)@[e] \<rbrakk>"

lemma get_no_pw[simp]:
  assumes "\<forall>e \<in> set (buffers m x). \<not> isPW e"
  shows "get m x = persistent m x"
  using assms by (auto simp: get_def fun_eq_iff split: option.splits pevent.splits)

lemma get_no_pw'[simp]:
  assumes "\<forall>e \<in> set (buffers m x). \<not> isPW e"
  shows "get (m\<lbrakk>x \<^sub>p= v\<rbrakk>) = (get m)(x := v)"
  using assms by (auto simp: get_def fun_eq_iff split: option.splits pevent.splits)

lemma get_simps [simp]:
  "x \<noteq> y \<Longrightarrow> get (m\<lbrakk>y \<^sub>b= p\<rbrakk>) x = get m x"
  "x \<noteq> y \<Longrightarrow> get (m\<lbrakk>y \<^sub>p= a\<rbrakk>) x = get m x"

  "get (m\<lbrakk>x \<^sub>@= PW v\<rbrakk>) = (get m)(x := v)"
  "get (m\<lbrakk>x \<^sub>@= PFO t\<rbrakk>) = get m"

  "(get (m\<lbrakk>x \<^sub>p= v\<rbrakk>))(x := v) = (get m)(x := v)"
  "get (m\<lbrakk>x \<^sub>b= []\<rbrakk>) = (get m)(x := persistent m x)"
  by (auto simp: get_def fun_eq_iff split: option.splits pevent.splits)

lemma [simp]:
  "(\<lambda>b. b(y := c)) \<circ> (\<lambda>b. b(x := g b)) = (\<lambda>b. b(x := g b, y := c))"
  by auto

lemma redundant_buffer_set [simp]:
  assumes "buffers m y = p"
  shows "m\<lbrakk>y \<^sub>b= p\<rbrakk> = m"
  using assms by auto

lemma pers_buf_twist:
  "buffers_update g (persistent_update f m) = persistent_update f (buffers_update g m)"
  by (metis surjective update_convs(1,2))

subsection \<open>remainder\<close>

fun rem :: "'t \<Rightarrow> ('t,'b) pevent list \<Rightarrow> ('t,'b) pevent list"
  where
    "rem t [] = []" |
    "rem t (a#xs) = (if PFO t \<in> set xs then rem t xs else if a = PFO t then xs else a#xs)"

lemma [simp]:
  "PFO s \<notin> set (rem s l)"
  by (induct l) auto

section \<open>Semantics\<close>

inductive step :: "('a,'t,'b) state \<Rightarrow> 't \<Rightarrow> ('a,'b) event \<Rightarrow> ('a,'t,'b) state \<Rightarrow> bool"
  ("\<langle>_\<rangle> -_,_\<rightarrow> \<langle>_\<rangle>")
  where
  wr: "\<langle>m\<rangle> -t,W x v\<rightarrow> \<langle>m\<lbrakk>x \<^sub>@= PW v\<rbrakk>\<rangle>" |
  rd: "get m x = v \<Longrightarrow> \<langle>m\<rangle> -t,R x v\<rightarrow> \<langle>m\<rangle>" |
  mf: "\<forall>y. PFO t \<notin> set (buffers m y) \<Longrightarrow> \<langle>m\<rangle> -t,MF\<rightarrow> \<langle>m\<rangle>" |
  fl: "buffers m x = [] \<Longrightarrow> \<langle>m\<rangle> -t,FL x\<rightarrow> \<langle>m\<rangle>" |
  fo: "\<langle>m\<rangle> -t,FO x\<rightarrow> \<langle>m\<lbrakk>x \<^sub>@= PFO t\<rbrakk>\<rangle>" |
  rmw: "get m x = v\<^sub>R \<Longrightarrow> \<forall>y. PFO t \<notin> set (buffers m y) \<Longrightarrow> \<langle>m\<rangle> -t,RMW x v\<^sub>R v\<^sub>W\<rightarrow> \<langle>m\<lbrakk>x \<^sub>@= PW v\<^sub>W\<rbrakk>\<rangle>" |
  rmf: "get m x = v\<^sub>R \<Longrightarrow> \<forall>y. PFO t \<notin> set (buffers m y) \<Longrightarrow> \<langle>m\<rangle> -t,RMF x v\<^sub>R\<rightarrow> \<langle>m\<rangle>"

definition eval :: "'t \<times> ('a,'b) event \<Rightarrow> ('a,'t,'b) state rel"
  where "eval a = {(m,m'). \<langle>m\<rangle> -fst a,snd a\<rightarrow> \<langle>m'\<rangle>}"

lemma step_det:
  assumes "\<langle>m\<rangle> -t,\<alpha>\<rightarrow> \<langle>m'\<rangle>"
  assumes "\<langle>m\<rangle> -t,\<alpha>\<rightarrow> \<langle>m''\<rangle>"
  shows "m' = m''"
  using assms by (induct) (auto elim: step.cases)

lemma eval_det:
  assumes "(m,m') \<in> eval \<alpha>"
  assumes "(m,m'') \<in> eval \<alpha>"
  shows "m' = m''"
  using assms by (auto simp: eval_def intro: step_det)

section \<open>Persistent Environment Steps\<close>

inductive env :: "('a,'t,'b) state \<Rightarrow> ('a,'t,'b) state \<Rightarrow> bool"
  ("\<langle>_\<rangle> -e\<rightarrow> \<langle>_\<rangle>")
  where
  pwr: "buffers m x = (PW v)#p \<Longrightarrow> \<langle>m\<rangle> -e\<rightarrow> \<langle>m\<lbrakk>x \<^sub>p= v\<rbrakk>\<lbrakk>x \<^sub>b= p\<rbrakk>\<rangle>" |
  pfo: "buffers m x = (PFO t)#p \<Longrightarrow> \<langle>m\<rangle> -e\<rightarrow> \<langle>m\<lbrakk>x \<^sub>b= p\<rbrakk>\<rangle>"

lemma pwrI [intro]:
  assumes "buffers m x = (PW v)#p"
  assumes "m' = m\<lbrakk>x \<^sub>p= v\<rbrakk>\<lbrakk>x \<^sub>b= p\<rbrakk>"
  shows "\<langle>m\<rangle> -e\<rightarrow> \<langle>m'\<rangle>"
  using env.intros(1) assms by metis

lemma pfoI [intro]:
  assumes "buffers m x = (PFO t)#p"
  assumes "m' = m\<lbrakk>x \<^sub>b= p\<rbrakk>"
  shows "\<langle>m\<rangle> -e\<rightarrow> \<langle>m'\<rangle>"
  using env.intros(2) assms by metis

inductive trace :: "('a,'t,'b) state \<Rightarrow> ('t \<times> ('a,'b) event) list \<Rightarrow> ('a,'t,'b) state \<Rightarrow> bool"
  where
  nil:  "trace a [] a" |
  step: "\<langle>m\<rangle> -thr,a\<rightarrow> \<langle>m'\<rangle> \<Longrightarrow> trace m' t m'' \<Longrightarrow> trace m ((thr,a)#t) m''" |
  env:  "\<langle>m\<rangle> -e\<rightarrow> \<langle>m'\<rangle> \<Longrightarrow> trace m' t m'' \<Longrightarrow> trace m t m''"

subsection \<open>Persistent Properties\<close>

lemma env_get [simp]:
  assumes "env m m'"
  shows "get m x = get m' x"
  using assms by cases (auto simp: get_def split: option.splits pevent.splits)

lemma envt_get [simp]:
  assumes "env\<^sup>*\<^sup>* m m'"
  shows "get m x = get m' x"
  using assms
proof (induct)
  case base
  then show ?case by auto
next
  case (step y z)
  then show ?case using env_get by metis
qed

lemma env_pers_setE:
  assumes "env (m\<^sub>1\<lbrakk>x \<^sub>p= v\<rbrakk>) m\<^sub>2"
  obtains (orth) m\<^sub>3 where "env m\<^sub>1 m\<^sub>3" "m\<^sub>2 = m\<^sub>3\<lbrakk>x \<^sub>p= v\<rbrakk>" |
          (wr) v' l where "m\<^sub>2 = m\<^sub>1\<lbrakk>x \<^sub>p= v'\<rbrakk>\<lbrakk>x \<^sub>b= l\<rbrakk>" "buffers m\<^sub>1 x = (PW v')#l"
  using assms
proof cases
  case (pwr y v' p)
  have e: "\<langle>m\<^sub>1\<rangle> -e\<rightarrow> \<langle>m\<^sub>1\<lbrakk>y \<^sub>p= v'\<rbrakk>\<lbrakk>y \<^sub>b= p\<rbrakk>\<rangle>" using pwr by (auto intro: env.pwr)
  then show ?thesis
  proof (cases "x = y")
    case True
    then show ?thesis using pwr wr by auto
  next
    case False
    then show ?thesis using pwr orth[OF e] by (simp add: fun_upd_twist)
  qed
next
  case (pfo y t p)
  then show ?thesis using orth[of "m\<^sub>1\<lbrakk>y \<^sub>b= p\<rbrakk>"] by (auto intro: env.pfo)
qed

subsection \<open>Buffer Properties\<close>

lemma env_buffers:
  assumes "env m m'"
  obtains pre where "buffers m x = pre @ buffers m' x"
  using assms
proof cases
  case (pwr y v p)
  then show ?thesis using that by (cases "x = y") auto
next
  case (pfo y t p)
  then show ?thesis using that by (cases "x = y") auto
qed

lemma env_buffer_empty:
  assumes "env m m'"
  assumes "buffers m x = []"
  shows "buffers m' x = []"
  using assms env_buffers
  by (metis Nil_is_append_conv)

lemma envt_buffers:
  assumes "env\<^sup>*\<^sup>* m m'"
  obtains pre where "buffers m x = pre @ buffers m' x"
  using assms
proof (induct)
  case base
  then show ?case by auto
next
  case (step y z)
  then show ?case using env_buffers by (metis append.assoc)
qed

lemma envt_buffer_empty:
  assumes "env\<^sup>*\<^sup>* m m'"
  assumes "buffers m x = []"
  shows "buffers m' x = []"
  using assms by (auto elim!: envt_buffers[where x = x])

lemma envt_buffer_subset:
  assumes "env\<^sup>*\<^sup>* m m'"
  shows "set (buffers m' x) \<subseteq> set (buffers m x)"
  using assms by (auto elim!: envt_buffers[where x = x])

subsubsection \<open>Introduction\<close>

lemma env_buffer_appI:
  assumes "env m m'"
  shows "env (m\<lbrakk>x \<^sub>@= b\<rbrakk>) (m'\<lbrakk>x \<^sub>@= b\<rbrakk>)"
  using assms
proof cases
  case (pwr y v p)
  thus ?thesis by (cases "x = y") (auto intro!: pwrI[where x=y] simp add: fun_upd_twist)
next
  case (pfo y t p)
  thus ?thesis by (cases "x = y") (auto intro!: pfoI[where x=y] simp add: fun_upd_twist)
qed

lemma envt_buffer_appI:
  assumes "env\<^sup>*\<^sup>* m m'"
  shows "env\<^sup>*\<^sup>* (m\<lbrakk>x \<^sub>@= b\<rbrakk>) (m'\<lbrakk>x \<^sub>@= b\<rbrakk>)"
  using assms
proof induct
  case base
  thus ?case by auto
next
  case (step y z)
  thus ?case by (blast intro: env_buffer_appI rtranclp.rtrancl_into_rtrancl)
qed

lemma envt_full_evalI:
  shows "env\<^sup>*\<^sup>* (m\<lbrakk>x \<^sub>@= PW v\<rbrakk>) (m\<lbrakk>x \<^sub>p= v\<rbrakk>\<lbrakk>x \<^sub>b= []\<rbrakk>)"
proof (induct "buffers m x" arbitrary: m)
  case Nil
  hence "env (m\<lbrakk>x \<^sub>@= PW v\<rbrakk>) (m\<lbrakk>x \<^sub>p= v\<rbrakk>\<lbrakk>x \<^sub>b= []\<rbrakk>)" by auto
  then show ?case by blast
next
  case (Cons pe p)
  then show ?case
  proof (cases pe)
    case (PFO t)
    hence "env (m\<lbrakk>x \<^sub>@= PW v\<rbrakk>) (m\<lbrakk>x \<^sub>b= p @ [PW v]\<rbrakk>)" using Cons(2) by (intro pfoI[where t=t]) auto
    then show ?thesis using Cons(1)[of "m\<lbrakk>x \<^sub>b= p\<rbrakk>"] by auto
  next
    case (PW v')
    hence "env (m\<lbrakk>x \<^sub>@= PW v\<rbrakk>) (m\<lbrakk>x \<^sub>p= v'\<rbrakk>\<lbrakk>x \<^sub>b= p @ [PW v]\<rbrakk>)" using Cons(2) by (intro pwrI) auto
    then show ?thesis using Cons(1)[of "m\<lbrakk>x \<^sub>p= v'\<rbrakk>\<lbrakk>x \<^sub>b= p\<rbrakk>"] by auto
  qed
qed

lemma envt_buffer_app_evalI:
  assumes "env\<^sup>*\<^sup>* m m'"
  shows "env\<^sup>*\<^sup>* (m\<lbrakk>x \<^sub>@= PW v\<rbrakk>) (m'\<lbrakk>x \<^sub>p= v\<rbrakk>\<lbrakk>x \<^sub>b= []\<rbrakk>)"
  using envt_buffer_appI[OF assms] envt_full_evalI by (metis (mono_tags) rtranclp_trans)

subsubsection \<open>Elimination\<close>

lemma env_buffer_appE:
  assumes "env (m\<^sub>1\<lbrakk>x \<^sub>@= e\<rbrakk>) m\<^sub>2"
  obtains (orth) m\<^sub>3 where "env m\<^sub>1 m\<^sub>3" "m\<^sub>2 = m\<^sub>3\<lbrakk>x \<^sub>@= e\<rbrakk>" |
          (wr) v where "e = PW v" "m\<^sub>2 = m\<^sub>1\<lbrakk>x \<^sub>p= v\<rbrakk>" "buffers m\<^sub>1 x = []" |
          (fo) v where "e = PFO v" "m\<^sub>2 = m\<^sub>1" "buffers m\<^sub>1 x = []"
  using assms
proof cases
  case (pwr y v p)
  then show ?thesis
  proof (cases "x = y")
    case True
    hence "buffers m\<^sub>1 y @ [e] = PW v # p" using pwr by auto
    then show ?thesis
    proof (cases rule: post_preE)
      case empty
      then show ?thesis using wr pwr True by auto
    next
      case (mid l)
      then show ?thesis using orth[of "m\<^sub>1\<lbrakk>y \<^sub>p= v\<rbrakk>\<lbrakk>y \<^sub>b= l\<rbrakk>"] pwr True by auto
    qed
  next
    case False
    then show ?thesis using pwr
      by (intro orth[of "m\<^sub>1\<lbrakk>y \<^sub>p= v\<rbrakk>\<lbrakk>y \<^sub>b= p\<rbrakk>"] pwrI) (auto simp: fun_upd_twist)
  qed
next
  case (pfo y t p)
  then show ?thesis
  proof (cases "x = y")
    case True
    hence "buffers m\<^sub>1 y @ [e] = PFO t # p" using pfo by auto
    then show ?thesis
    proof (cases rule: post_preE)
      case empty
      then show ?thesis using fo pfo True by auto
    next
      case (mid l)
      then show ?thesis using orth[of "m\<^sub>1\<lbrakk>y \<^sub>b= l\<rbrakk>"] pfo True by auto
    qed
  next
    case False
    then show ?thesis using pfo
      by (intro orth[of "m\<^sub>1\<lbrakk>y \<^sub>b= p\<rbrakk>"] pfoI) (auto simp: fun_upd_twist)
  qed
qed

lemma envt_buffer_appE:
  assumes "env\<^sup>*\<^sup>* (m\<^sub>1\<lbrakk>x \<^sub>@= e\<rbrakk>) m\<^sub>2"
  obtains (orth) m\<^sub>3 where "env\<^sup>*\<^sup>* m\<^sub>1 m\<^sub>3" "m\<^sub>2 = m\<^sub>3\<lbrakk>x \<^sub>@= e\<rbrakk>" |
          (pwr) m\<^sub>3 v where "e = PW v" "env\<^sup>*\<^sup>* m\<^sub>1 m\<^sub>3" "m\<^sub>2 = m\<^sub>3\<lbrakk>x \<^sub>p= v\<rbrakk>" "buffers m\<^sub>2 x = []" |
          (pfo) v where "e = PFO v" "env\<^sup>*\<^sup>* m\<^sub>1 m\<^sub>2" "buffers m\<^sub>2 x = []"
  using assms
proof (induct "m\<^sub>1\<lbrakk>x \<^sub>@= e\<rbrakk>" m\<^sub>2)
  case rtrancl_refl
  then show ?case by blast
next
  case (rtrancl_into_rtrancl m\<^sub>3 m\<^sub>4)
  show ?case
  proof (rule rtrancl_into_rtrancl(2), goal_cases)
    case (1 m\<^sub>5)
    hence "env (m\<^sub>5\<lbrakk>x \<^sub>@= e\<rbrakk>) m\<^sub>4" using rtrancl_into_rtrancl(3) by simp
    then show ?case
    proof (cases rule: env_buffer_appE)
      case (orth m\<^sub>3')
      then show ?thesis using rtrancl_into_rtrancl(4) 1(1)
        by (blast intro: rtranclp.rtrancl_into_rtrancl)
    next
      case (wr v)
      then show ?thesis using 1 rtrancl_into_rtrancl(5) by simp
    next
      case (fo v)
      then show ?thesis using 1 rtrancl_into_rtrancl(6) by simp
    qed
  next
    case (2 v m\<^sub>5)
    show ?case using rtrancl_into_rtrancl(3) unfolding 2
    proof (cases rule: env_pers_setE)
      case (orth m\<^sub>6)
      then show ?thesis using 2 rtrancl_into_rtrancl(3,5)
        by (blast intro: env_buffer_empty rtranclp.rtrancl_into_rtrancl)
    next
      case (wr v' l)
      then show ?thesis using 2 by auto
    qed
  next
    case (3 v)
    then show ?case using rtrancl_into_rtrancl(3,6)
      by (metis env_buffer_empty rtranclp.rtrancl_into_rtrancl)
  qed
qed

lemma simple:
  "m\<lbrakk>x \<^sub>b= p\<rbrakk>\<lbrakk>x \<^sub>b= q\<rbrakk>\<lbrakk>x \<^sub>p= f\<rbrakk> = m\<lbrakk>x \<^sub>b= q\<rbrakk>\<lbrakk>x \<^sub>p= f\<rbrakk>"
  by (auto)

lemma simple2:
  "(m\<lbrakk>x \<^sub>p= a\<rbrakk>\<lbrakk>y \<^sub>b= b\<rbrakk>\<lbrakk>x \<^sub>p= c\<rbrakk>) = (m\<lbrakk>y \<^sub>b= b\<rbrakk>\<lbrakk>x \<^sub>p= c\<rbrakk>)"
  by auto

lemma flush_x:
  shows "env\<^sup>*\<^sup>* m (m\<lbrakk>x \<^sub>b= []\<rbrakk>\<lbrakk>x \<^sub>p= get m x\<rbrakk>)"
proof (induct "buffers m x" arbitrary: m)
  case Nil
  hence "m\<lbrakk>x \<^sub>b= []\<rbrakk>\<lbrakk>x \<^sub>p= get m x\<rbrakk> = m" by auto
  then show ?case by (metis rtranclp.rtrancl_refl)
next
  case (Cons a p)
  hence t: "buffers m x = a # p" by auto

  then show ?case
  proof (cases a)
    case (PFO x1)
    hence "env\<^sup>*\<^sup>* (m\<lbrakk>x \<^sub>b= p\<rbrakk>) (m\<lbrakk>x \<^sub>b= p\<rbrakk>\<lbrakk>x \<^sub>b= []\<rbrakk>\<lbrakk>x \<^sub>p= get (m\<lbrakk>x \<^sub>b= p\<rbrakk>) x\<rbrakk>)"
      using Cons
      by (metis (mono_tags, lifting) fun_upd_same select_convs(2) surjective update_convs(1,2))
    moreover have e: "\<langle>m\<rangle> -e\<rightarrow> \<langle>m\<lbrakk>x \<^sub>b= p\<rbrakk>\<rangle>" using PFO env.pfo t by blast
    ultimately show ?thesis  unfolding simple
      by (smt (verit, best) converse_rtranclp_into_rtranclp env_get surjective update_convs(1))

  next
    case (PW v)
    let ?m="m\<lbrakk>x \<^sub>p= v\<rbrakk>\<lbrakk>x \<^sub>b= p\<rbrakk>"
    have "env\<^sup>*\<^sup>* ?m (?m\<lbrakk>x \<^sub>b= []\<rbrakk>\<lbrakk>x \<^sub>p= get ?m x\<rbrakk>)"
      using Cons PW
      by (smt (verit, best) fun_upd_same select_convs(2) surjective update_convs(1,2))
    moreover have e: "\<langle>m\<rangle> -e\<rightarrow> \<langle>m\<lbrakk>x \<^sub>p= v\<rbrakk>\<lbrakk>x \<^sub>b= p\<rbrakk>\<rangle>" using PW env.pwr t by blast
    moreover have "get (m\<lbrakk>x \<^sub>p= v\<rbrakk>\<lbrakk>x \<^sub>b= p\<rbrakk>) x = get m x"
      unfolding get_def t PW
      by (auto split: option.splits pevent.splits)
    ultimately show ?thesis unfolding simple simple2
      by (metis (mono_tags, lifting) converse_rtranclp_into_rtranclp surjective update_convs(1))
  qed
qed

section \<open>Predicate Language\<close>

type_synonym ('a,'t) ord = "'a \<Rightarrow> 't \<Rightarrow> bool"

text \<open>Predicate abstraction to simplify specification, consisting of:
      (volatile memory, persistent memory, memory after an mfence)\<close>
type_synonym ('a,'b,'t) pred = "(('a,'b) m \<times> ('a,'b) m \<times> ('a,'b) m) set"
type_synonym ('a,'b,'t) prel = "(('a,'b) m \<times> ('a,'b) m \<times> ('a,'b) m) rel"

subsection \<open>pre_fo\<close>

text \<open>Find a write before a PFO event in a buffer, returning None if there aren't any\<close>
fun pre_fo :: "'t \<Rightarrow> ('t,'b) pevent list \<Rightarrow> 'b option"
  where
    "pre_fo t [] = None" |
    "pre_fo t (PFO _#xs) = (if PFO t \<in> set xs then pre_fo t xs else None)" |
    "pre_fo t (PW x#PFO s#xs) = (if s = t \<and> PFO t \<notin> set xs then Some x else pre_fo t (PW x#xs))" |
    "pre_fo t (PW x#xs) = pre_fo t xs"

lemma pre_fo_no_pfo [simp]:
  assumes "PFO t \<notin> set l"
  shows "pre_fo t l = None"
  using assms by (induct l rule: pre_fo.induct) auto

lemma pre_fo_no_pw [simp]:
  assumes "\<forall>e \<in> set l. \<not> isPW e"
  shows "pre_fo t l = None"
  using assms by (induct l rule: pre_fo.induct) auto

lemma pre_fo_pfo [simp]:
  "pre_fo t (l @ [PFO t]) = (case lastf isPW l of Some (PW v) \<Rightarrow> Some v | _ \<Rightarrow> None)"
  by (induct "l@[PFO t]" arbitrary: l rule: pre_fo.induct)
      (auto elim!: pre_postE split: option.splits pevent.splits)

lemma pre_fo_pw [simp]:
  "pre_fo t (l @ [PW v]) = pre_fo t l"
  by (induct "l@[PW v]" arbitrary: l rule: pre_fo.induct)
      (auto elim!: pre_postE split: option.splits)

lemma pre_fo_other [simp]:
  "s \<noteq> t \<Longrightarrow> pre_fo t (l @ [PFO s]) = pre_fo t l"
  by (induct "l@[PFO t]" arbitrary: l rule: pre_fo.induct)
      (auto elim!: pre_postE split: option.splits pevent.splits)

subsection \<open>get for @{term PFO} effects\<close>

text \<open>Persistent memory after an @{term MF} is evaluated\<close>
definition get\<^sub>f :: "'t \<Rightarrow> ('a,'t,'b) state \<Rightarrow> ('a,'b) m"
  where "get\<^sub>f t m a \<equiv> case pre_fo t (buffers m a) of Some v \<Rightarrow> v | None \<Rightarrow> persistent m a"

lemma get\<^sub>f_no_pfo[simp]:
  assumes "\<forall>y. PFO t \<notin> set (buffers m y)"
  shows "get\<^sub>f t m = persistent m"
  using assms by (auto simp: get\<^sub>f_def fun_eq_iff split: option.splits)

lemma get\<^sub>f_no_pw[simp]:
  assumes "\<forall>e \<in> set (buffers m x). \<not> isPW e"
  shows "get\<^sub>f t m x = persistent m x"
  using assms by (auto simp: get\<^sub>f_def fun_eq_iff split: option.splits pevent.splits)

lemma get\<^sub>f_app_pfo [simp]:
  "get\<^sub>f t (m\<lbrakk>x \<^sub>@= PFO t\<rbrakk>) = (get\<^sub>f t m)(x := get m x)"
  by (auto simp: get_def fun_eq_iff get\<^sub>f_def split: option.splits pevent.splits)

lemma [simp]:
  assumes "\<forall>e \<in> set (buffers m x). \<not> isPW e"
  shows "get\<^sub>f t (m\<lbrakk>x \<^sub>p= v\<rbrakk>) = (get\<^sub>f t m)(x := v)"
  using assms by (auto simp: get\<^sub>f_def fun_eq_iff split: option.splits pevent.splits)

lemma get\<^sub>f_app_simps [simp]:
  "get\<^sub>f t (m\<lbrakk>x \<^sub>@= PW v\<rbrakk>) = (get\<^sub>f t m)"
  by (auto simp: get_def get\<^sub>f_def fun_eq_iff split: option.splits pevent.splits)

lemma [simp]:
  "get\<^sub>f t m x = c \<Longrightarrow> (get\<^sub>f t m)(x := c) = get\<^sub>f t m"
  by auto

lemma [simp]:
  "get\<^sub>f t (m\<lbrakk>x \<^sub>p= v\<rbrakk>\<lbrakk>x \<^sub>b= []\<rbrakk>) = (get\<^sub>f t m)(x := v)"
  unfolding get\<^sub>f_def fun_eq_iff by (auto split: option.splits)

lemma [simp]:
  "s \<noteq> t \<Longrightarrow> get\<^sub>f s (m\<lbrakk>x \<^sub>@= PFO t\<rbrakk>) = get\<^sub>f s m"
  by (auto simp: get\<^sub>f_def fun_eq_iff split: option.splits)

subsection \<open>sat\<close>

definition sat :: "'t \<Rightarrow> ('a,'b,'t) pred \<Rightarrow> ('a,'t,'b) state \<Rightarrow> bool"
  where "sat t Q m \<equiv> \<forall>m'. env\<^sup>*\<^sup>* m m' \<longrightarrow> (get m', persistent m', get\<^sub>f t m') \<in> Q"

lemma sat_env_stable:
  assumes "sat t Q m" "\<langle>m\<rangle> -e\<rightarrow> \<langle>m'\<rangle>"
  shows "sat t Q m'"
  using assms unfolding sat_def
  by (meson converse_rtranclp_into_rtranclp)

subsection \<open>wp\<close>

fun wp :: "('a,'b) event \<Rightarrow> ('a,'b,'t) pred \<Rightarrow> ('a,'b,'t) pred"
  where
    "wp (W x v) Q = {(m,p,f). (m(x:=v),p,f) \<in> Q \<and> (m(x:=v),p(x:=v),f(x:=v)) \<in> Q}" |
    "wp (R x v) Q = {(m,p,f). m x = v \<longrightarrow> (m,p,f) \<in> Q}" |
    "wp (FL x) Q = {(m,p,f). (m,p(x := m x),f(x := m x)) \<in> Q}" |
    "wp MF Q = {(m,p,f). (m,f,f) \<in> Q}" |
    "wp (FO x) Q = {(m,p,f). (m,p,f(x := m x)) \<in> Q}" |
    "wp (RMW x v\<^sub>R v\<^sub>W) Q = {(m,p,f). m x = v\<^sub>R \<longrightarrow> (m(x:=v\<^sub>W),f,f) \<in> Q \<and> (m(x:=v\<^sub>W),f(x:=v\<^sub>W),f(x:=v\<^sub>W)) \<in> Q}" |
    "wp (RMF x v\<^sub>R) Q = {(m,p,f). m x = v\<^sub>R \<longrightarrow> (m,f,f) \<in> Q}"

lemma wp_sound:
  assumes "\<langle>m\<rangle> -t,a\<rightarrow> \<langle>m'\<rangle>"
  shows "sat t (wp a Q) m \<longrightarrow> sat t Q m'"
  using assms
proof (cases)
  case (wr x v)
  thus ?thesis
    apply (clarsimp simp: sat_def)
    apply (elim envt_buffer_appE)
    by auto
next
  case (rd x v)
  thus ?thesis by (auto simp: sat_def)
next
  case mf
  hence "\<forall>y m'. env\<^sup>*\<^sup>* m m' \<longrightarrow> PFO t \<notin> set (buffers m' y)" by (meson envt_buffer_subset in_mono)
  thus ?thesis using mf by (auto simp: sat_def)
next
  case (fl x)
  hence "\<forall>m'. env\<^sup>*\<^sup>* m m' \<longrightarrow> buffers m' x = []" using envt_buffer_empty by metis
  thus ?thesis using fl by (auto simp: sat_def)
next
  case (fo x)
  thus ?thesis by (auto elim!: envt_buffer_appE simp: sat_def)
next
  case (rmw x v\<^sub>R v\<^sub>W)
  hence "\<forall>y m'. env\<^sup>*\<^sup>* m m' \<longrightarrow> PFO t \<notin> set (buffers m' y)" by (meson envt_buffer_subset in_mono)
  then show ?thesis using rmw apply (clarsimp simp: sat_def)
    apply (elim envt_buffer_appE)
    by auto
next
  case (rmf x v\<^sub>R)
  hence "\<forall>y m'. env\<^sup>*\<^sup>* m m' \<longrightarrow> PFO t \<notin> set (buffers m' y)" by (meson envt_buffer_subset in_mono)
  then show ?thesis using rmf by (auto simp: sat_def)
qed

subsection \<open>Concurrency\<close>

definition wpr
  where "wpr r Q \<equiv> {(m,p,f). \<forall>m' p' f'. ((m,p,f),(m',p',f')) \<in> r \<longrightarrow>  (m',p',f') \<in> Q}"

fun guar
  where
    "guar q (W x v) r = {(m,p,f). \<forall>s. ((m,p,s),(m(x := v),p,s)) \<in> r \<and> ((m,p,s),(m(x := v),p(x := v),s(x := v))) \<in> r}" |
    "guar q (RMW x v\<^sub>R v\<^sub>W) r = {(m,p,f). m x = v\<^sub>R \<longrightarrow> (\<forall>s. ((m,p,s),(m(x := v\<^sub>W),p,s)) \<in> r \<and> ((m,p,s),(m(x := v\<^sub>W),p(x := v\<^sub>W),s(x := v\<^sub>W))) \<in> r)}" |
    "guar q _ r = UNIV"

fun beh
  where
    "beh (W x v) = ({((m,p,f,s),(m(x := v),p,f,s))| m p f s. True} \<union> {((m,p,f,s),(m(x := v),p(x := v),f(x := v),s(x := v))) | m p s f. True})" |
    "beh (R x v) = {((m,p,f,s),(m,p,f,s))| m p f s. m x = v}" |
    "beh (FL x)  = {((m,p,f,s),(m,p(x := m x),f(x := m x),s(x := m x)))| m p f s. True}" |
    "beh MF      = {((m,p,f,s),(m,f,f,s))| m p f s. True}" |
    "beh (FO x)  = {((m,p,f,s),(m,p,f(x := m x),s))|m p f s. True}" |
    "beh (RMW x v\<^sub>R v\<^sub>W) = ({((m,p,f,s),(m(x := v\<^sub>W),f,f,s))| m p f s . m x = v\<^sub>R} \<union> {((m,p,f,s),(m(x := v\<^sub>W),p(x := v\<^sub>W),f(x := v\<^sub>W),s(x := v\<^sub>W))) | m p f s . m x = v\<^sub>R})" |
    "beh (RMF x v\<^sub>R) = {((m,p,f,s),(m,f,f,s))| m p f s. m x = v\<^sub>R}"

lemma step_rw:
  assumes "\<langle>m\<rangle> -t,x\<rightarrow> \<langle>m'\<rangle>"
  assumes "persistent m' = persistent m''"
  assumes "buffers m' = buffers m''"
  assumes "more m' = more m''"
  shows "\<langle>m\<rangle> -t,x\<rightarrow> \<langle>m''\<rangle>"
  using assms equality by blast

lemma wpr_sound:
  assumes "\<langle>m\<rangle> -t,a\<rightarrow> \<langle>m'\<rangle>" "sat t (guar t a r) m" "s \<noteq> t"
  assumes "sat s (wpr (r) Q) m" "trans (r)"
  shows "sat s (wpr (r) Q) m'"
  using assms
proof (cases)
  case (wr x v)
  hence "\<forall>m'. env\<^sup>*\<^sup>* m m' \<longrightarrow> get m = get m'" by auto
  then show ?thesis using assms wr
    apply (clarsimp simp: sat_def wpr_def)
    apply (elim envt_buffer_appE; simp)
     apply (meson transD)
    by (meson transD)
next
  case (rd x v)
  hence "\<forall>m'. env\<^sup>*\<^sup>* m m' \<longrightarrow> get m = get m'" by auto
  then show ?thesis using assms(4) rd
    by (clarsimp simp: sat_def wpr_def)
next
  case mf
  hence "\<forall>m'. env\<^sup>*\<^sup>* m m' \<longrightarrow> get m = get m'" by auto
  then show ?thesis using assms(4) mf
    by (clarsimp simp: sat_def wpr_def)
next
  case (fl x)
  hence "\<forall>m'. env\<^sup>*\<^sup>* m m' \<longrightarrow> get m = get m'" by auto
  then show ?thesis using assms(4) fl
    by (clarsimp simp: sat_def wpr_def)
next
  case (fo x)
  hence "\<forall>m'. env\<^sup>*\<^sup>* m m' \<longrightarrow> get m = get m'" by auto
  then show ?thesis using assms(3,4) fo
    apply (clarsimp simp: sat_def wpr_def)
    by (elim envt_buffer_appE; simp)
next
  case (rmw x v\<^sub>R v\<^sub>W)
  hence "\<forall>m'. env\<^sup>*\<^sup>* m m' \<longrightarrow> get m = get m'" by auto
  then show ?thesis using assms rmw
    apply (clarsimp simp: sat_def wpr_def)
    apply (elim envt_buffer_appE; simp)
     apply (meson transD)
    by (meson transD)
next
  case (rmf x v\<^sub>R)
  hence "\<forall>m'. env\<^sup>*\<^sup>* m m' \<longrightarrow> get m = get m'" by auto
  then show ?thesis using assms(4) rmf
    by (clarsimp simp: sat_def wpr_def)
qed

lemma guar_mono:
  assumes "r \<subseteq> g"
  shows "guar t a r \<subseteq> guar t a g"
  using assms by (cases a; clarsimp) blast+

subsection \<open>wpl\<close>

fun wpl :: "'t \<Rightarrow>  ('a,'b,'t) prel \<Rightarrow> ('a,'b,'t) prel \<Rightarrow> ('a,'b) event list \<Rightarrow> ('a,'b,'t) pred \<Rightarrow> ('a,'b,'t) pred"
  where
    "wpl t r g [] A = wpr r A" |
    "wpl t r g (x#xs) A = wpr r (wp x (wpl t r g xs A) \<inter> guar t x g)"

fun id_filter
  where
    "id_filter t [] = []" |
    "id_filter t ((s,e)#p) = (if t = s then e#(id_filter t p) else id_filter t p)"

definition compat
  where "compat r g \<equiv> \<forall>i j. i \<noteq> j \<longrightarrow> g i \<subseteq> r j"

lemma wpr_pres:
  assumes "sat s (wpr r Q) m" "refl r"
  shows "sat s Q m"
  using assms unfolding sat_def wpr_def
  apply clarsimp
  by (metis UNIV_I refl_on_def)

lemma [simp]:
  "sat t (P \<inter> Q) m = (sat t P m \<and> sat t Q m)"
  unfolding sat_def by auto

lemma sat_imp:
  "sat t P m \<Longrightarrow> P \<subseteq> Q \<Longrightarrow> sat t Q m"
  by (auto simp: sat_def)

lemma wp_mono:
  assumes "P \<subseteq> Q"
  shows "wp a P \<subseteq> wp a Q"
  using assms by (cases a) auto

lemma wp_mono':
  assumes "m \<in> wp a P"
  assumes "P \<subseteq> Q"
  shows "m \<in> wp a Q"
  using assms by (cases a) auto

lemma wpl_sound:
  assumes "trace m ts m'" "\<forall>t. sat t (wpl t (r t) (g t) (id_filter t ts) (Q t)) m"
  assumes compat: "compat r g"
  assumes refl: "\<forall>t. refl (r t) \<and> trans (r t)"
  shows "\<forall>t. sat t (Q t) m'"
  using assms(1,2)
proof (induct arbitrary: Q)
  case (nil a)
  then show ?case
    apply simp
    using refl wpr_pres by metis
next
  case (step m t a m' ts m'')
  have t: "sat t (wpl t (r t) (g t) (id_filter t ((t, a) # ts)) (Q t)) m" using step(4) by blast
  hence g: "sat t (guar t a (g t)) m"
    apply simp
    apply (drule wpr_pres, insert refl, blast)
    by auto

  show ?case
  proof (rule step(3), intro allI)
    fix s
    have a: "sat s (wpl s (r s) (g s) (id_filter s ((t, a) # ts)) (Q s)) m" using step by auto
    show "sat s (wpl s (r s) (g s) (id_filter s ts) (Q s)) m'"
    proof (cases "s = t")
      case True
      then show ?thesis
        using a step(1)
        apply simp
        by (drule wpr_pres, insert refl, blast) (simp add: wp_sound)
    next
      case False
      hence "g t \<subseteq> r s" using assms by (auto simp: compat_def)
      hence "guar t a (g t) \<subseteq> guar t a (r s)" by (rule guar_mono)
      hence g: "sat t (guar t a (r s)) m"
        using g sat_imp by meson

      show ?thesis
      proof (cases "id_filter s ts")
        case Nil
        then show ?thesis using refl False a wpr_sound[OF step(1) g False] by simp
      next
        case (Cons a list)
        then show ?thesis using refl False a wpr_sound[OF step(1) g False] by simp
      qed
    qed
  qed
next
  case (env m m' t m'')
  then show ?case using sat_env_stable by metis
qed

definition interleave
  where "interleave ts ts' \<equiv> \<forall>t. id_filter t ts = id_filter t ts'"

lemma interleave_nil:
  "interleave [] []"
  by (auto simp: interleave_def)

lemma interleave_cons:
  "interleave x y \<Longrightarrow> interleave (a#x) (a#y)"
  by (cases a) (auto simp: interleave_def)

lemma tenv_traceI:
  assumes "env\<^sup>*\<^sup>* m m'" "trace m' ts m''"
  shows "trace m ts m''"
  using assms
proof (induct)
  case base
  then show ?case by auto
next
  case (step y z)
  then show ?case
    using env by blast
qed

lemma sat_conj:
  assumes "sat t P m" "sat t Q m"
  shows "sat t (P \<inter> Q) m"
  using assms by (auto simp: sat_def)

lemma id_filter_remove_other [simp]:
  "s \<noteq> t \<Longrightarrow> id_filter s (remove1 (t, x) ts) = id_filter s ts"
  by (induct ts) (auto split: if_splits)

lemma id_filter_remove:
  assumes "id_filter t ts = x#re"
  shows "id_filter t (remove1 (t,x) ts) = re"
  using assms
proof (induct ts arbitrary: re)
  case Nil
  then show ?case by auto
next
  case (Cons a ts)
  then show ?case by (cases a) auto
qed

lemma interleave_remove:
  assumes "interleave (remove1 (t, x) ts) ts'"
  assumes "id_filter t ts = x#p"
  shows "interleave ts ((t,x)#ts')"
  using assms
  unfolding interleave_def
  apply auto
   prefer 2
    apply (frule id_filter_remove_other[where ts=ts and x=x])
   apply simp
  apply (frule id_filter_remove)
  apply simp
  done

subsection \<open>raise\<close>

text \<open>Convert the predicate encoding into a minimal state\<close>
definition raise
  where "raise t v p f \<equiv> \<lparr> persistent = p ,
                           buffers = \<lambda>x. (if p x \<noteq> f x then [PW (f x), PFO t] else []) @
                                         (if v x \<noteq> f x then [PW (v x)] else []) \<rparr>"

lemma [simp]:
  "get (raise t v p f) = v"
  by (auto simp: fun_eq_iff raise_def get_def)

lemma [simp]:
  "persistent (raise t v p f) = p"
  by (auto simp: fun_eq_iff raise_def)

lemma [simp]:
  "get\<^sub>f t (raise t v p f) = f"
  by (auto simp: fun_eq_iff raise_def get\<^sub>f_def contains_def)

lemma sat_wprI':
  assumes "\<And>m' m'' . env\<^sup>*\<^sup>* m m' \<longrightarrow> ((get m', persistent m', get\<^sub>f t m'),(get m'', persistent m'', get\<^sub>f t m'')) \<in> r \<longrightarrow> sat t Q m''"
  shows "sat t (wpr r Q) m"
  using assms unfolding sat_def wpr_def
  apply auto
  apply (subgoal_tac "((get m', persistent m', get\<^sub>f t m'), (get (raise t m'a p' f'), persistent  (raise t m'a p' f'), get\<^sub>f t  (raise t m'a p' f'))) \<in> r")
  prefer 2
   apply auto[1]
  apply (subgoal_tac "(get (raise t m'a p' f'), persistent (raise t m'a p' f'), get\<^sub>f t (raise t m'a p' f')) \<in> Q")
   apply simp
  by blast

section \<open>Completeness\<close>

text \<open>
Implication is sound but not complete for this encoding.
To make it complete, its necessary to enforce a wellformedness property over the predicate
representation, such that constraints on non-volatile variables can be observed by
their volatile equivalents.

The implications of this loss of completeness needs to be considered and either accepted
or a new @{term wp} transformer that preserves the wellformedness property implemented.
\<close>

definition wf
  where "wf P \<equiv> \<forall>v p f Fs Vs. (v,p,f) \<in> P \<longrightarrow>
              (v,(override_on (override_on p f Fs) v Vs),(override_on f v Vs)) \<in> P"

text \<open>Prefix a series of buffers with a constant list\<close>
definition prefix
  where "prefix m X p \<equiv> buffers_update (\<lambda>b. \<lambda>y. if y \<in> X then p@(b y) else b y) m"

lemma [simp]:
  "get (prefix m X [PFO t]) = get m"
  by (auto simp: prefix_def get_def fun_eq_iff split: option.splits pevent.split)

lemma [simp]:
  "persistent (prefix m X [PFO t]) = persistent m"
  by (auto simp: prefix_def fun_eq_iff split: option.splits pevent.split)

lemma [simp]:
  "get\<^sub>f t (prefix m X [PFO t]) = get\<^sub>f t m"
  by (auto simp: prefix_def fun_eq_iff get\<^sub>f_def split: option.splits pevent.split)

lemma env_raise:
  assumes "env (prefix (raise t v p f) X [PFO t]) m"
  obtains (wrv) x X where "m = prefix (raise t v (p(x := v x)) (f(x := v x))) X [PFO t]" |
          (wrf) x where "m = prefix (raise t v (p(x := f x)) f) (insert x X) [PFO t]" "v x \<noteq> f x" |
          (fo) x where "m = prefix (raise t v p f) (X - {x}) [PFO t]"
  using assms
proof cases
  case (pwr x v' l)
  show ?thesis
  proof (cases "v x = f x \<or> p x = f x")
    case True
    hence "m = prefix (raise t v (p(x := v x)) (f(x := v x))) (if p x \<noteq> f x then insert x X else X) [PFO t]"
      using pwr by (clarsimp split: if_splits simp: raise_def fun_eq_iff prefix_def)
    then show ?thesis using wrv by blast
  next
    case False
    hence "m = prefix (raise t v (p(x := f x)) f) (insert x X) [PFO t]"
      using pwr by (clarsimp split: if_splits simp: prefix_def raise_def fun_eq_iff)
    then show ?thesis using wrf False by auto
  qed
next
  case (pfo x t' l)
  hence "m = prefix (raise t v p f) (X - {x}) [PFO t]"
    by (clarsimp split: if_splits simp: prefix_def raise_def fun_eq_iff)
  then show ?thesis using fo by auto
qed

lemma envt_raise:
  assumes "env\<^sup>*\<^sup>* (prefix (raise t v p f) X [PFO t]) m"
  obtains Fs Vs X' where "m = prefix (raise t v (override_on (override_on p f Fs) v Vs) (override_on f v Vs)) X' [PFO t]"
  using assms
proof (induct)
  case base
  show ?case using base[where Fs="{}" and Vs="{}"] by auto
next
  case (step m\<^sub>2 m\<^sub>3)
  show ?case
  proof (rule step(3), goal_cases)
    case (1 Fs Vs X')
    show ?case using step(2) unfolding 1
    proof (cases rule: env_raise)
      case (wrv x X)
      then show ?thesis
        using step(4)[where Fs=Fs and Vs="insert x Vs" and X'=X]
        by (metis override_on_insert)
    next
      case (wrf x)
      hence e: "x \<notin> Vs" by (auto simp: override_on_def)
      hence a: "override_on f v Vs x = f x" by (auto simp: override_on_def)
      have b: "\<And>q f v. (override_on q v Vs)(x := f x) = override_on (q(x:=f x)) v Vs"
        using e unfolding override_on_def by auto
      show ?thesis
        using wrf(1) step(4)[where Fs="insert x Fs" and Vs=Vs and X'="insert x X'"]
        unfolding override_on_insert a b by blast
    next
      case (fo x)
      then show ?thesis using step(4) by blast
    qed
  qed
qed

subsection \<open>Implication\<close>

lemma imp_complete:
  assumes "wf P"
  assumes "\<forall>m. sat t P m \<longrightarrow> sat t Q m"
  shows "P \<subseteq> Q"
proof clarsimp
  fix v p f
  assume p: "(v,p,f) \<in> P"
  let ?m = "prefix (raise t v p f) {} [PFO t]"
  have "sat t P ?m" using p assms(1) unfolding wf_def sat_def by (clarsimp elim!: envt_raise)
  hence "sat t Q ?m" using assms by auto
  thus "(v,p,f) \<in> Q" by (auto simp: sat_def)
qed

lemma c[simp]:
  "override_on (p(x := e)) (f(x := e)) V = (override_on p f V)(x := e)"
  unfolding override_on_def fun_eq_iff by auto

lemma [simp]:
  "override_on (p(x := f x)) f V = (override_on p f V)(x := f x)"
  unfolding override_on_def fun_eq_iff by auto

lemma [simp]:
  "override_on f f Fs = f"
  by (auto simp: override_on_def)

lemma [simp]:
  "x \<notin> Vs \<Longrightarrow> override_on f (v(x := e)) Vs = override_on f v Vs"
  by (auto simp: override_on_def)

lemma d:
  "x \<in> Vs \<Longrightarrow> override_on (f(x := v x)) (v(x := e))
      (Vs - {x}) = override_on f v Vs"
  by (auto simp: override_on_def fun_eq_iff)

lemma [simp]:
  "(override_on f v (Vs - {x}))(x := e) = (override_on f v Vs)(x := e)"
  by (auto simp: override_on_def fun_eq_iff)

end


(*  Title:      HOL/Library/RBT.thy
    Author:     Lukas Bulwahn and Ondrej Kuncar
*)

section \<open>Abstract type of RBT trees\<close>

theory RBT
imports Main RBT_Impl
begin

subsection \<open>Type definition\<close>

typedef (overloaded) ('a, 'b) rbt = "{t :: ('a::linorder, 'b) RBT_Impl.rbt. is_rbt t}"
  morphisms impl_of RBT
proof -
  have "RBT_Impl.Empty \<in> ?rbt" by simp
  then show ?thesis ..
qed

lemma rbt_eq_iff:
  "t1 = t2 \<longleftrightarrow> impl_of t1 = impl_of t2"
  by (simp add: impl_of_inject)

lemma rbt_eqI:
  "impl_of t1 = impl_of t2 \<Longrightarrow> t1 = t2"
  by (simp add: rbt_eq_iff)

lemma RBT_impl_of [simp, code abstype]:
  "RBT (impl_of t) = t"
  by (simp add: impl_of_inverse)

subsection \<open>Primitive operations\<close>

setup_lifting type_definition_rbt

lift_definition lookup :: "('a::linorder, 'b) rbt \<Rightarrow> 'a \<rightharpoonup> 'b" is "rbt_lookup" .

lift_definition empty :: "('a::linorder, 'b) rbt" is RBT_Impl.Empty
by (simp add: empty_def)

lift_definition insert :: "'a::linorder \<Rightarrow> 'b \<Rightarrow> ('a, 'b) rbt \<Rightarrow> ('a, 'b) rbt" is "rbt_insert"
by simp

lift_definition delete :: "'a::linorder \<Rightarrow> ('a, 'b) rbt \<Rightarrow> ('a, 'b) rbt" is "rbt_delete"
by simp

lift_definition entries :: "('a::linorder, 'b) rbt \<Rightarrow> ('a \<times> 'b) list" is RBT_Impl.entries .

lift_definition keys :: "('a::linorder, 'b) rbt \<Rightarrow> 'a list" is RBT_Impl.keys .

lift_definition bulkload :: "('a::linorder \<times> 'b) list \<Rightarrow> ('a, 'b) rbt" is "rbt_bulkload" ..

lift_definition map_entry :: "'a \<Rightarrow> ('b \<Rightarrow> 'b) \<Rightarrow> ('a::linorder, 'b) rbt \<Rightarrow> ('a, 'b) rbt" is rbt_map_entry
by simp

lift_definition map :: "('a \<Rightarrow> 'b \<Rightarrow> 'c) \<Rightarrow> ('a::linorder, 'b) rbt \<Rightarrow> ('a, 'c) rbt" is RBT_Impl.map
by simp

lift_definition fold :: "('a \<Rightarrow> 'b \<Rightarrow> 'c \<Rightarrow> 'c) \<Rightarrow> ('a::linorder, 'b) rbt \<Rightarrow> 'c \<Rightarrow> 'c"  is RBT_Impl.fold .

lift_definition union :: "('a::linorder, 'b) rbt \<Rightarrow> ('a, 'b) rbt \<Rightarrow> ('a, 'b) rbt" is "rbt_union"
by (simp add: rbt_union_is_rbt)

lift_definition foldi :: "('c \<Rightarrow> bool) \<Rightarrow> ('a \<Rightarrow> 'b \<Rightarrow> 'c \<Rightarrow> 'c) \<Rightarrow> ('a :: linorder, 'b) rbt \<Rightarrow> 'c \<Rightarrow> 'c"
  is RBT_Impl.foldi .

lift_definition combine_with_key :: "('a \<Rightarrow> 'b \<Rightarrow> 'b \<Rightarrow> 'b) \<Rightarrow> ('a::linorder, 'b) rbt \<Rightarrow> ('a, 'b) rbt \<Rightarrow> ('a, 'b) rbt"
  is RBT_Impl.rbt_union_with_key by (rule is_rbt_rbt_unionwk)

lift_definition combine :: "('b \<Rightarrow> 'b \<Rightarrow> 'b) \<Rightarrow> ('a::linorder, 'b) rbt \<Rightarrow> ('a, 'b) rbt \<Rightarrow> ('a, 'b) rbt"
  is RBT_Impl.rbt_union_with by (rule rbt_unionw_is_rbt)

subsection \<open>Derived operations\<close>

definition is_empty :: "('a::linorder, 'b) rbt \<Rightarrow> bool" where
  [code]: "is_empty t = (case impl_of t of RBT_Impl.Empty \<Rightarrow> True | _ \<Rightarrow> False)"

(* TODO: Is deleting more efficient than re-building the tree?
   (Probably more difficult to prove though *)
definition filter :: "('a \<Rightarrow> 'b \<Rightarrow> bool) \<Rightarrow> ('a::linorder, 'b) rbt \<Rightarrow> ('a, 'b) rbt" where
  [code]: "filter P t = fold (\<lambda>k v t. if P k v then insert k v t else t) t empty"

subsection \<open>Abstract lookup properties\<close>

lemma lookup_RBT:
  "is_rbt t \<Longrightarrow> lookup (RBT t) = rbt_lookup t"
  by (simp add: lookup_def RBT_inverse)

lemma lookup_impl_of:
  "rbt_lookup (impl_of t) = lookup t"
  by transfer (rule refl)

lemma entries_impl_of:
  "RBT_Impl.entries (impl_of t) = entries t"
  by transfer (rule refl)

lemma keys_impl_of:
  "RBT_Impl.keys (impl_of t) = keys t"
  by transfer (rule refl)

lemma lookup_keys:
  "dom (lookup t) = set (keys t)"
  by transfer (simp add: rbt_lookup_keys)

lemma lookup_empty [simp]:
  "lookup empty = Map.empty"
  by (simp add: empty_def lookup_RBT fun_eq_iff)

lemma lookup_insert [simp]:
  "lookup (insert k v t) = (lookup t)(k \<mapsto> v)"
  by transfer (rule rbt_lookup_rbt_insert)

lemma lookup_delete [simp]:
  "lookup (delete k t) = (lookup t)(k := None)"
  by transfer (simp add: rbt_lookup_rbt_delete restrict_complement_singleton_eq)

lemma map_of_entries [simp]:
  "map_of (entries t) = lookup t"
  by transfer (simp add: map_of_entries)

lemma entries_lookup:
  "entries t1 = entries t2 \<longleftrightarrow> lookup t1 = lookup t2"
  by transfer (simp add: entries_rbt_lookup)

lemma lookup_bulkload [simp]:
  "lookup (bulkload xs) = map_of xs"
  by transfer (rule rbt_lookup_rbt_bulkload)

lemma lookup_map_entry [simp]:
  "lookup (map_entry k f t) = (lookup t)(k := map_option f (lookup t k))"
  by transfer (rule rbt_lookup_rbt_map_entry)

lemma lookup_map [simp]:
  "lookup (map f t) k = map_option (f k) (lookup t k)"
  by transfer (rule rbt_lookup_map)

lemma lookup_combine_with_key [simp]:
  "lookup (combine_with_key f t1 t2) k = combine_options (f k) (lookup t1 k) (lookup t2 k)"
  by transfer (simp_all add: combine_options_def rbt_lookup_rbt_unionwk)

lemma combine_altdef: "combine f t1 t2 = combine_with_key (\<lambda>_. f) t1 t2"
  by transfer (simp add: rbt_union_with_def)

lemma lookup_combine [simp]:
  "lookup (combine f t1 t2) k = combine_options f (lookup t1 k) (lookup t2 k)"
  by (simp add: combine_altdef)

lemma fold_fold:
  "fold f t = List.fold (case_prod f) (entries t)"
  by transfer (rule RBT_Impl.fold_def)

lemma impl_of_empty:
  "impl_of empty = RBT_Impl.Empty"
  by transfer (rule refl)

lemma is_empty_empty [simp]:
  "is_empty t \<longleftrightarrow> t = empty"
  unfolding is_empty_def by transfer (simp split: rbt.split)

lemma RBT_lookup_empty [simp]: (*FIXME*)
  "rbt_lookup t = Map.empty \<longleftrightarrow> t = RBT_Impl.Empty"
  by (cases t) (auto simp add: fun_eq_iff)

lemma lookup_empty_empty [simp]:
  "lookup t = Map.empty \<longleftrightarrow> t = empty"
  by transfer (rule RBT_lookup_empty)

lemma sorted_keys [iff]:
  "sorted (keys t)"
  by transfer (simp add: RBT_Impl.keys_def rbt_sorted_entries)

lemma distinct_keys [iff]:
  "distinct (keys t)"
  by transfer (simp add: RBT_Impl.keys_def distinct_entries)

lemma finite_dom_lookup [simp, intro!]: "finite (dom (lookup t))"
  by transfer simp

lemma lookup_union: "lookup (union s t) = lookup s ++ lookup t"
  by transfer (simp add: rbt_lookup_rbt_union)

lemma lookup_in_tree: "(lookup t k = Some v) = ((k, v) \<in> set (entries t))"
  by transfer (simp add: rbt_lookup_in_tree)

lemma keys_entries: "(k \<in> set (keys t)) = (\<exists>v. (k, v) \<in> set (entries t))"
  by transfer (simp add: keys_entries)

lemma fold_def_alt:
  "fold f t = List.fold (case_prod f) (entries t)"
  by transfer (auto simp: RBT_Impl.fold_def)

lemma distinct_entries: "distinct (List.map fst (entries t))"
  by transfer (simp add: distinct_entries)

lemma sorted_entries: "sorted (List.map fst (entries t))"
  by (transfer) (simp add: rbt_sorted_entries)

lemma non_empty_keys: "t \<noteq> empty \<Longrightarrow> keys t \<noteq> []"
  by transfer (simp add: non_empty_rbt_keys)

lemma keys_def_alt:
  "keys t = List.map fst (entries t)"
  by transfer (simp add: RBT_Impl.keys_def)

context
begin

private lemma lookup_filter_aux:
  assumes "distinct (List.map fst xs)"
  shows   "lookup (List.fold (\<lambda>(k, v) t. if P k v then insert k v t else t) xs t) k =
             (case map_of xs k of
                None \<Rightarrow> lookup t k
              | Some v \<Rightarrow> if P k v then Some v else lookup t k)"
  using assms by (induction xs arbitrary: t) (force split: option.splits)+

lemma lookup_filter:
  "lookup (filter P t) k =
     (case lookup t k of None \<Rightarrow> None | Some v \<Rightarrow> if P k v then Some v else None)"
  unfolding filter_def using lookup_filter_aux[of "entries t" P empty k]
  by (simp add: fold_fold distinct_entries split: option.splits)

end

subsection \<open>Quickcheck generators\<close>

quickcheck_generator rbt predicate: is_rbt constructors: empty, insert

subsection \<open>Hide implementation details\<close>

lifting_update rbt.lifting
lifting_forget rbt.lifting

hide_const (open) impl_of empty lookup keys entries bulkload delete map fold union insert map_entry foldi
  is_empty filter
hide_fact (open) empty_def lookup_def keys_def entries_def bulkload_def delete_def map_def fold_def
  union_def insert_def map_entry_def foldi_def is_empty_def filter_def

end


section{*Examples of Intuitionistic Reasoning*}

theory IFOL_examples imports "~~/src/FOL/IFOL" begin

text{*Quantifier example from the book Logic and Computation*}
lemma "(EX y. ALL x. Q(x,y)) -->  (ALL x. EX y. Q(x,y))"
  --{* @{subgoals[display,indent=0,margin=65]} *}
apply (rule impI)
  --{* @{subgoals[display,indent=0,margin=65]} *}
apply (rule allI)
  --{* @{subgoals[display,indent=0,margin=65]} *}
apply (rule exI)
  --{* @{subgoals[display,indent=0,margin=65]} *}
apply (erule exE)
  --{* @{subgoals[display,indent=0,margin=65]} *}
apply (erule allE)
  --{* @{subgoals[display,indent=0,margin=65]} *}
txt{*Now @{text "apply assumption"} fails*}
oops

text{*Trying again, with the same first two steps*}
lemma "(EX y. ALL x. Q(x,y)) -->  (ALL x. EX y. Q(x,y))"
  --{* @{subgoals[display,indent=0,margin=65]} *}
apply (rule impI)
  --{* @{subgoals[display,indent=0,margin=65]} *}
apply (rule allI)
  --{* @{subgoals[display,indent=0,margin=65]} *}
apply (erule exE)
  --{* @{subgoals[display,indent=0,margin=65]} *}
apply (rule exI)
  --{* @{subgoals[display,indent=0,margin=65]} *}
apply (erule allE)
  --{* @{subgoals[display,indent=0,margin=65]} *}
apply assumption
  --{* @{subgoals[display,indent=0,margin=65]} *}
done

lemma "(EX y. ALL x. Q(x,y)) -->  (ALL x. EX y. Q(x,y))"
by (tactic {*IntPr.fast_tac @{context} 1*})

text{*Example of Dyckhoff's method*}
lemma "~ ~ ((P-->Q) | (Q-->P))"
  --{* @{subgoals[display,indent=0,margin=65]} *}
apply (unfold not_def)
  --{* @{subgoals[display,indent=0,margin=65]} *}
apply (rule impI)
  --{* @{subgoals[display,indent=0,margin=65]} *}
apply (erule disj_impE)
  --{* @{subgoals[display,indent=0,margin=65]} *}
apply (erule imp_impE)
  --{* @{subgoals[display,indent=0,margin=65]} *}
 apply (erule imp_impE)
  --{* @{subgoals[display,indent=0,margin=65]} *}
apply assumption
apply (erule FalseE)+
done

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_propositional_AndIdempotent
  imports "../../Test_Base"
begin

datatype ('a, 'b) pair = pair2 "'a" "'b"

datatype 'a list = nil2 | cons2 "'a" "'a list"

datatype Form = x "Form" "Form" | Not "Form" | Var "int"

fun y :: "'a list => 'a list => 'a list" where
  "y (nil2) y2 = y2"
| "y (cons2 z2 xs) y2 = cons2 z2 (y xs y2)"

fun or2 :: "bool list => bool" where
  "or2 (nil2) = False"
| "or2 (cons2 y2 xs) = (y2 | (or2 xs))"

fun models7 :: "int => ((int, bool) pair) list =>
                ((int, bool) pair) list" where
  "models7 z (nil2) = nil2"
| "models7 z (cons2 z2 xs) =
     (if (z ~= (case z2 of pair2 x2 y22 => x2)) then
        cons2 z2 (models7 z xs)
        else
        models7 z xs)"

fun models6 :: "int => ((int, bool) pair) list => bool list" where
  "models6 z (nil2) = nil2"
| "models6 z (cons2 (pair2 y22 True) x2) = models6 z x2"
| "models6 z (cons2 (pair2 y22 False) x2) =
     cons2 (z = y22) (models6 z x2)"

fun models5 :: "int => ((int, bool) pair) list =>
                ((int, bool) pair) list" where
  "models5 z (nil2) = nil2"
| "models5 z (cons2 z2 xs) =
     (if (z ~= (case z2 of pair2 x2 y22 => x2)) then
        cons2 z2 (models5 z xs)
        else
        models5 z xs)"

fun models4 :: "int => ((int, bool) pair) list => bool list" where
  "models4 z (nil2) = nil2"
| "models4 z (cons2 (pair2 y22 True) x2) =
     cons2 (z = y22) (models4 z x2)"
| "models4 z (cons2 (pair2 y22 False) x2) = models4 z x2"

function models :: "(((int, bool) pair) list) list => Form =>
                    (((int, bool) pair) list) list => (((int, bool) pair) list) list"
  and
  models2 :: "Form => (((int, bool) pair) list) list =>
                     (((int, bool) pair) list) list"
  and
  models3 :: "Form => ((int, bool) pair) list =>
                     (((int, bool) pair) list) list" where
  "models z q (nil2) = models2 q z"
| "models z q (cons2 z2 x2) = cons2 z2 (models z q x2)"
| "models2 q (nil2) = nil2"
| "models2 q (cons2 y2 z2) = models z2 q (models3 q y2)"
| "models3 (x p q) y2 = models2 q (models3 p y2)"
| "models3 (Not (x r q2)) y2 =
     y (models3 (Not r) y2) (models3 (x r (Not q2)) y2)"
| "models3 (Not (Not p2)) y2 = models3 p2 y2"
| "models3 (Not (Var x2)) y2 =
     (if (~ (or2 (models4 x2 y2))) then
        cons2 (cons2 (pair2 x2 False) (models5 x2 y2)) (nil2)
        else
        nil2)"
| "models3 (Var x3) y2 =
     (if (~ (or2 (models6 x3 y2))) then
        cons2 (cons2 (pair2 x3 True) (models7 x3 y2)) (nil2)
        else
        nil2)"
  by pat_completeness auto

fun valid :: "Form => bool" where
  "valid z =
   (case models3 (Not z) (nil2) of
      nil2 => True
      | cons2 y2 z2 => False)"

theorem property0 :
  "((valid (x p p)) = (valid p))"
  oops

end


theory TrumpInIsabelle           (*Christoph Benzmüller and Alexander Steen, 2019*)
imports Definitions (*import of basic modal logic concepts in HOL *)
begin               (*unimportant*) sledgehammer_params[type_enc=mono_native,verbose]
                    (*unimportant*) nitpick_params[user_axioms,show_all,format=4]

consts (*accessibility relation for time, belief (of an agent), speech (of an agent)*)
  AnyTimeRel::\<alpha>   BeliefOfRel::"\<mu>\<Rightarrow>\<alpha>"   SaysRel::"\<mu>\<Rightarrow>\<alpha>"

abbreviation "ANYTIME \<phi> \<equiv> \<^bold>\<box>AnyTimeRel \<phi>"       (*ANYTIME as modal operator*)
abbreviation "BELIEF x \<phi> \<equiv> \<^bold>\<box>(BeliefOfRel x) \<phi>" (*BELIEF as modal operator*)
abbreviation "SAYS x \<phi> \<equiv> \<^bold>\<box>(SaysRel x) \<phi>"       (*SAYS as modal operator*)

consts (*uninterpreted, scenario specific constant symbols*)
 Trump::\<mu> campaignOfTrump::\<mu> officeOfTrump::\<mu> birthCertObama::\<mu> calls::"\<mu>\<Rightarrow>\<mu>\<Rightarrow>\<sigma>"
 isAbout::"\<sigma>\<Rightarrow>\<mu>\<Rightarrow>\<sigma>" source::"\<mu>\<Rightarrow>\<sigma>" credible::"\<mu>\<Rightarrow>\<sigma>" isFraud::"\<mu>\<Rightarrow>\<sigma>"

axiomatization where  (*formalisation of Trump's tweets in multi-modal logic*)
 Tweet1: "\<lfloor>SAYS Trump (\<^bold>\<exists>x. source x \<^bold>\<and> credible x \<^bold>\<and> calls x officeOfTrump \<^bold>\<and>
                          SAYS x (isFraud birthCertObama))\<rfloor>" and
 Tweet2: "\<lfloor>SAYS Trump (ANYTIME
           (\<^bold>\<forall>\<^sup>\<sigma>s. ((isAbout s Trump \<^bold>\<or> isAbout s campaignOfTrump)
                   \<^bold>\<and> (\<^bold>\<exists>x. source x \<^bold>\<and> SAYS x s))
                 \<^bold>\<rightarrow> (\<^bold>\<forall>y. \<^bold>\<not>(BELIEF y s))))\<rfloor>"

axiomatization where  (*a little implicit knowledge is needed*)
 Implicit: "\<lfloor>isAbout (isFraud birthCertObama) campaignOfTrump\<rfloor>" and
 AnyTimeIncludesNow: "\<lfloor>\<^bold>\<forall>\<^sup>\<sigma>s. ANYTIME s \<^bold>\<rightarrow> s\<rfloor>"

(*consistency check*)
lemma True nitpick [satisfy,user_axioms,show_all] oops (*yes, model by nitpick*)

(*Trump (essentially) says that he does not belief that birthCertObama is fraud*)
lemma L1: "\<lfloor>SAYS Trump (\<^bold>\<not>(BELIEF Trump (isFraud birthCertObama)))\<rfloor>"
 sledgehammer (*proof found*)
 by (metis AnyTimeIncludesNow Implicit Tweet1 Tweet2)

(*Trump does not belief that birthCertObama is fraud — not yet provable*)
lemma "\<lfloor>(\<^bold>\<not>(BELIEF Trump (isFraud birthCertObama)))\<rfloor>"
  sledgehammer (*timeout*)
  nitpick oops (*countermodel*)

axiomatization where
 TrumpBelievesWhatHeSays: "\<lfloor>\<^bold>\<forall>\<^sup>\<sigma>s. SAYS Trump s \<^bold>\<rightarrow> BELIEF Trump s\<rfloor>" and
 TrumpsBeliefIsTruth: "\<lfloor>\<^bold>\<forall>\<^sup>\<sigma>s. BELIEF Trump s \<^bold>\<leftrightarrow> s\<rfloor>"

(*Trump does not belief that birthCertObama is fraud*)
lemma L2: "\<lfloor>(\<^bold>\<not>(BELIEF Trump (isFraud birthCertObama)))\<rfloor>"
  sledgehammer (*proof found*)
  using L1 TrumpBelievesWhatHeSays TrumpsBeliefIsTruth by auto

(*birthCertObama is no fraud*)
lemma "\<lfloor>(\<^bold>\<not>(isFraud birthCertObama))\<rfloor>"
 sledgehammer (*proof found*)
 using L2 TrumpsBeliefIsTruth by auto

axiomatization where TrumpBelievesCredibleSources:
 "\<lfloor>\<^bold>\<forall>\<^sup>\<sigma>s. (\<^bold>\<exists>x. source x \<^bold>\<and> credible x \<^bold>\<and> SAYS x s) \<^bold>\<rightarrow> BELIEF Trump s\<rfloor>"

(*Trump is an inconsistent, irrational agent*)
lemma False
  sledgehammer (*proof found*)
 by (metis L2 TrumpBelievesCredibleSources TrumpBelievesWhatHeSays
           TrumpsBeliefIsTruth Tweet1)

end