(*<*)
theory Syntax
  imports "Nominal2.Nominal2" "Nominal-Utils"
begin
  (*>*)

chapter \<open>Syntax\<close>

text \<open>Syntax of MiniSail programs and the contexts we use in judgements.\<close>

section \<open>Program Syntax\<close>

subsection \<open>AST Datatypes\<close>

type_synonym num_nat = nat

atom_decl x  (* Immutable variables*)
atom_decl u  (* Mutable variables *)
atom_decl bv  (* Basic-type variables *)

type_synonym f = string  (* Function name *)
type_synonym dc = string (* Data constructor *)
type_synonym tyid = string

text \<open>Basic types. Types without refinement constraints\<close>
nominal_datatype "b" =
  B_int | B_bool | B_id tyid
| B_pair b b  ("[ _ , _ ]\<^sup>b")
| B_unit | B_bitvec | B_var bv
| B_app tyid b

nominal_datatype bit = BitOne | BitZero

text  \<open> Literals \<close>
nominal_datatype "l" =
  L_num "int" | L_true | L_false | L_unit  | L_bitvec "bit list"

text  \<open> Values. We include a type identifier, tyid, in the literal for constructors
to make typing and well-formedness checking easier \<close>

nominal_datatype "v" =
  V_lit "l"        ( "[ _ ]\<^sup>v")
  | V_var "x"        ( "[ _ ]\<^sup>v")
  | V_pair "v" "v"   ( "[ _ , _ ]\<^sup>v")
  | V_cons tyid dc "v"
  | V_consp tyid dc b "v"

text \<open> Binary Operations \<close>
nominal_datatype "opp" = Plus ( "plus") | LEq ("leq") | Eq ("eq")

text \<open> Expressions \<close>
nominal_datatype "e" =
  AE_val "v"           ( "[ _ ]\<^sup>e"       )
  | AE_app "f" "v"       ( "[ _ ( _ ) ]\<^sup>e" )
  | AE_appP  "f" "b" "v" ( "[_ [ _ ] ( _ )]\<^sup>e" )
  | AE_op "opp" "v" "v"  ( "[ _ _ _ ]\<^sup>e"  )
  | AE_concat v v        ( "[ _ @@ _ ]\<^sup>e" )
  | AE_fst "v"           ( "[#1_ ]\<^sup>e"    )
  | AE_snd "v"           ( "[#2_ ]\<^sup>e"     )
  | AE_mvar "u"          ( "[ _ ]\<^sup>e"      )
  | AE_len "v"           ( "[| _ |]\<^sup>e"    )
  | AE_split "v" "v"     ( "[ _ / _ ]\<^sup>e"  )

text \<open> Expressions for constraints\<close>
nominal_datatype "ce" =
  CE_val "v"           ( "[ _ ]\<^sup>c\<^sup>e"      )
  | CE_op "opp" "ce" "ce"  ( "[ _ _ _ ]\<^sup>c\<^sup>e"  )
  | CE_concat ce ce        ( "[ _ @@ _ ]\<^sup>c\<^sup>e" )
  | CE_fst "ce"           ( "[#1_]\<^sup>c\<^sup>e"      )
  | CE_snd "ce"           ( "[#2_]\<^sup>c\<^sup>e"      )
  | CE_len "ce"           ( "[| _ |]\<^sup>c\<^sup>e"    )

text  \<open> Constraints \<close>
nominal_datatype "c" =
  C_true          ( "TRUE" [] 50 )
  | C_false         ( "FALSE" [] 50 )
  | C_conj "c" "c"  ("_  AND  _ " [50, 50] 50)
  | C_disj "c" "c"  ("_ OR _ " [50,50] 50)
  | C_not "c"       ( "\<not> _ " [] 50 )
  | C_imp "c" "c"   ("_  IMP  _ " [50, 50] 50)
  | C_eq "ce" "ce"  ("_  ==  _ " [50, 50] 50)

text  \<open> Refined types \<close>
nominal_datatype "\<tau>" =
  T_refined_type  x::x b c::c   binds x in c   ("\<lbrace> _ : _  | _ \<rbrace>" [50, 50] 1000)

text \<open> Statements \<close>

nominal_datatype
  s =
  AS_val v                             ( "[_]\<^sup>s")
  | AS_let x::x  e s::s binds x in s     ( "(LET _ = _ IN _)")
  | AS_let2 x::x \<tau>  s s::s binds x in s  ( "(LET _ : _ = _ IN _)")
  | AS_if v s s                          ( "(IF _ THEN _ ELSE _)" [0, 61, 0] 61)
  | AS_var u::u \<tau> v s::s  binds u in s   ( "(VAR _ : _ = _ IN _)")
  | AS_assign u  v                       ( "(_ ::= _)")
  | AS_match v branch_list               ( "(MATCH _ WITH { _ })")
  | AS_while s s                         ( "(WHILE _ DO { _ } )" [0, 0] 61)
  | AS_seq s s                           ( "( _ ;; _ )"  [1000, 61] 61)
  | AS_assert c s                        ( "(ASSERT _ IN _ )" )
    and branch_s =
    AS_branch dc x::x s::s binds x in s  ( "( _ _ \<Rightarrow> _ )")
    and branch_list =
    AS_final  branch_s                   ( "{ _ }" )
  | AS_cons  branch_s branch_list        ( "( _ | _  )")

text \<open> Function and union type definitions \<close>

nominal_datatype "fun_typ"  =
  AF_fun_typ x::x "b" c::c \<tau>::\<tau> s::s binds x in c \<tau> s

nominal_datatype "fun_typ_q" =
  AF_fun_typ_some bv::bv ft::fun_typ binds bv in ft
  | AF_fun_typ_none fun_typ

nominal_datatype "fun_def" =  AF_fundef f fun_typ_q

nominal_datatype "type_def" =
  AF_typedef string "(string * \<tau>) list"
  |  AF_typedef_poly string bv::bv dclist::"(string * \<tau>) list"  binds bv in dclist

lemma check_typedef_poly:
  "AF_typedef_poly ''option'' bv [ (''None'', \<lbrace> zz : B_unit | TRUE \<rbrace>), (''Some'', \<lbrace> zz : B_var bv | TRUE \<rbrace>) ] =
    AF_typedef_poly ''option'' bv2 [ (''None'', \<lbrace> zz : B_unit | TRUE \<rbrace>), (''Some'', \<lbrace> zz : B_var bv2 | TRUE \<rbrace>) ]"
  by auto

nominal_datatype "var_def" =  AV_def u \<tau> v

text  \<open> Programs \<close>
nominal_datatype "p" =
  AP_prog "type_def list" "fun_def list" "var_def list" "s" ("PROG _ _ _ _")

declare l.supp [simp] v.supp [simp]  e.supp [simp] s_branch_s_branch_list.supp [simp]  \<tau>.supp [simp] c.supp [simp] b.supp[simp]

subsection \<open>Lemmas\<close>

text \<open>These lemmas deal primarily with freshness and alpha-equivalence\<close>

subsubsection \<open>Atoms\<close>

lemma x_not_in_u_atoms[simp]:
  fixes u::u and x::x and us::"u set"
  shows "atom x \<notin> atom`us"
  by (simp add: image_iff)

lemma x_fresh_u[simp]:
  fixes u::u and x::x
  shows "atom x \<sharp> u"
  by auto

lemma x_not_in_b_set[simp]:
  fixes  x::x and bs::"bv fset"
  shows "atom x \<notin> supp bs"
  by(induct bs,auto, simp add: supp_finsert supp_at_base)

lemma x_fresh_b[simp]:
  fixes  x::x and b::b
  shows "atom x \<sharp> b"
  apply (induct b rule: b.induct, auto simp: pure_supp)
  using pure_supp fresh_def by blast+

lemma x_fresh_bv[simp]:
  fixes  x::x and bv::bv
  shows "atom x \<sharp> bv"
  using fresh_def supp_at_base by auto

lemma u_not_in_x_atoms[simp]:
  fixes u::u and x::x and xs::"x set"
  shows "atom u \<notin> atom`xs"
  by (simp add: image_iff)

lemma bv_not_in_x_atoms[simp]:
  fixes bv::bv and x::x and xs::"x set"
  shows "atom bv \<notin> atom`xs"
  by (simp add: image_iff)

lemma u_not_in_b_atoms[simp]:
  fixes b :: b and u::u
  shows "atom u \<notin> supp b"
  by (induct b rule: b.induct,auto simp: pure_supp supp_at_base)

lemma u_not_in_b_set[simp]:
  fixes  u::u and bs::"bv fset"
  shows "atom u \<notin> supp bs"
  by(induct bs, auto simp add: supp_at_base supp_finsert)

lemma u_fresh_b[simp]:
  fixes  x::u and b::b
  shows "atom x \<sharp> b"
  by(induct b rule: b.induct, auto simp: pure_fresh )

lemma supp_b_v_disjoint:
  fixes x::x and bv::bv
  shows "supp (V_var x) \<inter> supp (B_var bv) = {}"
  by (simp add: supp_at_base)

lemma supp_b_u_disjoint[simp]:
  fixes b::b and u::u
  shows "supp u \<inter> supp b = {}"
  by(nominal_induct b rule:b.strong_induct,(auto simp add: pure_supp b.supp supp_at_base)+)

lemma u_fresh_bv[simp]:
  fixes  u::u and b::bv
  shows "atom u \<sharp> b"
  using fresh_at_base by simp

subsubsection \<open>Basic Types\<close>

nominal_function b_of :: "\<tau> \<Rightarrow> b" where
  "b_of \<lbrace> z : b | c \<rbrace> = b"
     apply(auto,simp add: eqvt_def b_of_graph_aux_def )
  by (meson \<tau>.exhaust)
nominal_termination (eqvt)  by lexicographic_order

lemma supp_b_empty[simp]:
  fixes b :: b and x::x
  shows "atom x \<notin> supp b"
  by (induct b rule: b.induct, auto simp: pure_supp supp_at_base x_not_in_b_set)

lemma flip_b_id[simp]:
  fixes x::x and b::b
  shows "(x \<leftrightarrow> x') \<bullet> b = b"
  by(rule flip_fresh_fresh, auto simp add: fresh_def)

lemma flip_x_b_cancel[simp]:
  fixes x::x and y::x  and b::b and bv::bv
  shows "(x \<leftrightarrow> y) \<bullet> b = b" and "(x \<leftrightarrow> y) \<bullet> bv = bv"
  using flip_b_id  apply simp
  by (metis b.eq_iff(7) b.perm_simps(7) flip_b_id)

lemma flip_bv_x_cancel[simp]:
  fixes bv::bv and z::bv and x::x
  shows "(bv \<leftrightarrow> z) \<bullet> x = x" using flip_fresh_fresh[of bv x z] fresh_at_base by auto

lemma flip_bv_u_cancel[simp]:
  fixes bv::bv and z::bv and x::u
  shows "(bv \<leftrightarrow> z) \<bullet> x = x" using flip_fresh_fresh[of bv x z] fresh_at_base by auto

subsubsection \<open>Literals\<close>

lemma supp_bitvec_empty:
  fixes bv::"bit list"
  shows "supp bv = {}"
proof(induct bv)
  case Nil
  then show ?case using supp_Nil by auto
next
  case (Cons a bv)
  then show ?case using supp_Cons  bit.supp
    by (metis (mono_tags, opaque_lifting) bit.strong_exhaust l.supp(5) sup_bot.right_neutral)
qed

lemma bitvec_pure[simp]:
  fixes bv::"bit list" and x::x
  shows "atom x \<sharp> bv" using fresh_def supp_bitvec_empty by auto

lemma supp_l_empty[simp]:
  fixes l:: l
  shows "supp (V_lit l) = {}"
  by(nominal_induct l rule: l.strong_induct,
      auto simp add: l.strong_exhaust pure_supp v.fv_defs supp_bitvec_empty)

lemma type_l_nosupp[simp]:
  fixes x::x and l::l
  shows "atom x \<notin> supp (\<lbrace> z : b  |  [[z]\<^sup>v]\<^sup>c\<^sup>e ==  [[l]\<^sup>v]\<^sup>c\<^sup>e \<rbrace>)"
  using supp_at_base supp_l_empty ce.supp(1) c.supp \<tau>.supp by force

lemma flip_bitvec0:
  fixes x::"bit list"
  assumes "atom c \<sharp> (z, x, z')"
  shows "(z \<leftrightarrow> c) \<bullet> x = (z' \<leftrightarrow> c) \<bullet> x"
proof -
  have "atom z \<sharp> x" and "atom z' \<sharp> x"
    using flip_fresh_fresh assms supp_bitvec_empty fresh_def by blast+
  moreover have "atom c \<sharp> x" using  supp_bitvec_empty fresh_def by auto
  ultimately show ?thesis  using assms flip_fresh_fresh by metis
qed

lemma flip_bitvec:
  assumes "atom c \<sharp> (z, L_bitvec x, z')"
  shows "(z \<leftrightarrow> c) \<bullet> x = (z' \<leftrightarrow> c) \<bullet> x"
proof -
  have "atom z \<sharp> x" and "atom z' \<sharp> x"
    using flip_fresh_fresh assms supp_bitvec_empty fresh_def by blast+
  moreover have "atom c \<sharp> x" using  supp_bitvec_empty fresh_def by auto
  ultimately show ?thesis  using assms flip_fresh_fresh by metis
qed

lemma type_l_eq:
  shows "\<lbrace> z : b  |  [[z]\<^sup>v]\<^sup>c\<^sup>e == [V_lit l]\<^sup>c\<^sup>e \<rbrace> = (\<lbrace> z' : b  |  [[z']\<^sup>v]\<^sup>c\<^sup>e == [V_lit l]\<^sup>c\<^sup>e \<rbrace>)"
  by(auto,nominal_induct l rule: l.strong_induct,auto, metis permute_pure, auto simp add: flip_bitvec)

lemma flip_l_eq:
  fixes x::l
  shows "(z \<leftrightarrow> c) \<bullet> x = (z' \<leftrightarrow> c) \<bullet> x"
proof -
  have "atom z \<sharp> x" and "atom c \<sharp> x" and "atom z' \<sharp> x"
    using flip_fresh_fresh fresh_def supp_l_empty by fastforce+
  thus ?thesis using flip_fresh_fresh by metis
qed

lemma flip_l_eq1:
  fixes x::l
  assumes  "(z \<leftrightarrow> c) \<bullet> x = (z' \<leftrightarrow> c) \<bullet> x'"
  shows "x' = x"
proof -
  have "atom z \<sharp> x" and "atom c \<sharp> x'" and "atom c \<sharp> x" and "atom z' \<sharp> x'"
    using flip_fresh_fresh fresh_def supp_l_empty by fastforce+
  thus ?thesis using flip_fresh_fresh assms by metis
qed

subsubsection \<open>Types\<close>

