section \<open> Extra Features for Finite Maps \<close>

theory Finite_Map_Extras
  imports "HOL-Library.Finite_Map"
begin

text \<open> Extra lemmas and syntactic sugar for \<open>fmap\<close> \<close>

notation fmlookup (infixl \<open>$$\<close> 900)

notation fmempty (\<open>{$$}\<close>)

nonterminal fmaplets and fmaplet

syntax
  "_fmaplet"  :: "['a, 'a] \<Rightarrow> fmaplet"                        ("_ /$$:=/ _")
  "_fmaplets" :: "['a, 'a] \<Rightarrow> fmaplet"                        ("_ /[$$:=]/ _")
  ""          :: "fmaplet \<Rightarrow> fmaplets"                        ("_")
  "_Fmaplets" :: "[fmaplet, fmaplets] \<Rightarrow> fmaplets"            ("_,/ _")
  "_FmapUpd"  :: "[('a, 'b) fmap, fmaplets] \<Rightarrow> ('a, 'b) fmap" ("_/'(_')" [900, 0] 900)
  "_Fmap"     :: "fmaplets \<Rightarrow> ('a, 'b) fmap"                  ("(1{_})")

translations
  "_FmapUpd m (_Fmaplets xy ms)"  \<rightleftharpoons> "_FmapUpd (_FmapUpd m xy) ms"
  "_FmapUpd m (_fmaplet  x y)"    \<rightleftharpoons> "CONST fmupd x y m"
  "_Fmap ms"                     \<rightleftharpoons> "_FmapUpd (CONST fmempty) ms"
  "_Fmap (_Fmaplets ms1 ms2)"     \<leftharpoondown> "_FmapUpd (_Fmap ms1) ms2"
  "_Fmaplets ms1 (_Fmaplets ms2 ms3)" \<leftharpoondown> "_Fmaplets (_Fmaplets ms1 ms2) ms3"

abbreviation fmap_lookup_the (infixl \<open>$$!\<close> 900) where
  "m $$! k \<equiv> the (m $$ k)"

lemma fmadd_singletons_comm:
  assumes "k\<^sub>1 \<noteq> k\<^sub>2"
  shows "{k\<^sub>1 $$:= v\<^sub>1} ++\<^sub>f {k\<^sub>2 $$:= v\<^sub>2} = {k\<^sub>2 $$:= v\<^sub>2} ++\<^sub>f {k\<^sub>1 $$:= v\<^sub>1}"
proof (intro fmap_ext)
  fix k
  consider
    (a) "k = k\<^sub>1" |
    (b) "k = k\<^sub>2" |
    (c) "k \<noteq> k\<^sub>1 \<and> k \<noteq> k\<^sub>2"
    by auto
  with assms show "({k\<^sub>1 $$:= v\<^sub>1} ++\<^sub>f {k\<^sub>2 $$:= v\<^sub>2}) $$ k = ({k\<^sub>2 $$:= v\<^sub>2} ++\<^sub>f {k\<^sub>1 $$:= v\<^sub>1}) $$ k"
    by auto
qed

lemma fmap_singleton_comm:
  assumes "m $$ k = None"
  shows "m ++\<^sub>f {k $$:= v} = {k $$:= v} ++\<^sub>f m"
  using assms
proof (induction m arbitrary: k v)
  case fmempty
  then show ?case
    by simp
next
  case (fmupd x y m)
  have "m(x $$:= y) ++\<^sub>f {k $$:= v} = m ++\<^sub>f {x $$:= y} ++\<^sub>f {k $$:= v}"
    by simp
  also from fmupd.hyps and fmupd.IH have "\<dots> = {x $$:= y} ++\<^sub>f m ++\<^sub>f {k $$:= v}"
    by simp
  also from fmupd.prems and fmupd.hyps and fmupd.IH have "\<dots> = {x $$:= y} ++\<^sub>f {k $$:= v} ++\<^sub>f m"
    by (metis fmadd_assoc fmupd_lookup)
  also have "\<dots> = {k $$:= v} ++\<^sub>f m(x $$:= y)"
  proof (cases "x \<noteq> k")
    case True
    then have "{x $$:= y} ++\<^sub>f {k $$:= v} ++\<^sub>f m = {k $$:= v} ++\<^sub>f {x $$:= y} ++\<^sub>f m"
      using fmadd_singletons_comm by metis
    also from fmupd.prems and fmupd.hyps and fmupd.IH have "\<dots> = {k $$:= v} ++\<^sub>f m ++\<^sub>f {x $$:= y}"
      by (metis fmadd_assoc)
    finally show ?thesis
      by simp
  next
    case False
    with fmupd.prems show ?thesis
      by auto
  qed
  finally show ?case .
qed

lemma fmap_disj_comm:
  assumes "fmdom' m\<^sub>1 \<inter> fmdom' m\<^sub>2 = {}"
  shows "m\<^sub>1 ++\<^sub>f m\<^sub>2 = m\<^sub>2 ++\<^sub>f m\<^sub>1"
  using assms
proof (induction m\<^sub>2 arbitrary: m\<^sub>1)
  case fmempty
  then show ?case
    by simp
next
  case (fmupd k v m\<^sub>2)
  then show ?case
  proof (cases "m\<^sub>1 $$ k = None")
    case True
    from fmupd.hyps have "m\<^sub>1 ++\<^sub>f m\<^sub>2(k $$:= v) = m\<^sub>1 ++\<^sub>f m\<^sub>2 ++\<^sub>f {k $$:= v}"
      by simp
    also from fmupd.prems and fmupd.hyps and fmupd.IH have "\<dots> = m\<^sub>2 ++\<^sub>f m\<^sub>1 ++\<^sub>f {k $$:= v}"
      by simp
    also from True have "\<dots> = m\<^sub>2 ++\<^sub>f {k $$:= v} ++\<^sub>f m\<^sub>1"
      using fmap_singleton_comm by (metis fmadd_assoc)
    finally show ?thesis
      by simp
  next
    case False
    with fmupd.prems show ?thesis
      by auto
  qed
qed

lemma fmran_singleton: "fmran {k $$:= v} = {|v|}"
proof -
  have "v' |\<in>| fmran {k $$:= v} \<Longrightarrow> v' = v" for v'
  proof -
    assume "v' |\<in>| fmran {k $$:= v}"
    fix k'
    have "fmdom' {k $$:= v} = {k}"
      by simp
    then show "v' = v"
    proof (cases "k' = k")
      case True
      with \<open>v' |\<in>| fmran {k $$:= v}\<close> show ?thesis
        using fmdom'I by fastforce
    next
      case False
      with \<open>fmdom' {k $$:= v} = {k}\<close> and \<open>v' |\<in>| fmran {k $$:= v}\<close> show ?thesis
        using fmdom'I by fastforce
    qed
  qed
  moreover have "v |\<in>| fmran {k $$:= v}"
    by (simp add: fmranI)
  ultimately show ?thesis
    by (simp add: fsubsetI fsubset_antisym)
qed

lemma fmmap_keys_hom:
  assumes "fmdom' m\<^sub>1 \<inter> fmdom' m\<^sub>2 = {}"
  shows "fmmap_keys f (m\<^sub>1 ++\<^sub>f m\<^sub>2) = fmmap_keys f m\<^sub>1 ++\<^sub>f fmmap_keys f m\<^sub>2"
  using assms
  by (simp add: fmap_ext)

