subsection \<open>Termination Proof for @{term integrate_insert}\label{sec:integrate_term}\<close>

theory IntegrateInsertCommute
  imports IntegrateAlgorithm Consistency CreateConsistent
begin

text \<open>In the following we show that @{term integrate_insert} terminates. Note that, this does not
  yet imply that the return value will not be an error state.\<close>

lemma substr_simp [simp]: "substr s l u = nths s {k. l < Suc k \<and> Suc k < u}"
proof (cases "l \<le> length s")
  case True
  have "set (nths (take l s) {k. l < Suc k \<and> Suc k < u}) = {}"
    by (simp add:set_nths)
  hence "nths (take l s) {k. l < Suc k \<and> Suc k < u} = []" by blast
  moreover have "{j. Suc (j + l) < u} = {..<(u-Suc l)}" by auto
  moreover have "min (length s) l = l" using True by auto
  ultimately
    have "nths (take l s @ drop l s) {k. l < Suc k \<and> Suc k < u} = substr s l u"
    by (simp add:nths_append del:append_take_drop_id)
  then show ?thesis by simp
next
  case False
  hence "set (nths s {k. l < Suc k \<and> Suc k < u}) = {}"
    by (simp add:set_nths)
  hence "nths s {k. l < Suc k \<and> Suc k < u} = []" by blast
  thus ?thesis using False by simp
qed

declare substr.simps [simp del]

text \<open>Instead of simplifying @{term substr} with its definition we use @{thm [source] substr_simp}
  as a simplification rule. The right hand side of @{thm [source] substr_simp} is a better
  representation within proofs. However, we cannot directly define @{term substr} using the right
  hand side as it is not constructible term for Isabelle.\<close>

lemma int_ins_loop_term_1:
  assumes "isOK (mapM (concurrent w l u) t)"
  assumes "x \<in> set (concat (projr (mapM (concurrent w l u) t)))"
  shows "x \<in> (InString \<circ> I) ` (set t)"
  using assms
  by (induction t, simp, simp add: bind_simp del:idx.simps set_concat, blast)

lemma fromSingleton_simp: "(fromSingleton xs = Inr x) = ([x] = xs)"
  by (cases xs rule: fromSingleton.cases, auto)

lemma filt_simp: "([b] = filter p [0..<n]) =
   (p b \<and> b < n \<and> (\<forall>y < n. p y \<longrightarrow> b = y))"
  apply (induction n, simp, simp)
  by (metis atLeast_upt cancel_comm_monoid_add_class.diff_cancel
      filter_empty_conv lessThan_iff less_Suc_eq neq0_conv zero_less_diff)

lemma substr_eff:
  assumes "x \<in> (InString \<circ> I) ` set (substr w l u)"
  assumes "isOK (idx w x)"
  shows "l < (projr (idx w x)) \<and> (projr (idx w x)) < u"
proof -
  obtain i where i_def: "idx w x = Inr i" using assms(2) by blast
  then have "l < i \<and> i < u" using assms(1)
    apply (simp add: set_nths image_iff fromSingleton_simp filt_simp)
    apply (simp add:ext_ids_def)
    by (metis (no_types, lifting) Suc_mono length_map less_SucI list_update_id
        list_update_same_conv map_update nth_Cons_Suc nth_append)
  thus ?thesis using i_def by auto
qed

lemma find_zip:
  assumes "find (cond \<circ> snd) (zip (p#v) (v@[s])) = Some (x,y)"
  assumes "v \<noteq> []"
  shows
    "cond y"
    "x \<in> set v \<or> y \<in> set v"
    "x = p \<or> (x \<in> set v \<and> \<not>(cond x))"
    "y = s \<or> (y \<in> set v)"
proof -
  obtain i where i_def:
    "i < Suc (length v)"
    "(zip (p#v) (v@[s])) ! i = (x,y)"
    "cond y"
    "\<forall>j. j < i \<longrightarrow> \<not>(cond ((v@[s])!j))"
    using assms apply (simp add:find_Some_iff) by force
  show "cond y" using i_def by auto
  show "x \<in> set v \<or> y \<in> set v" using assms(2) i_def(1,2)
    by (metis fst_conv in_set_conv_nth length_0_conv length_Cons length_append_singleton
        less_Suc_eq less_Suc_eq_0_disj nth_Cons_Suc nth_append nth_zip snd_conv)
  show "x = p \<or> (x \<in> set v \<and> (\<not>(cond x)))"
    apply (cases i)
    using i_def(2) apply auto[1]
    by (metis Suc_less_eq fst_conv i_def(1,2,4) length_Cons
        length_append_singleton lessI nth_Cons_Suc nth_append nth_mem nth_zip)
  show "y = s \<or> y \<in> set v"
    by (metis diff_is_0_eq' i_def(1,2) in_set_conv_nth length_Cons
        length_append_singleton less_Suc_eq_le nth_Cons_0 nth_append nth_zip snd_conv)
qed

fun int_ins_measure'
  where
    "int_ins_measure' (m,w,p,s) = (
      do {
        l \<leftarrow> idx w p;
        u \<leftarrow> idx w s;
        assert (l < u);
        return (u - l)
      })"

fun int_ins_measure
  where
    "int_ins_measure (m,w,p,s) = case_sum (\<lambda>e. 0) id (int_ins_measure' (m,w,p,s))"

text \<open>We show that during the iteration of @{term integrate_insert}, the arguments are decreasing
  with respect to @{term int_ins_measure}. Note, this means that the distance between the
  W-characters with identifiers @{term p} (resp. @{term s}) is decreasing.\<close>