lemma flip_base_eq:
  fixes b::b and x::x and y::x
  shows "(x \<leftrightarrow> y) \<bullet> b = b"
  using b.fresh  by (simp add: flip_fresh_fresh fresh_def)

text \<open> Obtain an alpha-equivalent type where the bound variable is fresh in some term t \<close>
lemma has_fresh_z0:
  fixes t::"'b::fs"
  shows "\<exists>z. atom z \<sharp> (c',t) \<and> (\<lbrace>z' : b | c' \<rbrace>) = (\<lbrace> z : b | (z \<leftrightarrow> z' ) \<bullet> c' \<rbrace>)"
proof -
  obtain z::x where fr: "atom z \<sharp> (c',t)" using obtain_fresh by blast
  moreover hence "(\<lbrace> z' : b | c' \<rbrace>) = (\<lbrace> z : b | (z \<leftrightarrow> z') \<bullet> c' \<rbrace>)"
    using \<tau>.eq_iff Abs1_eq_iff
    by (metis flip_commute flip_fresh_fresh fresh_PairD(1))
  ultimately show ?thesis by fastforce
qed

lemma has_fresh_z:
  fixes t::"'b::fs"
  shows "\<exists>z b c. atom z \<sharp> t \<and> \<tau> = \<lbrace> z : b | c \<rbrace>"
proof -
  obtain z' and b and c' where teq: "\<tau> =  (\<lbrace> z' : b | c' \<rbrace>)" using \<tau>.exhaust by blast
  obtain z::x where fr: "atom z \<sharp> (t,c')" using obtain_fresh by blast
  hence "(\<lbrace> z' : b | c' \<rbrace>) = (\<lbrace> z : b | (z \<leftrightarrow> z') \<bullet> c' \<rbrace>)"  using \<tau>.eq_iff Abs1_eq_iff
      flip_commute flip_fresh_fresh fresh_PairD(1)  by (metis fresh_PairD(2))
  hence "atom z \<sharp> t \<and> \<tau> = (\<lbrace> z : b | (z \<leftrightarrow> z') \<bullet> c' \<rbrace>)" using fr teq by force
  thus ?thesis using teq fr by fast
qed

lemma obtain_fresh_z:
  fixes t::"'b::fs"
  obtains z and b and c where "atom z \<sharp> t \<and> \<tau> = \<lbrace> z : b | c \<rbrace>"
  using has_fresh_z by blast

lemma has_fresh_z2:
  fixes t::"'b::fs"
  shows "\<exists>z c. atom z \<sharp> t \<and> \<tau> = \<lbrace> z : b_of \<tau> | c \<rbrace>"
proof -
  obtain z and b and c where "atom z \<sharp> t \<and> \<tau> = \<lbrace> z : b | c \<rbrace>" using obtain_fresh_z by metis
  moreover then have "b_of \<tau> = b" using \<tau>.eq_iff by simp
  ultimately show ?thesis using obtain_fresh_z \<tau>.eq_iff by auto
qed

lemma obtain_fresh_z2:
  fixes t::"'b::fs"
  obtains z and  c where "atom z \<sharp> t \<and> \<tau> = \<lbrace> z : b_of \<tau> | c \<rbrace>"
  using has_fresh_z2 by blast

subsubsection \<open>Values\<close>

lemma u_notin_supp_v[simp]:
  fixes u::u and v::v
  shows "atom u \<notin> supp v"
proof(nominal_induct v rule: v.strong_induct)
  case (V_lit l)
  then show ?case  using supp_l_empty by auto
next
  case (V_var x)
  then show ?case
    by (simp add: supp_at_base)
next
  case (V_pair v1 v2)
  then show ?case by auto
next
  case (V_cons tyid list v)
  then show ?case using pure_supp by auto
next
  case (V_consp tyid list b v)
  then show ?case using pure_supp by auto
qed

lemma u_fresh_xv[simp]:
  fixes u::u and x::x and v::v
  shows "atom u \<sharp>  (x,v)"
proof -
  have "atom u \<sharp> x" using fresh_def by fastforce
  moreover have "atom u \<sharp> v" using fresh_def u_notin_supp_v by metis
  ultimately show ?thesis using fresh_prod2 by auto
qed