lemma map_insort_is_insort_key:
  assumes "m $$ k = None"
  shows "map (\<lambda>k'. (k', m(k $$:= v) $$! k')) (insort k xs) =
    insort_key fst (k, v) (map (\<lambda>k'. (k', m(k $$:= v) $$! k')) xs)"
  using assms by (induction xs) auto

lemma sorted_list_of_fmap_is_insort_key_fst:
  assumes "m $$ k = None"
  shows "sorted_list_of_fmap (m(k $$:= v)) = insort_key fst (k, v) (sorted_list_of_fmap m)"
proof -
  have "sorted_list_of_fmap (m(k $$:= v)) =
    map (\<lambda>k'. (k', m(k $$:= v) $$! k')) (sorted_list_of_fset (fmdom (m(k $$:= v))))"
    unfolding sorted_list_of_fmap_def ..
  also have "\<dots> = 	map (\<lambda>k'. (k', m(k $$:= v) $$! k')) (sorted_list_of_fset (finsert k (fmdom m)))"
    by simp
  also from \<open>m $$ k = None\<close> have "\<dots> =
    map (\<lambda>k'. (k', m(k $$:= v) $$! k')) (insort k (sorted_list_of_fset (fmdom m - {|k|})))"
    by (simp add: sorted_list_of_fset.rep_eq)
  also from \<open>m $$ k = None\<close> have "\<dots> =
    map (\<lambda>k'. (k', m(k $$:= v) $$! k')) (insort k (sorted_list_of_fset (fmdom m)))"
    by (simp add: fmdom_notI)
  also from \<open>m $$ k = None\<close> have "\<dots> =
    insort_key fst (k, v) (map (\<lambda>k'. (k', m(k $$:= v) $$! k')) (sorted_list_of_fset (fmdom m)))"
    using map_insort_is_insort_key by fastforce
  also have "\<dots> = insort_key fst (k, v) (map (\<lambda>k'. (k', m $$! k')) (sorted_list_of_fset (fmdom m)))"
  proof -
    from \<open>m $$ k = None\<close> have "\<And>k'. k' \<in> fmdom' m \<Longrightarrow> m(k $$:= v) $$! k' = m $$! k'"
      using fmdom'_notI by force
    moreover from \<open>m $$ k = None\<close> have "k \<notin> set (sorted_list_of_fset (fmdom m))"
      using fmdom'_alt_def and fmdom'_notI and in_set_member by force
    ultimately show ?thesis
      by (metis (mono_tags, lifting) fmdom'_alt_def map_eq_conv sorted_list_of_fset_simps(1))
  qed
  finally show ?thesis
    unfolding sorted_list_of_fmap_def by simp
qed

lemma distinct_fst_inj:
  assumes "distinct (map fst ps)"
  and "inj f"
  shows "distinct (map fst (map (\<lambda>(k, v). (f k, v)) ps))"
proof -
  have "map fst (map (\<lambda>(k, v). (f k, v)) ps) = map f (map fst ps)"
    by (induction ps) auto
  moreover from assms have "distinct (map f (map fst ps))"
    by (simp add: distinct_map inj_on_def)
  ultimately show ?thesis
    by presburger
qed

lemma distinct_sorted_list_of_fmap:
  shows "distinct (map fst (sorted_list_of_fmap m))"
  unfolding sorted_list_of_fmap_def and sorted_list_of_fset_def
  by (simp add: distinct_map inj_on_def)

lemma map_inj_pair_non_membership:
  assumes "k \<notin> set (map fst ps)"
  and "inj f"
  shows "f k \<notin> set (map fst (map (\<lambda>(k, v). (f k, v)) ps))"
  using assms by (induction ps) (simp add: member_rec(2), fastforce simp add: injD)

lemma map_insort_key_fst:
  assumes "distinct (map fst ps)"
  and "k \<notin> set (map fst ps)"
  and "inj f"
  and "mono f"
  shows "map (\<lambda>(k, v). (f k, v)) (insort_key fst (k, v) ps) =
    insort_key fst (f k, v) (map (\<lambda>(k, v). (f k, v)) ps)"
  using assms
proof (induction ps)
  case Nil
  then show ?case
    by simp
next
  let ?g = "(\<lambda>(k, v). (f k, v))"
  case (Cons p ps)
  then show ?case
  proof (cases "k \<le> fst p")
    case True
    let ?f_p = "(f (fst p), snd p)"
    have "insort_key fst (f k, v) (map ?g (p # ps)) = insort_key fst (f k, v) (?f_p # map ?g ps)"
      by (simp add: prod.case_eq_if)
    moreover from Cons.prems(4) and True have "f k \<le> f (fst p)"
      by (auto dest: monoE)
    then have "insort_key fst (f k, v) (?f_p # map ?g ps) = (f k, v) # ?f_p # map ?g ps"
      by simp
    ultimately have "insort_key fst (f k, v) (map ?g (p # ps)) = (f k, v) # ?f_p # map ?g ps"
      by simp
    moreover from True have "map ?g (insort_key fst (k, v) (p # ps)) = (f k, v) # ?f_p # map ?g ps"
      by (simp add: case_prod_beta')
    ultimately show ?thesis
      by simp
  next
    case False
    let ?f_p = "(f (fst p), snd p)"
    have "insort_key fst (f k, v) (map ?g (p # ps)) = insort_key fst (f k, v) (?f_p # map ?g ps)"
      by (simp add: prod.case_eq_if)
    moreover from \<open>mono f\<close> and False have "f (fst p) \<le> f k"
      using not_le by (blast dest: mono_invE)
    ultimately have "insort_key fst (f k, v) (map ?g (p # ps)) =
      ?f_p # insort_key fst (f k, v) (map ?g ps)"
      using False and \<open>inj f\<close> by (fastforce dest: injD)
    also from Cons.IH and Cons.prems(1,2) and assms(3,4) have "\<dots> =
      ?f_p # (map ?g (insort_key fst (k, v) ps))"
      by (fastforce simp add: member_rec(1))
    also have "\<dots> = map ?g (p # insort_key fst (k, v) ps)"
      by (simp add: case_prod_beta)
    finally show ?thesis
      using False by simp
  qed
qed

lemma map_sorted_list_of_fmap:
  assumes "inj f"
  and "mono f"
  and "m $$ k = None"
  shows "map (\<lambda>(k, v). (f k, v)) (sorted_list_of_fmap (m(k $$:= v))) =
    insort_key fst (f k, v) (map (\<lambda>(k, v). (f k, v)) (sorted_list_of_fmap m))"
proof -
  let ?g = "(\<lambda>(k, v). (f k, v))"
  from \<open>m $$ k = None\<close> have "map ?g (sorted_list_of_fmap (m(k $$:= v))) =
  	map ?g (insort_key fst (k, v) (sorted_list_of_fmap m))"
  	using sorted_list_of_fmap_is_insort_key_fst by fastforce
  also have "\<dots> = insort_key fst (f k, v) (map ?g (sorted_list_of_fmap m))"
  proof -
    have "distinct (map fst (sorted_list_of_fmap m))"
      by (simp add: distinct_sorted_list_of_fmap)
    moreover from \<open>m $$ k = None\<close> have "k \<notin> set (map fst (sorted_list_of_fmap m))"
      by (metis image_set map_of_eq_None_iff map_of_sorted_list)
    ultimately show ?thesis
      by (simp add: map_insort_key_fst assms(1,2))
  qed
  finally show ?thesis .
qed

lemma fmap_of_list_insort_key_fst:
  assumes "distinct (map fst ps)"
  and "k \<notin> set (map fst ps)"
  shows "fmap_of_list (insort_key fst (k, v) ps) = (fmap_of_list ps)(k $$:= v)"
  using assms
proof (induction ps)
  case Nil
  then show ?case
    by simp
next
  case (Cons p ps)
  then show ?case
  proof (cases "k \<le> fst p")
    case True
    then show ?thesis
      by simp
  next
    case False
    then have "fmap_of_list (insort_key fst (k, v) (p # ps)) =
      fmap_of_list (p # insort_key fst (k, v) ps)"
      by simp
    also have "\<dots> = (fmap_of_list (insort_key fst (k, v) ps))(fst p $$:= snd p)"
      by (metis fmap_of_list_simps(2) prod.collapse)
    also from Cons.prems(1,2) and Cons.IH have "\<dots> = (fmap_of_list ps)(k $$:= v)(fst p $$:= snd p)"
      by (fastforce simp add: member_rec(1))
    finally show ?thesis
    proof -
      assume *: "fmap_of_list (insort_key fst (k, v) (p # ps)) =
        (fmap_of_list ps)(k $$:= v)(fst p $$:= snd p)"
      from Cons.prems(2) have "k \<notin> set (fst p # map fst ps)"
        by simp
      then have **: "{k $$:= v} $$ (fst p) = None"
        by (fastforce simp add: member_rec(1))
      have "fmap_of_list (p # ps) = (fmap_of_list ps)(fst p $$:= snd p)"
        by (metis fmap_of_list_simps(2) prod.collapse)
      with * and ** show ?thesis
        using fmap_singleton_comm by (metis fmadd_fmupd fmap_of_list_simps(1,2) fmupd_alt_def)
    qed
  qed
qed

lemma fmap_of_list_insort_key_fst_map:
  assumes "inj f"
  and "m $$ k = None"
  shows "fmap_of_list (insort_key fst (f k, v) (map (\<lambda>(k, v). (f k, v)) (sorted_list_of_fmap m))) =
    (fmap_of_list (map (\<lambda>(k, v). (f k, v)) (sorted_list_of_fmap m)))(f k $$:= v)"
proof -
  let ?g = "\<lambda>(k, v). (f k, v)"
  let ?ps = "map ?g (sorted_list_of_fmap m)"
  from \<open>inj f\<close> have "distinct (map fst ?ps)"
    using distinct_fst_inj and distinct_sorted_list_of_fmap by fastforce
  moreover have "f k \<notin> set (map fst ?ps)"
  proof -
    from \<open>m $$ k = None\<close> have "k \<notin> set (map fst (sorted_list_of_fmap m))"
      by (metis map_of_eq_None_iff map_of_sorted_list set_map)
    with \<open>inj f\<close> show ?thesis
      using map_inj_pair_non_membership by force
  qed
  ultimately show ?thesis
    using fmap_of_list_insort_key_fst by fast
qed

lemma fmap_of_list_sorted_list_of_fmap:
  fixes m :: "('a::linorder, 'b) fmap"
  and f :: "'a \<Rightarrow> 'c::linorder"
  assumes "inj f"
  and "mono f"
  and "m $$ k = None"
  shows "fmap_of_list (map (\<lambda>(k, v). (f k, v)) (sorted_list_of_fmap (m(k $$:= v)))) =
    (fmap_of_list (map (\<lambda>(k, v). (f k, v)) (sorted_list_of_fmap m)))(f k $$:= v)"
proof -
  let ?g = "\<lambda>(k, v). (f k, v)"
  from assms(3) have "fmap_of_list (map ?g (sorted_list_of_fmap (m(k $$:= v)))) =
    fmap_of_list (map ?g (insort_key fst (k, v) (sorted_list_of_fmap m)))"
    by (simp add: sorted_list_of_fmap_is_insort_key_fst)
  also from assms have "\<dots> = fmap_of_list (insort_key fst (f k, v) (map ?g (sorted_list_of_fmap m)))"
    using calculation and map_sorted_list_of_fmap by fastforce
  also from assms(1,3) have "\<dots> = (fmap_of_list (map ?g (sorted_list_of_fmap m)))(f k $$:= v)"
    by (simp add: fmap_of_list_insort_key_fst_map)
  finally show ?thesis .
qed

text \<open> Map difference \<close>

abbreviation
  fmdiff :: "('a, 'b) fmap \<Rightarrow> ('a, 'b) fmap \<Rightarrow> ('a, 'b) fmap" (infixl \<open>--\<^sub>f\<close> 100) where
  "m\<^sub>1 --\<^sub>f m\<^sub>2 \<equiv> fmfilter (\<lambda>x. x \<notin> fmdom' m\<^sub>2) m\<^sub>1"

lemma fmdiff_partition:
  assumes "m\<^sub>2 \<subseteq>\<^sub>f m\<^sub>1"
  shows "m\<^sub>2 ++\<^sub>f (m\<^sub>1 --\<^sub>f m\<^sub>2) = m\<^sub>1"
proof -
  have *: "m\<^sub>2 ++\<^sub>f (m\<^sub>1 --\<^sub>f m\<^sub>2) \<subseteq>\<^sub>f m\<^sub>1"
  proof -
    have "\<forall>k v. (m\<^sub>2 ++\<^sub>f (m\<^sub>1 --\<^sub>f m\<^sub>2)) $$ k = Some v \<longrightarrow> m\<^sub>1 $$ k = Some v"
    proof (intro allI impI)
      fix k v
      assume "(m\<^sub>2 ++\<^sub>f (m\<^sub>1 --\<^sub>f m\<^sub>2)) $$ k = Some v"
      then have **: "(if k |\<in>| fmdom (m\<^sub>1 --\<^sub>f m\<^sub>2) then (m\<^sub>1 --\<^sub>f m\<^sub>2) $$ k else m\<^sub>2 $$ k) = Some v"
        by simp
      then show "m\<^sub>1 $$ k = Some v"
      proof (cases "k |\<in>| fmdom (m\<^sub>1 --\<^sub>f m\<^sub>2)")
        case True
        with ** show ?thesis
          by simp
      next
        case False
        with ** and \<open>m\<^sub>2 \<subseteq>\<^sub>f m\<^sub>1\<close> show ?thesis
          by (metis (mono_tags, lifting) fmpredD fmsubset_alt_def)
      qed
    qed
    then have "fmpred (\<lambda>k v. m\<^sub>1 $$ k = Some v) (m\<^sub>2 ++\<^sub>f (m\<^sub>1 --\<^sub>f m\<^sub>2))"
      by (blast intro: fmpred_iff)
    then show ?thesis
      by (auto simp add: fmsubset_alt_def)
  qed
  then have "m\<^sub>1 \<subseteq>\<^sub>f m\<^sub>2 ++\<^sub>f (m\<^sub>1 --\<^sub>f m\<^sub>2)"
    by (simp add: fmsubset.rep_eq map_le_def)
  with * show ?thesis
    by (simp add: fsubset_antisym)
qed

lemma fmdiff_fmupd:
  assumes "m $$ k = None"
  shows "m(k $$:= v) --\<^sub>f {k $$:= v} = m"
proof -
  let ?P = "(\<lambda>k'. k' \<notin> {k})"
  have "m(k $$:= v) --\<^sub>f {k $$:= v} = fmfilter (\<lambda>x. x \<notin> fmdom' {k $$:= v}) (m(k $$:= v))" ..
  also have "\<dots> = fmfilter ?P (m(k $$:= v))"
    by simp
  also have "\<dots> = (if ?P k then (fmfilter ?P m)(k $$:= v) else fmfilter ?P m)"
    by simp
  also have "\<dots> = fmfilter ?P m"
    by simp
  finally show ?thesis
  proof -
    from \<open>m $$ k = None\<close> have "\<And>k' v'. m $$ k' = Some v' \<Longrightarrow> ?P k'"
      by fastforce
    then show ?thesis
      by simp
  qed
qed

text \<open> Map symmetric difference \<close>

abbreviation fmsym_diff :: "('a, 'b) fmap \<Rightarrow> ('a, 'b) fmap \<Rightarrow> ('a, 'b) fmap" (infixl \<open>\<Delta>\<^sub>f\<close> 100) where
  "m\<^sub>1 \<Delta>\<^sub>f m\<^sub>2 \<equiv> (m\<^sub>1 --\<^sub>f m\<^sub>2) ++\<^sub>f (m\<^sub>2 --\<^sub>f m\<^sub>1)"

text \<open> Domain restriction \<close>

abbreviation dom_res :: "'a set \<Rightarrow> ('a, 'b) fmap \<Rightarrow> ('a, 'b) fmap" (infixl \<open>\<lhd>\<close> 150) where
  "s \<lhd> m \<equiv> fmfilter (\<lambda>x. x \<in> s) m"

text \<open> Domain exclusion \<close>

abbreviation dom_exc :: "'a set \<Rightarrow> ('a, 'b) fmap \<Rightarrow> ('a, 'b) fmap" (infixl \<open>\<lhd>'/\<close> 150) where
  "s \<lhd>/ m \<equiv> fmfilter (\<lambda>x. x \<notin> s) m"

text \<open> Intersection plus \<close>

abbreviation intersection_plus :: "('a, 'b::monoid_add) fmap \<Rightarrow> ('a, 'b) fmap \<Rightarrow> ('a, 'b) fmap"
  (infixl \<open>\<inter>\<^sub>+\<close> 100)
where
  "m\<^sub>1 \<inter>\<^sub>+ m\<^sub>2 \<equiv> fmmap_keys (\<lambda>k v. v + m\<^sub>1 $$! k) (fmdom' m\<^sub>1 \<lhd> m\<^sub>2)"

text \<open> Union override right \<close>

abbreviation union_override_right :: "('a, 'b) fmap \<Rightarrow> ('a, 'b) fmap \<Rightarrow> ('a, 'b) fmap"
  (infixl \<open>\<union>\<^sub>\<rightarrow>\<close> 100)
where
  "m\<^sub>1 \<union>\<^sub>\<rightarrow> m\<^sub>2 \<equiv> (fmdom' m\<^sub>2 \<lhd>/ m\<^sub>1) ++\<^sub>f m\<^sub>2"

text \<open> Union override left \<close>

abbreviation union_override_left :: "('a, 'b) fmap \<Rightarrow> ('a, 'b) fmap \<Rightarrow> ('a, 'b) fmap"
  (infixl \<open>\<union>\<^sub>\<leftarrow>\<close> 100)
where
  "m\<^sub>1 \<union>\<^sub>\<leftarrow> m\<^sub>2 \<equiv> m\<^sub>1 ++\<^sub>f (fmdom' m\<^sub>1 \<lhd>/ m\<^sub>2)"

text \<open> Union override plus \<close>

abbreviation union_override_plus :: "('a, 'b::monoid_add) fmap \<Rightarrow> ('a, 'b) fmap \<Rightarrow> ('a, 'b) fmap"
  (infixl \<open>\<union>\<^sub>+\<close> 100)
where
  "m\<^sub>1 \<union>\<^sub>+ m\<^sub>2 \<equiv> (m\<^sub>1 \<Delta>\<^sub>f m\<^sub>2) ++\<^sub>f (m\<^sub>1 \<inter>\<^sub>+ m\<^sub>2)"

text \<open> Extra lemmas for the non-standard map operators \<close>

lemma dom_res_singleton:
  assumes "m $$ k = Some v"
  shows "{k} \<lhd> m = {k $$:= v}"
  using assms
proof (induction m)
  case fmempty
  then show ?case
    by simp
next
  case (fmupd k' v' m)
  then show ?case
  proof (cases "k = k'")
    case True
    with \<open>m(k' $$:= v') $$ k = Some v\<close> have "v = v'"
      by simp
    with True have "{k} \<lhd> m(k' $$:= v') = ({k} \<lhd> m)(k $$:= v)"
      by simp
    also from True and \<open>m $$ k' = None\<close> have "\<dots> = {$$}(k $$:= v)"
      by (simp add: fmap_ext)
    finally show ?thesis
      by simp
  next
    case False
    with \<open>m(k' $$:= v') $$ k = Some v\<close> have *: "m $$ k = Some v"
      by simp
    with False have "{k} \<lhd> m(k' $$:= v') = {k} \<lhd> m"
      by simp
    with * and fmupd.IH show ?thesis
      by simp
  qed
qed

lemma dom_res_union_distr:
  shows "(A \<union> B) \<lhd> m = A \<lhd> m ++\<^sub>f B \<lhd> m"
proof -
  have "($$) ((A \<union> B) \<lhd> m) \<subseteq>\<^sub>m ($$) (A \<lhd> m ++\<^sub>f B \<lhd> m)"
  proof (unfold map_le_def, intro ballI)
    fix k
    assume "k \<in> dom (($$) ((A \<union> B) \<lhd> m))"
    then show "((A \<union> B) \<lhd> m) $$ k = (A \<lhd> m ++\<^sub>f B \<lhd> m) $$ k"
      by auto
  qed
  moreover have "($$) (A \<lhd> m ++\<^sub>f B \<lhd> m) \<subseteq>\<^sub>m ($$) ((A \<union> B) \<lhd> m)"
  proof (unfold map_le_def, intro ballI)
    fix k
    assume "k \<in> dom (($$) (A \<lhd> m ++\<^sub>f B \<lhd> m))"
    then show "(A \<lhd> m ++\<^sub>f B \<lhd> m) $$ k = ((A \<union> B) \<lhd> m) $$ k"
      by auto
  qed
  ultimately show ?thesis
    using fmlookup_inject and map_le_antisym by blast
qed

lemma dom_exc_add_distr:
  shows "s \<lhd>/ (m\<^sub>1 ++\<^sub>f m\<^sub>2) = (s \<lhd>/ m\<^sub>1) ++\<^sub>f (s \<lhd>/ m\<^sub>2)"
  by (blast intro: fmfilter_add_distrib)

lemma fmap_partition:
  shows "m = s \<lhd>/ m ++\<^sub>f s \<lhd> m"
proof (induction m)
  case fmempty
  then show ?case
    by simp
next
  case (fmupd k v m)
  from fmupd.hyps have "s \<lhd>/ m(k $$:= v) ++\<^sub>f s \<lhd> m(k $$:= v) =
    s \<lhd>/ (m ++\<^sub>f {k $$:= v}) ++\<^sub>f s \<lhd> (m ++\<^sub>f {k $$:= v})"
    by simp
  also have "\<dots> = s \<lhd>/ m ++\<^sub>f s \<lhd>/ {k $$:= v} ++\<^sub>f s \<lhd> m ++\<^sub>f s \<lhd> {k $$:= v}"
    using dom_exc_add_distr by simp
  finally show ?case
  proof (cases "k \<in> s")
    case True
    then have "s \<lhd>/ m ++\<^sub>f s \<lhd>/ {k $$:= v} ++\<^sub>f s \<lhd> m ++\<^sub>f s \<lhd> {k $$:= v} =
      s \<lhd>/ m ++\<^sub>f {$$} ++\<^sub>f s \<lhd> m ++\<^sub>f {k $$:= v}"
      by simp
    also have "\<dots> = s \<lhd>/ m ++\<^sub>f s \<lhd> m ++\<^sub>f {k $$:= v}"
      by simp
    also from fmupd.IH have "\<dots> = m ++\<^sub>f {k $$:= v}"
      by simp
    finally show ?thesis using fmupd.hyps
      by auto
  next
    case False
    then have "s \<lhd>/ m ++\<^sub>f s \<lhd>/ {k $$:= v} ++\<^sub>f s \<lhd> m ++\<^sub>f s \<lhd> {k $$:= v} =
      s \<lhd>/ m ++\<^sub>f {k $$:= v} ++\<^sub>f s \<lhd> m ++\<^sub>f {$$}"
      by simp
    also have "\<dots> = s \<lhd>/ m ++\<^sub>f {k $$:= v} ++\<^sub>f s \<lhd> m"
      by simp
    also from fmupd.hyps have "\<dots> = s \<lhd>/ m ++\<^sub>f s \<lhd> m ++\<^sub>f {k $$:= v}"
      using fmap_singleton_comm by (metis (full_types) fmadd_assoc fmlookup_filter)
    also from fmupd.IH have "\<dots> = m ++\<^sub>f {k $$:= v}"
      by simp
    finally show ?thesis
      by auto
  qed
qed

lemma dom_res_addition_in:
  assumes "m\<^sub>1 $$ k = None"
  and "m\<^sub>2 $$ k = Some v'"
  shows "fmdom' (m\<^sub>1(k $$:= v)) \<lhd> m\<^sub>2 = fmdom' m\<^sub>1 \<lhd> m\<^sub>2 ++\<^sub>f {k $$:= v'}"
proof -
  from \<open>m\<^sub>1 $$ k = None\<close> have "fmdom' (m\<^sub>1(k $$:= v)) \<lhd> m\<^sub>2 = (fmdom' m\<^sub>1 \<union> {k}) \<lhd> m\<^sub>2"
    by simp
  also have "\<dots> = fmdom' m\<^sub>1 \<lhd> m\<^sub>2 ++\<^sub>f {k} \<lhd> m\<^sub>2"
    using dom_res_union_distr .
  finally show ?thesis
    using \<open>m\<^sub>2 $$ k = Some v'\<close> and dom_res_singleton by fastforce
qed

lemma dom_res_addition_not_in:
  assumes "m\<^sub>2 $$ k = None"
  shows "fmdom' (m\<^sub>1(k $$:= v)) \<lhd> m\<^sub>2 = fmdom' m\<^sub>1 \<lhd> m\<^sub>2"
proof -
  have "fmdom' (m\<^sub>1(k $$:= v)) \<lhd> m\<^sub>2 = fmfilter (\<lambda>k'. k' = k \<or> k' \<in> fmdom' m\<^sub>1) m\<^sub>2"
    by simp
  also have "\<dots> = fmdom' m\<^sub>1 \<lhd> m\<^sub>2"
  proof (intro fmfilter_cong')
    show "m\<^sub>2 = m\<^sub>2" ..
  next
    from assms show "k' \<in> fmdom' m\<^sub>2 \<Longrightarrow> (k' = k \<or> k' \<in> fmdom' m\<^sub>1) = (k' \<in> fmdom' m\<^sub>1)" for k'
    by (cases "k' = k") (simp_all add: fmdom'_notI)
  qed
  finally show ?thesis .
qed

lemma inter_plus_addition_in:
  assumes "m\<^sub>1 $$ k = None"
  and "m\<^sub>2 $$ k = Some v'"
  shows "m\<^sub>1(k $$:= v) \<inter>\<^sub>+ m\<^sub>2 = (m\<^sub>1 \<inter>\<^sub>+ m\<^sub>2) ++\<^sub>f {k $$:= v' + v}"
proof -
  let ?f = "\<lambda>k' v'. v' + m\<^sub>1(k $$:= v) $$! k'"
  from assms have "m\<^sub>1(k $$:= v) \<inter>\<^sub>+ m\<^sub>2 = fmmap_keys ?f ((fmdom' m\<^sub>1 \<lhd> m\<^sub>2) ++\<^sub>f {k $$:= v'})"
    using dom_res_addition_in by fastforce
  also have "\<dots> = fmmap_keys ?f (fmdom' m\<^sub>1 \<lhd> m\<^sub>2) ++\<^sub>f fmmap_keys ?f {k $$:= v'}"
  proof -
    from \<open>m\<^sub>1 $$ k = None\<close> have "fmdom' (fmdom' m\<^sub>1 \<lhd> m\<^sub>2) \<inter> fmdom' {k $$:= v'} = {}"
      by (simp add: fmdom'_notI)
    then show ?thesis
      using fmmap_keys_hom by blast
  qed
  also from assms
  have "\<dots> = fmmap_keys ?f (fmdom' m\<^sub>1 \<lhd> m\<^sub>2) ++\<^sub>f {k $$:= v' + v}"
  proof -
    have "fmmap_keys ?f {k $$:= v'} = {k $$:= v' + v}"
    proof (intro fmap_ext)
      fix k'
      have "fmmap_keys ?f {k $$:= v'} $$ k' = map_option (?f k') ({k $$:= v'} $$ k')"
        using fmlookup_fmmap_keys .
      also have "\<dots> = map_option (?f k') (if k = k' then Some v' else {$$} $$ k')"
        by simp
      also have "\<dots> = {k $$:= v' + v} $$ k'"
        by (cases "k' = k") simp_all
      finally show "fmmap_keys ?f {k $$:= v'} $$ k' = {k $$:= v' + v} $$ k'" .
    qed
    then show ?thesis
      by simp
  qed
  also have "\<dots> = fmmap_keys (\<lambda>k' v'. v' + m\<^sub>1 $$! k') (fmdom' m\<^sub>1 \<lhd> m\<^sub>2) ++\<^sub>f {k $$:= v' + v}"
    by (simp add: fmap_ext)
  finally show ?thesis .
qed

lemma inter_plus_addition_notin:
  assumes "m\<^sub>1 $$ k = None"
  and "m\<^sub>2 $$ k = None"
  shows "m\<^sub>1(k $$:= v) \<inter>\<^sub>+ m\<^sub>2 = (m\<^sub>1 \<inter>\<^sub>+ m\<^sub>2)"
proof -
  let ?f = "\<lambda>k' v'. v' + m\<^sub>1(k $$:= v) $$! k'"
  from \<open>m\<^sub>2 $$ k = None\<close>
  have "m\<^sub>1(k $$:= v) \<inter>\<^sub>+ m\<^sub>2 = fmmap_keys ?f (fmdom' m\<^sub>1 \<lhd> m\<^sub>2)"
    using dom_res_addition_not_in by metis
  also have "\<dots> = fmmap_keys (\<lambda>k' v'. v' + m\<^sub>1 $$! k') (fmdom' m\<^sub>1 \<lhd> m\<^sub>2)"
  proof (intro fmap_ext)
    fix k'
    have "fmmap_keys ?f (fmdom' m\<^sub>1 \<lhd> m\<^sub>2) $$ k' = map_option (?f k') ((fmdom' m\<^sub>1 \<lhd> m\<^sub>2) $$ k')"
      using fmlookup_fmmap_keys .
    also from \<open>m\<^sub>1 $$ k = None\<close> have "\<dots> = fmmap_keys (\<lambda>k' v'. v' + m\<^sub>1 $$! k') (fmdom' m\<^sub>1 \<lhd> m\<^sub>2) $$ k'"
      by (cases "k' = k") (simp_all add: fmdom'_notI)
    finally show "fmmap_keys ?f (fmdom' m\<^sub>1 \<lhd> m\<^sub>2) $$ k' =
      fmmap_keys (\<lambda>k' v'. v' + m\<^sub>1 $$! k') (fmdom' m\<^sub>1 \<lhd> m\<^sub>2) $$ k'" .
  qed
  finally show ?thesis .
qed

lemma union_plus_addition_notin: (* TODO: Find nicer proofs for SMT calls. *)
  assumes "m\<^sub>1 $$ k = None"
  and "m\<^sub>2 $$ k = None"
  shows "m\<^sub>1(k $$:= v) \<union>\<^sub>+ m\<^sub>2 = (m\<^sub>1 \<union>\<^sub>+ m\<^sub>2) ++\<^sub>f {k $$:= v}"
proof -
  from \<open>m\<^sub>2 $$ k = None\<close> have "(m\<^sub>1(k $$:= v)) \<union>\<^sub>+ m\<^sub>2 =
    fmdom' m\<^sub>2 \<lhd>/ m\<^sub>1 ++\<^sub>f {k $$:= v} ++\<^sub>f fmdom' (m\<^sub>1(k $$:= v)) \<lhd>/ m\<^sub>2 ++\<^sub>f (m\<^sub>1(k $$:= v) \<inter>\<^sub>+ m\<^sub>2)"
    by (simp add: fmdom'_notI)
  also from assms have "\<dots> =
    fmdom' m\<^sub>2 \<lhd>/ m\<^sub>1 ++\<^sub>f {k $$:= v} ++\<^sub>f fmdom' m\<^sub>1 \<lhd>/ m\<^sub>2 ++\<^sub>f (m\<^sub>1(k $$:= v) \<inter>\<^sub>+ m\<^sub>2)"
    by (smt fmdom'_fmupd fmfilter_cong insert_iff option.distinct(1))
  also from assms have "\<dots> = fmdom' m\<^sub>2 \<lhd>/ m\<^sub>1 ++\<^sub>f {k $$:= v} ++\<^sub>f fmdom' m\<^sub>1 \<lhd>/ m\<^sub>2 ++\<^sub>f (m\<^sub>1 \<inter>\<^sub>+ m\<^sub>2)"
    using inter_plus_addition_notin by metis
  also from assms have "\<dots> = fmdom' m\<^sub>2 \<lhd>/ m\<^sub>1 ++\<^sub>f fmdom' m\<^sub>1 \<lhd>/ m\<^sub>2 ++\<^sub>f (m\<^sub>1 \<inter>\<^sub>+ m\<^sub>2) ++\<^sub>f {k $$:= v}"
    using fmap_singleton_comm
    by (smt fmadd_assoc fmfilter_fmmap_keys fmlookup_filter fmlookup_fmmap_keys)
  finally show ?thesis .
qed

end


(*
    Author:      Norbert Schirmer
    Maintainer:  Norbert Schirmer, norbert.schirmer at web de
    License:     LGPL
*)

(*  Title:      StateSpace.thy
    Author:     Norbert Schirmer, TU Muenchen

Copyright (C) 2004-2008 Norbert Schirmer
Some rights reserved, TU Muenchen

This library is free software; you can redistribute it and/or modify
it under the terms of the GNU Lesser General Public License as
published by the Free Software Foundation; either version 2.1 of the
License, or (at your option) any later version.

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

You should have received a copy of the GNU Lesser General Public
License along with this library; if not, write to the Free Software
Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307
USA
*)

header {* State Space Template *}
theory StateSpace imports Hoare
begin

record 'g state = "globals"::'g

definition
  upd_globals:: "('g \<Rightarrow> 'g) \<Rightarrow> ('g,'z) state_scheme \<Rightarrow> ('g,'z) state_scheme"
where
  "upd_globals upd s = s\<lparr>globals := upd (globals s)\<rparr>"

record ('g, 'n, 'val) stateSP = "'g state" +
  locals :: "'n \<Rightarrow> 'val"

lemma upd_globals_conv: "upd_globals f = (\<lambda>s. s\<lparr>globals := f (globals s)\<rparr>)"
  by (rule ext) (simp add: upd_globals_def)

end


theory Spin_Lock
  imports Nat_Language
begin

section \<open>Define the variables\<close>
datatype addr = r\<^sub>1 | r\<^sub>2 | x | z | secret | public
definition all_vars
  where "all_vars = [r\<^sub>1, r\<^sub>2, x, z, secret, public]"
definition locals
  where "locals = [r\<^sub>1, r\<^sub>2]"

section \<open>Establish the language & logic\<close>
global_interpretation natlang: nat_language all_vars locals
  defines \<Gamma>\<^sub>a = natlang.\<Gamma>\<^sub>a
      and \<Gamma>\<^sub>b = natlang.\<Gamma>\<^sub>b
      and wp = natlang.wp
      and stabilize = natlang.stabilize
      and wp\<^sub>Q = natlang.wp\<^sub>Q
      and guar = natlang.guar
      and PO = natlang.PO
      and secureUpd = natlang.secureUpd
      and ctrled = natlang.ctrled
      and if_secure = natlang.if_secure
      and wellformed = natlang.wellformed
      and negate = natlang.negate
      and var_policy = natlang.var_policy
      and \<Gamma>\<^sub>e = natlang.\<Gamma>\<^sub>e
      and invar = natlang.invar
      and low\<^sub>v = natlang.low\<^sub>v
      and wf\<^sub>\<L> = natlang.wf\<^sub>\<L>
      and step = natlang.step
      and str_env = natlang.str_env
      and onlyGlobals = natlang.onlyGlobals
  apply unfold_locales unfolding all_vars_def by allvars_tac

syntax
  "_Assign" :: "'addr \<Rightarrow> ('addr) aexp \<Rightarrow> ('addr, nat, 'addr aexp, 'addr bexp) WPLang"
    ("(_ :=/ _)" [70, 65] 61)
  "_Store" :: "'addr \<Rightarrow> ('addr) aexp \<Rightarrow> ('addr) aexp \<Rightarrow> ('addr, nat, 'addr aexp, 'addr bexp) WPLang"
    ("(_ IN _ :=/ _)" [70, 70, 65] 61)
  "_Load" :: "'addr \<Rightarrow> ('addr) list \<Rightarrow> ('addr) aexp \<Rightarrow> ('addr, nat, 'addr aexp, 'addr bexp) WPLang"
    ("(_ :=/ _ IN/ _)" [70, 70, 70] 61)
  "_Secure" :: "('addr,nat) rpred \<Rightarrow> ('addr,nat) rpred \<Rightarrow> ('addr \<Rightarrow> 'addr bexp) \<Rightarrow> ('addr,nat) pred \<Rightarrow> ('addr, nat, 'addr aexp, 'addr bexp) WPLang \<Rightarrow> bool"
    ("(0_,_ \<turnstile> R: _ /G: _ /{_})" [0, 0, 0, 0, 0] 61)

translations
  "x := a" \<rightharpoonup> "CONST Act (CONST Assign x a)"
  "x IN i := a" \<rightharpoonup> "CONST Act (CONST Store x i a)"
  "r := a IN i" \<rightharpoonup> "CONST Act (CONST Action.Load r a i)"
  "L,P \<turnstile> R: RP G: GP {c}" \<rightharpoonup> "CONST if_secure RP GP L P c"

section \<open>Example\<close>

subsection \<open>Specification\<close>

fun \<L> :: "addr \<Rightarrow> addr bexp" where
  "\<L> z = true" |
  "\<L> public = true" |
  "\<L> x = UCmp (\<lambda>x. x \<noteq> 1) (Load z)" |
  "\<L> _ = false"

definition P\<^sub>0 :: "(addr,nat) pred"
  where "P\<^sub>0 \<equiv> Pb True"

subsection \<open>Functions\<close>

lemma secret_write:
  "\<L>,P\<^sub>0 \<turnstile>
   R: invar (Low x) \<and>\<^sub>p (PCmp (=) (Var z\<^sup>o) (Const 1) \<longrightarrow>\<^sub>p (const z))
   G: PCmp (=) (Var z\<^sup>o) (Const 2) \<longrightarrow>\<^sub>p (const z \<and>\<^sub>p const x)
   {
    WHILE NCAS z (Nat 0) (Nat 1)
    INV {Pb True}
    DO
      WHILE \<lbrace>BCmp (Load z) (\<noteq>) (Nat 0)\<rbrace>
      INV {Pb True} DO Skip OD
    OD;
    x := Load secret;
    x := Nat 0;
    z := Nat 0}"
  by natlang.vcgsolve

lemma public_read:
  "\<L>,P\<^sub>0 \<turnstile>
   R: PCmp (=) (Var z\<^sup>o) (Const 2) \<longrightarrow>\<^sub>p (const z \<and>\<^sub>p invar (Low x))
   G: const x \<and>\<^sub>p (PCmp (=) (Var z\<^sup>o) (Const 1) \<longrightarrow>\<^sub>p (const z))
   {IF CAS z (Nat 0) (Nat 2)
    THEN public := Load x; z := Nat 0
    ELSE Skip
    FI}"
  by natlang.vcgsolve

lemma public_write:
  "\<L>,P\<^sub>0 \<turnstile>
   R: Pb True
   G: const z \<and>\<^sub>p invar (Low x)
   { x := Load public }"
  by natlang.vcgsolve

lemma secret_read:
  "\<L>,P\<^sub>0 \<turnstile>
   R: Pb True
   G: const x \<and>\<^sub>p const z
   { secret := Load x }"
  by natlang.vcgsolve

end


theory Join
  imports Sepreftime "Refine_Monadic.Refine_Monadic"
begin

typ "'a nres"
typ "'a nrest"

fun einb :: "'a nres \<Rightarrow> 'a nrest" where
 "einb FAILi = FAILT"
| "einb (RES M) = REST (\<lambda>e. if e\<in>M then Some \<infinity> else None) "

lemma einb_FAIL[simp]: "einb FAIL = FAILT"
  unfolding top_nres_def by(simp only: einb.simps)

lemma grr: "A \<le> SPECT M \<Longrightarrow> A \<le> SPECT M' \<Longrightarrow> A \<le> SPECT (inf M M')"
  apply(cases A) apply simp by simp

lemma join: assumes  "A \<le> Sepreftime.SPEC Q t" "A \<le> Sepreftime.SPEC Q' t'"
  shows "A \<le> Sepreftime.SPEC (\<lambda>p. Q p \<and> Q' p) (inf t t')"
proof -
  have t: "SPECT (\<lambda>v. if Q v \<and> Q' v then Some (inf t t' v) else None)
        \<ge> SPECT (inf (\<lambda>v. if Q v then Some (t v) else None) (\<lambda>v. if Q' v then Some (t' v) else None))"
    by(auto intro!: ext simp add:  le_fun_def)

  from assms show ?thesis
    unfolding  Sepreftime.SPEC_def apply -
    apply(rule order.trans[OF _ t])
    apply(rule grr) apply simp apply simp done
qed

lemma einb_SPEC: "A \<le> SPEC \<Phi> \<Longrightarrow> einb A \<le> Sepreftime.SPEC \<Phi> (\<lambda>_. \<infinity>)"
  apply(cases A) apply simp
  unfolding Sepreftime.SPEC_def by (auto simp: le_fun_def )

lemma einb_SPEC': "einb A  \<le> Sepreftime.SPEC \<Phi> t
        \<Longrightarrow> A \<le> SPEC \<Phi>"
  unfolding Sepreftime.SPEC_def
  apply(cases A) apply simp  by (auto simp: le_fun_def split: if_splits )

lemma "einb A  \<le> Sepreftime.SPEC \<Phi> (\<lambda>_. \<infinity>)
        \<longleftrightarrow> A \<le> SPEC \<Phi>"
  using einb_SPEC einb_SPEC' by auto

lemma inf_infinity: "(inf (\<lambda>_. \<infinity>::enat) t) = t" by(auto simp: inf_enat_def )

lemma assumes A: "A \<le> SPEC \<Phi>"
  and T: "einb A \<le> Sepreftime.SPEC (\<lambda>_. True) t"
shows
          "einb A \<le> Sepreftime.SPEC \<Phi> t"
  using  join[OF A[THEN einb_SPEC] T] by (simp add: inf_infinity)

end


theory minus
imports Main

begin

lemma lemma_a [thy_expl]: "prop_07.minus x2 x2 = Z"
by (hipster_induct_schemes prop_07.minus.simps)

lemma lemma_aa [thy_expl]: "prop_07.minus x3 Z = x3"
by (hipster_induct_schemes prop_07.minus.simps)

lemma lemma_ab [thy_expl]: "prop_07.minus x2 (S x2) = Z"
by (hipster_induct_schemes)

lemma lemma_ac [thy_expl]: "prop_07.minus (S x2) x2 = S Z"
by (hipster_induct_schemes)

lemma lemma_ad [thy_expl]: "prop_07.minus (prop_07.minus x3 y3) (prop_07.minus y3 x3) =
prop_07.minus x3 y3"
by (hipster_induct_schemes prop_07.minus.simps)

lemma lemma_ae [thy_expl]: "prop_07.minus (prop_07.minus x3 y3) (S Z) = prop_07.minus x3 (S y3)"
by (hipster_induct_schemes prop_07.minus.simps)

lemma lemma_af [thy_expl]: "prop_07.minus (prop_07.minus x4 y4) x4 = Z"
by (hipster_induct_schemes prop_07.minus.simps)

end


(*<*)
(*
 * Copyright 2015, NICTA
 *
 * This software may be distributed and modified according to the terms of
 * the BSD 2-Clause license. Note that NO WARRANTY is provided.
 * See "LICENSE_BSD2.txt" for details.
 *
 * @TAG(NICTA_BSD)
 *)

theory CIMP_one_place_buffer
imports
  "../CIMP"
begin

(*>*)
section\<open>Example: a one-place buffer \label{sec:one_place_buffer}\<close>

text\<open>

To demonstrate the CIMP reasoning infrastructure, we treat the trivial
one-place buffer example of @{cite [cite_macro=citet]
\<open>\S3.3\<close> "DBLP:journals/toplas/LamportS84"}. Note that the
semantics for our language is different to @{cite
[cite_macro=citeauthor] "DBLP:journals/toplas/LamportS84"}'s, who
treated a historical variant of CSP (i.e., not the one in @{cite
"Hoare:1985"}).

We introduce some syntax for fixed-topology (static channel-based)
scenarios.

\<close>

abbreviation
  rcv_syn :: "'location \<Rightarrow> 'channel \<Rightarrow> ('val \<Rightarrow> 'state \<Rightarrow> 'state)
           \<Rightarrow> (unit, 'location, 'channel \<times> 'val, 'state) com" ("\<lbrace>_\<rbrace>/ _\<triangleright>_" [0,0,81] 81)
where
  "\<lbrace>l\<rbrace> ch\<triangleright>f \<equiv> \<lbrace>l\<rbrace> Response (\<lambda>q s. if fst q = ch then {(f (snd q) s, ())} else {})"

abbreviation
  snd_syn :: "'location \<Rightarrow> 'channel \<Rightarrow> ('state \<Rightarrow> 'val)
          \<Rightarrow> (unit, 'location, 'channel \<times> 'val, 'state) com" ("\<lbrace>_\<rbrace>/ _\<triangleleft>_" [0,0,81] 81)
where
  "\<lbrace>l\<rbrace> ch\<triangleleft>f \<equiv> \<lbrace>l\<rbrace> Request (\<lambda>s. (ch, f s)) (\<lambda>ans s. {s})"

text\<open>

These definitions largely follow @{cite [cite_macro=citet]
"DBLP:journals/toplas/LamportS84"}. We have three processes
communicating over two channels. We enumerate program locations.

\<close>

datatype ex_chname = \<xi>12 | \<xi>23
type_synonym ex_val = nat
type_synonym ex_ch = "ex_chname \<times> ex_val"
datatype ex_loc = r12 | r23 | s23 | s12
datatype ex_proc = p1 | p2 | p3

type_synonym ex_pgm = "(unit, ex_loc, ex_ch, ex_val) com"
type_synonym ex_pred = "(unit, ex_loc, ex_proc, ex_ch, ex_val) state_pred"
type_synonym ex_state = "(unit, ex_loc, ex_proc, ex_ch, ex_val) system_state"
type_synonym ex_sys = "(unit, ex_loc, ex_proc, ex_ch, ex_val) system"
type_synonym ex_history = "(ex_ch \<times> unit) list"

text\<open>

We further specialise these for our particular example.

\<close>

primrec
  ex_coms :: "ex_proc \<Rightarrow> ex_pgm"
where
  "ex_coms p1 = \<lbrace>s12\<rbrace> \<xi>12\<triangleleft>id"
| "ex_coms p2 = LOOP DO \<lbrace>r12\<rbrace> \<xi>12\<triangleright>(\<lambda>v _. v) ;; \<lbrace>s23\<rbrace> \<xi>23\<triangleleft>id OD"
| "ex_coms p3 = \<lbrace>r23\<rbrace> \<xi>23\<triangleright>(\<lambda>v _. v)"

text\<open>

Each process starts with an arbitrary initial local state.

\<close>

abbreviation ex_init :: "(ex_proc \<Rightarrow> ex_val) \<Rightarrow> bool" where
  "ex_init \<equiv> \<langle>True\<rangle>"

abbreviation sys :: ex_sys where
  "sys \<equiv> \<lparr>PGMs = ex_coms, INIT = ex_init, FAIR = \<langle>True\<rangle>\<rparr>" (* FIXME add fairness hypotheses *)

text\<open>

The following adapts Kai Engelhardt's, from his notes titled
\emph{Proving an Asynchronous Message Passing Program Correct},
2011. The history variable tracks the causality of the system, which I
feel is missing in Lamport's treatment. We tack on Lamport's invariant
so we can establish \<open>Etern_pred\<close>.

\<close>

abbreviation
  filter_on_channel :: "ex_chname \<Rightarrow> ex_state \<Rightarrow> ex_val list" ("\<downharpoonright>_" [100] 101)
where
  "\<downharpoonright>ch \<equiv> map (snd \<circ> fst) \<circ> filter ((=) ch \<circ> fst \<circ> fst) \<circ> HST"

definition IL :: ex_pred where
  "IL = pred_conjoin [
       at p1 s12 \<^bold>\<longrightarrow> LIST_NULL \<downharpoonright>\<xi>12
     , terminated p1 \<^bold>\<longrightarrow> \<downharpoonright>\<xi>12 \<^bold>= (\<lambda>s. [s\<down> p1])
     , at p2 r12 \<^bold>\<longrightarrow> \<downharpoonright>\<xi>12 \<^bold>= \<downharpoonright>\<xi>23
     , at p2 s23 \<^bold>\<longrightarrow> \<downharpoonright>\<xi>12 \<^bold>= \<downharpoonright>\<xi>23 \<^bold>@ (\<lambda>s. [s\<down> p2]) \<^bold>\<and> (\<lambda>s. s\<down> p1 = s\<down> p2)
     , at p3 r23 \<^bold>\<longrightarrow> LIST_NULL \<downharpoonright>\<xi>23
     , terminated p3 \<^bold>\<longrightarrow> \<downharpoonright>\<xi>23 \<^bold>= (\<lambda>s. [s\<down> p2]) \<^bold>\<and> (\<lambda>s. s\<down> p1 = s\<down> p3)
     ]"

text\<open>

If @{const p3} terminates, then it has @{const p1}'s value. This is
stronger than @{cite [cite_macro=citeauthor]
"DBLP:journals/toplas/LamportS84"}'s as we don't ask that the first
process has also terminated.

\<close>

definition Etern_pred :: ex_pred where
  "Etern_pred = (terminated p3 \<^bold>\<longrightarrow> (\<lambda>s. s\<down> p1 = s\<down> p3))"

text\<open>

Proofs from here down.

\<close>

lemma correct_system:
  assumes "IL sh"
  shows "Etern_pred sh"
using assms unfolding Etern_pred_def IL_def by simp

lemma IL_p1: "ex_coms, p1, lconst {} \<turnstile> \<lbrace>IL\<rbrace> \<lbrace>s12\<rbrace> \<xi>12\<triangleleft>(\<lambda>s. s)"
apply (rule vcg.intros)
apply (rename_tac p')
apply (case_tac p'; clarsimp simp: IL_def atLs_def)
done

lemma IL_p2: "ex_coms, p2, lconst {r12} \<turnstile> \<lbrace>IL\<rbrace> \<lbrace>s23\<rbrace> \<xi>23\<triangleleft>(\<lambda>s. s)"
apply (rule vcg.intros)
apply (rename_tac p')
apply (case_tac p'; clarsimp simp: IL_def)
done

lemma IL: "sys \<Turnstile>\<^bsub>pre\<^esub> IL"
apply (rule VCG)
 apply (clarsimp simp: IL_def atLs_def dest!: initial_stateD)
apply (rename_tac p)
apply (case_tac p; clarsimp simp: IL_p1 IL_p2)
done

lemma IL_valid: "sys \<Turnstile> \<box>\<lceil>IL\<rceil>"
by (rule valid_prerun_lift[OF IL])

(*<*)

end
(*>*)


(* Copyright 2021 (C) Mihails Milehins *)

section\<open>Smallness for semicategories\<close>
theory CZH_SMC_Small_Semicategory
  imports
    CZH_DG_Small_Digraph
    CZH_SMC_Semicategory
begin

subsection\<open>Background\<close>

text\<open>
An explanation of the methodology chosen for the exposition of all
matters related to the size of the semicategories and associated entities
is given in the previous chapter.
\<close>

named_theorems smc_small_cs_simps
named_theorems smc_small_cs_intros

subsection\<open>Tiny semicategory\<close>

subsubsection\<open>Definition and elementary properties\<close>

locale tiny_semicategory = \<Z> \<alpha> + vfsequence \<CC> + Comp: vsv \<open>\<CC>\<lparr>Comp\<rparr>\<close> for \<alpha> \<CC> +
  assumes tiny_smc_length[smc_cs_simps]: "vcard \<CC> = 5\<^sub>\<nat>"
    and tiny_smc_tiny_digraph[slicing_intros]: "tiny_digraph \<alpha> (smc_dg \<CC>)"
    and tiny_smc_Comp_vdomain: "gf \<in>\<^sub>\<circ> \<D>\<^sub>\<circ> (\<CC>\<lparr>Comp\<rparr>) \<longleftrightarrow>
      (\<exists>g f b c a. gf = [g, f]\<^sub>\<circ> \<and> g : b \<mapsto>\<^bsub>\<CC>\<^esub> c \<and> f : a \<mapsto>\<^bsub>\<CC>\<^esub> b)"
    and tiny_smc_Comp_is_arr[smc_cs_intros]:
      "\<lbrakk> g : b \<mapsto>\<^bsub>\<CC>\<^esub> c; f : a \<mapsto>\<^bsub>\<CC>\<^esub> b \<rbrakk> \<Longrightarrow> g \<circ>\<^sub>A\<^bsub>\<CC>\<^esub> f : a \<mapsto>\<^bsub>\<CC>\<^esub> c"
    and tiny_smc_assoc[smc_cs_simps]:
      "\<lbrakk> h : c \<mapsto>\<^bsub>\<CC>\<^esub> d; g : b \<mapsto>\<^bsub>\<CC>\<^esub> c; f : a \<mapsto>\<^bsub>\<CC>\<^esub> b \<rbrakk> \<Longrightarrow>
        (h \<circ>\<^sub>A\<^bsub>\<CC>\<^esub> g) \<circ>\<^sub>A\<^bsub>\<CC>\<^esub> f = h \<circ>\<^sub>A\<^bsub>\<CC>\<^esub> (g \<circ>\<^sub>A\<^bsub>\<CC>\<^esub> f)"

lemmas [smc_cs_simps] =
  tiny_semicategory.tiny_smc_length
  tiny_semicategory.tiny_smc_assoc

lemmas [slicing_intros] =
  tiny_semicategory.tiny_smc_Comp_is_arr

text\<open>Rules.\<close>

lemma (in tiny_semicategory) tiny_semicategory_axioms'[smc_small_cs_intros]:
  assumes "\<alpha>' = \<alpha>"
  shows "tiny_semicategory \<alpha>' \<CC>"
  unfolding assms by (rule tiny_semicategory_axioms)

mk_ide rf tiny_semicategory_def[unfolded tiny_semicategory_axioms_def]
  |intro tiny_semicategoryI|
  |dest tiny_semicategoryD[dest]|
  |elim tiny_semicategoryE[elim]|

lemma tiny_semicategoryI':
  assumes "semicategory \<alpha> \<CC>" and "\<CC>\<lparr>Obj\<rparr> \<in>\<^sub>\<circ> Vset \<alpha>" and "\<CC>\<lparr>Arr\<rparr> \<in>\<^sub>\<circ> Vset \<alpha>"
  shows "tiny_semicategory \<alpha> \<CC>"
proof-
  interpret semicategory \<alpha> \<CC> by (rule assms(1))
  show ?thesis
  proof(intro tiny_semicategoryI)
    show "vfsequence \<CC>" by (simp add: vfsequence_axioms)
    from assms show "tiny_digraph \<alpha> (smc_dg \<CC>)"
      by (intro tiny_digraphI') (auto simp: slicing_simps)
  qed (auto simp: smc_cs_simps intro: smc_cs_intros)
qed

lemma tiny_semicategoryI'':
  assumes "\<Z> \<alpha>"
    and "vfsequence \<CC>"
    and "vsv (\<CC>\<lparr>Comp\<rparr>)"
    and "vcard \<CC> = 5\<^sub>\<nat>"
    and "vsv (\<CC>\<lparr>Dom\<rparr>)"
    and "vsv (\<CC>\<lparr>Cod\<rparr>)"
    and "\<D>\<^sub>\<circ> (\<CC>\<lparr>Dom\<rparr>) = \<CC>\<lparr>Arr\<rparr>"
    and "\<R>\<^sub>\<circ> (\<CC>\<lparr>Dom\<rparr>) \<subseteq>\<^sub>\<circ> \<CC>\<lparr>Obj\<rparr>"
    and "\<D>\<^sub>\<circ> (\<CC>\<lparr>Cod\<rparr>) = \<CC>\<lparr>Arr\<rparr>"
    and "\<R>\<^sub>\<circ> (\<CC>\<lparr>Cod\<rparr>) \<subseteq>\<^sub>\<circ> \<CC>\<lparr>Obj\<rparr>"
    and "\<And>gf. gf \<in>\<^sub>\<circ> \<D>\<^sub>\<circ> (\<CC>\<lparr>Comp\<rparr>) \<longleftrightarrow>
      (\<exists>g f b c a. gf = [g, f]\<^sub>\<circ> \<and> g : b \<mapsto>\<^bsub>\<CC>\<^esub> c \<and> f : a \<mapsto>\<^bsub>\<CC>\<^esub> b)"
    and "\<And>b c g a f. \<lbrakk> g : b \<mapsto>\<^bsub>\<CC>\<^esub> c; f : a \<mapsto>\<^bsub>\<CC>\<^esub> b \<rbrakk> \<Longrightarrow> g \<circ>\<^sub>A\<^bsub>\<CC>\<^esub> f : a \<mapsto>\<^bsub>\<CC>\<^esub> c"
    and "\<And>c d h b g a f. \<lbrakk> h : c \<mapsto>\<^bsub>\<CC>\<^esub> d; g : b \<mapsto>\<^bsub>\<CC>\<^esub> c; f : a \<mapsto>\<^bsub>\<CC>\<^esub> b \<rbrakk> \<Longrightarrow>
        (h \<circ>\<^sub>A\<^bsub>\<CC>\<^esub> g) \<circ>\<^sub>A\<^bsub>\<CC>\<^esub> f = h \<circ>\<^sub>A\<^bsub>\<CC>\<^esub> (g \<circ>\<^sub>A\<^bsub>\<CC>\<^esub> f)"
    and "\<CC>\<lparr>Obj\<rparr> \<in>\<^sub>\<circ> Vset \<alpha>"
    and "\<CC>\<lparr>Arr\<rparr> \<in>\<^sub>\<circ> Vset \<alpha>"
  shows "tiny_semicategory \<alpha> \<CC>"
  by (intro tiny_semicategoryI tiny_digraphI, unfold slicing_simps)
    (simp_all add: smc_dg_def nat_omega_simps assms)

text\<open>Slicing.\<close>

context tiny_semicategory
begin

interpretation dg: tiny_digraph \<alpha> \<open>smc_dg \<CC>\<close> by (rule tiny_smc_tiny_digraph)

lemmas_with [unfolded slicing_simps]:
  tiny_smc_Obj_in_Vset[smc_small_cs_intros] = dg.tiny_dg_Obj_in_Vset
  and tiny_smc_Arr_in_Vset[smc_small_cs_intros] = dg.tiny_dg_Arr_in_Vset
  and tiny_smc_Dom_in_Vset[smc_small_cs_intros] = dg.tiny_dg_Dom_in_Vset
  and tiny_smc_Cod_in_Vset[smc_small_cs_intros] = dg.tiny_dg_Cod_in_Vset

end

text\<open>Elementary properties.\<close>

sublocale tiny_semicategory \<subseteq> semicategory
  by (rule semicategoryI)
    (
      auto
        simp:
          vfsequence_axioms
          tiny_digraph.tiny_dg_digraph
          tiny_smc_tiny_digraph
          tiny_smc_Comp_vdomain
        intro: smc_cs_intros smc_cs_simps
    )

lemmas (in tiny_semicategory) tiny_smc_semicategory = semicategory_axioms

lemmas [smc_small_cs_intros] = tiny_semicategory.tiny_smc_semicategory

text\<open>Size.\<close>

lemma (in tiny_semicategory) tiny_smc_Comp_in_Vset: "\<CC>\<lparr>Comp\<rparr> \<in>\<^sub>\<circ> Vset \<alpha>"
proof-
  have "\<CC>\<lparr>Arr\<rparr> \<in>\<^sub>\<circ> Vset \<alpha>" by (simp add: tiny_smc_Arr_in_Vset)
  with Axiom_of_Infinity have "\<CC>\<lparr>Arr\<rparr> ^\<^sub>\<times> 2\<^sub>\<nat> \<in>\<^sub>\<circ> Vset \<alpha>"
    by (intro Limit_vcpower_in_VsetI) auto
  with Comp.pnop_vdomain have D: "\<D>\<^sub>\<circ> (\<CC>\<lparr>Comp\<rparr>) \<in>\<^sub>\<circ> Vset \<alpha>" by auto
  moreover from tiny_smc_Arr_in_Vset smc_Comp_vrange have
    "\<R>\<^sub>\<circ> (\<CC>\<lparr>Comp\<rparr>) \<in>\<^sub>\<circ> Vset \<alpha>"
    by auto
  ultimately show ?thesis by (simp add: Comp.vbrelation_Limit_in_VsetI)
qed

lemma (in tiny_semicategory) tiny_smc_in_Vset: "\<CC> \<in>\<^sub>\<circ> Vset \<alpha>"
proof-
  note [smc_cs_intros] =
    tiny_smc_Obj_in_Vset
    tiny_smc_Arr_in_Vset
    tiny_smc_Dom_in_Vset
    tiny_smc_Cod_in_Vset
    tiny_smc_Comp_in_Vset
  show ?thesis
    by (subst smc_def) (cs_concl cs_shallow cs_intro: smc_cs_intros V_cs_intros)
qed

lemma small_tiny_semicategories[simp]: "small {\<CC>. tiny_semicategory \<alpha> \<CC>}"
proof(rule down)
  show "{\<CC>. tiny_semicategory \<alpha> \<CC>} \<subseteq> elts (set {\<CC>. semicategory \<alpha> \<CC>})"
    by (auto intro: smc_small_cs_intros)
qed

lemma tiny_semicategories_vsubset_Vset:
  "set {\<CC>. tiny_semicategory \<alpha> \<CC>} \<subseteq>\<^sub>\<circ> Vset \<alpha>"
  by (rule vsubsetI) (simp add: tiny_semicategory.tiny_smc_in_Vset)

lemma (in semicategory) smc_tiny_semicategory_if_ge_Limit:
  assumes "\<Z> \<beta>" and "\<alpha> \<in>\<^sub>\<circ> \<beta>"
  shows "tiny_semicategory \<beta> \<CC>"
proof(intro tiny_semicategoryI)
  show "tiny_digraph \<beta> (smc_dg \<CC>)"
    by (rule digraph.dg_tiny_digraph_if_ge_Limit, rule smc_digraph; intro assms)
qed
  (
    auto simp:
      assms(1)
      smc_cs_simps
      smc_cs_intros
      smc_digraph digraph.dg_tiny_digraph_if_ge_Limit
      smc_Comp_vdomain vfsequence_axioms
  )

subsubsection\<open>Opposite tiny semicategory\<close>

lemma (in tiny_semicategory) tiny_semicategory_op:
  "tiny_semicategory \<alpha> (op_smc \<CC>)"
  by (intro tiny_semicategoryI', unfold smc_op_simps)
    (auto simp: smc_op_intros smc_small_cs_intros)

lemmas tiny_semicategory_op[smc_op_intros] =
  tiny_semicategory.tiny_semicategory_op

subsection\<open>Finite semicategory\<close>

subsubsection\<open>Definition and elementary properties\<close>

text\<open>
A finite semicategory is a generalization of the concept of a finite category,
as presented in nLab
\<^cite>\<open>"noauthor_nlab_nodate"\<close>
\footnote{\url{https://ncatlab.org/nlab/show/finite+category}}.
\<close>

locale finite_semicategory = \<Z> \<alpha> + vfsequence \<CC> + Comp: vsv \<open>\<CC>\<lparr>Comp\<rparr>\<close> for \<alpha> \<CC> +
  assumes fin_smc_length[smc_cs_simps]: "vcard \<CC> = 5\<^sub>\<nat>"
    and fin_smc_finite_digraph[slicing_intros]: "finite_digraph \<alpha> (smc_dg \<CC>)"
    and fin_smc_Comp_vdomain: "gf \<in>\<^sub>\<circ> \<D>\<^sub>\<circ> (\<CC>\<lparr>Comp\<rparr>) \<longleftrightarrow>
      (\<exists>g f b c a. gf = [g, f]\<^sub>\<circ> \<and> g : b \<mapsto>\<^bsub>\<CC>\<^esub> c \<and> f : a \<mapsto>\<^bsub>\<CC>\<^esub> b)"
    and fin_smc_Comp_is_arr[smc_cs_intros]:
      "\<lbrakk> g : b \<mapsto>\<^bsub>\<CC>\<^esub> c; f : a \<mapsto>\<^bsub>\<CC>\<^esub> b \<rbrakk> \<Longrightarrow> g \<circ>\<^sub>A\<^bsub>\<CC>\<^esub> f : a \<mapsto>\<^bsub>\<CC>\<^esub> c"
    and fin_smc_assoc[smc_cs_simps]:
      "\<lbrakk> h : c \<mapsto>\<^bsub>\<CC>\<^esub> d; g : b \<mapsto>\<^bsub>\<CC>\<^esub> c; f : a \<mapsto>\<^bsub>\<CC>\<^esub> b \<rbrakk> \<Longrightarrow>
        (h \<circ>\<^sub>A\<^bsub>\<CC>\<^esub> g) \<circ>\<^sub>A\<^bsub>\<CC>\<^esub> f = h \<circ>\<^sub>A\<^bsub>\<CC>\<^esub> (g \<circ>\<^sub>A\<^bsub>\<CC>\<^esub> f)"

lemmas [smc_cs_simps] =
  finite_semicategory.fin_smc_length
  finite_semicategory.fin_smc_assoc

lemmas [slicing_intros] =
  finite_semicategory.fin_smc_Comp_is_arr

text\<open>Rules.\<close>

lemma (in finite_semicategory) finite_semicategory_axioms'[smc_small_cs_intros]:
  assumes "\<alpha>' = \<alpha>"
  shows "finite_semicategory \<alpha>' \<CC>"
  unfolding assms by (rule finite_semicategory_axioms)

mk_ide rf finite_semicategory_def[unfolded finite_semicategory_axioms_def]
  |intro finite_semicategoryI|
  |dest finite_semicategoryD[dest]|
  |elim finite_semicategoryE[elim]|

lemma finite_semicategoryI':
  assumes "semicategory \<alpha> \<CC>" and "vfinite (\<CC>\<lparr>Obj\<rparr>)" and "vfinite (\<CC>\<lparr>Arr\<rparr>)"
  shows "finite_semicategory \<alpha> \<CC>"
proof-
  interpret semicategory \<alpha> \<CC> by (rule assms(1))
  show ?thesis
  proof(intro finite_semicategoryI)
    show "vfsequence \<CC>" by (simp add: vfsequence_axioms)
    from assms show "finite_digraph \<alpha> (smc_dg \<CC>)"
      by (intro finite_digraphI) (auto simp: slicing_simps)
  qed (auto simp: smc_cs_simps intro: smc_cs_intros)
qed

lemma finite_semicategoryI'':
  assumes "tiny_semicategory \<alpha> \<CC>" and "vfinite (\<CC>\<lparr>Obj\<rparr>)" and "vfinite (\<CC>\<lparr>Arr\<rparr>)"
  shows "finite_semicategory \<alpha> \<CC>"
  using assms by (intro finite_semicategoryI')
    (auto intro: smc_cs_intros smc_small_cs_intros)

text\<open>Slicing.\<close>

context finite_semicategory
begin

interpretation dg: finite_digraph \<alpha> \<open>smc_dg \<CC>\<close> by (rule fin_smc_finite_digraph)

lemmas_with [unfolded slicing_simps]:
  fin_smc_Obj_vfinite[smc_small_cs_intros] = dg.fin_dg_Obj_vfinite
  and fin_smc_Arr_vfinite[smc_small_cs_intros] = dg.fin_dg_Arr_vfinite

end

text\<open>Elementary properties.\<close>

sublocale finite_semicategory \<subseteq> tiny_semicategory
  by (rule tiny_semicategoryI)
    (
      auto simp:
        vfsequence_axioms
        fin_smc_Comp_vdomain
        fin_smc_finite_digraph
        finite_digraph.fin_dg_tiny_digraph
        intro: smc_cs_intros smc_cs_simps
    )

lemmas (in finite_semicategory) fin_smc_tiny_semicategory =
  tiny_semicategory_axioms

lemmas [smc_small_cs_intros] = finite_semicategory.fin_smc_tiny_semicategory

lemma (in finite_semicategory) fin_smc_in_Vset: "\<CC> \<in>\<^sub>\<circ> Vset \<alpha>"
  by (rule tiny_smc_in_Vset)

text\<open>Size.\<close>

lemma small_finite_semicategories[simp]: "small {\<CC>. finite_semicategory \<alpha> \<CC>}"
proof(rule down)
  show "{\<CC>. finite_semicategory \<alpha> \<CC>} \<subseteq> elts (set {\<CC>. semicategory \<alpha> \<CC>})"
    by (auto intro: smc_small_cs_intros)
qed

lemma finite_semicategories_vsubset_Vset:
  "set {\<CC>. finite_semicategory \<alpha> \<CC>} \<subseteq>\<^sub>\<circ> Vset \<alpha>"
  by (rule vsubsetI) (simp add: finite_semicategory.fin_smc_in_Vset)

subsubsection\<open>Opposite finite semicategory\<close>

lemma (in finite_semicategory) finite_semicategory_op:
  "finite_semicategory \<alpha> (op_smc \<CC>)"
  by (intro finite_semicategoryI', unfold smc_op_simps)
    (auto simp: smc_op_intros smc_small_cs_intros)

lemmas finite_semicategory_op[smc_op_intros] =
  finite_semicategory.finite_semicategory_op

text\<open>\newpage\<close>

end


theory SeparationAlgebra
  imports "Separation_Algebra.Separation_Algebra" "Separation_Algebra.Sep_Heap_Instance"
begin

class sep_ramification = sep_algebra +
  assumes eq_zero_left: "p + q = 0 \<Longrightarrow> p = 0"
  assumes sep_disj_add: "h\<^sub>1 ## h\<^sub>2 \<and> h\<^sub>2 ## h\<^sub>3 \<and> h\<^sub>1 ## h\<^sub>3 \<Longrightarrow> h\<^sub>1 ## h\<^sub>2 + h\<^sub>3"
  assumes cross_split: "a+b=z \<and> c+d=z \<Longrightarrow> \<exists>ac ad bc bd. ac+ad=a \<and> bc+bd=b \<and> ac+bc=c \<and> ad+bd=d \<and>
                        ac ## ad \<and> ac ## bc \<and> ac ## bd \<and> ad ## bc \<and> ad ## bd \<and> bc ## bd"
begin

lemma eq_zero_right: "p + q = 0 \<Longrightarrow> q = 0"
  by (metis local.eq_zero_left local.sep_add_commute local.sep_disj_zero)

lemma sep_disj_left: "p ## q + r \<Longrightarrow> p ## q"
  sorry

lemma sep_disj_right: "p ## q + r \<Longrightarrow> p ## r"
  sorry

lemma sep_disj_add2: "h\<^sub>1 ## h\<^sub>2 \<and> h\<^sub>2 ## h\<^sub>3 \<and> h\<^sub>1 ## h\<^sub>3 \<Longrightarrow> h\<^sub>1 + h\<^sub>2 ## h\<^sub>3"
  by (simp add: local.sep_disj_add local.sep_disj_addI1)

lemma sep_disj_add3: "s ## p + q + r  \<Longrightarrow> s ## p"
  using sep_disj_commuteI sep_disj_left by blast

definition ovp_conj :: "('a \<Rightarrow> bool) \<Rightarrow> ('a \<Rightarrow> bool) \<Rightarrow> ('a \<Rightarrow> bool)" (infixr "\<union>*" 51)
  where
    "P \<union>* Q \<equiv> \<lambda>h. \<exists>h\<^sub>1 h\<^sub>2 h\<^sub>3. h\<^sub>1 ## h\<^sub>2 \<and> h\<^sub>2 ## h\<^sub>3 \<and> h\<^sub>1 ## h\<^sub>3 \<and>
                             h = h\<^sub>1 + h\<^sub>2 + h\<^sub>3 \<and>
                             P (h\<^sub>1 + h\<^sub>2) \<and> Q (h\<^sub>2 + h\<^sub>3)"

subsection {* Overlapping Conjunction Properties *}

lemma ovp_conjD:
  "(P \<union>* Q) h \<Longrightarrow> \<exists>h\<^sub>1 h\<^sub>2 h\<^sub>3. h\<^sub>1 ## h\<^sub>2 \<and> h\<^sub>2 ## h\<^sub>3 \<and> h\<^sub>1 ## h\<^sub>3 \<and> h = h\<^sub>1 + h\<^sub>2 + h\<^sub>3 \<and> P (h\<^sub>1 + h\<^sub>2) \<and> Q (h\<^sub>2 + h\<^sub>3)"
  by (simp add: ovp_conj_def)

lemma ovp_conjE:
  "\<lbrakk> (P \<union>* Q) h; \<And>h\<^sub>1 h\<^sub>2 h\<^sub>3. \<lbrakk> P (h\<^sub>1 + h\<^sub>2); Q (h\<^sub>2 + h\<^sub>3); h\<^sub>1 ## h\<^sub>2; h\<^sub>2 ## h\<^sub>3; h\<^sub>1 ## h\<^sub>3; h = h\<^sub>1 + h\<^sub>2 + h\<^sub>3 \<rbrakk> \<Longrightarrow> X \<rbrakk> \<Longrightarrow> X"
  by (auto simp: ovp_conj_def)

lemma ovp_conjI:
  "\<lbrakk> P (h\<^sub>1 + h\<^sub>2); Q (h\<^sub>2 + h\<^sub>3); h\<^sub>1 ## h\<^sub>2; h\<^sub>2 ## h\<^sub>3; h\<^sub>1 ## h\<^sub>3; h = h\<^sub>1 + h\<^sub>2 + h\<^sub>3 \<rbrakk> \<Longrightarrow> (P \<union>* Q) h"
  by (auto simp: ovp_conj_def)

lemma ovp_conj_commuteI:
  "(P \<union>* Q) h \<Longrightarrow> (Q \<union>* P) h"
  by (smt local.sep_add_assoc local.sep_add_commute local.sep_disj_commuteI ovp_conjE ovp_conjI)

lemma ovp_conj_impl:
  "\<lbrakk> (P \<union>* Q) h; \<And>h. P h \<Longrightarrow> P' h; \<And>h. Q h \<Longrightarrow> Q' h \<rbrakk> \<Longrightarrow> (P' \<union>* Q') h"
  using ovp_conj_def by fastforce

lemma ovp_conj_sep_true_left:
  assumes "(P \<union>* Q) h"
  shows "(sep_true \<and>* Q) h"
  unfolding ovp_conj_def sep_conj_def
proof -
  have "(P \<union>* Q) h" using assms by blast
  obtain h\<^sub>1 h\<^sub>2 h\<^sub>3 where "h\<^sub>1 ## h\<^sub>2 \<and> h\<^sub>2 ## h\<^sub>3 \<and> h\<^sub>1 ## h\<^sub>3 \<and>
    h = h\<^sub>1 + h\<^sub>2 + h\<^sub>3 \<and> P (h\<^sub>1 + h\<^sub>2) \<and> Q (h\<^sub>2 + h\<^sub>3)"
    using assms ovp_conjD by blast
  then have "h\<^sub>1 ## (h\<^sub>2 + h\<^sub>3) \<and> h = h\<^sub>1 + (h\<^sub>2 + h\<^sub>3) \<and> Q (h\<^sub>2 + h\<^sub>3)"
    by (simp add: local.sep_add_assoc local.sep_disj_add)
  then show "\<exists>x y. x ## y \<and> h = x + y \<and> True \<and> Q y" by blast
qed

subsection {* Further properties: Lemma 3.1 (The Ramifications of Sharing in Data Structures) *}

(* Lemma 3.1 (2) *)
lemma ovp_conj_empty:
  "P \<union>* \<box> = P"
  unfolding ovp_conj_def sep_empty_def
proof (rule ext)
qed (metis eq_zero_right local.sep_add_zero local.sep_disj_zero)

(* Lemma 3.1 (3) *)
lemma conj_ovp_conj:
  "(P and Q) h \<Longrightarrow> (P \<union>* Q) h"
  by (metis (no_types, lifting) local.sep_add_zero local.sep_conjE
      local.sep_conj_sep_true' local.sep_disj_zero ovp_conj_def)

(* Lemma 3.1 (4) *)
lemma sep_conj_ovp_conj:
  "(P \<and>* Q) h \<Longrightarrow> (P \<union>* Q) h"
  by (metis local.sep_add_commute local.sep_add_zero local.sep_conjE
      local.sep_disj_commuteI local.sep_disj_zero ovp_conj_def)

(* Lemma 3.1 (5) *)
lemma ovp_conj_sep_true_right:
  assumes "(P \<union>* Q) h"
  shows "(P \<and>* sep_true) h"
  unfolding ovp_conj_def sep_conj_def
proof -
  have "(P \<union>* Q) h" using assms by blast
  obtain h\<^sub>1 h\<^sub>2 h\<^sub>3 where "h\<^sub>1 ## h\<^sub>2 \<and> h\<^sub>2 ## h\<^sub>3 \<and> h\<^sub>1 ## h\<^sub>3 \<and>
    h = h\<^sub>1 + h\<^sub>2 + h\<^sub>3 \<and> P (h\<^sub>1 + h\<^sub>2) \<and> Q (h\<^sub>2 + h\<^sub>3)"
    using assms ovp_conjD by blast
  then have "(h\<^sub>1 + h\<^sub>2) ## h\<^sub>3 \<and> h = (h\<^sub>1 + h\<^sub>2) + h\<^sub>3 \<and> P (h\<^sub>1 + h\<^sub>2)"
    by (simp add: local.sep_disj_add local.sep_disj_addI1)
  then show "\<exists>x y. x ## y \<and> h = x + y \<and> P x \<and> True" by blast
qed

(* Lemma 3.1 (6) *)
lemma ovp_conj_sep_imp_conj3:
  "P \<union>* Q = (EXS R. (R \<longrightarrow>* P) \<and>* (R \<longrightarrow>* Q) \<and>* R)"
  unfolding ovp_conj_def sep_impl_def sep_conj_def
  apply rule
  apply safe
  subgoal for h h1 h2 h3
    apply (rule exI[where x="\<lambda>h. h=h2"])
    apply (simp add: sep_conj_def)
    apply (rule exI[where x="h1"])
    apply (rule exI[where x="h2+h3"])
    apply (simp add: sep_disj_add sep_add_assoc)
    apply (rule exI[where x="h3"])
    by (simp add: sep_disj_commuteI sep_add_commute)
  subgoal for h R
    by (metis sep_add_assoc sep_add_commute sep_disj_addD2 sep_disj_commuteI)
  done

(* Lemma 3.1 (7) *)
lemma ovp_conj_commute:
  "(P \<union>* Q) = (Q \<union>* P)"
  by (rule ext) (auto intro: ovp_conj_commuteI)

(* Lemma 3.1 (8) *)
lemma ovp_conj_assoc:
  "P \<union>* (Q \<union>* R) = (P \<union>* Q) \<union>* R" (is "?lhs = ?rhs")
proof (rule ext, rule iffI)
  fix h
  assume a: "?lhs h"
  then obtain h\<^sub>1 h\<^sub>2 h\<^sub>3 h\<^sub>1' h\<^sub>2' h\<^sub>3' where
    "P (h\<^sub>1 + h\<^sub>2)" and
    "h\<^sub>1 ## h\<^sub>2" and "h\<^sub>2 ## h\<^sub>3" and "h\<^sub>1 ## h\<^sub>3" and "h = h\<^sub>1 + h\<^sub>2 + h\<^sub>3" and
    "Q (h\<^sub>1' + h\<^sub>2')" and "R (h\<^sub>2' + h\<^sub>3')" and
    "h\<^sub>1' ## h\<^sub>2'" and "h\<^sub>2' ## h\<^sub>3'" and "h\<^sub>1' ## h\<^sub>3'" and "h\<^sub>2 + h\<^sub>3 = h\<^sub>1' + h\<^sub>2' + h\<^sub>3'"
    by (metis ovp_conjE)
  moreover
  then obtain ac ad bc bd where
    CS: "ac+ad=h\<^sub>2 \<and> bc+bd=h\<^sub>3 \<and> ac+bc=h\<^sub>1'+h\<^sub>2' \<and> ad+bd=h\<^sub>3' \<and>
     ac ## ad \<and> ac ## bc \<and> ac ## bd \<and> ad ## bc \<and> ad ## bd \<and> bc ## bd"
    using cross_split by blast
  ultimately
  show "?rhs h"
    unfolding ovp_conj_def
    apply safe
    apply (rule exI[where x="h\<^sub>1 + h\<^sub>1'"])
    apply (rule exI[where x="h\<^sub>2' + ad"])
    apply (rule exI[where x="bd"])
  proof (safe, goal_cases)
    case 1
    then show ?case by(metis sep_disj_add sep_disj_addI1 sep_disj_commuteI sep_disj_left)
  next
    case 2
    then show ?case using sep_disj_addI1 by blast
  next
    case 3
    have "h\<^sub>1 ## h\<^sub>2 + h\<^sub>3"
      by (simp add: \<open>h\<^sub>1 ## h\<^sub>2\<close> \<open>h\<^sub>1 ## h\<^sub>3\<close> \<open>h\<^sub>2 ## h\<^sub>3\<close> sep_disj_add)
    then have "h\<^sub>1 ## h\<^sub>1' + h\<^sub>2' + h\<^sub>3'"
      by (simp add: \<open>h\<^sub>2 + h\<^sub>3 = h\<^sub>1' + h\<^sub>2' + h\<^sub>3'\<close>)
    then have "h\<^sub>1 ## h\<^sub>1'"
      using sep_disj_add3 by blast
    then show ?case using CS \<open>h\<^sub>1 ## h\<^sub>3\<close> \<open>h\<^sub>1' ## h\<^sub>3'\<close> sep_disj_addD2 sep_disj_add2 by blast
  next
    case 4
    have "h\<^sub>1 ## h\<^sub>2 + h\<^sub>3"
      by (simp add: \<open>h\<^sub>1 ## h\<^sub>2\<close> \<open>h\<^sub>1 ## h\<^sub>3\<close> \<open>h\<^sub>2 ## h\<^sub>3\<close> sep_disj_add)
    then have "h\<^sub>1 ## h\<^sub>1' + h\<^sub>2' + h\<^sub>3'"
      by (simp add: \<open>h\<^sub>2 + h\<^sub>3 = h\<^sub>1' + h\<^sub>2' + h\<^sub>3'\<close>)
    then have A: "h\<^sub>1 ## h\<^sub>1' \<and> h\<^sub>1 ## h\<^sub>2' \<and> h\<^sub>1 ## ad \<and> h\<^sub>1 ## bd"
      using  sep_disj_add3 "4"(2) "4"(4) "4"(7) CS sep_disj_addD sep_disj_left by blast

    have "h\<^sub>1 + (ac + ad) + (bc + bd) = h\<^sub>1 + h\<^sub>2 + h\<^sub>3"
      using CS by blast
    also have "\<dots> = h\<^sub>1 + (h\<^sub>1' + h\<^sub>2' + h\<^sub>3')"
      by (simp add: \<open>h\<^sub>1 ## h\<^sub>2\<close> \<open>h\<^sub>1 ## h\<^sub>3\<close> \<open>h\<^sub>2 ## h\<^sub>3\<close> \<open>h\<^sub>2 + h\<^sub>3 = h\<^sub>1' + h\<^sub>2' + h\<^sub>3'\<close> sep_add_assoc)
    also have "\<dots> = h\<^sub>1 + (h\<^sub>1' + (h\<^sub>2' + ad) + bd)"
      by (smt CS \<open>h\<^sub>1' ## h\<^sub>2'\<close> \<open>h\<^sub>1' ## h\<^sub>3'\<close> \<open>h\<^sub>2 ## h\<^sub>3\<close> \<open>h\<^sub>2 + h\<^sub>3 = h\<^sub>1' + h\<^sub>2' + h\<^sub>3'\<close> \<open>h\<^sub>2' ## h\<^sub>3'\<close>
          sep_add_assoc sep_add_commute sep_disj_commuteI sep_disj_right)
    also have "\<dots> = h\<^sub>1 + h\<^sub>1' + (h\<^sub>2' + ad) + bd"
      using A by (metis (full_types) "4"(20) "4"(7) "4"(8) "4"(9) sep_add_assoc sep_disj_add local.sep_disj_addI1 sep_disj_left)
    finally show ?case by blast
  next
    case 5
    show ?case
      apply (rule exI[where x="ad + h\<^sub>1"])
      apply (rule exI[where x="ac"])
      apply (rule exI[where x="bc"])
    proof (safe, goal_cases)
      case 1
      then show ?case
        by (simp add: "5"(16) "5"(2) local.sep_add_commute local.sep_add_disjI1 local.sep_disj_commuteI)
    next
      case 2
      then show ?case by (simp add: "5"(17))
    next
      case 3
      then show ?case
        by (metis "5"(4) CS \<open>h\<^sub>1 ## h\<^sub>2\<close> local.sep_add_commute sep_disj_add2 sep_disj_left)
    next
      case 4
      have A: "h\<^sub>1' ## h\<^sub>2' \<and> h\<^sub>2' ## ad"
        using "5"(7) "5"(8) sep_disj_left by blast
      have B: "h\<^sub>1' + h\<^sub>2' = ac + bc"
        by (simp add: "5"(14))
      have "h\<^sub>1 + h\<^sub>1' + (h\<^sub>2' + ad) = h\<^sub>1 + (h\<^sub>1' + h\<^sub>2') + ad"
        by (metis A "5"(2) "5"(4) "5"(9) CS local.sep_add_assoc local.sep_disj_add local.sep_disj_addD1 sep_disj_add2 sep_disj_right)
      also have "\<dots> = h\<^sub>1 + (ac + bc) + ad" using B by simp
      also have "\<dots> = h\<^sub>1 + ac + bc + ad"
        by (metis "5"(17) "5"(2) "5"(4) sep_add_assoc sep_disj_left)
      also have "\<dots> = ad + h\<^sub>1 + ac + bc"
        by (smt "5"(2) "5"(4) CS sep_add_assoc sep_add_commute sep_disj_commuteI sep_disj_add2 sep_disj_right)
      finally show ?case by simp
    next
      case 5
      then show ?case
        by (metis CS \<open>P (h\<^sub>1 + h\<^sub>2)\<close> \<open>h\<^sub>1 ## h\<^sub>2\<close> sep_add_assoc sep_add_commute sep_disj_commuteI sep_disj_left)
    next
      case 6
      then show ?case by (simp add: "5"(14) "5"(5))
    qed
  next
    case 6
    then show ?case by (metis sep_add_assoc sep_add_commute sep_disj_left)
  qed
next
  fix h
  assume a: "?rhs h"
  then obtain h\<^sub>1 h\<^sub>2 h\<^sub>3 h\<^sub>1' h\<^sub>2' h\<^sub>3' where
    "R (h\<^sub>2 + h\<^sub>3)" and
    "h\<^sub>1 ## h\<^sub>2" and "h\<^sub>2 ## h\<^sub>3" and "h\<^sub>1 ## h\<^sub>3" and "h = h\<^sub>1 + h\<^sub>2 + h\<^sub>3" and
    "P (h\<^sub>1' + h\<^sub>2')" and "Q (h\<^sub>2' + h\<^sub>3')" and
    "h\<^sub>1' ## h\<^sub>2'" and "h\<^sub>2' ## h\<^sub>3'" and "h\<^sub>1' ## h\<^sub>3'" and "h\<^sub>1 + h\<^sub>2 = h\<^sub>1' + h\<^sub>2' + h\<^sub>3'"
    by (metis ovp_conjE)
  moreover
  then have "h\<^sub>1 + h\<^sub>2 = h\<^sub>1' + (h\<^sub>2' + h\<^sub>3')"
    by (simp add: local.sep_add_assoc)
  then obtain ac ad bc bd where
    CS: "ac+ad=h\<^sub>1 \<and> bc+bd=h\<^sub>2 \<and> ac+bc=h\<^sub>1' \<and> ad+bd=h\<^sub>2'+h\<^sub>3' \<and>
     ac ## ad \<and> ac ## bc \<and> ac ## bd \<and> ad ## bc \<and> ad ## bd \<and> bc ## bd"
    using cross_split by blast
  ultimately
  show "?lhs h"
    unfolding ovp_conj_def
    apply safe
    apply (rule exI[where x="ac"])
    apply (rule exI[where x="h\<^sub>2' + bc"])
    apply (rule exI[where x="h\<^sub>3 + h\<^sub>3'"])
  proof (safe, goal_cases)
    case 1
    then show ?case
      using sep_add_disjI2 sep_disj_commute by blast
  next
    case 2
    then show ?case
      by (smt local.sep_add_assoc local.sep_add_commute local.sep_add_disjD local.sep_add_disjI2 local.sep_disj_commuteI sep_disj_add2)
  next
    case 3
    have "h\<^sub>3 ## h\<^sub>1 + h\<^sub>2"
      using \<open>h\<^sub>1 ## h\<^sub>2\<close> \<open>h\<^sub>1 ## h\<^sub>3\<close> \<open>h\<^sub>2 ## h\<^sub>3\<close> local.sep_disj_add local.sep_disj_commuteI by blast
    then have "h\<^sub>3 ## h\<^sub>1' + h\<^sub>2' + h\<^sub>3'"
      by (simp add: \<open>h\<^sub>1 + h\<^sub>2 = h\<^sub>1' + h\<^sub>2' + h\<^sub>3'\<close>)
    then have "h\<^sub>3 ## h\<^sub>1'"
      using sep_disj_add3 by blast
    then show ?case
      using "3"(16) "3"(17) "3"(4) "3"(9) \<open>h\<^sub>3 ## h\<^sub>1' + h\<^sub>2' + h\<^sub>3'\<close> local.sep_add_disjD local.sep_disj_add sep_disj_right by blast
  next
    case 4
    have "h\<^sub>3 ## h\<^sub>1 + h\<^sub>2"
      using \<open>h\<^sub>1 ## h\<^sub>2\<close> \<open>h\<^sub>1 ## h\<^sub>3\<close> \<open>h\<^sub>2 ## h\<^sub>3\<close> local.sep_disj_add local.sep_disj_commuteI by blast
    then have A: "h\<^sub>3 ## h\<^sub>1' + h\<^sub>2' + h\<^sub>3'"
      by (simp add: \<open>h\<^sub>1 + h\<^sub>2 = h\<^sub>1' + h\<^sub>2' + h\<^sub>3'\<close>)

    have "ac + ad + (bc + bd) + h\<^sub>3 = h\<^sub>1 + h\<^sub>2 + h\<^sub>3"
      using "4"(11) \<open>h = h\<^sub>1 + h\<^sub>2 + h\<^sub>3\<close> by blast
    also have "\<dots> = h\<^sub>3 + (h\<^sub>1' + h\<^sub>2' + h\<^sub>3')"
      using \<open>h\<^sub>1 + h\<^sub>2 = h\<^sub>1' + h\<^sub>2' + h\<^sub>3'\<close> A local.sep_add_commute by fastforce
    also have "\<dots> = ac + (h\<^sub>2' + bc) + (h\<^sub>3 + h\<^sub>3')"
      by (smt "4"(14) "4"(17) "4"(8) \<open>h\<^sub>1' ## h\<^sub>2'\<close> \<open>h\<^sub>1' ## h\<^sub>3'\<close> A local.sep_add_commute local.sep_add_left_commute local.sep_disj_add local.sep_disj_commuteI sep_disj_right)
    finally show ?case by blast
  next
    case 5
    then show ?case
      by (metis local.sep_add_assoc local.sep_add_commute local.sep_add_disjD)
  next
    case 6
    show ?case
      apply (rule exI[where x="ad"])
      apply (rule exI[where x="bd"])
      apply (rule exI[where x="bc + h\<^sub>3"])
    proof (safe, goal_cases)
      case 1
      then show ?case
        by (simp add: "6"(20))
    next
      case 2
      then show ?case
        using "6"(21) "6"(3) local.sep_add_disjI1 local.sep_disj_commuteI by blast
    next
      case 3
      then show ?case
        by (meson "6"(16) "6"(19) "6"(21) "6"(3) "6"(4) local.sep_add_disjD local.sep_disj_commuteI sep_disj_add2)
    next
      case 4
      have A: "h\<^sub>3 ## bc \<and> bc ## h\<^sub>2' \<and> bc ## h\<^sub>3'"
        using CS \<open>h\<^sub>1' ## h\<^sub>2'\<close> \<open>h\<^sub>1' ## h\<^sub>3'\<close> \<open>h\<^sub>2 ## h\<^sub>3\<close> local.sep_add_disjD local.sep_disj_commuteI by blast
      have B: "h\<^sub>3 ## h\<^sub>3'"
        by (metis "6"(8) \<open>h\<^sub>1 ## h\<^sub>2\<close> \<open>h\<^sub>1 ## h\<^sub>3\<close> \<open>h\<^sub>1 + h\<^sub>2 = h\<^sub>1' + (h\<^sub>2' + h\<^sub>3')\<close> \<open>h\<^sub>1' ## h\<^sub>2'\<close> \<open>h\<^sub>1' ## h\<^sub>3'\<close> \<open>h\<^sub>2 ## h\<^sub>3\<close> local.sep_add_disjD local.sep_disj_add local.sep_disj_commuteI)
      have C: "h\<^sub>2' ## h\<^sub>3' \<and> h\<^sub>2' ## h\<^sub>3"
        by (metis "6"(8) \<open>h\<^sub>1 ## h\<^sub>2\<close> \<open>h\<^sub>1 ## h\<^sub>3\<close> \<open>h\<^sub>1 + h\<^sub>2 = h\<^sub>1' + (h\<^sub>2' + h\<^sub>3')\<close> \<open>h\<^sub>1' ## h\<^sub>2'\<close> \<open>h\<^sub>1' ## h\<^sub>3'\<close> \<open>h\<^sub>2 ## h\<^sub>3\<close> local.sep_add_left_commute local.sep_disj_add local.sep_disj_commuteI sep_disj_left)

      have "h\<^sub>2' + bc + (h\<^sub>3 + h\<^sub>3') = h\<^sub>2' + bc + h\<^sub>3 + h\<^sub>3'"
        using A by (metis "6"(8) \<open>h\<^sub>1 ## h\<^sub>2\<close> \<open>h\<^sub>1 ## h\<^sub>3\<close> \<open>h\<^sub>1 + h\<^sub>2 = h\<^sub>1' + (h\<^sub>2' + h\<^sub>3')\<close> \<open>h\<^sub>1' ## h\<^sub>2'\<close> \<open>h\<^sub>1' ## h\<^sub>3'\<close> \<open>h\<^sub>2 ## h\<^sub>3\<close> local.sep_add_assoc local.sep_add_disjD local.sep_disj_commuteI sep_disj_add2)
      also have "\<dots> = h\<^sub>2' + (bc + h\<^sub>3 + h\<^sub>3')"
        using A by (metis "6"(8) \<open>h\<^sub>1 ## h\<^sub>2\<close> \<open>h\<^sub>1 ## h\<^sub>3\<close> \<open>h\<^sub>1 + h\<^sub>2 = h\<^sub>1' + (h\<^sub>2' + h\<^sub>3')\<close> \<open>h\<^sub>1' ## h\<^sub>2'\<close> \<open>h\<^sub>1' ## h\<^sub>3'\<close> \<open>h\<^sub>2 ## h\<^sub>3\<close> local.sep_add_assoc local.sep_add_disjD local.sep_disj_add local.sep_disj_commuteI)
      also have "\<dots> = h\<^sub>2' + (h\<^sub>3' + bc + h\<^sub>3)"
        using B by (simp add: A local.sep_add_assoc local.sep_add_commute local.sep_disj_commuteI)
      also have "\<dots> = h\<^sub>2' + h\<^sub>3' + bc + h\<^sub>3"
        using B C by (simp add: A local.sep_add_assoc local.sep_disj_commuteI sep_disj_add2)
      also have "\<dots> = ad + bd + (bc + h\<^sub>3)"
        by (simp add: "6"(15) A B C local.sep_add_assoc local.sep_disj_commuteI sep_disj_add2)
      finally show ?case by simp
    next
      case 5
      then show ?case by (simp add: "6"(15) "6"(6))
    next
      case 6
      then show ?case
        by (metis CS \<open>R (h\<^sub>2 + h\<^sub>3)\<close> \<open>h\<^sub>2 ## h\<^sub>3\<close> local.sep_add_assoc local.sep_add_commute local.sep_disj_commuteI sep_disj_left)
    qed
  qed
qed

end

instance "fun" :: (type,opt) sep_ramification
  apply standard
  unfolding zero_fun_def plus_fun_def
  apply (rule ext)
  apply meson
  sorry

end


section \<open>Time Monad\<close>

theory Time_Monad
imports
  Main
  "HOL-Library.Monad_Syntax"
begin

datatype 'a tm = TM (val: 'a) nat

fun val :: "'a tm \<Rightarrow> 'a" where
"val (TM v n) = v"

fun time :: "'a tm \<Rightarrow> nat" where
"time (TM v n) = n"

definition bind_tm :: "'a tm \<Rightarrow> ('a \<Rightarrow> 'b tm) \<Rightarrow> 'b tm" where
"bind_tm s f = (case s of TM u m \<Rightarrow> case f u of TM v n \<Rightarrow> TM v (m+n))"

adhoc_overloading Monad_Syntax.bind bind_tm

definition "tick v = TM v 1"

definition "return v = TM v 0"

abbreviation eqtick :: "'a tm \<Rightarrow> 'a tm \<Rightarrow> bool" (infix "=1" 50) where
 "eqtick l r \<equiv> (l = (r \<bind> tick))"

(* warning: bind_tm is not a constant on purpose, does not work if it is: *)
translations "CONST eqtick l r" <= "(l = (bind_tm r CONST tick))"

lemmas tm_simps = bind_tm_def return_def tick_def

lemma time_return[simp]: "time (return x) = 0"
by(simp add: return_def)

lemma surj_TM: "v = val tm \<Longrightarrow> t = time tm \<Longrightarrow> tm = TM v t"
by (metis time.simps tm.exhaust val.simps)

text\<open>The following lemmas push @{const val} into a monadic term:\<close>

lemma val_return[simp]: "val (return x) = x"
by(simp add: return_def)

lemma val_bind_tm[simp]: "val (bind_tm m f) = (let x = val m in val(f x))"
by(simp add: bind_tm_def split: tm.split)

lemma val_tick[simp]: "val (tick x) = x"
by(simp add: tick_def)

lemma val_let: "val (let x = t in f(x)) = (let x = t in val(f x))"
by simp

lemma let_id: "(let x = t in x) = t"
by simp

lemmas val_simps =
  val_return
  val_bind_tm
  val_tick
  val_let
  let_id
  if_distrib[of val]
  prod.case_distrib[of val]

lemmas val_cong = arg_cong[where f=val]

hide_const TM

end


theory List_Examples
imports
  Main
  "HOL-Library.Predicate_Compile_Quickcheck"
  "HOL-Library.Code_Prolog"
begin

setup \<open>
  Context.theory_map
    (Quickcheck.add_tester ("prolog", (Code_Prolog.active, Code_Prolog.test_goals)))
\<close>

setup \<open>Code_Prolog.map_code_options (K
  {ensure_groundness = true,
   limit_globally = NONE,
   limited_types = [(\<^typ>\<open>nat\<close>, 2), (\<^typ>\<open>nat list\<close>, 4)],
   limited_predicates = [(["appendP"], 4), (["revP"], 4)],
   replacing =
     [(("appendP", "limited_appendP"), "quickcheck"),
      (("revP", "limited_revP"), "quickcheck"),
      (("appendP", "limited_appendP"), "lim_revP")],
   manual_reorder = []})\<close>

lemma "(xs :: nat list) = ys @ ys --> rev xs = xs"
quickcheck[tester = random, iterations = 10000]
quickcheck[tester = smart_exhaustive, iterations = 1, expect = counterexample]
quickcheck[tester = prolog, expect = counterexample]
oops

end


section\<open>Accounts\<close>
theory Accounts
imports Valuetypes
begin

type_synonym Balance = Valuetype

type_synonym Accounts = "Address \<Rightarrow> Balance"

fun emptyAccount :: "Accounts"
where
  "emptyAccount _ = ShowL\<^sub>i\<^sub>n\<^sub>t 0"

fun accessBalance :: "Accounts \<Rightarrow> Address \<Rightarrow> Balance"
where
  "accessBalance acc ad = acc ad"

fun updateBalance :: "Address \<Rightarrow> Balance \<Rightarrow> Accounts \<Rightarrow> Accounts"
where
  "updateBalance ad bal acc = (\<lambda>i. (if i = ad then bal else acc i))"

fun addBalance :: "Address \<Rightarrow> Valuetype \<Rightarrow> Accounts \<Rightarrow> Accounts option"
where
  "addBalance ad val acc =
    (if ReadL\<^sub>i\<^sub>n\<^sub>t val \<ge> 0
      then (let v = ReadL\<^sub>i\<^sub>n\<^sub>t (accessBalance acc ad) + ReadL\<^sub>i\<^sub>n\<^sub>t val
         in if (v < 2^256)
           then Some (updateBalance ad (ShowL\<^sub>i\<^sub>n\<^sub>t v) acc)
           else None)
      else None)"

lemma addBalance_val:
  assumes "addBalance ad val acc = Some acc'"
    shows "ReadL\<^sub>i\<^sub>n\<^sub>t (accessBalance acc ad) + ReadL\<^sub>i\<^sub>n\<^sub>t val < 2^256"
using assms by (simp add:Let_def split:if_split_asm)

lemma addBalance_limit:
  assumes "addBalance ad val acc = Some acc'"
     and "\<forall>ad. ReadL\<^sub>i\<^sub>n\<^sub>t (accessBalance acc ad) \<ge> 0 \<and> ReadL\<^sub>i\<^sub>n\<^sub>t (accessBalance acc ad) < 2 ^ 256"
   shows "\<forall>ad. ReadL\<^sub>i\<^sub>n\<^sub>t (accessBalance acc' ad) \<ge> 0 \<and> ReadL\<^sub>i\<^sub>n\<^sub>t (accessBalance acc' ad) < 2 ^ 256"
proof
  fix ad'
  show "ReadL\<^sub>i\<^sub>n\<^sub>t (accessBalance acc' ad') \<ge> 0 \<and> ReadL\<^sub>i\<^sub>n\<^sub>t (accessBalance acc' ad') < 2 ^ 256"
  proof (cases "ReadL\<^sub>i\<^sub>n\<^sub>t val \<ge> 0")
    case t1: True
    define v where v_def: "v = ReadL\<^sub>i\<^sub>n\<^sub>t (accessBalance acc ad) + ReadL\<^sub>i\<^sub>n\<^sub>t val"
    with assms(2) have "v \<ge>0" by (simp add: t1)
    then show ?thesis
    proof (cases "v < 2^256")
      case t2: True
      with t1 v_def have "addBalance ad val acc = Some (updateBalance ad (ShowL\<^sub>i\<^sub>n\<^sub>t v) acc)" by simp
      with t2 `v \<ge>0` show ?thesis using assms Read_ShowL_id by auto
    next
      case False
      with t1 v_def show ?thesis using assms(1) by simp
    qed
  next
    case False
    then show ?thesis using assms(1) by simp
  qed
qed

lemma addBalance_add:
  assumes "addBalance ad val acc = Some acc'"
    shows "ReadL\<^sub>i\<^sub>n\<^sub>t (accessBalance acc' ad) = ReadL\<^sub>i\<^sub>n\<^sub>t (accessBalance acc ad) + ReadL\<^sub>i\<^sub>n\<^sub>t val"
proof -
  define v where "v = ReadL\<^sub>i\<^sub>n\<^sub>t (accessBalance acc ad) + ReadL\<^sub>i\<^sub>n\<^sub>t val"
  with assms have "acc' = updateBalance ad (ShowL\<^sub>i\<^sub>n\<^sub>t v) acc" by (simp add:Let_def split:if_split_asm)
  thus ?thesis using v_def Read_ShowL_id assms by (simp split:if_split_asm)
qed

lemma addBalance_mono:
  assumes "addBalance ad val acc = Some acc'"
    shows "ReadL\<^sub>i\<^sub>n\<^sub>t (accessBalance acc' ad) \<ge> ReadL\<^sub>i\<^sub>n\<^sub>t (accessBalance acc ad)"
proof -
  define v where "v = ReadL\<^sub>i\<^sub>n\<^sub>t (accessBalance acc ad) + ReadL\<^sub>i\<^sub>n\<^sub>t val"
  with assms have "acc' = updateBalance ad (ShowL\<^sub>i\<^sub>n\<^sub>t v) acc" by (simp add:Let_def split:if_split_asm)
  thus ?thesis using v_def Read_ShowL_id assms by (simp split:if_split_asm)
qed

lemma addBalance_eq:
  assumes "addBalance ad val acc = Some acc'"
      and "ad \<noteq> ad'"
    shows "(accessBalance acc ad') = (accessBalance acc' ad')"
proof -
  define v where "v = ReadL\<^sub>i\<^sub>n\<^sub>t (accessBalance acc ad) + ReadL\<^sub>i\<^sub>n\<^sub>t val"
  with assms have "acc' = updateBalance ad (ShowL\<^sub>i\<^sub>n\<^sub>t v) acc" by (simp add:Let_def split:if_split_asm)
  thus ?thesis using v_def Read_ShowL_id assms by (simp split:if_split_asm)
qed

fun subBalance :: "Address \<Rightarrow> Valuetype \<Rightarrow> Accounts \<Rightarrow> Accounts option"
  where
  "subBalance ad val acc =
    (if ReadL\<^sub>i\<^sub>n\<^sub>t val \<ge> 0
      then (let v = ReadL\<^sub>i\<^sub>n\<^sub>t (accessBalance acc ad) - ReadL\<^sub>i\<^sub>n\<^sub>t val
         in if (v \<ge> 0)
           then Some (updateBalance ad (ShowL\<^sub>i\<^sub>n\<^sub>t v) acc)
           else None)
      else None)"

lemma subBalance_val:
  assumes "subBalance ad val acc = Some acc'"
    shows "ReadL\<^sub>i\<^sub>n\<^sub>t val \<ge> 0"
using assms by (simp split:if_split_asm)

lemma subBalance_sub:
  assumes "subBalance ad val acc = Some acc'"
    shows "ReadL\<^sub>i\<^sub>n\<^sub>t (accessBalance acc' ad) = ReadL\<^sub>i\<^sub>n\<^sub>t (accessBalance acc ad) - ReadL\<^sub>i\<^sub>n\<^sub>t val"
proof -
  define v where "v = ReadL\<^sub>i\<^sub>n\<^sub>t (accessBalance acc ad) - ReadL\<^sub>i\<^sub>n\<^sub>t val"
  with assms have "acc' = updateBalance ad (ShowL\<^sub>i\<^sub>n\<^sub>t v) acc" by (simp add:Let_def split:if_split_asm)
  thus ?thesis using v_def Read_ShowL_id assms by (simp split:if_split_asm)
qed

lemma subBalance_limit:
  assumes "subBalance ad val acc = Some acc'"
     and "\<forall>ad. ReadL\<^sub>i\<^sub>n\<^sub>t (accessBalance acc ad) \<ge> 0 \<and> ReadL\<^sub>i\<^sub>n\<^sub>t (accessBalance acc ad) < 2 ^ 256"
   shows "\<forall>ad. ReadL\<^sub>i\<^sub>n\<^sub>t (accessBalance acc' ad) \<ge> 0 \<and> ReadL\<^sub>i\<^sub>n\<^sub>t (accessBalance acc' ad) < 2 ^ 256"
proof
  fix ad'
  show "ReadL\<^sub>i\<^sub>n\<^sub>t (accessBalance acc' ad') \<ge> 0 \<and> ReadL\<^sub>i\<^sub>n\<^sub>t (accessBalance acc' ad') < 2 ^ 256"
  proof (cases "ReadL\<^sub>i\<^sub>n\<^sub>t val \<ge> 0")
    case t1: True
    define v where v_def: "v = ReadL\<^sub>i\<^sub>n\<^sub>t (accessBalance acc ad) - ReadL\<^sub>i\<^sub>n\<^sub>t val"
    with assms(2) t1 have "v < 2 ^ 256" by (smt (verit))
    then show ?thesis
    proof (cases "v \<ge> 0")
      case t2: True
      with t1 v_def have "subBalance ad val acc = Some (updateBalance ad (ShowL\<^sub>i\<^sub>n\<^sub>t v) acc)" by simp
      with t2 `v < 2 ^ 256` show ?thesis using assms Read_ShowL_id by auto
    next
      case False
      with t1 v_def show ?thesis using assms(1) by simp
    qed
  next
    case False
    then show ?thesis using assms(1) by simp
  qed
qed

lemma subBalance_mono:
  assumes "subBalance ad val acc = Some acc'"
    shows "ReadL\<^sub>i\<^sub>n\<^sub>t (accessBalance acc ad) \<ge> ReadL\<^sub>i\<^sub>n\<^sub>t (accessBalance acc' ad)"
proof -
  define v where "v = ReadL\<^sub>i\<^sub>n\<^sub>t (accessBalance acc ad) - ReadL\<^sub>i\<^sub>n\<^sub>t val"
  with assms have "acc' = updateBalance ad (ShowL\<^sub>i\<^sub>n\<^sub>t v) acc" by (simp add:Let_def split:if_split_asm)
  thus ?thesis using v_def Read_ShowL_id assms by (simp split:if_split_asm)
qed

lemma subBalance_eq:
  assumes "subBalance ad val acc = Some acc'"
      and "ad \<noteq> ad'"
    shows "(accessBalance acc ad') = (accessBalance acc' ad')"
proof -
  define v where "v = ReadL\<^sub>i\<^sub>n\<^sub>t (accessBalance acc ad) - ReadL\<^sub>i\<^sub>n\<^sub>t val"
  with assms have "acc' = updateBalance ad (ShowL\<^sub>i\<^sub>n\<^sub>t v) acc" by (simp add:Let_def split:if_split_asm)
  thus ?thesis using v_def Read_ShowL_id assms by (simp split:if_split_asm)
qed

fun transfer :: "Address \<Rightarrow> Address \<Rightarrow> Valuetype \<Rightarrow> Accounts \<Rightarrow> Accounts option"
where
  "transfer ads addr val acc =
    (case subBalance ads val acc of
      Some acc' \<Rightarrow> addBalance addr val acc'
    | None \<Rightarrow> None)"

lemma transfer_val1:
  assumes "transfer ads addr val acc = Some acc'"
    shows "ReadL\<^sub>i\<^sub>n\<^sub>t val \<ge> 0"
proof -
  from assms(1) obtain acc''
    where *: "subBalance ads val acc = Some acc''"
      and **: "addBalance addr val acc'' = Some acc'" by (simp split:if_split_asm)
  then show "ReadL\<^sub>i\<^sub>n\<^sub>t val \<ge> 0" using subBalance_val[OF *] by simp
qed

lemma transfer_val2:
  assumes "transfer ads addr val acc = Some acc'"
      and "ads \<noteq> addr"
    shows "ReadL\<^sub>i\<^sub>n\<^sub>t (accessBalance acc addr) + ReadL\<^sub>i\<^sub>n\<^sub>t val < 2^256"
proof -
  from assms(1) obtain acc''
    where *: "subBalance ads val acc = Some acc''"
      and **: "addBalance addr val acc'' = Some acc'" by (simp split:if_split_asm)

  then have "ReadL\<^sub>i\<^sub>n\<^sub>t (accessBalance acc'' addr) + ReadL\<^sub>i\<^sub>n\<^sub>t val < 2^256" using addBalance_val[OF **] by simp
  with * show ?thesis using assms(2) subBalance_eq[OF *] by simp
qed

lemma transfer_add:
  assumes "transfer ads addr val acc = Some acc'"
      and "addr \<noteq> ads"
  shows "ReadL\<^sub>i\<^sub>n\<^sub>t (accessBalance acc' addr) = ReadL\<^sub>i\<^sub>n\<^sub>t (accessBalance acc addr) + ReadL\<^sub>i\<^sub>n\<^sub>t val"
proof -
  from assms(1) obtain acc''
    where *: "subBalance ads val acc = Some acc''"
      and **: "addBalance addr val acc'' = Some acc'" by (simp split:if_split_asm)

  with assms(2) have "ReadL\<^sub>i\<^sub>n\<^sub>t (accessBalance acc addr) = ReadL\<^sub>i\<^sub>n\<^sub>t (accessBalance acc'' addr)" using subBalance_eq[OF *] by simp
  moreover have "ReadL\<^sub>i\<^sub>n\<^sub>t (accessBalance acc' addr) = ReadL\<^sub>i\<^sub>n\<^sub>t (accessBalance acc'' addr) + ReadL\<^sub>i\<^sub>n\<^sub>t val" using addBalance_add[OF **] by simp
  ultimately show ?thesis using Read_ShowL_id by simp
qed

lemma transfer_sub:
  assumes "transfer ads addr val acc = Some acc'"
      and "addr \<noteq> ads"
  shows "ReadL\<^sub>i\<^sub>n\<^sub>t (accessBalance acc' ads) = ReadL\<^sub>i\<^sub>n\<^sub>t (accessBalance acc ads) - ReadL\<^sub>i\<^sub>n\<^sub>t val"
proof -
  from assms(1) obtain acc''
    where *: "subBalance ads val acc = Some acc''"
      and **: "addBalance addr val acc'' = Some acc'" by (simp split:if_split_asm)

  then have "ReadL\<^sub>i\<^sub>n\<^sub>t (accessBalance acc'' ads) = ReadL\<^sub>i\<^sub>n\<^sub>t (accessBalance acc ads) - ReadL\<^sub>i\<^sub>n\<^sub>t val" using subBalance_sub[OF *] by simp
  moreover from assms(2) have "ReadL\<^sub>i\<^sub>n\<^sub>t (accessBalance acc' ads) = ReadL\<^sub>i\<^sub>n\<^sub>t (accessBalance acc'' ads)" using addBalance_eq[OF **] by simp
  ultimately show ?thesis using Read_ShowL_id by simp
qed

lemma transfer_mono:
  assumes "transfer ads addr val acc = Some acc'"
  shows "ReadL\<^sub>i\<^sub>n\<^sub>t (accessBalance acc' addr) \<ge> ReadL\<^sub>i\<^sub>n\<^sub>t (accessBalance acc addr)"
proof -
  from assms(1) obtain acc''
    where *: "subBalance ads val acc = Some acc''"
      and **: "addBalance addr val acc'' = Some acc'" by (simp split:if_split_asm)

  show ?thesis
  proof (cases "addr = ads")
    case True
    with * have "acc'' = updateBalance addr (ShowL\<^sub>i\<^sub>n\<^sub>t (ReadL\<^sub>i\<^sub>n\<^sub>t (accessBalance acc addr) - ReadL\<^sub>i\<^sub>n\<^sub>t val)) acc" by (simp add:Let_def split: if_split_asm)
    moreover from ** have "acc'=updateBalance addr (ShowL\<^sub>i\<^sub>n\<^sub>t (ReadL\<^sub>i\<^sub>n\<^sub>t (accessBalance acc'' addr) + ReadL\<^sub>i\<^sub>n\<^sub>t val)) acc''" by (simp add:Let_def split: if_split_asm)
    ultimately show ?thesis using Read_ShowL_id by auto
  next
    case False
    then have "ReadL\<^sub>i\<^sub>n\<^sub>t (accessBalance acc addr) \<le> ReadL\<^sub>i\<^sub>n\<^sub>t (accessBalance acc'' addr)" using subBalance_eq[OF *] by simp
    also have "\<dots> \<le> ReadL\<^sub>i\<^sub>n\<^sub>t (accessBalance acc' addr)" using addBalance_mono[OF **] by simp
    finally show ?thesis .
  qed
qed

lemma transfer_eq:
  assumes "transfer ads addr val acc = Some acc'"
      and "ad \<noteq> ads"
      and "ad \<noteq> addr"
  shows "ReadL\<^sub>i\<^sub>n\<^sub>t (accessBalance acc' ad) = ReadL\<^sub>i\<^sub>n\<^sub>t (accessBalance acc ad)"
proof -
  from assms(1) obtain acc''
    where *: "subBalance ads val acc = Some acc''"
      and **: "addBalance addr val acc'' = Some acc'" by (simp split:if_split_asm)

  from assms(3) have "ReadL\<^sub>i\<^sub>n\<^sub>t (accessBalance acc' ad) = ReadL\<^sub>i\<^sub>n\<^sub>t (accessBalance acc'' ad)" using addBalance_eq[OF **] by simp
  also from assms(2) have "\<dots> = ReadL\<^sub>i\<^sub>n\<^sub>t (accessBalance acc ad)" using subBalance_eq[OF *] by simp
  finally show ?thesis .
qed

lemma transfer_limit:
  assumes "transfer ads addr val acc = Some acc'"
     and "\<forall>ad. ReadL\<^sub>i\<^sub>n\<^sub>t (accessBalance acc ad) \<ge> 0 \<and> ReadL\<^sub>i\<^sub>n\<^sub>t (accessBalance acc ad) < 2 ^ 256"
   shows "\<forall>ad. ReadL\<^sub>i\<^sub>n\<^sub>t (accessBalance acc' ad) \<ge> 0 \<and> ReadL\<^sub>i\<^sub>n\<^sub>t (accessBalance acc' ad) < 2 ^ 256"
proof
  fix ad'
  from assms(1) obtain acc'' where "subBalance ads val acc = Some acc''" and "addBalance addr val acc'' = Some acc'" by (simp split: if_split_asm)
  with subBalance_limit[OF _ assms(2)]
  show "ReadL\<^sub>i\<^sub>n\<^sub>t (accessBalance acc' ad') \<ge> 0 \<and> ReadL\<^sub>i\<^sub>n\<^sub>t (accessBalance acc' ad') < 2 ^ 256"
    using addBalance_limit by presburger
qed

end


theory prop_51
imports Main
        "$HIPSTER_HOME/IsaHipster"
begin
  datatype 'a list = Nil2 | Cons2 "'a" "'a list"
  fun butlast :: "'a list => 'a list" where
  "butlast (Nil2) = Nil2"
  | "butlast (Cons2 y (Nil2)) = Nil2"
  | "butlast (Cons2 y (Cons2 x2 x3)) =
       Cons2 y (butlast (Cons2 x2 x3))"
  fun append :: "'a list => 'a list => 'a list" where
  "append (Nil2) y = y"
  | "append (Cons2 z xs) y = Cons2 z (append xs y)"
  (*hipster butlast append *)
  theorem x0 :
    "(butlast (append xs (Cons2 x (Nil2)))) = xs"
    by (tactic \<open>Subgoal.FOCUS_PARAMS (K (Tactic_Data.hard_tac @{context})) @{context} 1\<close>)
end


theory Balance_Opt_Ext
  imports
    Balance_Opt
    "../../Assertion_Tree_Lookup"
    "../../Utilities_Ext"
    "HOL-Eisbach.Eisbach_Tools"
begin

context rbt_impl
begin

lemma balance_opt_correct_ext [vcg_rules]:
  "llvm_htriple
  (
    rbt_assn_ext (ATBranch color.B k v ci li ki vi ri l r) {} ti ** \<up>(rbt_sorted (rbt_of (ATBranch color.B k v ci li ki vi ri l r)))
  )
  (balance_opt ti)
  (\<lambda>res. EXS t_res. rbt_assn_ext t_res {} res **
    \<up>(rbt_of t_res = rbt_balance (rbt_of l) k v (rbt_of r)) **
    \<up>(rbt_sorted (rbt_of t_res)) **
    \<up>(ptr_of_key t_res res = ptr_of_key (ATBranch color.B k v ci li ki vi ri l r) ti) **
    \<up>(value_of_key t_res = value_of_key (ATBranch color.B k v ci li ki vi ri l r))
  )
  "
  unfolding
    balance_opt_def
    balance_opt_case_1_def
    balance_opt_case_2_def
    balance_opt_case_3_def
    balance_opt_case_4_def
    balance_opt_case_5_def
    rotate_left_def
    rotate_right_def
    right_def
    left_def
  supply rbt_greater_trans[intro] rbt_less_trans[intro]
  apply vcg
  subgoal (*Case 1*)
    apply (cases "(rbt_of l, k, v, rbt_of r)" rule: RBT_Impl.balance.cases)
                        apply auto
    apply vcg_vok
    done
  subgoal (*Case 2+*)
    apply vcg
    subgoal (*Case 2*)
      apply (cases "(rbt_of l, k, v, rbt_of r)" rule: RBT_Impl.balance.cases)
                          apply auto
      subgoal by vcg_vok
      subgoal by vcg_vok
      done
    subgoal (*Case 3+*)
      apply vcg
      subgoal (*Case 3*)
        apply (cases "(rbt_of l, k, v, rbt_of r)" rule: RBT_Impl.balance.cases)
        apply auto
        subgoal by vcg_vok
        subgoal by vcg_vok
        subgoal by vcg_vok
        subgoal by vcg_vok
        done
      subgoal (*Case 4+*)
        apply vcg
        subgoal (*Case 4*)
          apply (cases "(rbt_of l, k, v, rbt_of r)" rule: RBT_Impl.balance.cases)
                              apply auto
          subgoal by vcg_vok
          subgoal by vcg_vok
          done
        subgoal (*Case 5+*)
          apply vcg
          subgoal (*Case 5*)
            apply (cases "(rbt_of l, k, v, rbt_of r)" rule: RBT_Impl.balance.cases)
                                apply auto
            subgoal by vcg_vok
            subgoal by vcg_vok
            subgoal by vcg_vok
            subgoal by vcg_vok
            done
          subgoal (*Case 6*)
            apply (cases "(rbt_of l, k, v, rbt_of r)" rule: RBT_Impl.balance.cases)
                                apply auto
            by vcg
          done
        done
      done
    done
  done

end

end


(*************************************************************************************************)
(* Project: The Isabelle/UTP Proof System                                                        *)
(* File: utp_sp.thy                                                                              *)
(* Authors: Yakoub Nemouchi (Virginia Tech, USA) and Simon Foster (University of York, UK)       *)
(* Emails: nemouchi@vt.edu and simon.foster@york.ac.uk                                           *)
(*************************************************************************************************)

section \<open> Strong Postcondition Calculus\<close>

theory utp_sp
imports utp_wp
begin

named_theorems sp

method sp_tac = (simp add: sp)

consts
  usp :: "'a \<Rightarrow> 'b \<Rightarrow> 'c" (infix "sp" 60)

definition sp_upred :: "'\<alpha> cond \<Rightarrow> ('\<alpha>, '\<beta>) urel \<Rightarrow> '\<beta> cond" where
"sp_upred p Q = \<lfloor>(\<lceil>p\<rceil>\<^sub>> ;; Q) :: ('\<alpha>, '\<beta>) urel\<rfloor>\<^sub>>"

adhoc_overloading
  usp sp_upred

declare sp_upred_def [upred_defs]

lemma sp_false [sp]: "p sp false = false"
  by (rel_simp)

lemma sp_true [sp]: "q \<noteq> false \<Longrightarrow> q sp true = true"
  by (rel_auto)

lemma sp_assigns_r [sp]:
  "vwb_lens x \<Longrightarrow> (p sp x := e ) = (\<^bold>\<exists>v \<bullet> p\<lbrakk>\<guillemotleft>v\<guillemotright>/x\<rbrakk> \<and> &x =\<^sub>u e\<lbrakk>\<guillemotleft>v\<guillemotright>/x\<rbrakk>)"
  by (rel_auto, metis vwb_lens_wb wb_lens.get_put, metis vwb_lens.put_eq)

lemma sp_it_is_post_condition:
  "\<lbrace>p\<rbrace>C\<lbrace>p sp C\<rbrace>\<^sub>u"
  by rel_blast

lemma sp_it_is_the_strongest_post:
  "`p sp C \<Rightarrow> Q`\<Longrightarrow>\<lbrace>p\<rbrace>C\<lbrace>Q\<rbrace>\<^sub>u"
  by rel_blast

lemma sp_so:
  "`p sp C \<Rightarrow> Q` = \<lbrace>p\<rbrace>C\<lbrace>Q\<rbrace>\<^sub>u"
  by rel_blast

theorem sp_hoare_link:
  "\<lbrace>p\<rbrace>Q\<lbrace>r\<rbrace>\<^sub>u \<longleftrightarrow> (r \<sqsubseteq> p sp Q)"
  by rel_auto

lemma sp_while_r [sp]:
   assumes \<open>`pre \<Rightarrow> I`\<close> and \<open>\<lbrace>I \<and> b\<rbrace>C\<lbrace>I'\<rbrace>\<^sub>u\<close> and \<open>`I' \<Rightarrow> I`\<close>
   shows "(pre sp invar I while\<^sub>\<bottom> b do C od) = (\<not>b \<and> I)"
   unfolding sp_upred_def
   oops

theorem sp_eq_intro: "\<lbrakk>\<And>r. r sp P = r sp Q\<rbrakk> \<Longrightarrow> P = Q"
  by (rel_auto robust, fastforce+)

lemma wp_sp_sym:
  "`prog wp (true sp prog)`"
  by rel_auto

lemma it_is_pre_condition:"\<lbrace>C wp Q\<rbrace>C\<lbrace>Q\<rbrace>\<^sub>u"
  by rel_blast

lemma it_is_the_weakest_pre:"`P \<Rightarrow> C wp Q` = \<lbrace>P\<rbrace>C\<lbrace>Q\<rbrace>\<^sub>u"
  by rel_blast

lemma s_pre:"`P \<Rightarrow> C wp Q`=\<lbrace>P\<rbrace>C\<lbrace>Q\<rbrace>\<^sub>u"
  by rel_blast

end


(* Title: Pseudo_Random_Function.thy
  Author: Andreas Lochbihler, ETH Zurich *)

theory Pseudo_Random_Function imports
  CryptHOL.Computational_Model
begin

subsection \<open>Pseudo-random function\<close>

locale random_function =
  fixes p :: "'a spmf"
begin

type_synonym ('b,'a') dict = "'b \<rightharpoonup> 'a'"

definition random_oracle :: "('b, 'a) dict \<Rightarrow> 'b \<Rightarrow> ('a \<times> ('b, 'a) dict) spmf"
where
  "random_oracle \<sigma> x =
  (case \<sigma> x of Some y \<Rightarrow> return_spmf (y, \<sigma>)
   | None \<Rightarrow> p \<bind> (\<lambda>y. return_spmf (y, \<sigma>(x \<mapsto> y))))"

definition forgetful_random_oracle :: "unit \<Rightarrow> 'b \<Rightarrow> ('a \<times> unit) spmf"
where
  "forgetful_random_oracle \<sigma> x = p \<bind> (\<lambda>y. return_spmf (y, ()))"

lemma weight_random_oracle [simp]:
  "weight_spmf p = 1 \<Longrightarrow> weight_spmf (random_oracle \<sigma> x) = 1"
by(simp add: random_oracle_def weight_bind_spmf o_def split: option.split)

lemma lossless_random_oracle [simp]:
  "lossless_spmf p \<Longrightarrow> lossless_spmf (random_oracle \<sigma> x)"
by(simp add: lossless_spmf_def)

sublocale finite: callee_invariant_on random_oracle "\<lambda>\<sigma>. finite (dom \<sigma>)" \<I>_full
by(unfold_locales)(auto simp add: random_oracle_def split: option.splits)

lemma card_dom_random_oracle:
  assumes "interaction_any_bounded_by \<A> q"
  and "(y, \<sigma>') \<in> set_spmf (exec_gpv random_oracle \<A> \<sigma>)"
  and fin: "finite (dom \<sigma>)"
  shows "card (dom \<sigma>') \<le> q + card (dom \<sigma>)"
by(rule finite.interaction_bounded_by'_exec_gpv_count[OF assms(1-2)])
  (auto simp add: random_oracle_def fin card_insert_if simp del: fun_upd_apply split: option.split_asm)

end

subsection \<open>Pseudo-random function\<close>

locale "prf" =
  fixes key_gen :: "'key spmf"
  and "prf" :: "'key \<Rightarrow> 'domain \<Rightarrow> 'range"
  and rand :: "'range spmf"
begin

sublocale random_function "rand" .

definition prf_oracle :: "'key \<Rightarrow> unit \<Rightarrow> 'domain \<Rightarrow> ('range \<times> unit) spmf"
where "prf_oracle key \<sigma> x = return_spmf (prf key x, ())"

type_synonym ('domain', 'range') adversary = "(bool, 'domain', 'range') gpv"

definition game_0 :: "('domain, 'range) adversary \<Rightarrow> bool spmf"
where
  "game_0 \<A> = do {
     key \<leftarrow> key_gen;
     (b, _) \<leftarrow> exec_gpv (prf_oracle key) \<A> ();
     return_spmf b
   }"

definition game_1 :: "('domain, 'range) adversary \<Rightarrow> bool spmf"
where
  "game_1 \<A> = do {
     (b, _) \<leftarrow> exec_gpv random_oracle \<A> Map.empty;
     return_spmf b
   }"

definition advantage :: "('domain, 'range) adversary \<Rightarrow> real"
where "advantage \<A> = \<bar>spmf (game_0 \<A>) True - spmf (game_1 \<A>) True\<bar>"

lemma advantage_nonneg: "advantage \<A> \<ge> 0"
by(simp add: advantage_def)

abbreviation lossless :: "('domain, 'range) adversary \<Rightarrow> bool"
where "lossless \<equiv> lossless_gpv \<I>_full"

abbreviation (input) ibounded_by :: "('domain, 'range) adversary \<Rightarrow> enat \<Rightarrow> bool"
where "ibounded_by \<equiv> interaction_any_bounded_by"

end

end