lemma int_ins_loop_term:
  assumes "idx w p = Inr l"
  assumes "idx w s = Inr u"
  assumes "mapM (concurrent w l u) (substr w l u) = Inr d"
  assumes "concat d \<noteq> []"
  assumes "find ((\<lambda>x.\<lbrakk>I m\<rbrakk> < x \<or> x = s) \<circ> snd)
    (zip (p#concat d) (concat d@[s])) = Some r"
  shows "int_ins_measure (m, w, r) < u - l"
proof -
  have a: "\<And>x y. x \<in> set (concat d) \<Longrightarrow> idx w x = Inr y \<Longrightarrow> l < y \<and> y < u"
    using int_ins_loop_term_1 substr_eff assms(3) by (metis isOK_I sum.sel(2))
  hence b: "l < u" using assms
    by (metis concat.simps(1) diff_is_0_eq less_imp_le_nat
        mapM.simps(1) not_less_eq substr.simps sum.sel(2) take0)
  obtain p' s' where ps_def: "r = (p', s')" by (cases r, simp+)
  show ?thesis
  proof (cases "int_ins_measure' (m, w, r)")
    case (Inl a)
    then show ?thesis using b by (simp add:ps_def)
  next
    case (Inr b)
    then obtain l' u' where ps'_def: "idx w p' = Inr l'" "idx w s' = Inr u'"
      using ps_def apply (simp add:bind_simp del:idx.simps) by blast
    then have "l' \<ge> l \<and> l' < u \<and> u' > l \<and> u' \<le> u \<and> (l' > l \<or> u' < u)"
      using a b ps_def find_zip(2,3,4) assms(1,2,4,5)
      by (metis (no_types, lifting) Inr_inject order.order_iff_strict)
    thus ?thesis using ps_def ps'_def apply (simp add:bind_simp del:idx.simps)
      by (cases "l' < u'", simp del:idx.simps, linarith, simp del:idx.simps)
  qed
qed

lemma assert_ok_simp [simp]: "(assert p = Inr z) = p" by (cases p, simp+)

termination integrate_insert
  apply (relation "measure int_ins_measure", simp)
  using int_ins_loop_term by (simp del:idx.simps, blast)

subsection \<open>Integrate Commutes\<close>

locale integrate_insert_commute =
  fixes M :: "('a :: linorder, 's) message set"
  fixes a :: "'a extended \<Rightarrow> 'a position"
  fixes s :: "('a, 's) woot_character list"
  assumes associated_string_assm: "is_associated_string M s"
  assumes a_conditions_assm: "a_conditions (insert_messages M) a"
begin

lemma dist_ext_ids: "distinct (ext_ids s)"
  using associated_string_assm a_conditions_assm
  apply (simp add:is_associated_string_def sorted_wrt_map)
  by (metis (mono_tags) irreflp_def le_less not_le sorted_wrt_irrefl_distinct)

lemma I_inj_on_S:
  "l < length s \<and> u < length s \<and> I(s ! l) = I(s ! u) \<Longrightarrow> l = u"
  using dist_ext_ids apply (simp add:ext_ids_def)
  using nth_eq_iff_index_eq by fastforce

lemma idx_find:
  assumes "x < length (ext_ids s)"
  assumes "ext_ids s ! x = i"
  shows "idx s i = Inr x"
  using assms dist_ext_ids nth_eq_iff_index_eq
  by (simp add:filt_simp fromSingleton_simp, blast)

lemma obtain_idx:
  assumes "x \<in> set (ext_ids s)"
  shows "\<exists>i. idx s x = Inr i"
  using idx_find assms by (metis in_set_conv_nth)

lemma sorted_a:
  assumes "idx s x = Inr l"
  assumes "idx s y = Inr u"
  shows "(l \<le> u) = (a x \<le> a y)"
proof -
  have "sorted_wrt (<) (map a (ext_ids s))"
    using associated_string_assm a_conditions_assm is_associated_string_def by blast
  then show ?thesis
  using assms apply (simp add:filt_simp fromSingleton_simp)
  by (metis leD leI le_less length_map nth_map sorted_wrt_nth_less)
qed

lemma sorted_a_le: "idx s x = Inr l \<Longrightarrow> idx s y = Inr u \<Longrightarrow> (l < u) = (a x < a y)"
  by (meson sorted_a not_le)

lemma idx_intro_ext: "i < length (ext_ids s) \<Longrightarrow> idx s (ext_ids s ! i) = Inr i"
  using dist_ext_ids by (simp add:fromSingleton_simp filt_simp  nth_eq_iff_index_eq)

lemma idx_intro:
  assumes "i < length s"
  shows "idx s \<lbrakk>I (s ! i)\<rbrakk> = Inr (Suc i)"
proof -
  have "ext_ids s  ! (Suc i) = \<lbrakk>I (s ! i)\<rbrakk> \<and> Suc i < length (ext_ids s)"
    using assms by (simp add:ext_ids_def nth_append)
  thus ?thesis using idx_intro_ext by force
qed

end

locale integrate_insert_commute_insert = integrate_insert_commute +
  fixes m
  assumes consistent_assm: "consistent (M \<union> {Insert m})"
  assumes insert_assm: "Insert m \<notin> M"
  assumes a_conditions_assm_2:
    "a_conditions (insert_messages (M \<union> {Insert m})) a"
begin

definition invariant where
  "invariant pm sm = (pm \<in> set (ext_ids s) \<and> sm \<in> set (ext_ids s) \<and>
   subset (a pm, a sm) (a (P m), a (S m)) \<and>
   elem (a \<lbrakk>I m\<rbrakk>) (a pm, a sm))"

fun is_concurrent where
  "is_concurrent pm sm x = (x \<in> set s \<and>
   subset (a pm, a sm) (a (P x), a (S x)) \<and>
   elem (a \<lbrakk>I x\<rbrakk>) (a pm, a sm))"

lemma no_id_collision: "I m \<notin> I ` insert_messages M"
proof -
  have "inj_on I (insert_messages (M \<union> {Insert m}))"
    using consistent_def consistent_assm by fastforce
  hence "I m \<in> I ` insert_messages M \<longrightarrow> Insert m \<in> M"
    by (simp add: image_iff inj_on_eq_iff insert_messages_def)
  thus ?thesis using insert_assm by blast
qed

lemma not_deleted: "to_woot_char m = to_woot_character M m"
proof -
  have "Delete (DeleteMessage (I m)) \<notin> M"
  proof
    assume "Delete (DeleteMessage (I m)) \<in> M"
    hence "deps (Delete (DeleteMessage (I m))) \<subseteq> I ` insert_messages M"
      using consistent_assm associated_string_assm
      apply (simp add:consistent_def is_associated_string_def)
      using image_subset_iff by fastforce
    thus "False" using no_id_collision by simp
  qed
  thus "to_woot_char m = to_woot_character M m"
    by (cases m, simp add:to_woot_character_def delete_maybe_def)
qed

lemma invariant_imp_sorted:
  assumes "Suc l < length (ext_ids s)"
  assumes "a(ext_ids s ! l) < a \<lbrakk>I m\<rbrakk> \<and> a \<lbrakk>I m\<rbrakk> < a(ext_ids s ! (l+1))"
  shows "sorted_wrt (<) (map a (ext_ids ((take l s)@to_woot_char m#drop l s)))"
proof -
  have "l \<le> length s" using assms(1) by (simp add:ext_ids_def)
  hence "ext_ids (take l s@to_woot_char m#drop l s) =
        (take (Suc l) (ext_ids s))@\<lbrakk>I m\<rbrakk>#(drop (Suc l) (ext_ids s))"
    by (cases m, simp add:ext_ids_def take_map drop_map)
  thus ?thesis
    using assms associated_string_assm is_associated_string_def a_conditions_assm
    apply (simp flip:take_map drop_map)
    by (rule insort, simp+, blast)
qed

lemma no_self_dep: "\<not> depends_on (insert_messages M \<union> {m}) m m"
proof -
  have "wfP (depends_on (insert_messages M \<union> {m}))"
    using consistent_assm
    apply (simp add:consistent_def)
    by (metis Un_insert_right insert_insert_message sup_bot.right_neutral)
  thus ?thesis
    by (metis mem_Collect_eq wfP_eq_minimal)
qed

lemma pred_succ_order:
  "m' \<in> (insert_messages M \<union> {m}) \<Longrightarrow> a(P m') < a \<lbrakk>I m'\<rbrakk> \<and> a(S m') > a \<lbrakk>I m'\<rbrakk>"
  by (metis elem.simps is_interval.simps psi_elem a_conditions_def
      a_conditions_assm_2 insert_insert_message)

lemma find_dep:
  assumes "Insert m' \<in> (M \<union> {Insert m})"
  assumes "i \<in> deps (Insert m')"
  shows "\<lbrakk>i\<rbrakk> \<in> set (ext_ids s)"
proof -
  have "i \<in> I ` insert_messages M"
  proof (cases "m' = m")
    case True
    hence "i \<in> I ` insert_messages (M \<union> {Insert m})"
      using assms consistent_assm
      by (simp add:consistent_def, blast)
    moreover have "i \<noteq> I m" using assms True no_self_dep by auto
    ultimately show ?thesis
      by (metis (no_types, lifting) UnE image_Un image_empty image_insert
          insert_insert_message singletonD)
  next
    case False
    hence "Insert m' \<in> M" using assms by simp
    then show "i \<in> I ` insert_messages M"
      using assms is_associated_string_def associated_string_assm consistent_def
      by (metis (no_types, hide_lams) Union_iff contra_subsetD image_iff)
  qed
  hence "i \<in> I ` (set s)"
    using associated_string_assm by (simp add:is_associated_string_def)
  thus "\<lbrakk>i\<rbrakk> \<in> set (ext_ids s)"
    by (simp add:ext_ids_def image_iff)
qed

lemma find_pred:
  "m' \<in> (insert_messages M \<union> {m}) \<Longrightarrow> P m' \<in> set (ext_ids s)"
  using find_dep by (cases "P m'", (simp add:ext_ids_def insert_messages_def pred_is_dep)+)

lemma find_succ:
  "m' \<in> (insert_messages M \<union> {m}) \<Longrightarrow> S m' \<in> set (ext_ids s)"
  using find_dep by (cases "S m'", (simp add:ext_ids_def insert_messages_def succ_is_dep)+)