text \<open> Part of an effort to make the proofs across inductive cases more uniform by distilling
the non-uniform parts into lemmas like this\<close>
lemma v_flip_eq:
  fixes v::v and va::v and x::x and c::x
  assumes "atom c \<sharp> (v, va)" and "atom c \<sharp> (x, xa, v, va)" and "(x \<leftrightarrow> c) \<bullet> v = (xa \<leftrightarrow> c) \<bullet> va"
  shows "((v = V_lit l \<longrightarrow> (\<exists>l'. va = V_lit l' \<and>  (x \<leftrightarrow> c) \<bullet> l = (xa \<leftrightarrow> c) \<bullet> l'))) \<and>
         ((v = V_var y \<longrightarrow> (\<exists>y'. va = V_var y' \<and>  (x \<leftrightarrow> c) \<bullet> y = (xa \<leftrightarrow> c) \<bullet> y'))) \<and>
         ((v = V_pair vone vtwo \<longrightarrow> (\<exists>v1' v2'. va = V_pair v1' v2' \<and>  (x \<leftrightarrow> c) \<bullet> vone = (xa \<leftrightarrow> c) \<bullet> v1' \<and>  (x \<leftrightarrow> c) \<bullet> vtwo = (xa \<leftrightarrow> c) \<bullet> v2'))) \<and>
         ((v = V_cons tyid dc vone \<longrightarrow> (\<exists>v1'. va = V_cons tyid dc v1'\<and>  (x \<leftrightarrow> c) \<bullet> vone = (xa \<leftrightarrow> c) \<bullet> v1'))) \<and>
         ((v = V_consp tyid dc b vone \<longrightarrow> (\<exists>v1'. va = V_consp tyid dc b v1'\<and>  (x \<leftrightarrow> c) \<bullet> vone = (xa \<leftrightarrow> c) \<bullet> v1')))"
  using assms proof(nominal_induct v rule:v.strong_induct)
  case (V_lit l)
  then show ?case  using assms v.perm_simps
      empty_iff flip_def fresh_def fresh_permute_iff supp_l_empty swap_fresh_fresh v.fresh
    by (metis permute_swap_cancel2 v.distinct)
next
  case (V_var x)
  then show ?case  using assms v.perm_simps
      empty_iff flip_def fresh_def fresh_permute_iff supp_l_empty swap_fresh_fresh v.fresh
    by (metis permute_swap_cancel2 v.distinct)
next
  case (V_pair v1 v2)
  have " (V_pair v1 v2 = V_pair vone vtwo \<longrightarrow> (\<exists>v1' v2'. va = V_pair v1' v2' \<and> (x \<leftrightarrow> c) \<bullet> vone = (xa \<leftrightarrow> c) \<bullet> v1' \<and> (x \<leftrightarrow> c) \<bullet> vtwo = (xa \<leftrightarrow> c) \<bullet> v2'))" proof
    assume "V_pair v1 v2= V_pair vone vtwo"
    thus  "(\<exists>v1' v2'. va = V_pair v1' v2' \<and> (x \<leftrightarrow> c) \<bullet> vone = (xa \<leftrightarrow> c) \<bullet> v1' \<and> (x \<leftrightarrow> c) \<bullet> vtwo = (xa \<leftrightarrow> c) \<bullet> v2')"
      using V_pair assms
      by (metis (no_types, opaque_lifting) flip_def permute_swap_cancel v.perm_simps(3))
  qed
  thus ?case using V_pair by auto
next
  case (V_cons tyid dc v1)
  have " (V_cons tyid dc v1 = V_cons tyid dc vone \<longrightarrow> (\<exists> v1'. va = V_cons tyid dc  v1' \<and> (x \<leftrightarrow> c) \<bullet> vone = (xa \<leftrightarrow> c) \<bullet> v1'))" proof
    assume as: "V_cons tyid dc v1 = V_cons tyid dc  vone"
    hence "(x \<leftrightarrow> c) \<bullet>  (V_cons tyid dc  vone) =  V_cons tyid dc ((x \<leftrightarrow> c) \<bullet> vone)" proof -
      have "(x \<leftrightarrow> c)  \<bullet> dc = dc" using pure_permute_id  by metis
      moreover have "(x \<leftrightarrow> c)  \<bullet> tyid = tyid" using pure_permute_id  by metis
      ultimately show ?thesis using v.perm_simps(4) by simp
    qed
    then obtain v1' where "(xa \<leftrightarrow> c) \<bullet> va = V_cons tyid dc v1' \<and> (x \<leftrightarrow> c) \<bullet> vone = v1'" using assms V_cons
      using as by fastforce
    hence " va = V_cons tyid dc ((xa \<leftrightarrow> c) \<bullet> v1') \<and> (x \<leftrightarrow> c) \<bullet> vone = v1'" using permute_flip_cancel empty_iff flip_def fresh_def supp_b_empty swap_fresh_fresh
      by (metis pure_fresh v.perm_simps(4))

    thus  "(\<exists>v1'. va = V_cons tyid dc  v1' \<and> (x \<leftrightarrow> c) \<bullet> vone = (xa \<leftrightarrow> c) \<bullet> v1')"
      using V_cons assms by simp
  qed
  thus ?case using V_cons by auto
next
  case (V_consp tyid dc b v1)
  have " (V_consp tyid dc b v1 = V_consp tyid dc b vone \<longrightarrow> (\<exists> v1'. va = V_consp tyid dc  b v1' \<and> (x \<leftrightarrow> c) \<bullet> vone = (xa \<leftrightarrow> c) \<bullet> v1'))" proof
    assume as: "V_consp tyid dc b v1 = V_consp tyid dc b vone"
    hence "(x \<leftrightarrow> c) \<bullet>  (V_consp tyid dc  b vone) =  V_consp tyid dc b ((x \<leftrightarrow> c) \<bullet> vone)" proof -
      have "(x \<leftrightarrow> c)  \<bullet> dc = dc" using pure_permute_id  by metis
      moreover have "(x \<leftrightarrow> c)  \<bullet> tyid = tyid" using pure_permute_id  by metis
      ultimately show ?thesis using v.perm_simps(4) by simp
    qed
    then obtain v1' where "(xa \<leftrightarrow> c) \<bullet> va = V_consp tyid dc b v1' \<and> (x \<leftrightarrow> c) \<bullet> vone = v1'" using assms V_consp
      using as by fastforce
    hence " va = V_consp tyid dc b ((xa \<leftrightarrow> c) \<bullet> v1') \<and> (x \<leftrightarrow> c) \<bullet> vone = v1'" using permute_flip_cancel empty_iff flip_def fresh_def supp_b_empty swap_fresh_fresh
        pure_fresh v.perm_simps
      by (metis (mono_tags, opaque_lifting))
    thus   "(\<exists>v1'. va = V_consp tyid dc  b v1' \<and> (x \<leftrightarrow> c) \<bullet> vone = (xa \<leftrightarrow> c) \<bullet> v1')"
      using V_consp assms by simp
  qed
  thus ?case using V_consp by auto
qed

lemma flip_eq:
  fixes x::x and xa::x and s::"'a::fs" and sa::"'a::fs"
  assumes "(\<forall>c. atom c \<sharp> (s, sa) \<longrightarrow> atom c \<sharp> (x, xa, s, sa) \<longrightarrow> (x \<leftrightarrow> c) \<bullet> s = (xa \<leftrightarrow> c) \<bullet> sa)" and "x \<noteq> xa"
  shows "(x \<leftrightarrow> xa) \<bullet> s = sa"
proof -
  have  " ([[atom x]]lst. s = [[atom xa]]lst. sa)" using assms Abs1_eq_iff_all by simp
  hence  "(xa = x \<and> sa = s \<or> xa \<noteq> x \<and> sa = (xa \<leftrightarrow> x) \<bullet> s \<and> atom xa \<sharp> s)" using assms Abs1_eq_iff[of xa sa x s] by simp
  thus ?thesis using assms
    by (metis flip_commute)
qed

lemma  swap_v_supp:
  fixes v::v and d::x and z::x
  assumes "atom d \<sharp> v"
  shows "supp ((z \<leftrightarrow> d ) \<bullet> v) \<subseteq> supp v - { atom z } \<union> { atom d}"
  using assms
proof(nominal_induct v rule:v.strong_induct)
  case (V_lit l)
  then show ?case using l.supp by (metis supp_l_empty empty_subsetI l.strong_exhaust pure_supp supp_eqvt v.supp)
next
  case (V_var x)
  hence "d \<noteq> x" using fresh_def by fastforce
  thus ?case apply(cases "z = x")  using   supp_at_base V_var \<open>d\<noteq>x\<close> by fastforce+
next
  case (V_cons tyid dc v)
  show ?case using v.supp(4) pure_supp
    using V_cons.hyps V_cons.prems fresh_def by auto
next
  case (V_consp tyid dc b v)
  show ?case using v.supp(4) pure_supp
    using V_consp.hyps V_consp.prems fresh_def by auto
qed(force+)

subsubsection \<open>Expressions\<close>

lemma  swap_e_supp:
  fixes e::e and d::x and z::x
  assumes "atom d \<sharp> e"
  shows "supp ((z \<leftrightarrow> d ) \<bullet> e) \<subseteq> supp e - { atom z } \<union> { atom d}"
  using assms
proof(nominal_induct e rule:e.strong_induct)
  case (AE_val v)
  then show ?case using swap_v_supp by simp
next
  case (AE_app f v)
  then show ?case using swap_v_supp  by (simp add: pure_supp)
next
  case (AE_appP b f v)
  hence df: "atom d \<sharp> v" using fresh_def e.supp by force
  have  "supp ((z \<leftrightarrow> d ) \<bullet> (AE_appP b f v)) =  supp (AE_appP b f ((z \<leftrightarrow> d ) \<bullet> v))" using  e.supp
    by (metis b.eq_iff(3) b.perm_simps(3) e.perm_simps(3) flip_b_id)
  also have "... = supp b \<union> supp f \<union> supp ((z \<leftrightarrow> d ) \<bullet> v)" using e.supp by auto
  also have "... \<subseteq>  supp b \<union> supp f \<union> supp v  - { atom z } \<union> { atom d}" using swap_v_supp[OF df] pure_supp  by auto
  finally show ?case using e.supp by auto
next
  case (AE_op opp v1 v2)
  hence df: "atom d \<sharp> v1 \<and> atom d \<sharp> v2" using fresh_def e.supp by force
  have "((z \<leftrightarrow> d ) \<bullet> (AE_op opp v1 v2)) = AE_op opp ((z \<leftrightarrow> d ) \<bullet> v1) ((z \<leftrightarrow> d ) \<bullet> v2)" using
      e.perm_simps flip_commute opp.perm_simps AE_op opp.strong_exhaust  pure_supp
    by (metis (full_types))

  hence "supp ((z \<leftrightarrow> d) \<bullet> AE_op opp v1 v2) = supp (AE_op opp ((z \<leftrightarrow> d) \<bullet>v1)  ((z \<leftrightarrow> d) \<bullet>v2))" by simp
  also have "... = supp  ((z \<leftrightarrow> d) \<bullet>v1) \<union> supp  ((z \<leftrightarrow> d) \<bullet>v2)" using e.supp
    by (metis (mono_tags, opaque_lifting) opp.strong_exhaust opp.supp sup_bot.left_neutral)
  also have "... \<subseteq> (supp v1 -  { atom z } \<union> { atom d}) \<union>  (supp v2 - { atom z } \<union> { atom d})" using swap_v_supp AE_op df by blast
  finally show ?case using e.supp opp.supp by blast
next
  case (AE_fst v)
  then show ?case   using swap_v_supp by auto
next
  case (AE_snd v)
  then show ?case   using swap_v_supp by auto
next
  case (AE_mvar u)
  then show ?case using
      Diff_empty Diff_insert0 Un_upper1 atom_x_sort flip_def flip_fresh_fresh fresh_def set_eq_subset supp_eqvt swap_set_in_eq
    by (metis sort_of_atom_eq)
next
  case (AE_len v)
  then show ?case   using swap_v_supp by auto
next
  case (AE_concat v1 v2)
  then show ?case   using swap_v_supp by auto
next
  case (AE_split v1 v2)
  then show ?case   using swap_v_supp by auto
qed

lemma  swap_ce_supp:
  fixes e::ce and d::x and z::x
  assumes "atom d \<sharp> e"
  shows "supp ((z \<leftrightarrow> d ) \<bullet> e) \<subseteq> supp e - { atom z } \<union> { atom d}"
  using assms
proof(nominal_induct e rule:ce.strong_induct)
  case (CE_val v)
  then show ?case using swap_v_supp ce.fresh ce.supp by simp
next
  case (CE_op opp v1 v2)
  hence df: "atom d \<sharp> v1 \<and> atom d \<sharp> v2" using fresh_def e.supp by force
  have "((z \<leftrightarrow> d ) \<bullet> (CE_op opp v1 v2)) = CE_op opp ((z \<leftrightarrow> d ) \<bullet> v1) ((z \<leftrightarrow> d ) \<bullet> v2)" using
      ce.perm_simps flip_commute opp.perm_simps CE_op opp.strong_exhaust x_fresh_b pure_supp
    by (metis (full_types))

  hence "supp ((z \<leftrightarrow> d) \<bullet> CE_op opp v1 v2) = supp (CE_op opp ((z \<leftrightarrow> d) \<bullet>v1)  ((z \<leftrightarrow> d) \<bullet>v2))" by simp
  also have "... = supp  ((z \<leftrightarrow> d) \<bullet>v1) \<union> supp  ((z \<leftrightarrow> d) \<bullet>v2)" using ce.supp
    by (metis (mono_tags, opaque_lifting) opp.strong_exhaust opp.supp sup_bot.left_neutral)
  also have "... \<subseteq> (supp v1 -  { atom z } \<union> { atom d}) \<union>  (supp v2 - { atom z } \<union> { atom d})" using swap_v_supp CE_op df by blast
  finally show ?case using ce.supp opp.supp by blast
next
  case (CE_fst v)
  then show ?case   using ce.supp ce.fresh swap_v_supp by auto
next
  case (CE_snd v)
  then show ?case   using ce.supp ce.fresh swap_v_supp by auto
next
  case (CE_len v)
  then show ?case   using ce.supp ce.fresh swap_v_supp by auto
next
  case (CE_concat v1 v2)
  then show ?case using ce.supp ce.fresh swap_v_supp ce.perm_simps
  proof -
    have "\<forall>x v xa. \<not> atom (x::x) \<sharp> (v::v) \<or> supp ((xa \<leftrightarrow> x) \<bullet> v) \<subseteq> supp v - {atom xa} \<union> {atom x}"
      by (meson swap_v_supp) (* 0.0 ms *)
    then show ?thesis
      using CE_concat ce.supp by auto
  qed
qed

lemma  swap_c_supp:
  fixes c::c and d::x and z::x
  assumes "atom d \<sharp> c"
  shows "supp ((z \<leftrightarrow> d ) \<bullet> c) \<subseteq> supp c - { atom z } \<union> { atom d}"
  using assms
proof(nominal_induct c rule:c.strong_induct)
  case (C_eq e1 e2)
  then show ?case using swap_ce_supp by auto
qed(auto+)

lemma type_e_eq:
  assumes "atom z \<sharp> e" and "atom z' \<sharp> e"
  shows "\<lbrace> z : b  |  [[z]\<^sup>v]\<^sup>c\<^sup>e == e \<rbrace> = (\<lbrace> z' : b  |  [[z']\<^sup>v]\<^sup>c\<^sup>e ==  e \<rbrace>)"
  by (auto,metis (full_types) assms(1) assms(2) flip_fresh_fresh fresh_PairD(1) fresh_PairD(2))

lemma type_e_eq2:
  assumes "atom z \<sharp> e" and "atom z' \<sharp> e" and "b=b'"
  shows "\<lbrace> z : b  |  [[z]\<^sup>v]\<^sup>c\<^sup>e == e \<rbrace> = (\<lbrace> z' : b'  |  [[z']\<^sup>v]\<^sup>c\<^sup>e == e \<rbrace>)"
  using assms type_e_eq by fast

lemma e_flip_eq:
  fixes e::e and ea::e
  assumes "atom c \<sharp> (e, ea)" and "atom c \<sharp> (x, xa, e, ea)" and "(x \<leftrightarrow> c) \<bullet> e = (xa \<leftrightarrow> c) \<bullet> ea"
  shows "(e = AE_val w \<longrightarrow> (\<exists>w'. ea = AE_val w' \<and> (x \<leftrightarrow> c) \<bullet> w = (xa \<leftrightarrow> c) \<bullet> w')) \<or>
         (e = AE_op opp v1 v2 \<longrightarrow> (\<exists>v1' v2'. ea = AS_op opp v1' v2' \<and> (x \<leftrightarrow> c) \<bullet> v1 = (xa \<leftrightarrow> c) \<bullet> v1') \<and> (x \<leftrightarrow> c) \<bullet> v2 = (xa \<leftrightarrow> c) \<bullet> v2') \<or>
         (e = AE_fst v \<longrightarrow> (\<exists>v'. ea = AE_fst v' \<and> (x \<leftrightarrow> c) \<bullet> v = (xa \<leftrightarrow> c) \<bullet> v')) \<or>
         (e = AE_snd v \<longrightarrow> (\<exists>v'. ea = AE_snd v' \<and> (x \<leftrightarrow> c) \<bullet> v = (xa \<leftrightarrow> c) \<bullet> v')) \<or>
         (e = AE_len v \<longrightarrow> (\<exists>v'. ea = AE_len v' \<and> (x \<leftrightarrow> c) \<bullet> v = (xa \<leftrightarrow> c) \<bullet> v')) \<or>
         (e = AE_concat v1 v2 \<longrightarrow> (\<exists>v1' v2'. ea = AS_concat v1' v2' \<and> (x \<leftrightarrow> c) \<bullet> v1 = (xa \<leftrightarrow> c) \<bullet> v1') \<and> (x \<leftrightarrow> c) \<bullet> v2 = (xa \<leftrightarrow> c) \<bullet> v2') \<or>
         (e = AE_app f v \<longrightarrow> (\<exists>v'. ea = AE_app f  v' \<and> (x \<leftrightarrow> c) \<bullet> v = (xa \<leftrightarrow> c) \<bullet> v'))"
  by (metis assms e.perm_simps permute_flip_cancel2)

lemma fresh_opp_all:
  fixes opp::opp
  shows "z \<sharp> opp"
  using e.fresh opp.exhaust opp.fresh  by metis

lemma fresh_e_opp_all:
  shows "(z \<sharp> v1 \<and> z \<sharp> v2) = z \<sharp> AE_op opp v1 v2"
  using e.fresh opp.exhaust opp.fresh fresh_opp_all by simp

lemma fresh_e_opp:
  fixes z::x
  assumes "atom z \<sharp> v1 \<and> atom z \<sharp> v2"
  shows "atom z \<sharp> AE_op opp v1 v2"
  using e.fresh opp.exhaust opp.fresh opp.supp  by (metis assms)

subsubsection \<open>Statements\<close>

lemma branch_s_flip_eq:
  fixes v::v and va::v
  assumes "atom c \<sharp> (v, va)" and "atom c \<sharp> (x, xa, v, va)" and "(x \<leftrightarrow> c) \<bullet> s = (xa \<leftrightarrow> c) \<bullet> sa"
  shows "(s = AS_val w \<longrightarrow> (\<exists>w'. sa = AS_val w' \<and> (x \<leftrightarrow> c) \<bullet> w = (xa \<leftrightarrow> c) \<bullet> w')) \<or>
         (s = AS_seq s1 s2 \<longrightarrow> (\<exists>s1' s2'. sa = AS_seq s1' s2' \<and> (x \<leftrightarrow> c) \<bullet> s1 = (xa \<leftrightarrow> c) \<bullet> s1') \<and> (x \<leftrightarrow> c) \<bullet> s2 = (xa \<leftrightarrow> c) \<bullet> s2') \<or>
         (s = AS_if v s1 s2 \<longrightarrow> (\<exists>v' s1' s2'. sa = AS_if seq s1' s2' \<and> (x \<leftrightarrow> c) \<bullet> s1 = (xa \<leftrightarrow> c) \<bullet> s1') \<and> (x \<leftrightarrow> c) \<bullet> s2 = (xa \<leftrightarrow> c) \<bullet> s2' \<and> (x \<leftrightarrow> c) \<bullet> c = (xa \<leftrightarrow> c) \<bullet> v')"
  by (metis assms s_branch_s_branch_list.perm_simps permute_flip_cancel2)

section \<open>Context Syntax\<close>

subsection \<open>Datatypes\<close>

text \<open>Type and function/type definition contexts\<close>
type_synonym \<Phi> = "fun_def list"
type_synonym \<Theta> = "type_def list"
type_synonym \<B> = "bv fset"

datatype \<Gamma> =
  GNil
  | GCons "x*b*c" \<Gamma>  (infixr "#\<^sub>\<Gamma>" 65)

datatype \<Delta> =
  DNil  ("[]\<^sub>\<Delta>")
  | DCons "u*\<tau>" \<Delta>  (infixr "#\<^sub>\<Delta>" 65)

subsection \<open>Functions and Lemmas\<close>

lemma \<Gamma>_induct [case_names GNil GCons] : "P GNil \<Longrightarrow> (\<And>x b c \<Gamma>'. P \<Gamma>' \<Longrightarrow> P ((x,b,c) #\<^sub>\<Gamma> \<Gamma>')) \<Longrightarrow> P \<Gamma>"
proof(induct \<Gamma> rule:\<Gamma>.induct)
  case GNil
  then show ?case by auto
next
  case (GCons x1 x2)
  then obtain x and b and c where "x1=(x,b,c)"  using prod_cases3 by blast
  then show ?case using GCons by presburger
qed

instantiation \<Delta> ::  pt
begin

primrec permute_\<Delta>
  where
    DNil_eqvt:  "p \<bullet> DNil = DNil"
  | DCons_eqvt: "p \<bullet> (x #\<^sub>\<Delta> xs) = p \<bullet> x #\<^sub>\<Delta> p \<bullet> (xs::\<Delta>)"

instance  by standard (induct_tac [!] x, simp_all)
end

lemmas [eqvt] =  permute_\<Delta>.simps

lemma \<Delta>_induct [case_names DNil DCons] : "P DNil \<Longrightarrow> (\<And>u t \<Delta>'. P \<Delta>' \<Longrightarrow> P ((u,t) #\<^sub>\<Delta> \<Delta>')) \<Longrightarrow> P \<Delta>"
proof(induct \<Delta> rule: \<Delta>.induct)
  case DNil
  then show ?case by auto
next
  case (DCons x1 x2)
  then obtain u and t  where "x1=(u,t)"  by fastforce
  then show ?case using DCons by presburger
qed

lemma \<Phi>_induct [case_names PNil PConsNone PConsSome] : "P [] \<Longrightarrow> (\<And>f x b c \<tau> s' \<Phi>'. P \<Phi>' \<Longrightarrow> P ((AF_fundef f (AF_fun_typ_none (AF_fun_typ x b c \<tau> s'))) # \<Phi>')) \<Longrightarrow>
                                                                  (\<And>f bv x b c \<tau> s' \<Phi>'. P \<Phi>' \<Longrightarrow> P ((AF_fundef f (AF_fun_typ_some bv (AF_fun_typ x b c \<tau> s'))) # \<Phi>'))  \<Longrightarrow> P \<Phi>"
proof(induct \<Phi> rule: list.induct)
  case Nil
  then show ?case by auto
next
  case (Cons x1 x2)
  then obtain f and t where ft: "x1 = (AF_fundef f t)"
    by (meson fun_def.exhaust)
  then show ?case proof(nominal_induct t rule:fun_typ_q.strong_induct)
    case (AF_fun_typ_some bv ft)
    then show ?case using Cons ft
      by (metis fun_typ.exhaust)
  next
    case (AF_fun_typ_none ft)
    then show ?case using Cons ft
      by (metis fun_typ.exhaust)
  qed
qed

lemma \<Theta>_induct [case_names TNil AF_typedef AF_typedef_poly] : "P [] \<Longrightarrow> (\<And>tid dclist \<Theta>'. P \<Theta>' \<Longrightarrow> P ((AF_typedef tid dclist) # \<Theta>')) \<Longrightarrow>
                                                                  (\<And>tid bv dclist \<Theta>'. P \<Theta>' \<Longrightarrow> P ((AF_typedef_poly tid bv dclist ) # \<Theta>'))  \<Longrightarrow> P \<Theta>"
proof(induct \<Theta> rule: list.induct)
  case Nil
  then show ?case by auto
next
  case (Cons td T)
  show ?case by(cases td rule: type_def.exhaust, (simp add: Cons)+)
qed

instantiation \<Gamma> ::  pt
begin

primrec permute_\<Gamma>
  where
    GNil_eqvt:  "p \<bullet> GNil = GNil"
  | GCons_eqvt: "p \<bullet> (x #\<^sub>\<Gamma> xs) = p \<bullet> x #\<^sub>\<Gamma> p \<bullet> (xs::\<Gamma>)"

instance by standard (induct_tac [!] x, simp_all)
end

lemmas [eqvt] =  permute_\<Gamma>.simps

lemma G_cons_eqvt[simp]:
  fixes \<Gamma>::\<Gamma>
  shows "p \<bullet> ((x,b,c) #\<^sub>\<Gamma> \<Gamma>) = ((p \<bullet> x,  p \<bullet> b , p \<bullet> c) #\<^sub>\<Gamma> (p \<bullet> \<Gamma> ))" (is "?A = ?B" )
  using Cons_eqvt triple_eqvt  supp_b_empty by simp

lemma G_cons_flip[simp]:
  fixes  x::x and \<Gamma>::\<Gamma>
  shows  "(x\<leftrightarrow>x') \<bullet> ((x'',b,c) #\<^sub>\<Gamma> \<Gamma>) = (((x\<leftrightarrow>x') \<bullet> x'',  b , (x\<leftrightarrow>x') \<bullet> c) #\<^sub>\<Gamma> ((x\<leftrightarrow>x') \<bullet> \<Gamma> ))"
  using Cons_eqvt triple_eqvt  supp_b_empty by auto

lemma G_cons_flip_fresh[simp]:
  fixes  x::x and \<Gamma>::\<Gamma>
  assumes  "atom x \<sharp> (c,\<Gamma>)" and "atom x' \<sharp> (c,\<Gamma>)"
  shows  "(x\<leftrightarrow>x') \<bullet> ((x',b,c) #\<^sub>\<Gamma> \<Gamma>) = ((x,  b , c) #\<^sub>\<Gamma> \<Gamma> )"
  using G_cons_flip flip_fresh_fresh assms by force

lemma G_cons_flip_fresh2[simp]:
  fixes  x::x and \<Gamma>::\<Gamma>
  assumes  "atom x \<sharp> (c,\<Gamma>)" and "atom x' \<sharp> (c,\<Gamma>)"
  shows  "(x\<leftrightarrow>x') \<bullet> ((x,b,c) #\<^sub>\<Gamma> \<Gamma>) = ((x',  b , c) #\<^sub>\<Gamma> \<Gamma> )"
  using G_cons_flip flip_fresh_fresh assms by force

lemma G_cons_flip_fresh3[simp]:
  fixes  x::x and \<Gamma>::\<Gamma>
  assumes  "atom x \<sharp> \<Gamma>" and "atom x' \<sharp> \<Gamma>"
  shows  "(x\<leftrightarrow>x') \<bullet> ((x',b,c) #\<^sub>\<Gamma> \<Gamma>) = ((x,  b , (x\<leftrightarrow>x') \<bullet> c) #\<^sub>\<Gamma> \<Gamma> )"
  using G_cons_flip flip_fresh_fresh assms by force

lemma neq_GNil_conv: "(xs \<noteq> GNil) = (\<exists>y ys. xs = y #\<^sub>\<Gamma> ys)"
  by (induct xs) auto

nominal_function toList :: "\<Gamma> \<Rightarrow> (x*b*c) list" where
  "toList GNil = []"
| "toList (GCons xbc G) = xbc#(toList G)"
       apply (auto, simp add: eqvt_def toList_graph_aux_def )
  using neq_GNil_conv surj_pair by metis
nominal_termination (eqvt)
  by lexicographic_order

nominal_function toSet :: "\<Gamma> \<Rightarrow> (x*b*c) set" where
  "toSet GNil = {}"
| "toSet (GCons xbc G) = {xbc} \<union> (toSet G)"
       apply (auto,simp add: eqvt_def toSet_graph_aux_def )
  using neq_GNil_conv surj_pair by metis
nominal_termination (eqvt)
  by lexicographic_order

nominal_function append_g :: "\<Gamma> \<Rightarrow> \<Gamma> \<Rightarrow> \<Gamma>" (infixr "@" 65) where
  "append_g GNil g = g"
| "append_g (xbc #\<^sub>\<Gamma> g1) g2 = (xbc #\<^sub>\<Gamma> (g1@g2))"
       apply (auto,simp add: eqvt_def append_g_graph_aux_def )
  using neq_GNil_conv surj_pair by metis
nominal_termination (eqvt) by lexicographic_order

nominal_function dom  ::  "\<Gamma> \<Rightarrow> x set"  where
  "dom \<Gamma> = (fst` (toSet \<Gamma>))"
     apply auto
  unfolding  eqvt_def dom_graph_aux_def lfp_eqvt toSet.eqvt by simp
nominal_termination (eqvt) by lexicographic_order

text \<open> Use of this is sometimes mixed in with use of freshness and support for the context however it makes it clear
that for immutable variables, the context is `self-supporting'\<close>

nominal_function atom_dom  ::  "\<Gamma> \<Rightarrow> atom set"  where
  "atom_dom \<Gamma>  = atom`(dom  \<Gamma>)"
     apply auto
  unfolding  eqvt_def atom_dom_graph_aux_def lfp_eqvt toSet.eqvt by simp
nominal_termination (eqvt) by lexicographic_order

subsection \<open>Immutable Variable Context Lemmas\<close>

lemma append_GNil[simp]:
  "GNil @ G = G"
  by simp

lemma append_g_toSetU [simp]: "toSet (G1@G2) = toSet G1 \<union> toSet G2"
  by(induct G1, auto+)

lemma supp_GNil:
  shows "supp GNil = {}"
  by (simp add: supp_def)

lemma supp_GCons:
  fixes xs::\<Gamma>
  shows "supp (x #\<^sub>\<Gamma> xs) = supp x \<union> supp xs"
  by (simp add: supp_def Collect_imp_eq Collect_neg_eq)

lemma atom_dom_eq[simp]:
  fixes G::\<Gamma>
  shows  "atom_dom ((x, b, c) #\<^sub>\<Gamma> G) = atom_dom ((x, b, c') #\<^sub>\<Gamma> G)"
  using atom_dom.simps toSet.simps by simp

lemma dom_append[simp]:
  "atom_dom (\<Gamma>@\<Gamma>') = atom_dom \<Gamma> \<union> atom_dom \<Gamma>'"
  using image_Un append_g_toSetU atom_dom.simps dom.simps by metis

lemma dom_cons[simp]:
  "atom_dom ((x,b,c) #\<^sub>\<Gamma> G) = { atom x } \<union> atom_dom G"
  using image_Un append_g_toSetU atom_dom.simps by auto

lemma fresh_GNil[ms_fresh]:
  shows "a \<sharp> GNil"
  by (simp add: fresh_def supp_GNil)

lemma fresh_GCons[ms_fresh]:
  fixes xs::\<Gamma>
  shows "a \<sharp> (x #\<^sub>\<Gamma> xs) \<longleftrightarrow> a \<sharp> x \<and> a \<sharp> xs"
  by (simp add: fresh_def supp_GCons)

lemma dom_supp_g[simp]:
  "atom_dom G \<subseteq> supp G"
  apply(induct G rule: \<Gamma>_induct,simp)
  using supp_at_base supp_Pair atom_dom.simps supp_GCons by fastforce

lemma fresh_append_g[ms_fresh]:
  fixes xs::\<Gamma>
  shows "a \<sharp> (xs @ ys) \<longleftrightarrow> a \<sharp> xs \<and> a \<sharp> ys"
  by (induct xs) (simp_all add: fresh_GNil fresh_GCons)

lemma append_g_assoc:
  fixes xs::\<Gamma>
  shows  "(xs @ ys) @ zs = xs @ (ys @ zs)"
  by (induct xs) simp_all

lemma append_g_inside:
  fixes xs::\<Gamma>
  shows "xs @ (x #\<^sub>\<Gamma> ys) = (xs @ (x #\<^sub>\<Gamma> GNil)) @ ys"
  by(induct xs,auto+)

lemma finite_\<Gamma>:
  "finite (toSet \<Gamma>)"
  by(induct \<Gamma> rule: \<Gamma>_induct,auto)

lemma supp_\<Gamma>:
  "supp \<Gamma> = supp (toSet \<Gamma>)"
proof(induct \<Gamma> rule: \<Gamma>_induct)
  case GNil
  then show ?case using supp_GNil toSet.simps
    by (simp add: supp_set_empty)
next
  case (GCons x b c \<Gamma>')
  then show ?case using  supp_GCons toSet.simps finite_\<Gamma> supp_of_finite_union
    using supp_of_finite_insert by fastforce
qed

lemma supp_of_subset:
  fixes G::"('a::fs set)"
  assumes "finite G" and "finite G'" and "G \<subseteq> G'"
  shows "supp G \<subseteq> supp G'"
  using supp_of_finite_sets assms  by (metis subset_Un_eq supp_of_finite_union)

lemma supp_weakening:
  assumes "toSet G \<subseteq> toSet G'"
  shows "supp G \<subseteq> supp G'"
  using supp_\<Gamma> finite_\<Gamma> by (simp add: supp_of_subset assms)

lemma fresh_weakening[ms_fresh]:
  assumes "toSet G \<subseteq> toSet G'" and "x \<sharp> G'"
  shows "x \<sharp> G"
proof(rule ccontr)
  assume "\<not> x \<sharp> G"
  hence "x \<in> supp G" using fresh_def by auto
  hence "x \<in> supp G'" using supp_weakening assms by auto
  thus False using fresh_def assms by auto
qed

instance \<Gamma> :: fs
  by (standard, induct_tac x, simp_all add: supp_GNil supp_GCons  finite_supp)

lemma fresh_gamma_elem:
  fixes \<Gamma>::\<Gamma>
  assumes "a \<sharp> \<Gamma>"
    and "e \<in> toSet \<Gamma>"
  shows "a \<sharp> e"
  using assms by(induct \<Gamma>,auto simp add: fresh_GCons)

lemma fresh_gamma_append:
  fixes xs::\<Gamma>
  shows "a \<sharp> (xs @ ys) \<longleftrightarrow> a \<sharp> xs \<and> a \<sharp> ys"
  by (induct xs, simp_all add: fresh_GNil fresh_GCons)

lemma supp_triple[simp]:
  shows "supp (x, y, z) = supp x \<union> supp y \<union> supp z"
proof -
  have "supp (x,y,z) = supp (x,(y,z))"  by auto
  hence "supp (x,y,z) = supp x \<union> (supp y  \<union> supp z)" using supp_Pair by metis
  thus ?thesis by auto
qed

lemma supp_append_g:
  fixes xs::\<Gamma>
  shows "supp (xs @ ys) = supp xs \<union> supp ys"
  by(induct xs,auto simp add: supp_GNil supp_GCons )

lemma fresh_in_g[simp]:
  fixes \<Gamma>::\<Gamma> and x'::x
  shows "atom x' \<sharp> \<Gamma>' @ (x, b0, c0) #\<^sub>\<Gamma> \<Gamma> = (atom x' \<notin> supp \<Gamma>' \<union> supp x \<union> supp b0 \<union> supp c0 \<union> supp \<Gamma>)"
proof -
  have  "atom x' \<sharp> \<Gamma>' @ (x, b0, c0) #\<^sub>\<Gamma> \<Gamma> = (atom x' \<notin> supp (\<Gamma>' @((x,b0,c0) #\<^sub>\<Gamma> \<Gamma>)))"
    using fresh_def by auto
  also have "... = (atom x' \<notin> supp \<Gamma>' \<union> supp ((x,b0,c0) #\<^sub>\<Gamma> \<Gamma>))" using supp_append_g by fast
  also have "... = (atom x' \<notin> supp \<Gamma>' \<union> supp x \<union> supp b0 \<union> supp c0 \<union> supp \<Gamma>)" using supp_GCons supp_append_g supp_triple  by auto
  finally show ?thesis by fast
qed

lemma fresh_suffix[ms_fresh]:
  fixes \<Gamma>::\<Gamma>
  assumes "atom x \<sharp> \<Gamma>'@\<Gamma>"
  shows "atom x \<sharp> \<Gamma>"
  using assms by(induct  \<Gamma>' rule: \<Gamma>_induct, auto simp add: append_g.simps fresh_GCons)

lemma not_GCons_self [simp]:
  fixes xs::\<Gamma>
  shows "xs \<noteq> x #\<^sub>\<Gamma> xs"
  by (induct xs) auto

lemma not_GCons_self2 [simp]:
  fixes xs::\<Gamma>
  shows "x #\<^sub>\<Gamma> xs \<noteq> xs"
  by (rule not_GCons_self [symmetric])

lemma fresh_restrict:
  fixes y::x and \<Gamma>::\<Gamma>
  assumes  "atom y \<sharp>  (\<Gamma>' @ (x, b, c) #\<^sub>\<Gamma> \<Gamma>)"
  shows "atom y \<sharp> (\<Gamma>'@\<Gamma>)"
  using assms by(induct \<Gamma>' rule: \<Gamma>_induct, auto simp add:fresh_GCons fresh_GNil  )

lemma fresh_dom_free:
  assumes "atom x \<sharp> \<Gamma>"
  shows "(x,b,c) \<notin> toSet \<Gamma>"
  using assms proof(induct \<Gamma> rule: \<Gamma>_induct)
  case GNil
  then show ?case by auto
next
  case (GCons x' b' c' \<Gamma>')
  hence "x\<noteq>x'" using fresh_def fresh_GCons fresh_Pair supp_at_base by blast
  moreover have "atom x \<sharp> \<Gamma>'" using fresh_GCons GCons by auto
  ultimately show ?case using toSet.simps GCons by auto
qed

lemma \<Gamma>_set_intros: "x \<in> toSet ( x #\<^sub>\<Gamma> xs)" and "y \<in> toSet xs \<Longrightarrow> y \<in> toSet (x #\<^sub>\<Gamma> xs)"
  by simp+

lemma fresh_dom_free2:
  assumes "atom x \<notin> atom_dom \<Gamma>"
  shows "(x,b,c) \<notin> toSet \<Gamma>"
  using assms proof(induct \<Gamma> rule: \<Gamma>_induct)
  case GNil
  then show ?case by auto
next
  case (GCons x' b' c' \<Gamma>')
  hence "x\<noteq>x'" using fresh_def fresh_GCons fresh_Pair supp_at_base by auto
  moreover have "atom x \<notin> atom_dom \<Gamma>'" using fresh_GCons GCons by auto
  ultimately show ?case using toSet.simps GCons by auto
qed

subsection \<open>Mutable Variable Context Lemmas\<close>

lemma supp_DNil:
  shows "supp DNil = {}"
  by (simp add: supp_def)

lemma supp_DCons:
  fixes xs::\<Delta>
  shows "supp (x #\<^sub>\<Delta> xs) = supp x \<union> supp xs"
  by (simp add: supp_def Collect_imp_eq Collect_neg_eq)

lemma fresh_DNil[ms_fresh]:
  shows "a \<sharp> DNil"
  by (simp add: fresh_def supp_DNil)

lemma fresh_DCons[ms_fresh]:
  fixes xs::\<Delta>
  shows "a \<sharp> (x #\<^sub>\<Delta> xs) \<longleftrightarrow> a \<sharp> x \<and> a \<sharp> xs"
  by (simp add: fresh_def supp_DCons)

instance \<Delta> :: fs
  by (standard, induct_tac x, simp_all add: supp_DNil supp_DCons  finite_supp)

subsection \<open>Lookup Functions\<close>

nominal_function lookup :: "\<Gamma> \<Rightarrow> x \<Rightarrow> (b*c) option" where
  "lookup GNil x = None"
| "lookup ((x,b,c)#\<^sub>\<Gamma>G) y = (if x=y then Some (b,c) else lookup G y)"
  by (auto,simp add: eqvt_def lookup_graph_aux_def, metis neq_GNil_conv surj_pair)
nominal_termination (eqvt) by lexicographic_order

nominal_function replace_in_g :: "\<Gamma> \<Rightarrow> x \<Rightarrow> c \<Rightarrow> \<Gamma>"  ("_[_\<longmapsto>_]" [1000,0,0] 200) where
  "replace_in_g GNil _ _ = GNil"
| "replace_in_g ((x,b,c)#\<^sub>\<Gamma>G) x' c' = (if x=x' then ((x,b,c')#\<^sub>\<Gamma>G) else (x,b,c)#\<^sub>\<Gamma>(replace_in_g G x' c'))"
       apply(auto,simp add: eqvt_def replace_in_g_graph_aux_def)
  using surj_pair \<Gamma>.exhaust by metis
nominal_termination (eqvt) by lexicographic_order

text \<open> Functions for looking up data-constructors in the Pi context \<close>

nominal_function lookup_fun :: "\<Phi> \<Rightarrow> f  \<Rightarrow> fun_def option" where
  "lookup_fun [] g = None"
|  "lookup_fun ((AF_fundef f ft)#\<Pi>) g = (if (f=g) then Some (AF_fundef f ft) else lookup_fun \<Pi> g)"
       apply(auto,simp add: eqvt_def lookup_fun_graph_aux_def )
  by (metis fun_def.exhaust neq_Nil_conv)
nominal_termination (eqvt)  by lexicographic_order

nominal_function lookup_td :: "\<Theta> \<Rightarrow> string  \<Rightarrow> type_def option" where
  "lookup_td [] g = None"
|  "lookup_td ((AF_typedef s lst ) # (\<Theta>::\<Theta>)) g = (if (s = g) then Some (AF_typedef s lst ) else lookup_td \<Theta> g)"
|  "lookup_td ((AF_typedef_poly s bv lst ) # (\<Theta>::\<Theta>)) g = (if (s = g) then Some (AF_typedef_poly s bv lst ) else lookup_td \<Theta> g)"
          apply(auto,simp add: eqvt_def lookup_td_graph_aux_def )
  by (metis type_def.exhaust neq_Nil_conv)
nominal_termination (eqvt)  by lexicographic_order

nominal_function name_of_type  ::"type_def \<Rightarrow> f "  where
  "name_of_type (AF_typedef f _ ) = f"
| "name_of_type (AF_typedef_poly f _ _) = f"
       apply(auto,simp add: eqvt_def name_of_type_graph_aux_def )
  using type_def.exhaust by blast
nominal_termination (eqvt)  by lexicographic_order

nominal_function name_of_fun  ::"fun_def \<Rightarrow> f "  where
  "name_of_fun  (AF_fundef f ft) = f"
     apply(auto,simp add: eqvt_def name_of_fun_graph_aux_def )
  using fun_def.exhaust by blast
nominal_termination (eqvt)  by lexicographic_order

nominal_function remove2 :: "'a::pt \<Rightarrow> 'a list \<Rightarrow> 'a list" where
  "remove2 x [] = []" |
  "remove2 x (y # xs) = (if x = y then xs else y # remove2 x xs)"
  by (simp add: eqvt_def remove2_graph_aux_def,auto+,meson list.exhaust)
nominal_termination (eqvt)  by lexicographic_order

nominal_function base_for_lit :: "l \<Rightarrow> b" where
  "base_for_lit (L_true) = B_bool "
| "base_for_lit (L_false) = B_bool "
| "base_for_lit (L_num n) = B_int "
| "base_for_lit (L_unit) = B_unit "
| "base_for_lit (L_bitvec v) = B_bitvec"
                   apply (auto simp: eqvt_def base_for_lit_graph_aux_def )
  using l.strong_exhaust by blast
nominal_termination (eqvt) by lexicographic_order

lemma neq_DNil_conv: "(xs \<noteq> DNil) = (\<exists>y ys. xs = y #\<^sub>\<Delta> ys)"
  by (induct xs) auto

nominal_function setD :: "\<Delta> \<Rightarrow> (u*\<tau>) set" where
  "setD DNil = {}"
| "setD (DCons xbc G) = {xbc} \<union> (setD G)"
       apply (auto,simp add: eqvt_def setD_graph_aux_def )
  using neq_DNil_conv surj_pair by metis
nominal_termination (eqvt) by lexicographic_order

lemma eqvt_triple:
  fixes y::"'a::at" and ya::"'a::at" and xa::"'c::at" and va::"'d::fs" and s::s and sa::s and f::"s*'c*'d \<Rightarrow> s"
  assumes "atom y \<sharp> (xa, va)" and "atom ya \<sharp> (xa, va)" and
    "\<forall>c. atom c \<sharp> (s, sa) \<longrightarrow> atom c \<sharp> (y, ya, s, sa) \<longrightarrow> (y \<leftrightarrow> c) \<bullet> s = (ya \<leftrightarrow> c) \<bullet> sa"
    and "eqvt_at f (s,xa,va)" and "eqvt_at f (sa,xa,va)" and
    "atom c \<sharp> (s, va, xa, sa)" and "atom c \<sharp> (y, ya, f (s, xa, va), f (sa, xa, va))"
  shows "(y \<leftrightarrow> c) \<bullet> f (s, xa, va) =  (ya \<leftrightarrow> c) \<bullet> f (sa, xa, va)"
proof -
  have " (y \<leftrightarrow> c) \<bullet> f (s, xa, va) = f ( (y \<leftrightarrow> c) \<bullet> (s,xa,va))" using assms eqvt_at_def by metis
  also have "... = f ( (y \<leftrightarrow> c) \<bullet> s, (y \<leftrightarrow> c) \<bullet> xa ,(y \<leftrightarrow> c) \<bullet> va)" by auto
  also have "... = f ( (ya \<leftrightarrow> c) \<bullet> sa, (ya \<leftrightarrow> c) \<bullet> xa ,(ya \<leftrightarrow> c) \<bullet> va)" proof -
    have " (y \<leftrightarrow> c) \<bullet> s = (ya \<leftrightarrow> c) \<bullet> sa" using assms Abs1_eq_iff_all by auto
    moreover have  "((y \<leftrightarrow> c) \<bullet> xa) =  ((ya \<leftrightarrow> c) \<bullet> xa)" using assms flip_fresh_fresh fresh_prodN by metis
    moreover have  "((y \<leftrightarrow> c) \<bullet> va) =  ((ya \<leftrightarrow> c) \<bullet> va)" using assms flip_fresh_fresh fresh_prodN by metis
    ultimately show ?thesis by auto
  qed
  also have "... =  f ( (ya \<leftrightarrow> c) \<bullet> (sa,xa,va))" by auto
  finally show ?thesis using assms eqvt_at_def by metis
qed

section \<open>Functions for bit list/vectors\<close>

inductive split :: "int \<Rightarrow> bit list \<Rightarrow> bit list * bit list \<Rightarrow> bool" where
  "split 0 xs ([], xs)"
| "split m xs (ys,zs) \<Longrightarrow> split (m+1) (x#xs) ((x # ys), zs)"
equivariance split
nominal_inductive split .

lemma split_concat:
  assumes "split n v (v1,v2)"
  shows "v = append v1 v2"
  using assms proof(induct "(v1,v2)" arbitrary: v1 v2 rule: split.inducts)
  case 1
  then show ?case by auto
next
  case (2 m xs ys zs x)
  then show ?case by auto
qed

lemma split_n:
  assumes "split n v (v1,v2)"
  shows "0 \<le> n \<and> n \<le> int (length v)"
  using assms proof(induct rule: split.inducts)
  case (1 xs)
  then show ?case by auto
next
  case (2 m xs ys zs x)
  then show ?case by auto
qed

lemma split_length:
  assumes "split n v (v1,v2)"
  shows "n = int (length v1)"
  using assms proof(induct  "(v1,v2)" arbitrary: v1 v2 rule: split.inducts)
  case (1 xs)
  then show ?case by auto
next
  case (2 m xs ys zs x)
  then show ?case by auto
qed

lemma obtain_split:
  assumes "0 \<le> n" and "n \<le> int (length bv)"
  shows "\<exists> bv1 bv2. split n bv (bv1 , bv2)"
  using assms proof(induct bv arbitrary: n)
  case Nil
  then show ?case using split.intros by auto
next
  case (Cons b bv)
  show ?case proof(cases "n = 0")
    case True
    then show ?thesis using split.intros by auto
  next
    case False
    then obtain m where m:"n=m+1" using Cons
      by (metis add.commute add_minus_cancel)
    moreover have "0 \<le> m" using False m Cons by linarith
    then obtain bv1 and bv2 where "split m bv (bv1 , bv2)" using Cons m by force
    hence "split n (b # bv) ((b#bv1), bv2)" using m split.intros by auto
    then show ?thesis by auto
  qed
qed

end


section "Example: Chat application"

theory example_chat
  imports
    program_verification_tactics
    impl_language_loops
    crdt_specs2
    unique_ids
    program_proof_rules_loops
    app_verification_helpers
    unique_ids_loops
    proof_state_facts
begin

text_raw \<open>\DefineSnippet{chat_example_val}{\<close>
datatype val =
    String string
  | Bool bool
  | Undef
  | UserId int
  | ChatId int
  | MessageId int
  | Found val val
  | NotFound
text_raw \<open>}%EndSnippet\<close>

instance val :: countable
  by countable_datatype

fun uniqueIds_val_r  where
  "uniqueIds_val_r (UserId i) = {}" \<comment> \<open>These are not considered Ids as they are not generated by this part of the app.\<close>
| "uniqueIds_val_r (MessageId i) = {to_nat i}"
| "uniqueIds_val_r (Found x y) = uniqueIds_val_r x \<union> uniqueIds_val_r y"
| "uniqueIds_val_r _ = {}"

instantiation val :: valueType begin
definition [simp]: "uniqueIds_val \<equiv> uniqueIds_val_r"
definition [simp]: "default_val \<equiv> Undef"

instance by (standard, auto)
end

instantiation val :: from_bool begin
definition [simp]: "from_bool_val \<equiv> Bool"

instance by (standard, auto)
end

fun stringval where
  "stringval (String s) = s"
| "stringval _ = ''''"

text_raw \<open>\DefineSnippet{chat_example_messageDataOp}{\<close>
datatype messageDataOp =
    Author "(val registerOp)"
  | Content "(val registerOp)"
text_raw \<open>}%EndSnippet\<close>

instance messageDataOp :: countable
  by countable_datatype
instantiation messageDataOp :: crdt_op begin
definition "uniqueIds_messageDataOp x \<equiv>
  case x of
     Author x \<Rightarrow> uniqueIds x
   | Content x \<Rightarrow> uniqueIds x"

definition [simp]: "default_messageDataOp = Author default"

definition "is_update_messageDataOp x \<equiv> case x of Author x \<Rightarrow> is_update x | Content x \<Rightarrow> is_update x"

lemma is_update_messageDataOp_simp[simp]:
  "is_update (Author x) = is_update x"
  "is_update (Content y) = is_update y"
  by (auto simp add: is_update_messageDataOp_def)

instance by (standard, auto)
end

definition "isMessageId x \<equiv> case x of MessageId _ \<Rightarrow> True | _ \<Rightarrow> False"

text_raw \<open>\DefineSnippet{chat_example_operation}{\<close>
datatype operation =
    Chat "(val setOp)"
  | Message "((val, messageDataOp) mapOp)"
text_raw \<open>}%EndSnippet\<close>

instance operation :: countable
  by countable_datatype
instantiation operation :: crdt_op begin
definition "uniqueIds_operation x \<equiv>
  case x of
     Chat x \<Rightarrow> uniqueIds x
   | Message x \<Rightarrow> uniqueIds x"

lemma [simp]: "uniqueIds (Chat x) = uniqueIds x"
  "uniqueIds (Message y) = uniqueIds y"
  by (auto simp add: uniqueIds_operation_def)

definition [simp]: "default_operation = Chat default"

definition "is_update_operation x \<equiv> case x of Chat x \<Rightarrow> is_update x | Message x \<Rightarrow> is_update x"

instance by (standard, auto)
end

definition messageStruct :: "(messageDataOp, val) crdtSpec" where
  "messageStruct \<equiv>
      struct_field Author (register_spec Undef)
  .\<or>. struct_field Content (register_spec Undef)
"

definition crdtSpec :: "(operation, val) crdtSpec" where
"crdtSpec \<equiv>
      struct_field Message (map_sdw_spec messageStruct)
  .\<or>. struct_field Chat set_rw_spec
"

definition messageStruct'  :: "('a, messageDataOp, val) ccrdtSpec"  where
  "messageStruct' \<equiv>
       struct_field' Author (register_spec' Undef)
  .\<or>.. struct_field' Content (register_spec' Undef)
"

definition crdtSpec' :: "(operation, operation, val) ccrdtSpec" where
"crdtSpec' \<equiv>
        struct_field' Message (map_sdw_spec' messageStruct')
  .\<or>.. struct_field'  Chat set_rw_spec'
"

lemma subset_map_map:
  assumes "Cs \<subseteq> dom (map_map (calls ctxt) call_operation \<ggreater> C_in)"
  shows "Cs \<subseteq> dom (calls ctxt)"
  by (smt assms domI dom_map_map in_dom map_chain_eq_some subsetI)

lemma crdtSpec_rel:
  shows "crdt_spec_rel crdtSpec crdtSpec'"
  unfolding crdtSpec_def crdtSpec'_def
  by (auto simp add: inj_def messageStruct_def messageStruct'_def)

lemma crdtSpec'_alt:
  assumes wf: "operationContext_wf ctxt"
  shows "crdtSpec oper ctxt res
\<longleftrightarrow> crdtSpec' oper (dom (calls ctxt)) (extract_op (calls ctxt)) (happensBefore ctxt) id res "
  by (simp add: crdtSpec_rel local.wf operationContext_wf_hb_field use_crdt_spec_rel_toplevel)

lemma crdtSpec'_wf:
"ccrdtSpec_wf crdtSpec'"
  unfolding crdtSpec'_def
  by (auto simp add: messageStruct'_def  split: operation.splits )

lemma crdtSpec'_simp_op:
  assumes "Cs \<subseteq> vis"
  shows
  "crdtSpec' oper Cs (extract_op (s_calls |` vis)) s_happensBefore id r
 = crdtSpec' oper Cs (extract_op (s_calls)) s_happensBefore id r"
  apply (rule use_ccrdtSpec_wf[OF crdtSpec'_wf])
  using assms by (auto simp add: map_same_on_def restrict_map_def extract_op_def split: option.splits call.splits)

lemma crdtSpec'_simp_hb:
  assumes "Cs \<subseteq> vis"
  shows "
   crdtSpec' oper Cs op (s_happensBefore |r vis) id r
 = crdtSpec' oper Cs op s_happensBefore id r"
apply (rule use_ccrdtSpec_wf[OF crdtSpec'_wf])
  using assms by (auto simp add: rel_same_on_def restrict_relation_def split: option.splits call.splits)

text_raw \<open>\DefineSnippet{sendMessage_impl}{\<close>
definition sendMessage_impl :: "val \<Rightarrow> val \<Rightarrow> (val,operation,val) io" where
  "sendMessage_impl from content \<equiv>  do {
  m \<leftarrow> newId isMessageId;
  atomic (do {
    call (Message (NestedOp m (Author (Assign from))));
    call (Message (NestedOp m (Content (Assign content))));
    call (Chat (Add m))
  });
  return m
}"
text_raw \<open>}%EndSnippet\<close>

text_raw \<open>\DefineSnippet{editMessage_impl}{\<close>
definition editMessage_impl :: "val \<Rightarrow> val \<Rightarrow> (val,operation,val) io" where
  "editMessage_impl m newContent \<equiv>  do {
  atomic (do {
    exists \<leftarrow> call (Message (KeyExists m));
    if exists = Bool True then
      call (Message (NestedOp m (Content (Assign newContent))))
    else
      skip
  })
}"
text_raw \<open>}%EndSnippet\<close>

text_raw \<open>\DefineSnippet{deleteMessage_impl}{\<close>
definition deleteMessage_impl :: "val \<Rightarrow> (val,operation,val) io" where
  "deleteMessage_impl m \<equiv>  do {
  atomic (do {
    call (Chat (Remove m));
    call (Message (DeleteKey m))
  })
}"
text_raw \<open>}%EndSnippet\<close>

text_raw \<open>\DefineSnippet{getMessage_impl}{\<close>
definition getMessage_impl :: "val \<Rightarrow> (val,operation,val) io" where
  "getMessage_impl m \<equiv>  do {
  atomic (do {
    exists \<leftarrow> call (Message (KeyExists m));
    if exists = Bool True then do {
      author \<leftarrow> call (Message (NestedOp m (Author Read)));
      content \<leftarrow> call (Message (NestedOp m (Content Read)));
      return (Found author content)
    } else do {
      return NotFound
    }
  })
}"
text_raw \<open>}%EndSnippet\<close>

 text \<open>
 \DefineSnippet{getMessage_impl2}{
    @{thm [display] getMessage_impl_def}
 }%EndSnippet
 \<close>

text_raw \<open>\DefineSnippet{chat_example_proc}{\<close>
datatype proc =
    SendMessage string string
  | EditMessage int string
  | DeleteMessage int
  | GetMessage int
text_raw \<open>}%EndSnippet\<close>

instance proc :: countable
  by countable_datatype

instantiation proc :: valueType begin
definition "uniqueIds_proc proc \<equiv>
  case proc of
     SendMessage a c \<Rightarrow> {}
   | EditMessage m s  \<Rightarrow> uniqueIds (MessageId m)
   | DeleteMessage m  \<Rightarrow> uniqueIds (MessageId m)
   | GetMessage m  \<Rightarrow> uniqueIds (MessageId m)"

lemma [simp]:
  "uniqueIds (SendMessage a c) = {}"
  "uniqueIds (EditMessage m s) = uniqueIds (MessageId m)"
  "uniqueIds (DeleteMessage m) = uniqueIds (MessageId m)"
  "uniqueIds (GetMessage m) = uniqueIds (MessageId m)"
  by (auto simp add: uniqueIds_proc_def)

definition [simp]: "default_proc \<equiv> SendMessage [] []"

instance by (standard, auto)
end

lemma inj_fields[simp]: "inj Chat"
  "inj Message"
  "inj Author"
  "inj Content"
  by (auto simp add: inj_def)

thm inj_fields

type_synonym localState = "val store  \<times> uniqueId set \<times> (val, operation, val) io"

text_raw \<open>\DefineSnippet{chat_example_procedures}{\<close>
definition procedures :: "proc \<Rightarrow> (localState \<times> (localState, operation, val) procedureImpl)" where
  "procedures invoc \<equiv>
  case invoc of
    SendMessage author content \<Rightarrow> toImpl' invoc (sendMessage_impl (String author) (String content))
  | EditMessage m newContent \<Rightarrow> toImpl' invoc (editMessage_impl (MessageId m) (String newContent))
  | DeleteMessage m \<Rightarrow>  toImpl' invoc (deleteMessage_impl (MessageId m))
  | GetMessage m  \<Rightarrow>  toImpl' invoc (getMessage_impl (MessageId m))
"
text_raw \<open>}%EndSnippet\<close>

(*
// getMessage returns correct authors
invariant (forall g: invocationId, m: MessageId, author: UserId, content: String ::
     g.info == getMessage(m)
  && g.result == getMessage_res(found(author, content))
  ==> (exists s: invocationId, content2: String :: s.info == sendMessage(author, content2)))
*)

definition inv1 where
"inv1 op res \<equiv> \<forall>g m author content.
    op g \<triangleq> GetMessage m
  \<and> res g \<triangleq> Found (String author) content
  \<longrightarrow> (\<exists>s content2. op s \<triangleq> SendMessage author content2)
"

subsection \<open>Additional invariants:\<close>

(*
// if there is an assignment of the content field, there also is one for the author field that happened before:
invariant forall c1: callId, m: MessageId, s: String ::
    c1.op == message_content_assign(m, s)
    ==> (exists c2: callId, u: UserId ::
            c2.op == message_author_assign(m, u)
            && c2 happened before c1)
*)

definition inv2 where
"inv2 cop hb \<equiv> \<forall>c1 m s.
    cop c1 \<triangleq> Message (NestedOp m (Content (Assign s)))
    \<longrightarrow> (\<exists>c2 u.
           cop c2 \<triangleq> Message (NestedOp m (Author (Assign u)))
           \<and> (c2, c1)\<in>hb) "

(*
// there is no update after a delete
invariant !(exists write: callId, delete: callId, m: MessageId ::
       ((exists u: UserId ::  write.op == message_author_assign(m, u))
        || (exists s: String ::  write.op == message_content_assign(m, s)))
    && delete.op == message_delete(m)
    && delete happened before write)
*)

definition inv3 where
"inv3 cop hb \<equiv>
  \<nexists>write delete m no.
   cop write \<triangleq> Message (NestedOp m no)
   \<and> is_update no
   \<and> cop delete \<triangleq> Message (DeleteKey m)
   \<and> (delete,write)\<in>hb"

(*
// for every author-assignment there is a corresponding invocation of sendMessage
invariant forall c: callId, m: MessageId, u: UserId ::
    c.op == message_author_assign(m, u)
    ==> (exists i: invocationId, s: String ::
            i.info == sendMessage(u, s))
*)

definition inv4 where
"inv4 op cop \<equiv> \<forall>c m u.
  cop c \<triangleq> Message (NestedOp m (Author (Assign (String u))))
  \<longrightarrow> (\<exists>i s. op i \<triangleq> SendMessage u s) "

definition inv :: "(proc, operation, val) invContext \<Rightarrow> bool" where
  "inv ctxt \<equiv>
    inv1 (invocOp ctxt) (invocRes ctxt)
  \<and> inv2 (Op ctxt) (happensBefore ctxt)
  \<and> inv3 (Op ctxt) (happensBefore ctxt)
  \<and> inv4 (invocOp ctxt) (Op ctxt)"

text \<open>\DefineSnippet{chat_example_messageStruct_def}{
  @{thm [display] messageStruct_def}
}%EndSnippet\<close>

text \<open>\DefineSnippet{chat_example_crdtSpec_def}{
  @{thm [display] crdtSpec_def}
}%EndSnippet\<close>

text \<open>\DefineSnippet{chat_example_inv1}{
  @{thm [display] inv1_def}
}%EndSnippet\<close>

text \<open>\DefineSnippet{chat_example_inv2}{
  @{thm [display] inv2_def}
}%EndSnippet\<close>

text \<open>\DefineSnippet{chat_example_inv3}{
  @{thm [display] inv3_def}
}%EndSnippet\<close>

text \<open>\DefineSnippet{chat_example_inv4}{
  @{thm [display] inv4_def}
}%EndSnippet\<close>

text \<open>\DefineSnippet{chat_example_inv}{
  @{thm [display] inv_def}
}%EndSnippet\<close>

definition progr :: "(proc, localState, operation, val) prog" where
  "progr \<equiv> \<lparr>
  querySpec = crdtSpec,
  procedure = procedures,
  invariant = inv
\<rparr>"

lemma [simp]: "procedure progr = procedures"
"querySpec progr = crdtSpec"
"invariant progr = inv"
  by (auto simp add: progr_def)

declare convert_spec_def[simp]

(*
lemma uniqueId_no_nested: "x \<in> uniqueIds uid \<Longrightarrow> x = (to_nat (uid :: val))"
  by (auto simp add: uniqueIds_val_def split: val.splits)

lemma uniqueId_no_nested2: "x \<in> uniqueIds uid \<longleftrightarrow> (\<exists>u. x = to_nat (MessageId u) \<and> uid = MessageId u)"
  by (auto simp add: uniqueIds_val_def split: val.splits)
*)

lemma progr_wf[simp]: "program_wellFormed progr"
proof (auto simp add: program_wellFormed_def)
  show "invocations_cannot_guess_ids progr"
  proof (rule invocations_cannot_guess_ids_io)
    fix proc store localKnown cmd impl
    assume a0: "procedure progr proc = ((store, localKnown, cmd), impl)"

    thus "impl = impl_language_loops.toImpl \<and> localKnown = uniqueIds proc"
      by (auto simp add: progr_def procedures_def split: proc.splits)
  qed

  show "queries_cannot_guess_ids crdtSpec"
    by (auto simp add: inj_def crdtSpec_def messageStruct_def)

qed

lemma isMessageId_infinite[simp]: "infinite (Collect isMessageId)"
proof (rule infinite_if_mappable_to_nat)
  show "\<exists>x\<in>Collect isMessageId. n \<le> (case x of MessageId n \<Rightarrow> nat n)" for n
    by (rule bexI[where x="MessageId (int n)"],
        auto simp add: isMessageId_def)
qed

\<comment> \<open>Move to helpers\<close>
lemma get_query_spec2:
  assumes wf: "proof_state_wellFormed S"
    and upd_call: "calls S upd_c \<triangleq> Call oper upd_r"
  shows "\<exists>ctxt. querySpec (ps_prog S) oper ctxt upd_r"
proof -
  from wf
  obtain CS where rel: "proof_state_rel S CS"
    using proof_state_wellFormed_def by blast

  hence state_wf: "state_wellFormed CS"
    using proof_state_rel_wf by blast

  have upd_call': "calls CS upd_c \<triangleq> Call oper upd_r"
    using rel upd_call proof_state_rel_calls[OF rel] by auto

  have "prog CS = ps_prog S"
    using proof_state_rel_prog rel by fastforce

  from wf_queryspec[OF state_wf] upd_call' `prog CS = ps_prog S`
  obtain ctxt where "querySpec (ps_prog S) oper ctxt upd_r"
    apply atomize_elim
    apply auto
    by blast
  thus ?thesis
    by blast
qed

lemma select_field_some[simp]:
  assumes "inj f"
  shows "select_field f (f x) \<triangleq> x"
  using assms by (auto simp add: select_field_def)

lemma select_field_none[simp]:
  assumes "\<And>x y. g x \<noteq> f y"
  shows "select_field f (g x) = None"
  using assms by (auto simp add: select_field_def)

lemma query_result_undef:
  assumes wf: "proof_state_wellFormed S"
    and upd_call: "calls S upd_c \<triangleq> Call (Message (NestedOp (MessageId m) upd_op)) upd_r"
    and upd_is_update: "is_update upd_op"
    and progr: "ps_prog S = progr"
  shows "upd_r = Undef"
proof -

  obtain ctxt where "querySpec progr (Message (NestedOp (MessageId m) upd_op)) ctxt upd_r"
    using get_query_spec2 local.wf progr upd_call by fastforce

  thus "upd_r = Undef"
    using upd_is_update
    by (cases upd_op)
     (auto simp add: inj_def crdtSpec_def struct_field_def map_sdw_spec_def map_spec_def messageStruct_def register_spec_def split: messageDataOp.splits registerOp.splits if_splits)

qed

declare invContext.defs[simp]

lemmas crdt_spec_defs =
  toplevel_spec_def crdtSpec'_def struct_field'_def map_sdw_spec'_def map_spec'_def messageStruct'_def register_spec'_def
  set_rw_spec'_def deleted_calls_sdw'_def

theorem chat_app_correct: "programCorrect progr"
proof M_show_programCorrect

  subsection \<open>Initial State\<close>

  case invariant_initial_state
  show "invariant_all' (initialState progr)"
    by (simp add: inv_def initialState_def invContextH2_calls inv1_def inv2_def inv3_def inv4_def invContextH2_happensBefore invContextH2_i_invocOp progr_def)

  case (procedure_correct S i)

  show "procedureCorrect S i"
  proof (rule Initial_Label, rule show_initial_state_prop[OF procedure_correct], rule DC_final2, casify)
    case (show_P S_pre proc initState impl)
    have "invocOp S i \<triangleq> proc"
      using show_P by auto
    have "invocRes S i = None"
      using show_P apply auto
      using wf_result_after_invocation by blast

    have "uniqueIds proc \<subseteq> knownIds S"
      using show_P by auto

    note show_P[simp]

    show "procedureCorrect S i"
    proof (cases proc)
      subsection \<open>SendMessage\<close>

      case (SendMessage author content)

      show "procedureCorrect S i"
      proof M_show_procedureCorrect
        case after_invocation
        show ?case
          using show_P.invariant_pre
        proof (auto simp add: inv_def invContextH2_simps)

          show "inv1 (invocOp S_pre(i \<mapsto> proc)) (invocRes S_pre)" if "inv1 (invocOp S_pre) (invocRes S_pre)"
            using show_P.i_fresh SendMessage that
            by (auto simp add: inv1_def)
             (metis option.discI show_P.i_fresh)

          show "inv4 (invocOp S_pre(i \<mapsto> proc)) (Op S_pre)" if "inv4 (invocOp S_pre) (Op S_pre)"
            using show_P.i_fresh SendMessage that
            by (auto simp add: inv4_def)
             (metis option.discI show_P.i_fresh)
        qed

      next
        case execution

        show "execution_s_correct S i"
          using procedure_correct.in_initial_state
        proof (fuzzy_rule execution_s_check_sound4)
          show "currentProc S i \<triangleq> toImpl"
            by (auto simp add: SendMessage procedures_def )

          show "localState S i \<triangleq> (Map.empty, uniqueIds (SendMessage author content), sendMessage_impl (String author) (String content))"
            by (auto simp add: SendMessage procedures_def )

          show "invocOp S i \<triangleq> SendMessage author content"
            using SendMessage \<open>invocOp S i \<triangleq> proc\<close> by blast

          note sendMessage_impl_def[simp]

          show "program_wellFormed (prog S)"
            by simp

          show "invariant_all' S"
            using execution.in_initial_state by blast

          show "crdt_spec_rel (querySpec progr) crdtSpec' "
            by (simp add: crdtSpec_rel)

          show "execution_s_check (invariant progr) crdtSpec' \<lparr>calls = s_calls, happensBefore = s_happensBefore, callOrigin = s_callOrigin, txOrigin = s_txOrigin, knownIds = s_knownIds, invocOp = s_invocOp(i \<mapsto> SendMessage author content), invocRes = s_invocRes(i := None), ps_i = i, ps_generatedLocal = {}, ps_generatedLocalPrivate = {}, ps_localKnown = uniqueIds (SendMessage author content), ps_vis = {}, ps_localCalls = [], ps_tx = None, ps_firstTx = True, ps_store = Map.empty, ps_prog = progr\<rparr> (sendMessage_impl (String author) (String content)) (finalCheck (invariant progr) i)"
            if tx_fresh: "\<And>tx. s_txOrigin tx \<noteq> Some i"
              and inv_initial: "invariant progr \<lparr>calls = s_calls, happensBefore = s_happensBefore, callOrigin = s_callOrigin, txOrigin = s_txOrigin, knownIds = s_knownIds, invocOp = s_invocOp(i \<mapsto> SendMessage author content), invocRes = s_invocRes(i := None)\<rparr>"
            for  s_calls s_happensBefore s_callOrigin s_txOrigin s_knownIds s_invocOp s_invocRes
          proof (repliss_vcg_l, fuzzy_goal_cases "AtCommit" "AtReturn" )
            case (AtCommit v vn tx s_calls' s_happensBefore' s_callOrigin' s_txOrigin' s_knownIds' vis' s_invocOp' s_invocRes' c res ca resa cb resb PS')

            have "res = Undef"
              using AtCommit.toplevel_spec
              by (auto simp add: crdt_spec_defs)
            have "resa = Undef"
              using AtCommit.toplevel_spec2
              by (auto simp add: crdt_spec_defs)

            have "resb = Undef"
              using AtCommit.toplevel_spec3
              by (auto simp add: crdt_spec_defs)

            have "in_sequence [c, ca, cb] c ca"
              by (simp add: in_sequence_cons)

            have "new_unique_not_in_calls s_calls' vn"
              by (meson AtCommit.uid_is_private'2 uid_is_private'_def)

            hence no_v: "vn \<notin> uniqueIds opr" if "cOp s_calls' c \<triangleq> opr" for c opr
              using that
              by (auto simp add: new_unique_not_in_calls_def cOp_Some_iff)

            have no_delete_v: "cOp s_calls' delete \<noteq> Some (Message (DeleteKey v))" for delete
              using `uniqueIds_val_r v = {vn}` by (auto dest!: no_v)

            from AtCommit
            show ?case
            proof (auto simp add: inv_def, fuzzy_goal_cases  inv2 inv3 inv4)

            next
              case (inv2 )

              from inv2 show ?case
                by (auto simp add: inv2_def updateHb_cases in_sequence_cons cong: conj_cong, meson)
            next
              case (inv3)

              then show ?case
                by (auto simp add: inv3_def  in_sequence_cons updateHb_cases no_delete_v)

              case (inv4)
              then show ?case
                by (auto simp add: inv4_def)

            qed

          next
            case (AtReturn v tx s_calls' s_happensBefore' s_callOrigin' s_txOrigin' s_knownIds' vis' s_invocOp' s_invocRes' c res ca resa cb resb)
            from AtReturn.inv2
            show ?case
              by (auto simp add: inv_def inv1_def  split: if_splits)
               blast
          qed
        qed
      qed

    next
      subsection \<open>EditMessage\<close>
      case (EditMessage m newContent)
      show "procedureCorrect S i"
      proof M_show_procedureCorrect
        case after_invocation
        show ?case
          using show_P.invariant_pre EditMessage show_P.i_fresh
          by (auto simp add:  inv_def inv1_def inv2_def inv3_def inv4_def invContextH2_simps,
              metis option.distinct(1) show_P.i_fresh)+

      next
        case execution

        show "execution_s_correct S i"
          using procedure_correct.in_initial_state
        proof (fuzzy_rule execution_s_check_sound4)
          show "currentProc S i \<triangleq> toImpl"
            by (auto simp add: EditMessage procedures_def )

          show "invocOp S i \<triangleq> EditMessage m newContent"
            using EditMessage \<open>invocOp S i \<triangleq> proc\<close> by blast

          show "localState S i \<triangleq> (Map.empty, uniqueIds (EditMessage m newContent), editMessage_impl (MessageId m) (String newContent))"
            by (auto simp add: EditMessage procedures_def )

          note editMessage_impl_def[simp]

          show "program_wellFormed (prog S)"
            by simp

          show "invariant_all' S"
            using execution.in_initial_state by blast

          show "crdt_spec_rel (querySpec progr) crdtSpec'"
            by (simp add: crdtSpec_rel)

          show "execution_s_check (invariant progr) crdtSpec' \<lparr>calls = s_calls, happensBefore = s_happensBefore, callOrigin = s_callOrigin, txOrigin = s_txOrigin, knownIds = s_knownIds, invocOp = s_invocOp(i \<mapsto> EditMessage m newContent), invocRes = s_invocRes(i := None), ps_i = i, ps_generatedLocal = {}, ps_generatedLocalPrivate = {}, ps_localKnown = uniqueIds (EditMessage m newContent), ps_vis = {}, ps_localCalls = [], ps_tx = None, ps_firstTx = True, ps_store = Map.empty, ps_prog = progr\<rparr> (editMessage_impl (MessageId m) (String newContent)) (finalCheck (invariant progr) i)"
            if tx_fresh: "\<And>tx. s_txOrigin tx \<noteq> Some i"
              and inv_init: "invariant progr \<lparr>calls = s_calls, happensBefore = s_happensBefore, callOrigin = s_callOrigin, txOrigin = s_txOrigin, knownIds = s_knownIds, invocOp = s_invocOp(i \<mapsto> EditMessage m newContent), invocRes = s_invocRes(i := None)\<rparr>"
            for  s_calls s_happensBefore s_callOrigin s_txOrigin s_knownIds s_invocOp s_invocRes
          proof (repliss_vcg_l, fuzzy_goal_cases "Exists_AtCommit" "Exists_AtReturn" "NotExists_AtCommit" "NotExists_AtReturn")

            case (Exists_AtCommit tx s_calls' s_happensBefore' s_callOrigin' s_txOrigin' s_knownIds' vis' s_invocOp' s_invocRes' c ca resa PS')

            note `c \<noteq> ca`[simp]

            from `example_chat.inv
             \<lparr>calls = s_calls', happensBefore = s_happensBefore', callOrigin = s_callOrigin', txOrigin = s_txOrigin',
                knownIds = s_knownIds', invocOp = s_invocOp'(i \<mapsto> EditMessage m newContent),
                invocRes = s_invocRes'(i := None)\<rparr>`
            have  i1: "inv1 (s_invocOp'(i \<mapsto> EditMessage m newContent)) (s_invocRes'(i := None))"
              and i2: "inv4 (s_invocOp'(i \<mapsto> EditMessage m newContent)) (cOp s_calls')"
              and i3: "inv2 (cOp s_calls') s_happensBefore'"
              and i4: "inv3 (cOp s_calls') s_happensBefore'"
              by (auto simp add: inv_def)

            text \<open>From existance of entry, obtain information about the history:\<close>

            from \<open>toplevel_spec crdtSpec' \<lparr>calls = s_calls', happensBefore = s_happensBefore'\<rparr> vis' (Message (KeyExists (MessageId m))) (Bool True)\<close>
            obtain upd_c upd_op
              where upd_vis: "upd_c \<in> vis'"
                and upd_call: "extract_op s_calls' upd_c = Message (NestedOp (MessageId m) upd_op)"
                and upd_is_update: "is_update upd_op"
                and upd_not_deleted: "\<forall>d\<in>vis'. extract_op s_calls' d = Message (DeleteKey (MessageId m)) \<longrightarrow> (d, upd_c) \<in> s_happensBefore'"
              by (auto simp add: crdt_spec_defs C_out_calls_def )

            from upd_call and upd_vis
            have upd_call': "cOp s_calls' upd_c \<triangleq> Message (NestedOp (MessageId m) upd_op)"
              by (metis Exists_AtCommit.less_eq cOp_Some extract_op_def in_dom option.sel)

            from upd_not_deleted
            have upd_not_deleted': "\<forall>d\<in>vis'. cOp s_calls' d \<triangleq> Message (DeleteKey (MessageId m)) \<longrightarrow> (d, upd_c) \<in> s_happensBefore'"
              by (meson Exists_AtCommit.less_eq cOp_Some_iff extract_op_eq in_mono)

            with \<open>inv3 (cOp s_calls') s_happensBefore'\<close>
            have no_delete: \<open>\<forall>d\<in>vis'. \<not> cOp s_calls' d \<triangleq> Message (DeleteKey (MessageId m))\<close>
              using upd_call' upd_is_update by (auto simp add: inv3_def)

            have "upd_c \<noteq> c"
              using Exists_AtCommit.not_member upd_vis by blast

            have "upd_c \<noteq> ca"
              using Exists_AtCommit.not_member upd_vis by blast

            text \<open>with @{term inv2} get an assignment of the author:\<close>

            obtain upda_c upda_val
              where upda_call: "cOp s_calls' upda_c \<triangleq> Message (NestedOp (MessageId m) (Author (Assign upda_val)))"
                and upda_before_upd: "(upda_c, upd_c) \<in> s_happensBefore' \<or> upda_c = upd_c"

            proof (atomize_elim, cases upd_op)
              case (Author x)

              obtain a where "x = Assign a"
                using Author upd_is_update
                by (cases x) auto

              show " \<exists>upda_c upda_val.
                   cOp s_calls' upda_c \<triangleq> Message (NestedOp (MessageId m) (Author (Assign upda_val))) \<and>
                   ((upda_c, upd_c) \<in> s_happensBefore' \<or> upda_c = upd_c)"
                using Author \<open>x = Assign a\<close>  upd_call' by blast
            next
              case (Content x)

              from this
              obtain content
                where content_assign: "cOp s_calls' upd_c \<triangleq> Message (NestedOp (MessageId m) (Content (Assign content)))"
                using registerOp.exhaust upd_call' upd_is_update by auto

              from `inv2 (cOp s_calls') s_happensBefore'`[unfolded inv2_def, rule_format, OF content_assign]
              show " \<exists>upda_c upda_val.
                 cOp s_calls' upda_c \<triangleq> Message (NestedOp (MessageId m) (Author (Assign upda_val))) \<and>
                 ((upda_c, upd_c) \<in> s_happensBefore' \<or> upda_c = upd_c)"
                by blast
            qed

            have upda_c_vis: "upda_c \<in> vis'"
              using Exists_AtCommit.causallyConsistent causallyConsistent_def upd_vis upda_before_upd by fastforce

            have "upda_c \<noteq> c"
              using Exists_AtCommit \<open>upd_c \<noteq> c\<close> upda_before_upd by blast

            have "upda_c \<noteq> ca"
              using Exists_AtCommit \<open>upd_c \<noteq> ca\<close> upda_before_upd by blast

            from Exists_AtCommit.inv
            show ?case
            proof (auto simp add: inv_def Exists_AtCommit.PS'_eq, fuzzy_goal_cases  "inv2" "inv3" "inv4")
              case (inv4)
              then show ?case
                by (auto simp add: inv4_def)

            next
              case (inv2)
              show ?case
                using \<open>upda_c \<in> vis'\<close> \<open>upda_c \<noteq> c\<close> \<open>upda_c \<noteq> ca\<close> upda_call inv2.inv2 Exists_AtCommit.not_member2
                by (auto simp add: inv2_def updateHb_cases in_sequence_cons `c \<noteq> ca`[symmetric] cong: conj_cong)
                  blast
            next
              case (inv3)

              text \<open>The update performed in the transaction is not after an delete, which we get from the query results.\<close>

              from Exists_AtCommit.not_member3 inv3.inv3
                no_delete
              show ?case
                by (auto simp add: inv3_def updateHb_cases in_sequence_cons )
            qed

          next
            case (Exists_AtReturn tx s_calls' s_happensBefore' s_callOrigin' s_txOrigin' s_knownIds' vis' s_invocOp' s_invocRes' c ca resa)

            from Exists_AtReturn.inv2
            show ?case
              by (auto simp add: inv_def inv1_def cong: conj_cong split: if_splits)
          next
            case (NotExists_AtCommit tx s_calls' s_happensBefore' s_callOrigin' s_txOrigin' s_knownIds' vis' s_invocOp' s_invocRes' c res PS')

            then show ?case
            proof (auto simp add: inv_def, fuzzy_goal_cases inv2 inv3 inv4)
              case (inv4 )
              then show ?case by (auto simp add: inv4_def)
            next
              case (inv2)
              then show ?case by (auto simp add: inv2_def updateHb_single cong: conj_cong, fastforce)
            next
              case (inv3)
              then show ?case
                by (auto simp add: inv3_def updateHb_single)
            qed
          next
            case (NotExists_AtReturn tx s_calls' s_happensBefore' s_callOrigin' s_txOrigin' s_knownIds' vis' s_invocOp' s_invocRes' c res)
            then show ?case
              by (auto simp add: inv_def inv1_def cong: conj_cong split: if_splits)
          qed
        qed
      qed
    next
      subsection \<open>DeleteMessage\<close>
      case (DeleteMessage m)

      show "procedureCorrect S i"
      proof M_show_procedureCorrect
        case after_invocation
        show ?case
          using show_P.invariant_pre DeleteMessage show_P.i_fresh
          by (auto simp add:  inv_def inv1_def inv2_def inv3_def inv4_def invContextH2_simps,
              metis option.distinct(1) show_P.i_fresh)+

      next
        case execution

        show "execution_s_correct S i"
          using procedure_correct.in_initial_state
        proof (fuzzy_rule execution_s_check_sound4)
          show "currentProc S i \<triangleq> toImpl"
            by (auto simp add: DeleteMessage procedures_def )

          show "localState S i \<triangleq> (Map.empty, uniqueIds (DeleteMessage m), deleteMessage_impl (MessageId m))"
            by (auto simp add: DeleteMessage procedures_def )

          show "invocOp S i \<triangleq> DeleteMessage m"
            using DeleteMessage \<open>invocOp S i \<triangleq> proc\<close> by blast

          note deleteMessage_impl_def[simp]

          show "program_wellFormed (prog S)"
            by simp

          show "invariant_all' S"
            using execution.in_initial_state by blast

          show "crdt_spec_rel (querySpec progr) crdtSpec'"
            by (simp add: crdtSpec_rel)

          show "execution_s_check (invariant progr) crdtSpec' \<lparr>calls = s_calls, happensBefore = s_happensBefore, callOrigin = s_callOrigin, txOrigin = s_txOrigin, knownIds = s_knownIds, invocOp = s_invocOp(i \<mapsto> DeleteMessage m), invocRes = s_invocRes(i := None), ps_i = i, ps_generatedLocal = {}, ps_generatedLocalPrivate = {}, ps_localKnown = uniqueIds (DeleteMessage m), ps_vis = {}, ps_localCalls = [], ps_tx = None, ps_firstTx = True, ps_store = Map.empty, ps_prog = progr\<rparr> (deleteMessage_impl (MessageId m)) (finalCheck (invariant progr) i)"
            if tx_fresh: "\<And>tx. s_txOrigin tx \<noteq> Some i"
              and inv_i: "invariant progr \<lparr>calls = s_calls, happensBefore = s_happensBefore, callOrigin = s_callOrigin, txOrigin = s_txOrigin, knownIds = s_knownIds, invocOp = s_invocOp(i \<mapsto> DeleteMessage m), invocRes = s_invocRes(i := None)\<rparr>"
            for  s_calls s_happensBefore s_callOrigin s_txOrigin s_knownIds s_invocOp s_invocRes
          proof (repliss_vcg_l, fuzzy_goal_cases "AtCommit" "AtReturn" )
            case (AtCommit tx s_calls' s_happensBefore' s_callOrigin' s_txOrigin' s_knownIds' vis' s_invocOp' s_invocRes' c res ca resa PS')

            have [simp]: "c \<noteq> ca"
              by (simp add: AtCommit.not_c_eq)

            from `example_chat.inv
               \<lparr>calls = s_calls', happensBefore = s_happensBefore', callOrigin = s_callOrigin', txOrigin = s_txOrigin',
                  knownIds = s_knownIds', invocOp = s_invocOp'(i \<mapsto> DeleteMessage m), invocRes = s_invocRes'(i := None)\<rparr>`
            have  i1: "inv1 (s_invocOp'(i \<mapsto> DeleteMessage m)) (s_invocRes'(i := None))"
              and i4: "inv4 (s_invocOp'(i \<mapsto> DeleteMessage m)) (cOp s_calls')"
              and i2: "inv2 (cOp s_calls') s_happensBefore'"
              and i3: "inv3 (cOp s_calls') s_happensBefore'"
              by (auto simp add: inv_def)

            show ?case
            proof (auto simp add: inv_def AtCommit.PS'_eq, fuzzy_goal_cases inv1 inv2 inv3 inv4)
              case inv1
              from i1
              show ?case
                by simp
            next
              case inv4
              from i4
              show ?case
                by (auto simp add: inv4_def)
            next
              case inv2

              from i2
              show ?case
                using AtCommit.cOp_eq AtCommit.cOp_eq2
                by (auto simp add: inv2_def updateHb_cases     cong: conj_cong )
                 (metis option.distinct(1))

            next
              case inv3
              then show ?case
                using AtCommit.not_member2 i3
                by (auto simp add: inv3_def updateHb_cases in_sequence_cons )
            qed

          next
           case (AtReturn tx s_calls' s_happensBefore' s_callOrigin' s_txOrigin' s_knownIds' vis' s_invocOp' s_invocRes' c res ca resa)
            then show ?case
              by (auto simp add: inv_def inv1_def split: if_splits)
               meson
          qed
        qed
      qed
    next
      subsection \<open>GetMessage\<close>
      case (GetMessage m)

      show "procedureCorrect S i"
      proof M_show_procedureCorrect
        case after_invocation
        show ?case
          using show_P.invariant_pre GetMessage show_P.i_fresh
        proof (auto simp add:  inv_def invContextH2_simps, fuzzy_goal_cases inv1 inv4)
          case inv1
          then show ?case
            apply (auto simp add: inv1_def state_wellFormed_invocation_before_result)
            by (metis option.simps(3) show_P.i_fresh)
        next
          case inv4
          then show ?case
            apply (auto simp add: inv4_def)
            by (metis option.distinct(1) show_P.i_fresh)
        qed

      next
        case execution

        show "execution_s_correct S i"
          using procedure_correct.in_initial_state
        proof (fuzzy_rule execution_s_check_sound4)
          show "currentProc S i \<triangleq> toImpl"
            by (auto simp add: GetMessage procedures_def )

          show "localState S i \<triangleq> (Map.empty, uniqueIds (GetMessage m), getMessage_impl (MessageId m))"
            by (auto simp add: GetMessage procedures_def )

          show "invocOp S i \<triangleq> GetMessage m"
            using GetMessage \<open>invocOp S i \<triangleq> proc\<close> by blast

          note getMessage_impl_def[simp]

          show "program_wellFormed (prog S)"
            by simp

          show "invariant_all' S"
            using execution.in_initial_state by blast

          show "crdt_spec_rel (querySpec progr) crdtSpec'"
            by (simp add: crdtSpec_rel)

          show "execution_s_check (invariant progr) crdtSpec' \<lparr>calls = s_calls, happensBefore = s_happensBefore, callOrigin = s_callOrigin, txOrigin = s_txOrigin, knownIds = s_knownIds, invocOp = s_invocOp(i \<mapsto> GetMessage m), invocRes = s_invocRes(i := None), ps_i = i, ps_generatedLocal = {}, ps_generatedLocalPrivate = {}, ps_localKnown = uniqueIds (GetMessage m), ps_vis = {}, ps_localCalls = [], ps_tx = None, ps_firstTx = True, ps_store = Map.empty, ps_prog = progr\<rparr> (getMessage_impl (MessageId m)) (finalCheck (invariant progr) i)"
            if tx_fresh: "\<And>tx. s_txOrigin tx \<noteq> Some i"
              and inv_pre: "invariant progr \<lparr>calls = s_calls, happensBefore = s_happensBefore, callOrigin = s_callOrigin, txOrigin = s_txOrigin, knownIds = s_knownIds, invocOp = s_invocOp(i \<mapsto> GetMessage m), invocRes = s_invocRes(i := None)\<rparr>"
            for  s_calls s_happensBefore s_callOrigin s_txOrigin s_knownIds s_invocOp s_invocRes
          proof (repliss_vcg_l, fuzzy_goal_cases "Exists_AtCommit" "Exists_AtReturn" uids1 uids2 "NotExists_AtCommit" "NotExists_AtReturn")
            case (Exists_AtCommit tx s_calls' s_happensBefore' s_callOrigin' s_txOrigin' s_knownIds' vis' s_invocOp' s_invocRes' c ca resa cb res PS')
            then show ?case
            proof (auto simp add: inv_def, fuzzy_goal_cases inv2 inv3 inv4 )
              case (inv4)
              then show ?case
                by (auto simp add: inv4_def)
            next
              case (inv2)
              then show ?case
                by (auto simp add: inv2_def  updateHb_cons cong: conj_cong, meson)
            next
              case (inv3)
              then show ?case
                by (auto simp add: inv3_def updateHb_cons is_update_messageDataOp_def)
            qed
          next
            case (Exists_AtReturn tx s_calls' s_happensBefore' s_callOrigin' s_txOrigin' s_knownIds' vis' s_invocOp' s_invocRes' c ca resa cb res)

            from \<open>example_chat.inv
             \<lparr>calls = s_calls', happensBefore = s_happensBefore', callOrigin = s_callOrigin',
                txOrigin = s_txOrigin', knownIds = s_knownIds',
                invocOp = s_invocOp'(i \<mapsto> GetMessage m), invocRes = s_invocRes'(i := None)\<rparr>\<close>
            have i1: "inv1 (s_invocOp'(i \<mapsto> GetMessage m)) (s_invocRes'(i := None))"
              and i2: "inv4 (s_invocOp'(i \<mapsto> GetMessage m)) (cOp s_calls')"
              and i3: "inv2 (cOp s_calls') s_happensBefore'"
              and i4: "inv3 (cOp s_calls') s_happensBefore'"
              by (auto simp add: inv_def)

            have "c \<notin> vis'"
              by (simp add: Exists_AtReturn.not_member)

            text \<open>Only invariant 1 is affected here:\<close>

            from Exists_AtReturn show ?case
            proof (auto simp add: inv_def, fuzzy_goal_cases inv1)
              case (inv1)

              show ?case
              proof (auto simp add: inv1_def cong: conj_cong)

                text \<open>Old invocations are unaffected:\<close>

                show "\<exists>s. s \<noteq> i \<and> (\<exists>content2. s_invocOp' s \<triangleq> SendMessage author content2)"
                  if c0: "g \<noteq> i"
                    and c1: "s_invocOp' g \<triangleq> GetMessage m'"
                    and c2: "s_invocRes' g \<triangleq> Found (String author) content"
                  for  g m' author content
                  using \<open>inv1 (s_invocOp'(i \<mapsto> GetMessage m)) (s_invocRes'(i := None))\<close>
                  using that apply (auto simp add: inv1_def)
                  by (metis option.inject proc.distinct(5))

                text \<open>The interesting case is to show that there is a SendMessage invocation corresponding
                  to the current invocation of GetMessage and the result Found:\<close>

                show "\<exists>s. s \<noteq> i \<and> (\<exists>content2. s_invocOp' s \<triangleq> SendMessage author content2)"
                  if resa_def: "resa = String author"
                  for  author
                proof -
                  define ops' where "ops' \<equiv> extract_op (s_calls'(c \<mapsto> Call (Message (KeyExists (MessageId m))) (Bool True)))"
                  define hb' where "hb' \<equiv> updateHb s_happensBefore' vis' [c]"

                  from \<open>toplevel_spec crdtSpec'
                       \<lparr>calls = s_calls'(c \<mapsto> Call (Message (KeyExists (MessageId m))) (Bool True)),
                          happensBefore = updateHb s_happensBefore' vis' [c]\<rparr>
                       (insert c vis') (Message (NestedOp (MessageId m) (Author Read))) resa\<close>
                  have spec0: "crdtSpec' (Message (NestedOp (MessageId m) (Author Read))) (insert c vis')     (extract_op (s_calls'(c \<mapsto> Call (Message (KeyExists (MessageId m))) (Bool True)))) (updateHb s_happensBefore' vis' [c]) id     resa"
                    by (simp add: toplevel_spec_def)
                  have h_compose_simp: "(\<lambda>x. Message (NestedOp (MessageId m) x)) \<circ> Author
                      = Message \<circ> (NestedOp (MessageId m)) \<circ> Author"
                    by auto

                  from spec0
                  have "crdtSpec' (Message (NestedOp (MessageId m) (Author Read))) (insert c vis') ops' hb' id resa"
                    by (fold ops'_def hb'_def) auto

                  hence h1: "is_from resa Undef
                       (latest_values' (insert c vis' - deleted_calls_sdw' (insert c vis') ops' hb' Message (MessageId m)) ops' hb'
                         (Message \<circ> NestedOp (MessageId m) \<circ> Author))"
                    by (auto simp add: h_compose_simp crdtSpec'_def map_sdw_spec'_def map_spec'_def messageStruct'_def register_spec'_def)

                  define author_vis where "author_vis \<equiv> insert c vis' -
                      deleted_calls_sdw' (insert c vis') ops' hb' Message (MessageId m)"

                  from h1
                  obtain updb_c
                    where h2: "updb_c \<in> author_vis"
                      and h3: "ops' updb_c = Message (NestedOp (MessageId m) (Author (Assign (String author))))"
                    by (auto simp add: resa_def is_from_not_initial latest_values'_def)
                     (auto simp add:  latest_assignments'_def author_vis_def)

                  have c_in_dom[simp]: "c \<in> dom s_calls'" if "c \<in> vis'" for c
                    using inv1(4) that by blast

                  have "updb_c \<noteq> c"
                    by (metis call.sel(1) extract_op_def fun_upd_same h3 mapOp.distinct(1) operation.inject(2) ops'_def option.sel)

                  have updb_c_call': "cOp s_calls' updb_c \<triangleq> Message (NestedOp (MessageId m) (Author (Assign (String author))))"
                    using h2 h3 \<open> vis' \<subseteq> dom s_calls'\<close>
                    by (auto simp add: author_vis_def ops'_def extract_op_def `updb_c \<noteq> c`)

                  from `inv4 (s_invocOp'(i \<mapsto> GetMessage m)) (cOp s_calls')`[unfolded inv4_def, rule_format, OF updb_c_call']
                  obtain ia s where "(s_invocOp'(i \<mapsto> GetMessage m)) ia \<triangleq> SendMessage author s"
                    by blast

                  show "\<exists>s. s \<noteq> i \<and> (\<exists>content2. s_invocOp' s \<triangleq> SendMessage author content2)"
                    by (metis \<open>(s_invocOp'(i \<mapsto> GetMessage m)) ia \<triangleq> SendMessage author s\<close> map_upd_Some_unfold proc.simps(10))
                qed
              qed
            qed
          next
            case (uids1 tx s_calls' s_happensBefore' s_callOrigin' s_txOrigin' s_knownIds' vis' s_invocOp' s_invocRes' c ca resa cb res)
            show ?case
              by auto
          next
            case (uids2 tx s_calls' s_happensBefore' s_callOrigin' s_txOrigin' s_knownIds' vis' s_invocOp' s_invocRes' c ca resa cb res)
            show ?case
              by auto
          next
            case (NotExists_AtCommit tx s_calls' s_happensBefore' s_callOrigin' s_txOrigin' s_knownIds' vis' s_invocOp' s_invocRes' c res)
            then show ?case
            proof (auto simp add: inv_def, fuzzy_goal_cases inv2 inv3 inv4)
              case (inv4)
              then show ?case
                by (auto simp add: inv4_def)
            next
              case (inv2)
              then show ?case
                by (auto simp add: inv2_def updateHb_cases in_sequence_cons cong: conj_cong, fastforce)
            next
              case (inv3)
              then show ?case
                by (auto simp add: inv3_def updateHb_cases in_sequence_cons)
            qed
          next
            case (NotExists_AtReturn tx s_calls' s_happensBefore' s_callOrigin' s_txOrigin' s_knownIds' vis' s_invocOp' s_invocRes' c res)
            then show ?case
              by (auto simp add: inv_def inv1_def)
               (metis (no_types, lifting) option.inject proc.distinct(5))
          qed
        qed
      qed
    qed
  qed
qed

end