fun is_certified_associated_string' where
  "is_certified_associated_string' (Inr v) = (
    set v = to_woot_character (M \<union> {Insert m}) `
      (insert_messages (M \<union> {Insert m})) \<and>
    sorted_wrt (<) (map a (ext_ids v)))" |
  "is_certified_associated_string' (Inl _) = False"

lemma integrate_insert_final_step:
  assumes "invariant pm sm"
  assumes "idx s pm = Inr l"
  assumes "idx s sm = Inr (Suc l)"
  shows "is_certified_associated_string' (Inr (take l s@(to_woot_char m)#drop l s))"
proof -
  define t where "t = (take l s@(to_woot_char m)#drop l s)"
  hence "set t = set s \<union> {to_woot_char m}"
    by (metis Un_insert_right append_take_drop_id list.simps(15)
        set_append sup_bot.right_neutral)
  hence
    "set t = to_woot_character M ` insert_messages M \<union> {to_woot_character M m}"
    using not_deleted by (metis associated_string_assm is_associated_string_def)
  hence
    "set t = to_woot_character (M \<union> {Insert m}) ` insert_messages (M \<union> {Insert m})"
    apply (simp add: to_woot_character_insert_no_eff)
    using insert_insert_message by fastforce
  moreover have "sorted_wrt (<) (map a (ext_ids t))" using assms invariant_imp_sorted
    by (simp add:invariant_def fromSingleton_simp filt_simp t_def)
  ultimately show ?thesis
    using t_def associated_string_assm by (simp add:is_associated_string_def)
qed

lemma concurrent_eff:
  assumes "idx s pm = Inr l"
  assumes "idx s sm = Inr u"
  obtains d where "mapM (concurrent s l u) (substr s l u) = Inr d \<and>
    set (concat d) = InString ` I ` {x. is_concurrent pm sm x}"
proof -
  define t where "t = substr s l u"
  have "set t \<subseteq> set s \<Longrightarrow> (isOK (mapM (concurrent s l u) t) \<and>
    set (concat (projr (mapM (concurrent s l u) t))) =
    InString ` I ` {x. x \<in> set t \<and> a (P x) \<le> a pm \<and> a (S x) \<ge> a sm})"
  proof (induction t)
    case Nil
    then show ?case by simp
  next
    case (Cons th tt)
    hence "th \<in> to_woot_character M ` insert_messages M"
      using associated_string_assm by (simp add: is_associated_string_def)
    then obtain th' where th'_def:
      "th' \<in> insert_messages M \<and> P th' = P th \<and> S th' = S th"
      by (metis image_iff to_woot_character_keeps_P to_woot_character_keeps_S)
    obtain l' where l'_def: "idx s (P th) = Inr l'"
      using th'_def find_pred obtain_idx by fastforce
    obtain u' where u'_def: "idx s (S th) = Inr u'"
      using th'_def find_succ obtain_idx by fastforce
    have "{x. x = \<lbrakk>I th\<rbrakk> \<and> l' \<le> l \<and> u \<le> u'} =
      InString ` I ` {x. x = th \<and> a (P x) \<le> a pm \<and> a sm \<le> a (S x)}"
      using sorted_a l'_def u'_def assms
      by (rule_tac set_eqI, simp add:image_iff, blast)
    then show ?case
      using Cons
      by (simp add:bind_simp l'_def u'_def
          concurrent.simps[where w=th] del:idx.simps, auto)
  qed
  moreover have
    "\<And>x. (x \<in> set (substr s l u)) = (x \<in> set s \<and> a pm < a \<lbrakk>I x\<rbrakk> \<and> a \<lbrakk>I x\<rbrakk> < a sm)"
    apply (simp add:set_nths in_set_conv_nth)
    using sorted_a_le idx_intro assms by blast
  ultimately have "
    isOK (mapM (concurrent s l u) (substr s l u)) \<and>
    set (concat (projr (mapM (concurrent s l u) (substr s l u)))) =
      InString ` I ` {x. is_concurrent pm sm x}"
    by (simp only:t_def, fastforce)
  thus ?thesis using that by auto
qed

lemma concurrent_eff_2:
  assumes "invariant pm sm"
  assumes "is_concurrent pm sm x"
  shows "preserve_order \<lbrakk>I x\<rbrakk> \<lbrakk>I m\<rbrakk> (a \<lbrakk>I x\<rbrakk>) (a \<lbrakk>I m\<rbrakk>)"
proof -
  have "x \<in> to_woot_character M ` insert_messages M"
    using assms(2) associated_string_assm is_associated_string_def
      is_concurrent.elims(2) by blast
  then obtain x' where x'_def: "I x = I x' \<and> P x = P x' \<and> S x = S x' \<and> x' \<in> insert_messages M"
    using to_woot_character_keeps_P to_woot_character_keeps_S
      to_woot_character_keeps_i by fastforce
  have "elem (a \<lbrakk>I x\<rbrakk>) (a (P m), a (S m))"
    using assms by (simp add: invariant_def, auto)
  moreover have "elem (a \<lbrakk>I m\<rbrakk>) (a (P x), a (S x))"
    using assms by (simp add: invariant_def, auto)
  moreover have "a_conditions (insert_messages M \<union> {m}) a"
    by (metis insert_insert_message a_conditions_assm_2)
  ultimately have "preserve_order (I x) (I m) (a \<lbrakk>I x\<rbrakk>) (a \<lbrakk>I m\<rbrakk>)"
    by (simp add: a_conditions_def psi_preserve_order x'_def)
  thus ?thesis by (simp add: preserve_order_def)
qed

lemma concurrent_eff_3:
  assumes "idx s pm = Inr l"
  assumes "idx s sm = Inr u"
  assumes "Suc l < u"
  shows "{x. is_concurrent pm sm x} \<noteq> {}"
proof -
  define H where
    "H = {x. x \<in> insert_messages M \<and> a pm < a \<lbrakk>I x\<rbrakk> \<and> a \<lbrakk>I x\<rbrakk> < a sm}"
  have "wfP (depends_on (insert_messages M))"
    using associated_string_assm by (simp add: consistent_def is_associated_string_def)
  moreover have f:"H \<subseteq> insert_messages M" using H_def by blast
  hence "depends_on H \<le> depends_on (insert_messages M)" by auto
  ultimately have "wfP (depends_on H)" using wf_subset [to_pred] by blast
  moreover
  have u: "l < length s" using assms(2) assms(3)
    by (simp add:fromSingleton_simp filt_simp, simp add:ext_ids_def)
  hence v:"a pm < a \<lbrakk>I(s ! l)\<rbrakk> \<and> a \<lbrakk>I(s ! l)\<rbrakk> < a sm"
    using sorted_a_le assms u idx_intro by blast
  have "I (s ! l) \<in> I ` insert_messages M"
    by (metis image_eqI associated_string_assm is_associated_string_def nth_mem
        to_woot_character_keeps_i_lifted u)
  hence "\<exists>x. x \<in> H" using v H_def by auto
  ultimately obtain z where z_def: "z \<in> H" "\<And> y. depends_on H y z \<Longrightarrow> y \<notin> H"
    by (metis wfP_eq_minimal)
  have a:"\<And>x. x \<in> deps (Insert z) \<Longrightarrow> \<not>(a pm < a \<lbrakk>x\<rbrakk> \<and> a \<lbrakk>x\<rbrakk> < a sm)"
  proof -
    fix x
    assume a:"x \<in> deps (Insert z)"
    hence "x \<in> I ` insert_messages M"
      using insert_messages_def associated_string_assm
      apply (simp add:consistent_def is_associated_string_def)
      using H_def z_def(1) by blast
    then obtain x' where x'_def: "x' \<in> insert_messages M \<and> x = I x'" by blast
    hence "x' \<notin> H" using z_def
      using a depends_on.simps by blast
    thus "\<not>(a pm < a \<lbrakk>x\<rbrakk> \<and> a \<lbrakk>x\<rbrakk> < a sm)" using H_def x'_def by blast
  qed
  have "ext_ids s ! 0 = \<turnstile> \<and> 0 < length (ext_ids s)" by (simp add:ext_ids_def)
  hence b:"\<not>(a pm < a \<turnstile>)"
    by (metis not_less_zero  sorted_a_le assms(1) idx_intro_ext)
  have "ext_ids s ! (Suc (length s)) = \<stileturn> \<and> Suc (length s) < length (ext_ids s)"
    by (simp add:nth_append ext_ids_def)
  moreover have "\<not>(Suc (length s) < u)" using assms(2)
    by (simp add:fromSingleton_simp filt_simp, simp add:ext_ids_def)
  ultimately have c:"\<not>(a \<stileturn> < a sm)" by (metis sorted_a_le assms(2) idx_intro_ext)
  have d:"a (P z) \<le> a pm"
    using a b c pred_is_dep pred_succ_order H_def z_def(1) by (cases "P z", fastforce+)
  have e:"a (S z) \<ge> a sm"
    using a b c succ_is_dep pred_succ_order H_def z_def(1) by (cases "S z", fastforce+)
  have "to_woot_character M z \<in> set s"
    using f associated_string_assm is_associated_string_def z_def(1) by fastforce
  hence "is_concurrent pm sm (to_woot_character M z)"
    using H_def z_def(1) d e by simp
  thus ?thesis by blast
qed

lemma integrate_insert_result_helper:
  "invariant pm sm \<Longrightarrow> m' = m \<Longrightarrow> s' = s \<Longrightarrow>
  is_certified_associated_string' (integrate_insert m' s' pm sm)"
proof (induction m' s' pm sm rule:integrate_insert.induct)
  case (1 m' s' pm sm)
  obtain l where l_def: "idx s pm = Inr l"
    using "1"(2) invariant_def obtain_idx by blast
  obtain u where u_def: "idx s sm = Inr u"
    using "1"(2) invariant_def obtain_idx by blast
  show ?case
  proof (cases "Suc l = u")
    case True
    then show ?thesis
      apply (simp add:l_def u_def 1 del:idx.simps is_certified_associated_string'.simps)
      using "1"(2) l_def u_def integrate_insert_final_step by blast
  next
    case False
    have "a pm < a sm" using invariant_def "1"(2) by auto
    hence a:"l < u" using sorted_a_le  l_def u_def by blast
    obtain d where d_def: "mapM (concurrent s l u) (substr s l u) = Inr d \<and>
      set (concat d) = InString ` I ` {x. is_concurrent pm sm x}"
      by (metis concurrent_eff l_def u_def)
    have b:"concat d \<noteq> []"
      by (metis Suc_lessI concurrent_eff_3 False l_def u_def
          a d_def empty_set image_is_empty)
    have c:"\<And>x. x \<in> set (concat d) \<Longrightarrow>
      preserve_order x \<lbrakk>I m\<rbrakk> (a x) (a \<lbrakk>I m\<rbrakk>) \<and> x \<in> set (ext_ids s) \<and>
       a pm < a x \<and> a x < a sm"
      using 1(2) d_def concurrent_eff_2
      by (simp del:set_concat add:ext_ids_def, blast)
    obtain pm' sm' where ps'_def: "find ((\<lambda>x.\<lbrakk>I m\<rbrakk> < x \<or> x = sm) \<circ> snd)
         (zip (pm # concat d) (concat d @ [sm])) = Some (pm',sm')"
      (is "?lhs = ?rhs")
      apply (cases "?lhs")
      apply (simp add:find_None_iff)
       apply (metis in_set_conv_decomp in_set_impl_in_set_zip2 length_Cons
              length_append_singleton)
      by fastforce
    have d:"pm' = pm \<or> pm' \<in> set (concat d)" using ps'_def b
      by (metis (full_types) find_zip(3))
    hence "pm' \<in> set (ext_ids s)" using c 1(2) invariant_def by auto
    hence "pm' \<in> InString ` I ` insert_messages M \<or> pm' = \<turnstile> \<or> pm' = \<stileturn>"
      apply (simp add:ext_ids_def)
      by (metis image_image associated_string_assm is_associated_string_def
          to_woot_character_keeps_i_lifted)
    hence "pm' \<noteq> \<lbrakk>I m\<rbrakk>" using no_id_collision by blast
    hence "(pm' = pm \<or> pm' < \<lbrakk>I m\<rbrakk>) \<and> (sm' = sm \<or> sm' > \<lbrakk>I m\<rbrakk> \<and> sm' \<in> set (concat d))"
      by (metis (mono_tags, lifting) ps'_def b find_zip(1) find_zip(3) find_zip(4) less_linear)
    hence e:"invariant pm' sm'"
      using 1(2) c d apply (simp add:invariant_def del:set_concat)
      by (meson dual_order.strict_trans leD leI preserve_order_def)
    show ?thesis apply (subst integrate_insert.simps)
      using a b e ps'_def 1 d_def False l_def u_def
      by (simp add:1 del:idx.simps integrate_insert.simps)
  qed
qed

lemma integrate_insert_result:
  "is_certified_associated_string' (integrate_insert m s (P m) (S m))"
proof -
  have "invariant (P m) (S m)"
    using find_pred find_succ pred_succ_order by (simp add:invariant_def)
  thus ?thesis using integrate_insert_result_helper by blast
qed
end

lemma integrate_insert_result:
  assumes "consistent (M \<union> {Insert m})"
  assumes "Insert m \<notin> M"
  assumes "is_associated_string M s"
  shows "is_certified_associated_string (M \<union> {Insert m}) (integrate_insert m s (P m) (S m))"
proof -
  obtain t where t_def: "(integrate_insert m s (P m) (S m)) = Inr t \<and>
    set t = to_woot_character (M \<union> {Insert m}) ` (insert_messages (M \<union> {Insert m}))"
  proof -
    fix tt
    assume a:"(\<And>t. (integrate_insert m s (P m) (S m)) = Inr t \<and>
          set t = to_woot_character (M \<union> {Insert m}) ` insert_messages (M \<union> {Insert m}) \<Longrightarrow>
          tt)"
    obtain a where a_def: "a_conditions (insert_messages (M \<union> {Insert m})) a"
      using consistent_def assms by blast
    moreover have "a_conditions (insert_messages M) a"
      using assms a_subset is_associated_string_def a_def by blast
    ultimately interpret integrate_insert_commute_insert "M" "a" "s" "m"
      using assms by (simp add: integrate_insert_commute_insert_def integrate_insert_commute_def (*
                *) integrate_insert_commute_insert_axioms.intro)
    show tt using a integrate_insert_result
      apply (cases "integrate_insert m s (P m) (S m)") by auto
  qed
  have b:"\<And>a. a_conditions (insert_messages (M \<union> {Insert m})) a \<Longrightarrow>
    sorted_wrt (<) (map a (ext_ids t))"
  proof -
    fix a
    assume c:"a_conditions (insert_messages (M \<union> {Insert m})) a"
    moreover have "a_conditions (insert_messages M) a"
      using assms a_subset is_associated_string_def c by blast
    ultimately interpret integrate_insert_commute_insert "M" "a" "s" "m"
      using assms by (simp add: integrate_insert_commute_insert_def integrate_insert_commute_def (*
                *) integrate_insert_commute_insert_axioms.intro)
    show "sorted_wrt (<) (map a (ext_ids t))"
      using integrate_insert_result t_def by simp
  qed
  show "?thesis" using b t_def assms(1) by (simp add:is_associated_string_def)
qed

locale integrate_insert_commute_delete = integrate_insert_commute +
  fixes m
  assumes consistent_assm: "consistent (M \<union> {Delete m})"
begin

fun delete :: "('a, 's) woot_character \<Rightarrow> ('a, 's) woot_character"
  where "delete (InsertMessage p i u _) = InsertMessage p i u None"

definition delete_only_m :: "('a, 's) woot_character \<Rightarrow> ('a, 's) woot_character"
  where "delete_only_m x = (if DeleteMessage (I x) = m then delete x else x)"

lemma set_s: "set s = to_woot_character M ` insert_messages M"
  using associated_string_assm by (simp add:is_associated_string_def)

lemma delete_only_m_effect:
  "delete_only_m (to_woot_character M x) = to_woot_character (M \<union> {Delete m}) x"
  apply (cases x, simp add:to_woot_character_def delete_maybe_def)
  by (metis delete_only_m_def insert_message.sel(2) delete.simps)

lemma integrate_delete_result:
  "is_certified_associated_string (M \<union> {Delete m}) (integrate_delete m s)"
proof (cases m)
  case (DeleteMessage i)
  have "deps (Delete m) \<subseteq> I ` insert_messages (M \<union> {Delete m})"
    using consistent_assm by (simp add:consistent_def DeleteMessage)
  hence "i \<in> I ` insert_messages (M \<union> {Delete m})" using DeleteMessage by auto
  hence "i \<in> I ` set s" using set_s by (simp add:insert_messages_def)
  then obtain k where k_def: "I (s ! k) = i \<and> k < length s"
    by (metis imageE in_set_conv_nth)
  hence "ext_ids s ! (Suc k) = \<lbrakk>i\<rbrakk> \<and> Suc k < length (ext_ids s)"
    by (simp add:ext_ids_def nth_append)
  hence g:"idx s \<lbrakk>i\<rbrakk> = Inr (Suc k)" apply (simp add:fromSingleton_simp filt_simp)
     using dist_ext_ids nth_eq_iff_index_eq by fastforce
  moreover define t where "t = List.list_update s k (delete (s ! k))"
  ultimately have a: "integrate_delete m s = Inr t"
    using k_def DeleteMessage by (cases "s ! k", simp)
  have "\<And>j. j < length s \<Longrightarrow> (DeleteMessage (I(s ! j)) = m) = (j = k)"
    apply (simp add: DeleteMessage) using I_inj_on_S k_def by blast
  hence "List.list_update s k (delete (s ! k)) = map delete_only_m s"
    by (rule_tac nth_equalityI, (simp add:k_def delete_only_m_def)+)
  hence "set t = delete_only_m ` set s" using t_def by auto
  also have "... = to_woot_character (M \<union> {Delete m}) ` (insert_messages M)"
    using set_s delete_only_m_effect image_cong by (metis (no_types, lifting) image_image)
  finally have b:
    "set t = to_woot_character (M \<union> {Delete m}) ` (insert_messages (M \<union> {Delete m}))"
    by (simp add: insert_messages_def)
  have "ext_ids s = ext_ids t"
    apply (cases "s ! k", simp add:t_def ext_ids_def)
    by (metis (no_types, lifting) insert_message.sel(2) list_update_id map_update)
  moreover have "\<And>a. a_conditions (insert_messages M) a \<Longrightarrow> sorted_wrt (<) (map a (ext_ids s))"
    using associated_string_assm is_associated_string_def by blast
  ultimately have c: "\<And>a. a_conditions (insert_messages (M \<union> {Delete m})) a
                  \<Longrightarrow> sorted_wrt (<) (map a (ext_ids t))"
    by (simp add:insert_messages_def)
  show ?thesis
    apply (simp add:a is_associated_string_def b c)
    using consistent_assm by fastforce
qed
end

lemma integrate_delete_result:
  assumes "consistent (M \<union> {Delete m})"
  assumes "is_associated_string M s"
  shows "is_certified_associated_string (M \<union> {Delete m}) (integrate_delete m s)"
proof -
  obtain a where a_def: "a_conditions (insert_messages (M \<union> {Delete m})) a"
    using consistent_def assms by blast
  moreover have "a_conditions (insert_messages M) a"
    using assms a_subset is_associated_string_def a_def by blast
  ultimately interpret integrate_insert_commute_delete "M" "a" "s" "m"
    using assms by (simp add: integrate_insert_commute_def integrate_insert_commute_delete.intro
            integrate_insert_commute_delete_axioms.intro)
  show "?thesis" using integrate_delete_result by blast
qed

fun is_delete :: "(('a, 's) message) \<Rightarrow> bool"
  where
    "is_delete (Insert m) = False" |
    "is_delete (Delete m) = True"

proposition integrate_insert_commute:
  assumes "consistent (M \<union> {m})"
  assumes "is_delete m \<or> m \<notin> M"
  assumes "is_associated_string M s"
  shows "is_certified_associated_string (M \<union> {m}) (integrate s m)"
  using assms integrate_insert_result integrate_delete_result by (cases m, fastforce+)

end


section \<open> Undefinedness \<close>

theory utp_undef
  imports "UTP1-Designs.utp_designs" "UTP1.utp_expr_funcs"
begin

type_synonym ('a, '\<alpha>) pexpr = "('a option, '\<alpha>) uexpr"

definition pexpr_undef :: "('a, '\<alpha>) pexpr" ("\<bottom>\<^sub>\<D>") where
[upred_defs]: "\<bottom>\<^sub>\<D> = \<guillemotleft>None\<guillemotright>"

definition pexpr_down :: "('a, '\<alpha>) pexpr \<Rightarrow> ('a, '\<alpha>) uexpr" ("\<lfloor>_\<rfloor>\<^sub>\<D>") where
[upred_defs]: "\<lfloor>e\<rfloor>\<^sub>\<D> = uop the e"

no_utp_lift pexpr_down (0)

lift_definition pexpr_defined :: "('a, '\<alpha>) pexpr \<Rightarrow> '\<alpha> upred" ("\<D>'(_')") is
"\<lambda> e b. b \<in> dom(e)" .

update_uexpr_rep_eq_thms

lemma undef_defined: "\<D>(\<bottom>\<^sub>\<D>) = false"
  by (rel_simp)

definition partial_assign :: "('a \<Longrightarrow> '\<alpha>) \<Rightarrow> ('a, '\<alpha>) pexpr \<Rightarrow> '\<alpha> hrel_des" where
[upred_defs, ndes_simp]: "partial_assign x e = (\<^bold>S(x) \<and> \<D>(e)) \<turnstile>\<^sub>n x := \<lfloor>e\<rfloor>\<^sub>\<D>"

syntax
  "_passignd" :: "svid \<Rightarrow> logic \<Rightarrow> logic"  (infixr ":=\<^sub>\<D>" 62)

translations
  "_passignd x e" == "CONST partial_assign x e"

lemma passign_bot: "x :=\<^sub>\<D> \<bottom>\<^sub>\<D> = \<bottom>\<^sub>D"
  by (rel_auto)

lemma passign_wp [wp]: "x :=\<^sub>\<D> v wp\<^sub>D b = (\<^bold>S(x) \<and> \<D>(v) \<and> b\<lbrakk>\<lfloor>v\<rfloor>\<^sub>\<D>/&x\<rbrakk>)"
  by (simp add: partial_assign_def wp conj_assoc)

end


(*
 * Copyright 2020, Data61, CSIRO (ABN 41 687 119 230)
 *
 * SPDX-License-Identifier: BSD-2-Clause
 *)

(* License: BSD, terms see file ./LICENSE *)

(*
  Structures supporting CTypes.
  Primarily sets up types, defines pointers and the raw heap view.
*)

theory CTypesBase
imports
  "./$L4V_ARCH/Addr_Type"
  "HOL-Library.Prefix_Order"
  "Word_Lib.Signed_Words"
begin

section "Type setup"

type_synonym byte = "8 word"

type_synonym memory = "addr \<Rightarrow> byte"
type_synonym 'a mem_upd = "addr \<Rightarrow> 'a \<Rightarrow> memory \<Rightarrow> memory"
type_synonym 'a mem_read = "addr \<Rightarrow> memory \<Rightarrow> 'a"

class unit_class =
  assumes there_is_only_one: "x = y"

instantiation unit :: unit_class
begin
instance by (intro_classes, simp)
end

subsection "Pointers"

datatype 'a ptr = Ptr addr

abbreviation
  NULL :: "'a ptr" where
  "NULL \<equiv> Ptr 0"

ML \<open>
structure Ptr_Syntax =
struct

  val show_ptr_types = Attrib.setup_config_bool @{binding show_ptr_types} (K true)

  fun ptr_tr' cnst ctxt typ ts = if Config.get ctxt show_ptr_types then
      case Term.strip_type typ of
        ([@{typ addr}], Type (@{type_name "ptr"}, [T])) =>
          list_comb
            (Syntax.const cnst $ Syntax_Phases.term_of_typ ctxt T
            , ts)
        | _ => raise Match
  else raise Match

  fun ptr_coerce_tr' cnst ctxt typ ts = if Config.get ctxt show_ptr_types then
      case Term.strip_type typ of
        ([Type (@{type_name ptr}, [S])], Type (@{type_name "ptr"}, [T])) =>
          list_comb
            (Syntax.const cnst $ Syntax_Phases.term_of_typ ctxt S
                               $ Syntax_Phases.term_of_typ ctxt T
            , ts)
        | _ => raise Match
  else raise Match
end
\<close>

syntax
  "_Ptr" :: "type \<Rightarrow> logic" ("(1PTR/(1'(_')))")
translations
  "PTR('a)" => "CONST Ptr :: (addr \<Rightarrow> 'a ptr)"
typed_print_translation
  \<open> [(@{const_syntax Ptr}, Ptr_Syntax.ptr_tr' @{syntax_const "_Ptr"})] \<close>

primrec
  ptr_val :: "'a ptr \<Rightarrow> addr"
where
  ptr_val_def: "ptr_val (Ptr a) = a"

primrec
  ptr_coerce :: "'a ptr \<Rightarrow> 'b ptr" where
  "ptr_coerce (Ptr a) = Ptr a"

syntax
  "_Ptr_coerce" :: "type \<Rightarrow> type \<Rightarrow> logic" ("(1PTR'_COERCE/(1'(_ \<rightarrow> _')))")
translations
  "PTR_COERCE('a \<rightarrow> 'b)" => "CONST ptr_coerce :: ('a ptr \<Rightarrow> 'b ptr)"
typed_print_translation
  \<open> [(@{const_syntax ptr_coerce}, Ptr_Syntax.ptr_coerce_tr' @{syntax_const "_Ptr_coerce"})] \<close>

definition
  (* no ctype/memtype-class constraints on these so as to allow comparison of
     void * pointers, which are represented as Isabelle type unit ptr *)
  ptr_less :: "'a ptr \<Rightarrow> 'a ptr \<Rightarrow> bool" (infixl "<\<^sub>p" 50) where
  "p <\<^sub>p q \<equiv> ptr_val p < ptr_val q"

definition
  ptr_le :: "'a ptr \<Rightarrow> 'a ptr \<Rightarrow> bool" (infixl "\<le>\<^sub>p" 50) where
  "p \<le>\<^sub>p q \<equiv> ptr_val p \<le> ptr_val q"

instantiation ptr :: (type) ord
begin

definition
  ptr_less_def': "p < q \<equiv> p <\<^sub>p q"
definition
  ptr_le_def': "p \<le> q \<equiv> p \<le>\<^sub>p q"

instance ..

end

lemma ptr_val_case: "ptr_val p = (case p of Ptr v \<Rightarrow> v)"
  by (cases p) simp

instantiation ptr :: (type) linorder
begin
instance
  by (intro_classes)
     (unfold ptr_le_def' ptr_le_def ptr_less_def' ptr_less_def ptr_val_case,
      auto split: ptr.splits)
end

subsection "Raw heap"

text \<open>A raw map from addresses to bytes\<close>

type_synonym heap_mem = "addr \<Rightarrow> byte"

text \<open>For heap h, pointer p and nat n, (heap_list h n p) returns the list
        of bytes in the heap taken from addresses {p..+n}\<close>

primrec
  heap_list :: "heap_mem \<Rightarrow> nat \<Rightarrow> addr \<Rightarrow> byte list"
where
  heap_list_base: "heap_list h 0 p = []"
| heap_list_rec:  "heap_list h (Suc n) p = h p # heap_list h n (p + 1)"

section "Intervals"

text \<open>
  For word a and nat b, {a..+b} is the set of words x,
  with unat (x - a) < b.\<close>

definition
  intvl :: "'a::len word \<times> nat \<Rightarrow> 'a::len word set" where
  "intvl x \<equiv> {z. \<exists>k. z = fst x + of_nat k \<and> k < snd x}"

abbreviation
  "intvl_abbr" :: "'a::len word \<Rightarrow> nat \<Rightarrow> 'a word set" ("{_..+_}") where
  "{a..+b} \<equiv> intvl (a,b)"

section "dt_pair: a reimplementation of 2 item tuples"

datatype
    ('a,'b) dt_pair = DTPair 'a 'b

primrec
  dt_fst :: "('a,'b) dt_pair \<Rightarrow> 'a"
where
  "dt_fst (DTPair a b) = a"

primrec
  dt_snd :: "('a,'b) dt_pair \<Rightarrow> 'b"
where
  "dt_snd (DTPair a b) = b"

lemma split_DTPair_All:
  "(\<forall>x. P x) = (\<forall>a b. P (DTPair a b))"
  by (rule iffI; clarsimp) (case_tac x, simp)

lemma surjective_dt_pair:
  "p = DTPair (dt_fst p) (dt_snd p)"
  by (cases p) simp

lemmas dt_pair_collapse [simp] = surjective_dt_pair[symmetric]

lemma split_DTPair_all[no_atp]: "(\<And>x. PROP P x) \<equiv> (\<And>a b. PROP P (DTPair a b))"
proof
  fix a b
  assume "\<And>x. PROP P x"
  then show "PROP P (DTPair a b)" .
next
  fix x
  assume "\<And>a b. PROP P (DTPair a b)"
  from \<open>PROP P (DTPair (dt_fst x) (dt_snd x))\<close> show "PROP P x" by simp
qed

type_synonym normalisor = "byte list \<Rightarrow> byte list"

section "Properties of pointers"

lemma Ptr_ptr_val [simp]:
  "Ptr (ptr_val p) = p"
  by (case_tac p) simp

lemma ptr_val_ptr_coerce [simp]:
  "ptr_val (ptr_coerce p) = ptr_val p"
  by (case_tac p) simp

lemma Ptr_ptr_coerce [simp]:
  "Ptr (ptr_val p) = ptr_coerce p"
  by (case_tac p) simp

lemma ptr_coerce_id [simp]:
  "ptr_coerce p = p"
  by (case_tac p) simp

lemma ptr_coerce_idem [simp]:
  "ptr_coerce (ptr_coerce p) = ptr_coerce p"
  by (case_tac p) simp

lemma ptr_val_inj [simp]:
  "(ptr_val p = ptr_val q) = (p = q)"
  by (case_tac p, case_tac q) auto

lemma ptr_coerce_NULL [simp]:
  "(ptr_coerce p = NULL) = (p = NULL)"
  by (case_tac p) simp

lemma NULL_ptr_val:
  "(p = NULL) = (ptr_val p = 0)"
  by (case_tac p) simp

instantiation ptr :: (type) finite
begin
instance
  by (intro_classes)
     (auto intro!: finite_code finite_imageD [where f=ptr_val] injI)
end

section "Properties of the raw heap"

lemma heap_list_length [simp]:
  "length (heap_list h n p) = n"
  by (induct n arbitrary: p) auto

lemma heap_list_split:
  shows "k \<le> n \<Longrightarrow> heap_list h n x = heap_list h k x @ heap_list h (n - k) (x + of_nat k)"
proof (induct n arbitrary: k x)
  case 0 thus ?case by simp
next
  case (Suc n) thus ?case
    by (cases k, auto simp: ac_simps)
qed

lemma heap_list_split2:
  "heap_list h (x + y) p = heap_list h x p @ heap_list h y (p + of_nat x)"
  by (subst heap_list_split [where k=x], auto)

section "Properties of intervals"

lemma intvlI:
  "x < n \<Longrightarrow> p + of_nat x \<in> {p..+n}"
  by (force simp: intvl_def)

lemma intvlD:
  "q \<in> {p..+n} \<Longrightarrow> \<exists>k. q = p + of_nat k \<and> k < n"
  by (force simp: intvl_def)

lemma intvl_empty [simp]:
  "{p..+0} = {}"
  by (fast dest: intvlD)

lemma intvl_Suc:
  "q \<in> {p..+Suc 0} \<Longrightarrow> p = q"
  by (force dest: intvlD)

lemma intvl_self:
  "0 < n \<Longrightarrow> x \<in> {x..+n}"
  by (force simp: intvl_def)

lemma intvl_start_inter:
  "\<lbrakk> 0 < m; 0 < n \<rbrakk> \<Longrightarrow> {p..+m} \<inter> {p..+n} \<noteq> {}"
  by (force simp: disjoint_iff_not_equal dest: intvl_self)

lemma intvl_overflow:
  assumes "2^len_of TYPE('a) \<le> n"
  shows "{(p::'a::len word)..+n} = UNIV"
proof -
  have witness:
    "\<And>x. x = p + of_nat (unat (x - p)) \<and> unat (x - p) < n"
    using assms by simp unat_arith
  show ?thesis unfolding intvl_def by (auto intro!: witness)
qed

declare of_nat_diff [simp]

lemma intvl_self_offset:
  fixes p::"'a::len word"
  assumes a: "2^len_of TYPE('a) - n < x" and b: "x < 2^len_of TYPE('a)" and
      c: "(p::'a::len word) \<notin> {p + of_nat x..+n}"
  shows False
proof -
  let ?j = "2^len_of TYPE('a) - x"
  from b have b': "of_nat x + of_nat ?j  = (0::'a::len word)" using of_nat_2p by auto
  moreover from a b have "?j < n" by arith
  with b b' c show  ?thesis by (force simp: intvl_def)
qed

lemma intvl_mem_offset:
  "\<lbrakk> q \<in> {p..+unat x}; q \<notin> {p..+unat y}; unat y \<le> unat x \<rbrakk> \<Longrightarrow>
      q \<in> {p + y..+unat x - unat y}"
  by (clarsimp simp: intvl_def) (rule_tac x="k - unat y" in exI, auto)

lemma intvl_plus_sub_offset:
  "x \<in> {p + y..+q - unat y} \<Longrightarrow> x \<in> {p..+q}"
  by (clarsimp simp: intvl_def) (rule_tac x="k + unat y" in exI, auto)

lemma intvl_plus_sub_Suc:
  "x \<in> {p + 1..+q - Suc 0} \<Longrightarrow> x \<in> {p..+q}"
  by (rule intvl_plus_sub_offset [where y=1], simp)

lemma intvl_neq_start:
  "\<lbrakk> (q::'a::len word) \<in> {p..+n}; p \<noteq> q \<rbrakk> \<Longrightarrow> q \<in> {p + 1..+n - Suc 0}"
  by (clarsimp simp: intvl_def)
     (metis (no_types) Suc_diff_1 add.commute add_Suc_right diff_diff_left neq0_conv
                       of_nat_Suc semiring_1_class.of_nat_0 zero_less_diff)

lemmas unat_simps' =
  word_arith_nat_defs word_unat.eq_norm len_of_addr_card mod_less

lemma intvl_offset_nmem:
  "\<lbrakk> q \<in> {(p::'a::len word)..+unat x}; y \<le>  2^len_of TYPE('a) - unat x \<rbrakk> \<Longrightarrow>
      q \<notin> {p + x..+y}"
  apply (clarsimp simp: intvl_def)
  apply (simp only: unat_simps')
  apply (subst (asm) word_unat.Abs_inject)
    apply (auto simp: unats_def)
  done

lemma intvl_Suc_nmem' [simp]:
  "n < 2^len_of TYPE('a) \<Longrightarrow> (p::'a::len word) \<notin> {p + 1..+n - Suc 0}"
  by (clarsimp simp: intvl_def)
     (unat_arith, simp only: unat_simps')

lemma intvl_start_le:
  "x \<le> y \<Longrightarrow> {p..+x} \<subseteq> {p..+y}"
  by (force simp: intvl_def)

lemma intvl_sub_eq:
  assumes "x \<le> y"
  shows "{p + x..+unat (y - x)} = {p..+unat y} - {p..+unat x}"
proof -
  have "unat y - unat x \<le> 2 ^ len_of TYPE('a) - unat x"
    by (insert unat_lt2p [of y], arith)
  moreover have "x \<le> y" by fact
  moreover hence "unat (y - x) = unat y - unat x"
    by (simp add: word_le_nat_alt, unat_arith)
  ultimately show ?thesis
    by (force dest: intvl_offset_nmem intvl_mem_offset elim: intvl_plus_sub_offset
              simp: word_le_nat_alt)

qed

end


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

begin
(*>*)

subsection \<open>Introduction\<close>

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

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

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

(*which is illustrated in Figure 1. In particular, proofs are
given for the equivalences of different axiomatizations and the
inclusion relations shown in the cube.*)

section \<open>Framework\<close>

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

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

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

(*Possibilist--constant domain--quantification.*)
abbreviation eforall ("\<^bold>\<forall>") where "\<^bold>\<forall>\<Phi> \<equiv> \<lambda>w.\<forall>x. (\<Phi> x w)"
abbreviation eforallB (binder"\<^bold>\<forall>"[8]9) where "\<^bold>\<forall>x. \<phi>(x) \<equiv> \<^bold>\<forall>\<phi>"
abbreviation eexists ("\<^bold>\<exists>") where "\<^bold>\<exists>\<Phi> \<equiv> \<lambda>w.\<exists>x. (\<Phi> x w)"
abbreviation eexistsB (binder"\<^bold>\<exists>"[8]9) where "\<^bold>\<exists>x. \<phi>(x) \<equiv> \<^bold>\<exists>\<phi>"

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

consts r :: "\<alpha>" (infixr "r" 70) (*Betterness relation, cf. def. of \<circle><_|_>.*)

(*Max rule *)

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

(* opt rule*)

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

(*David Lewis's evaluation rule for the conditional *)
abbreviation lewcond  :: "\<sigma>\<Rightarrow>\<sigma>\<Rightarrow>\<sigma>" ("\<otimes><_|_>")
  where "\<otimes><\<psi>|\<phi>> \<equiv> (\<lambda>v. (\<not>(\<exists>x. (\<phi>)(x))\<or>  (\<exists>x. ((\<phi>)(x)\<and>(\<psi>)(x) \<and> (\<forall>y. ((y r x) \<longrightarrow> (\<phi>)(y)\<longrightarrow>(\<psi>)(y)))))))"
definition lewperm :: "\<sigma>\<Rightarrow>\<sigma>\<Rightarrow>\<sigma>" ("\<pi><_|_>")
  where "\<pi><\<psi>|\<phi>> \<equiv>\<^bold>\<not>\<otimes><\<^bold>\<not>\<psi>|\<phi>>"

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

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

subsection \<open>Properties\<close>

text \<open>We have the following constraints on the betterness relation\<close>

abbreviation reflexivity  where "reflexivity  \<equiv> (\<forall>x. x r x)"
abbreviation mlimitedness  where "mlimitedness \<equiv> (\<forall>\<phi>. (\<exists>x. (\<phi>)x) \<longrightarrow> (\<exists>x. max<\<phi>>x))"
abbreviation msmoothness  where "msmoothness \<equiv> (\<forall>\<phi> x. ((\<phi>)x \<longrightarrow> (max<\<phi>>x \<or> (\<exists>y. (y r x \<and> \<not>(x r y) \<and> max<\<phi>>y)))))"
abbreviation transitivity where "transitivity \<equiv> (\<forall>x y z. (x r y \<and> y r z) \<longrightarrow> x r z)"
abbreviation totalness where "totalness \<equiv> (\<forall>x y. (x r y \<or> y r x))"
abbreviation Ferrers where "Ferrers \<equiv> (\<forall>x y z u. ((x r u) \<and> (y r z)) \<longrightarrow> (x r z) \<or> (y r u))"

(* Some useful relations for constraining accessibility relations*)

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

(*In HOL the transitive closure of a relation can be defined in a single line.*)
definition tc :: "\<alpha>\<Rightarrow>\<alpha>" where "tc R \<equiv> \<lambda>x y.\<forall>Q. transitive Q \<longrightarrow> (sub_rel R Q \<longrightarrow> Q x y)"

text \<open>We define Suzumura consistency:\<close>
abbreviation Suzumura
  where "Suzumura R \<equiv> \<forall>x y. (tc R x y \<longrightarrow> ( R y x \<longrightarrow> R x y))"

(* this is the  condition of a-cyclicity. Loops of pairs of strict betterness are ruled out *)

text \<open>We define a-cyciclicity TODO:\<close>

abbreviation loopfree
  where "loopfree R \<equiv> \<forall>x y. (tc assfactor R x y \<longrightarrow> ( R y x \<longrightarrow> R x y))"

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

text \<open>We go through the known correspondances, and verify them \<close>

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

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

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

text \<open>Smoothness corresponds to cautious monotony (CM)\<close>

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

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

  text \<open>interval order (totalness plus Ferrers) corresponds to disjunctive rationality
 DR. The proof of completeness has not been published yet\<close>

lemma assumes "totalness"
     (* assumes "Ferrers"*)
      shows  DR: "\<lfloor>\<circle><\<chi>|(\<phi>\<^bold>\<or>\<psi>)>\<^bold>\<rightarrow>((\<circle><\<chi>|\<phi>>\<^bold>)\<^bold>\<or>(\<circle><\<chi>|\<psi>>))\<rfloor>" sledgehammer  (*proof found*)

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

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

lemma assumes "transitivity"
      assumes "totalness"
      shows  Sp: "\<lfloor>( P<\<psi>|\<phi>> \<^bold>\<and> \<circle><(\<psi>\<^bold>\<rightarrow>\<chi>)|\<phi>>) \<^bold>\<rightarrow> \<circle><\<chi>|(\<phi>\<^bold>\<and>\<psi>)>\<rfloor>" sledgehammer oops
                                                                       (*proof found*)
lemma assumes  Sp: "\<lfloor>( P<\<psi>|\<phi>> \<^bold>\<and> \<circle><(\<psi>\<^bold>\<rightarrow>\<chi>)|\<phi>>) \<^bold>\<rightarrow> \<circle><\<chi>|(\<phi>\<^bold>\<and>\<psi>)>\<rfloor>"
      shows "totalness" sledgehammer  oops (* timed out*)
lemma assumes  Sp: "\<lfloor>( P<\<psi>|\<phi>> \<^bold>\<and> \<circle><(\<psi>\<^bold>\<rightarrow>\<chi>)|\<phi>>) \<^bold>\<rightarrow> \<circle><\<chi>|(\<phi>\<^bold>\<and>\<psi>)>\<rfloor>"
      shows "transitivity" sledgehammer   (* timed out*)

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

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

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

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

text \<open>Correspondance\<close>

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

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

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

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

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

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

text \<open>interval order (totalness plus Ferrers) corresponds to DR\<close>

lemma assumes "totalness"
     (* assumes "Ferrers"*)
      shows  DR: "\<lfloor>\<odot><\<chi>|\<phi>\<^bold>\<or>\<psi>>\<^bold>\<rightarrow>(\<odot><\<chi>|\<phi>>\<^bold>\<or>\<odot><\<chi>|\<psi>>)\<rfloor>" sledgehammer oops (* timed out*)

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

subsection \<open>Closure maximality and Lewis rule\<close>

(*ToDO*)

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

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

lemma
  assumes  D : "\<lfloor>\<diamond>\<phi> \<^bold>\<rightarrow> (\<otimes><\<psi>|\<phi>> \<^bold>\<rightarrow>\<pi><\<psi>|\<phi>>)\<rfloor>"
  shows "totalness" sledgehammer

section \<open>Negative results\<close>

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

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

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

(*ToDO*)

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

(*ToDO*)

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

(*ToDO*)

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

(*ToDO*)

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

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

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

lemma assumes "transitivity"
      shows  Sp: "\<lfloor>( \
<\<psi>|\<phi>> \<^bold>\<and> \<odot><(\<psi>\<^bold>\<rightarrow>\<chi>)|\<phi>>) \<^bold>\<rightarrow> \<odot><\<chi>|(\<phi>\<^bold>\<and>\<psi>)>\<rfloor>" sledgehammer oops
                                                                       (*proof found*)
lemma assumes "transitivity"
  shows  Trans: "\<lfloor>(\
<\<phi>|\<phi>\<^bold>\<or>\<psi>> \<^bold>\<and> \
<\<xi>|\<psi>\<^bold>\<or>\<xi>>)\<^bold>\<rightarrow>\
<\<xi>|\<phi>\<^bold>\<or>\<xi>>\<rfloor>" sledgehammer oops
                                                                       (*the prover gave up*)
lemma assumes Sp: "\<lfloor>( \
<\<psi>|\<phi>> \<^bold>\<and> \<odot><(\<psi>\<^bold>\<rightarrow>\<chi>)|\<phi>>) \<^bold>\<rightarrow> \<odot><\<chi>|(\<phi>\<^bold>\<and>\<psi>)>\<rfloor>"
      assumes Trans: "\<lfloor>(\
<\<phi>|\<phi>\<^bold>\<or>\<psi>> \<^bold>\<and> \
<\<xi>|\<psi>\<^bold>\<or>\<xi>>)\<^bold>\<rightarrow>\
<\<xi>|\<phi>\<^bold>\<or>\<xi>>\<rfloor>"
      shows "transitivity"  sledgehammer

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

(*to do*)

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


section \<open>Generic Algorithm to Generate Sets from Lists\<close>
theory From_List_GA
imports Imp_Set_Spec Imp_List_Spec Hash_Set_Impl Array_Set_Impl
begin

term fold

  primrec from_list_ga_aux where
    "from_list_ga_aux ins [] s = return s"
  | "from_list_ga_aux ins (x#l) s
     = do { s \<leftarrow> ins x s; from_list_ga_aux ins l s }"

  lemma from_list_ga_aux_rule:
    assumes "imp_set_ins is_set ins"
    shows
    "< is_set s p > from_list_ga_aux ins l p <\<lambda>r. is_set (set l \<union> s) r >\<^sub>t"
  proof -
    interpret imp_set_ins is_set ins by fact
    show ?thesis
    proof (induction l arbitrary: s p)
      case Nil thus ?case by sep_auto
    next
      case (Cons x l)
      show ?case by (sep_auto heap: Cons.IH)
    qed
  qed

  definition "from_list_ga e i l = do { s\<leftarrow>e; from_list_ga_aux i l s}"

  lemma from_list_ga_rule:
    fixes empty
    assumes "imp_set_empty is_set empty"
    assumes I: "imp_set_ins is_set ins"
    shows "<emp> from_list_ga empty ins l <\<lambda>r. is_set (set l) r>\<^sub>t"
  proof -
    interpret imp_set_empty is_set empty by fact
    note [sep_heap_rules] = from_list_ga_aux_rule[OF I]
    show ?thesis unfolding from_list_ga_def by sep_auto
  qed

  definition "hs_from_list \<equiv> from_list_ga hs_new hs_ins"
  lemmas hs_from_list_rule[sep_heap_rules]
    = from_list_ga_rule[OF hs_new_impl hs_ins_impl, folded hs_from_list_def]

  definition "ias_from_list \<equiv> from_list_ga ias_new ias_ins"
  lemmas ias_from_list_rule[sep_heap_rules]
    = from_list_ga_rule[OF ias_empty_impl ias_ins_impl,
        folded ias_from_list_def]

end