\<^marker>\<open>creator Bernhard Pöttinger\<close>

theory FF
  imports Flow_Base Flow_Extensions "Separation_Logic_Imperative_HOL.Sep_Main"
begin

paragraph \<open>Summary\<close>
text \<open>This theory introduces a locale that provides general infrastructure to
embed the Flow Framework into a Separation Logic. See section 3 in @{cite krishna20}.
\<close>

section \<open>The Framework\<close>

locale FF =
  fixes \<gamma> :: "'a \<Rightarrow> 'n ref \<Rightarrow> 'n :: heap \<Rightarrow> 'm :: cancel_comm_monoid_add \<Rightarrow> bool"
    and \<phi> :: "('n ref, 'm) fi \<Rightarrow> bool"
    and edges :: "'n ref \<Rightarrow> 'n \<Rightarrow> 'n ref \<Rightarrow> 'm \<Rightarrow> 'm"
  assumes edges_not_refl: "\<And>x fs g m. \<gamma> g x fs m \<Longrightarrow>  edges x fs x = (\<lambda>_. 0)"
begin

lemma int_fg_fg:
  assumes "\<gamma> g x fs m"
  shows "int_fg (fg {x} (\<lambda>_. edges x fs) (\<lambda>_. m)) = fi {x} (\<lambda>_. m) (\<lambda>y. edges x fs y m)"
proof -
  let ?e = "\<lambda>_ y. edges x fs y"
  let ?f = "\<lambda>_. m"
  let ?h = "fg {x} ?e ?f"

  have *: "?h \<noteq> bot"
    using def_fg_singleton' edges_not_refl assms by metis
  have **: "flow_eq ?h ?f"
    apply (rule flow_eqI) using edges_not_refl assms by auto
  show ?thesis
    unfolding int_fg_def inf_fg_def outf_fg_def
    using * ** apply auto
    apply (rule fi_cong, auto)
    by (metis (mono_tags, lifting) dom_fg_fg flow_eq_unique singletonI someI_ex)
qed

subsection \<open>Flow Graph Abstractions\<close>

text \<open>Our framework abstracts heap objects as nodes. The underlying heap object induces
a singleton flow graph. Each node has to satisfy the node-local invariant $\gamma$.\<close>

definition N :: "'a \<Rightarrow> 'n ref \<Rightarrow> 'n \<Rightarrow> 'm \<Rightarrow> ('n ref, 'm) fg \<Rightarrow> assn" where
"N g x fs m h \<equiv>
  x \<mapsto>\<^sub>r fs * \<up>(\<gamma> g x fs m \<and> h \<noteq> bot \<and> h = fg {x} (\<lambda>_. edges x fs) (\<lambda>_. m))"

text \<open>Graphs compose multiple nodes. The nodes' singleton flow graphs have to
make up a valid flow graph again.\<close>

definition
  Gr :: "('n ref \<Rightarrow> 'a) \<Rightarrow> ('n ref \<Rightarrow> 'n) \<Rightarrow> 'n ref set \<Rightarrow> ('n ref, 'm) fg \<Rightarrow> assn"
where
  "Gr \<eta> Fs X h \<equiv>
    \<exists>\<^sub>AH M. (\<Prod>x \<in> X. N (\<eta> x) x (Fs x) (M x) (H x)) *
           \<up>(finite X \<and> h \<noteq> bot \<and> h = (\<Sum>x \<in> X. H x))"

text \<open>Some useful entailments for our graph/node abstractions:\<close>

lemma decomp_Gr:
  assumes "xs1 \<inter> xs2 = {}" "dom_fg h = xs1 \<union> xs2"
  shows "Gr \<eta> Fs (xs1 \<union> xs2) h \<Longrightarrow>\<^sub>A
    \<exists>\<^sub>Ah1 h2. Gr \<eta> Fs xs1 h1 * Gr \<eta> Fs xs2 h2 * \<up>(h \<noteq> bot \<and> h = h1 + h2)"
  apply (unfold Gr_def)
  apply (simp)
  apply (intro ent_ex_preI)
  subgoal for H M
    using assms split_sum[of H xs1 xs2] finiteUn[OF dom_fg_finite assms(2)] apply simp
    apply clarsimp
    apply (rule ent_ex_postI[of _ _ "sum H xs1"])
    apply (rule ent_ex_postI[of _ _ "sum H xs2"])
    apply (rule ent_ex_postI[of _ _ H])
    apply (rule ent_ex_postI[of _ _ M])
    apply (rule ent_ex_postI[of _ _ H])
    apply (rule ent_ex_postI[of _ _ M])
    apply (auto simp: prod.union_disjoint assms)
    done
  done

lemma ent_prod_cong:
  assumes "finite X" "\<And>x. x \<in> X \<Longrightarrow> P x \<Longrightarrow>\<^sub>A P' x"
  shows "(\<Prod>x \<in> X. P x) \<Longrightarrow>\<^sub>A (\<Prod>x \<in> X. P' x)"
  using assms
  apply (induction X rule: finite_induct)
   apply simp
  apply sep_auto
  apply (rule ent_star_mono)
  using assms apply auto
  done

lemma comp_Gr:
  assumes "xs1 \<inter> xs2 = {}" "finite xs1" "finite xs2" "h = h1 + h2" "h \<noteq> bot"
  shows "Gr \<eta>1 Fs1 xs1 h1 * Gr \<eta>2 Fs2 xs2 h2 \<Longrightarrow>\<^sub>A
    Gr (\<lambda>x. if x \<in> xs1 then \<eta>1 x else \<eta>2 x)
       (\<lambda>x. if x \<in> xs1 then Fs1 x else Fs2 x) (xs1 \<union> xs2) h"
  apply (unfold Gr_def)
  apply clarsimp
  apply (intro ent_ex_preI)
  subgoal for H2 M2 H1 M1
    apply clarsimp
    apply (rule ent_trans[of _ "\<Prod>x\<in>xs1 \<union> xs2.
      N ((\<lambda>x. if x \<in> xs1 then \<eta>1 x else \<eta>2 x) x)
        x
        ((\<lambda>x. if x \<in> xs1 then Fs1 x else Fs2 x) x)
        ((\<lambda>x. if x \<in> xs1 then M1 x else M2 x) x) ((\<lambda>x. if x \<in> xs1 then H1 x else H2 x) x)"])
    using assms apply (simp add: prod.union_disjoint)
     apply (rule ent_star_mono[OF ent_refl ent_prod_cong])
    using assms apply simp
    using assms apply sep_auto
    apply (intro ent_ex_postI[of _ _ "\<lambda>x. if x \<in> xs1 then H1 x else H2 x"])
    apply (intro ent_ex_postI[of _ _ "\<lambda>x. if x \<in> xs1 then M1 x else M2 x"])
    apply clarsimp
    using assms apply (simp)
    apply (subst (1) sum.cong[where h="\<lambda>x. restrict xs1 (H2 x) H1 x"], simp, simp)
    apply (subst (2) sum.cong[where h="\<lambda>x. restrict xs1 (H2 x) H1 x"], simp, simp)
    using assms apply blast
    by (rule sum.union_disjoint[symmetric], simp_all add: assms)
  done

lemma sing_N_Gr: "N (\<eta> x) x fs m h \<Longrightarrow>\<^sub>A Gr \<eta> (\<lambda>_. fs) {x} h"
  apply (unfold N_def Gr_def)
  by sep_auto

lemma sing_Gr_N:
  "Gr \<eta> Fs {x} h \<Longrightarrow>\<^sub>A \<exists>\<^sub>Am. N (\<eta> x) x (Fs x) m h *
    \<up>(\<gamma> (\<eta> x) x (Fs x) m \<and> h \<noteq> bot \<and> h = fg {x} (\<lambda>_. edges x (Fs x)) (\<lambda>_. m))"
  apply (unfold N_def Gr_def)
  by sep_auto

lemma peek_N:
  shows "N g x fs m h \<Longrightarrow>\<^sub>A N g x fs m h * \<up>(h = fg {x} (\<lambda>_. edges x fs) (\<lambda>_. m))"
  unfolding N_def by sep_auto

lemma unfold_N:
  assumes "x \<in> X" "X = dom_fg h"
  shows "Gr \<eta> Fs X h \<Longrightarrow>\<^sub>A
    \<exists>\<^sub>Am h1 h'. Gr \<eta> Fs (X - {x}) h' * N (\<eta> x) x (Fs x) m h1 *
      \<up>(h = h1 + h' \<and> \<gamma> (\<eta> x) x (Fs x) m \<and> h1 = fg {x} (\<lambda>_. edges x (Fs x)) (\<lambda>_. m))"
proof -
  have *: "X = insert x X" using assms by auto
  show ?thesis
    apply (subst *)
    apply (rule ent_trans[OF decomp_Gr[of "{x}" "X - {x}" h], simplified])
    using assms * apply simp
    apply (intro ent_ex_preI, clarsimp)
    apply (rule ent_trans[OF ent_frame_fwd[OF sing_Gr_N[where x=x]]])
      apply frame_inference+
    apply clarsimp
    apply (intro ent_ex_preI, clarsimp)
    apply (rule_tac x=m in ent_ex_postI)
    apply (rule ent_ex_postI)
    apply (rule_tac x=h2 in ent_ex_postI)
    apply (rule ent_trans[OF ent_frame_fwd[OF peek_N]])
    by frame_inference+
qed

lemma Gr_cong:
  assumes "X = X'" "\<eta> = \<eta>' on X" "Fs = Fs' on X" "h = h'" "h \<noteq> bot"
  shows "Gr \<eta> Fs X h \<Longrightarrow>\<^sub>A Gr \<eta>' Fs' X' h'"
  unfolding Gr_def using assms by sep_auto

lemma fold_N:
  assumes "x \<notin> X" "X = dom_fg h" "h + h1 \<noteq> bot" "\<gamma> g x fs m"
  shows "Gr \<eta> Fs X h * N g x fs m h1 \<Longrightarrow>\<^sub>A
    Gr (\<lambda>y. if y = x then g else \<eta> y) (\<lambda>y. if y = x then fs else Fs y) ({x} \<union> X) (h1 + h)"
  apply (rule ent_trans[OF ent_frame_fwd[OF sing_N_Gr]])
  using assms apply simp
    apply frame_inference+
  apply (rule ent_trans[OF comp_Gr])
  using assms apply simp_all
  by (rule Gr_cong, auto simp: algebra_simps)

lemma dom_fi_plus_fg_iterated:
  fixes H :: "'n ref \<Rightarrow> ('n ref,'b :: cancel_comm_monoid_add) fg"
  assumes "finite X" "sum H X \<noteq> bot"
  shows "dom_fg (sum H X) = (\<Union>x \<in> X. dom_fg (H x))"
  using assms
  apply (induction X rule: finite_induct)
   apply simp_all
  using plus_fg_ops_exist by blast

lemma Gr_dom:
  "Gr \<eta> Fs X H \<Longrightarrow>\<^sub>A Gr \<eta> Fs X H * \<up>(finite X \<and> dom_fg H = X)"
proof -
  have X: "finite X \<Longrightarrow> (\<Prod>x\<in>X. N (\<eta> x) x (Fs x) (M x) (Ha x)) \<Longrightarrow>\<^sub>A
    (\<Prod>x\<in>X. N (\<eta> x) x (Fs x) (M x) (Ha x)) * \<up>(\<forall>x \<in> X. dom_fg (Ha x) = {x})" for M Ha
    apply (induction X rule: finite_induct)
    by (sep_auto simp: mod_star_conv N_def)+

  show ?thesis
    unfolding Gr_def
    apply (intro ent_ex_preI, clarsimp)
    apply (rule ent_trans[OF X])
     apply simp
    subgoal for Ha M
      using dom_fi_plus_fg_iterated[of X Ha] by sep_auto
    done
qed

lemma Gr_emp: "emp \<Longrightarrow>\<^sub>A \<exists>\<^sub>AFs. Gr \<eta> Fs {} 0"
  apply (unfold Gr_def)
  using def_fg_zero_fg by sep_auto

lemma repl:
  assumes "xs1' \<inter> xs2 = {}" "finite xs1'" "finite xs2" "int_fg h1 = int_fg h1'"
    "h = h1 + h2" "h \<noteq> bot"
  shows "Gr \<eta> Fs1 xs1' h1' * Gr \<eta> Fs2 xs2 h2 \<Longrightarrow>\<^sub>A
    Gr \<eta> (\<lambda>x. if x \<in> xs1' then Fs1 x else Fs2 x) (xs1' \<union> xs2) (h1' + h2) *
    \<up>(int_fg h = int_fg (h1' + h2))"
proof -
  have "int_fg (h1 + h2) = int_fg h1 + int_fg h2" by (rule int_fg_fi_hom)
  also have "... = int_fg h1' + int_fg h2" using assms by simp
  also have "... = int_fg (h1' + h2)" by (rule int_fg_fi_hom[symmetric])
  finally have H: "int_fg h = int_fg (h1' + h2)" using assms by simp
  then have nbot': "h1' + h2 \<noteq> bot" using assms by auto

  show ?thesis
    apply sep_auto
     apply (simp add: H)
    apply (rule ent_trans[OF comp_Gr], simp_all add: assms)
    using nbot' apply simp
    by sep_auto
qed

lemma open_N:
  shows "N g x fs m h \<Longrightarrow>\<^sub>A
    x \<mapsto>\<^sub>r fs * \<up>(h \<noteq> bot \<and> \<gamma> g x fs m \<and> h = fg {x} (\<lambda>_. edges x fs) (\<lambda>_. m))"
  unfolding N_def by sep_auto

lemma close_N:
  assumes "\<gamma> g x fs m"
  shows "x \<mapsto>\<^sub>r fs \<Longrightarrow>\<^sub>A N g x fs m (fg {x} (\<lambda>_. edges x fs) (\<lambda>_. m))"
  using assms unfolding N_def apply sep_auto
  using assms def_fg_singleton'[of "\<lambda>_ y. edges x fs y" x "\<lambda>_. m"] edges_not_refl[of g x fs m]
  by metis

subsection \<open>Flow Interface\<close>

text \<open>Building on top of the flow graph abstraction we introduce another level of abstraction:
flow interfaces.\<close>

definition NI :: "'a \<Rightarrow> 'n ref \<Rightarrow> 'n \<Rightarrow> 'm \<Rightarrow> ('n ref, 'm) fi \<Rightarrow> assn" where
"NI g x fs m i \<equiv> \<exists>\<^sub>Ah. N g x fs m h * \<up>(i \<noteq> bot \<and> i = int_fg h)"

definition
  GrI :: "('n ref \<Rightarrow> 'a) \<Rightarrow> ('n ref \<Rightarrow> 'n) \<Rightarrow> 'n ref set \<Rightarrow> ('n ref, 'm) fi \<Rightarrow> assn"
where
  "GrI \<eta> Fs X i \<equiv> \<exists>\<^sub>Ah. Gr \<eta> Fs X h * \<up>(i = int_fg h)"

text \<open>Lifting the generally useful entailments to flow interfaces:\<close>

lemma decomp_GrI:
  assumes "xs1 \<inter> xs2 = {}" "dom_fi i = xs1 \<union> xs2"
  shows "GrI \<eta> Fs (xs1 \<union> xs2) i \<Longrightarrow>\<^sub>A
    \<exists>\<^sub>Ai1 i2. GrI \<eta> Fs xs1 i1 * GrI \<eta> Fs xs2 i2 * \<up>(i \<noteq> bot \<and> i = i1 + i2)"
  apply (unfold GrI_def)
  apply (rule ent_ex_preI)
  apply clarsimp
  apply (rule ent_trans[OF decomp_Gr])
  using assms apply simp
  using assms apply simp
  apply (intro ent_ex_preI)
  subgoal for h h1 h2
  apply (rule ent_ex_postI[of _ _ "int_fg h1"])
  apply (rule ent_ex_postI[of _ _ "int_fg h2"])
  apply (rule ent_ex_postI[of _ _ h2])
    apply (rule ent_ex_postI[of _ _ h1])
    using int_fg_fi_hom by sep_auto
  done

lemma comp_GrI:
  assumes "xs1 \<inter> xs2 = {}" "finite xs1" "finite xs2" "i = i1 + i2" "i \<noteq> bot"
  shows "GrI \<eta>1 Fs1 xs1 i1 * GrI \<eta>2 Fs2 xs2 i2 \<Longrightarrow>\<^sub>A
    GrI (\<lambda>x. if x \<in> xs1 then \<eta>1 x else \<eta>2 x) (\<lambda>x. if x \<in> xs1 then Fs1 x else Fs2 x) (xs1 \<union> xs2) i"
  apply (unfold GrI_def)
  apply clarsimp
  apply (intro ent_ex_preI)
  apply clarsimp
  subgoal for h2 h1
    using assms int_fg_fi_hom[symmetric,of h1 h2]
    apply auto
    apply (rule ent_ex_postI[of _ _ "h1+h2"])
    apply sep_auto
    apply (rule comp_Gr[of xs1 xs2 "h1 + h2" h1 h2 \<eta>1 Fs1 \<eta>2 Fs2])
    apply auto
    done
  done

lemma sing_GrI_NI: "GrI \<eta> Fs {x} i \<Longrightarrow>\<^sub>A \<exists>\<^sub>Am. NI (\<eta> x) x (Fs x) m i * \<up>(\<gamma> (\<eta> x) x (Fs x) m)"
  unfolding GrI_def NI_def Gr_def N_def
  by sep_auto

lemma sing_NI_GrI:
  shows "NI (\<eta> x) x fs m i \<Longrightarrow>\<^sub>A GrI \<eta> (\<lambda>_. fs) {x} i"
  unfolding NI_def GrI_def using sing_N_Gr by sep_auto

lemma GrI_emp: "emp \<Longrightarrow>\<^sub>A \<exists>\<^sub>AFs. GrI \<eta> Fs {} 0"
  unfolding GrI_def
  by (rule ent_trans[OF Gr_emp], sep_auto)

lemma repli:
  assumes "xs1' \<inter> xs2 = {}" "finite xs1'" "finite xs2"
  shows "GrI \<eta>1 Fs1 xs1' i1 * GrI \<eta>2 Fs2 xs2 i2 * \<up>(i \<noteq> bot \<and> i = i1 + i2 \<and> i1 = i2) \<Longrightarrow>\<^sub>A
    GrI (\<lambda>x. if x \<in> xs1' then \<eta>1 x else \<eta>2 x) (\<lambda>x. if x \<in> xs1' then Fs1 x else Fs2 x) (xs1' \<union> xs2) i"
  using assms
  apply (unfold GrI_def)
  apply clarsimp
  apply (intro ent_ex_preI)
  apply clarsimp
  subgoal for h2 h1
    using assms int_fg_fi_hom[symmetric,of h1 h2]
    apply simp
    apply (rule ent_ex_postI[of _ _ "h1+h2"])
    apply sep_auto
    apply (rule comp_Gr)
    apply auto
    done
  done

lemma unfold_GrI:
  assumes "x \<in> xs" "xs = dom_fi i"
  shows "GrI \<eta> Fs xs i \<Longrightarrow>\<^sub>A
    (\<exists>\<^sub>Aix ixs m. NI (\<eta> x) x (Fs x) m ix * GrI \<eta> Fs (xs - {x}) ixs *
                 \<up>(\<gamma> (\<eta> x) x (Fs x) m \<and> i \<noteq> bot \<and> ix + ixs = i))"
proof -
  have A: "xs = {x} \<union> (xs - {x})"
    using assms by blast
  show ?thesis
    apply (subst A)
    apply (rule ent_trans[OF decomp_GrI], blast)
    using assms A apply simp
  apply (intro ent_ex_preI, clarsimp)
    apply (rule ent_trans[OF ent_frame_fwd[OF sing_GrI_NI[where x=x]]])
      apply frame_inference+
    by sep_auto
qed

lemma GrI_cong:
  assumes "\<eta>1 = \<eta>2 on X1" "Fs1 = Fs2 on X1" "X1 = X2" "i1 = i2"
  shows "GrI \<eta>1 Fs1 X1 i1 \<Longrightarrow>\<^sub>A GrI \<eta>2 Fs2 X2 i2"
  using assms
  unfolding GrI_def Gr_def
  by sep_auto

lemma NI_cong:
  assumes "g = g'" "fs = fs'" "m = m'" "i = i'"
  shows "NI g x fs m i \<Longrightarrow>\<^sub>A NI g' x fs' m' i'"
  using assms unfolding NI_def by sep_auto

lemma NI_dom: "NI g x fs m i \<Longrightarrow>\<^sub>A NI g x fs m i * \<up>(dom_fi i = {x})"
  unfolding NI_def N_def by sep_auto

lemma GrI_dom: "GrI \<eta> Fs X i \<Longrightarrow>\<^sub>A GrI \<eta> Fs X i * \<up>(dom_fi i = X \<and> finite X \<and> i \<noteq> bot)"
  unfolding GrI_def
  apply (clarsimp, intro ent_ex_preI, clarsimp)
  using Gr_dom apply sep_auto
  unfolding Gr_def
  by (metis (mono_tags, lifting) int_fg_bot_bot' mod_ex_dist mod_pure_star_dist)

lemma foldi:
  assumes "x \<notin> xs" "finite xs" "i \<noteq> bot" "i = ix + ixs"
  shows "NI g x fs m ix * GrI \<eta> Fs xs ixs \<Longrightarrow>\<^sub>A GrI (\<lambda>n. if n \<in> {x} then g else \<eta> n) (\<lambda>n. if n \<in> {x} then fs else Fs n) ({x} \<union> xs) i"
proof -
  show ?thesis
    apply (rule ent_trans[OF ent_frame_fwd[OF sing_NI_GrI]])
      apply frame_inference+
    apply (rule ent_trans[OF comp_GrI])
    using assms apply (simp_all add: algebra_simps)
    by (rule GrI_cong, simp_all)
qed

(*lemma N_\<eta>_cong:
  assumes "\<eta> x = \<eta>' x"
  shows "N \<eta> x h \<Longrightarrow>\<^sub>A N \<eta>' x h"
  using assms
  unfold_GrIng N_def
  by sep_auto

lemma NI_\<eta>_cong:
  assumes "\<eta> x = \<eta>' x"
  shows "NI \<eta> x i \<Longrightarrow>\<^sub>A NI \<eta>' x i"
  using assms
  unfold_GrIng NI_def N_def
  by sep_auto

lemma GrI_\<eta>_cong:
  assumes "\<eta> = \<eta>' on X"
  shows "GrI \<eta> X i \<Longrightarrow>\<^sub>A GrI \<eta>' X i"
  using assms
  unfold_GrIng GrI_def Gr_def
  apply sep_auto
  by (rule sep_prod_cong[OF N_\<eta>_cong], simp)*)

subsection \<open>SL Ghost Commands\<close>

text \<open>We additionally introduce ghost commands that enable us to trigger the above entailments
in our SL-proofs by placing the ghost commands in the program text.\<close>

definition "sing_NI_GrI x \<equiv> return ()"
definition "sing_GrI_NI x \<equiv> return ()"
definition "ghost_diff x y \<equiv> return ()"
definition "preserve_interface2 x y b \<equiv> b"
definition extends :: "('a,'b) fi \<Rightarrow> ('a,'b) fi \<Rightarrow> unit Heap" where "extends i1 i2 \<equiv> return ()"
definition "open_N x \<equiv> return ()"
definition "close_N x c \<equiv> return ()"
definition "open_NI x \<equiv> return ()"
definition "close_NI x c \<equiv> return ()"
definition "fold_GrI x \<equiv> return ()"
definition "unfold_GrI x \<equiv> return ()"
definition "peek_NI x \<equiv> return ()"

lemma sing_NI_GrI_rule:
  "<NI (\<eta> x) x fs m i> sing_NI_GrI x <\<lambda>_. GrI \<eta> (\<lambda>_. fs) {x} i>"
  unfolding sing_NI_GrI_def
  using sing_NI_GrI by sep_auto

lemma sing_GrI_NI_rule:
  "<GrI \<eta> Fs {x} i> sing_GrI_NI x <\<lambda>_. \<exists>\<^sub>Am. NI (\<eta> x) x (Fs x) m i>"
  unfolding sing_GrI_NI_def
  by (rule cons_pre_rule[OF sing_GrI_NI], sep_auto)

lemma diff_NI_rule: "<NI g1 x1 fs1 m1 i1 * NI g2 x2 fs2 m2 i2> ghost_diff x1 x2 <\<lambda>_. NI g1 x1 fs1 m1 i1 * NI g2 x2 fs2 m2 i2 * \<up>(x1 \<noteq> x2)>"
  unfolding ghost_diff_def NI_def N_def by sep_auto

lemma ent_diff_NI: "NI g1 x1 fs1 m1 i1 * NI g2 x2 fs2 m2 i2 \<Longrightarrow>\<^sub>A NI g1 x1 fs1 m1 i1 * NI g2 x2 fs2 m2 i2 * \<up>(x1 \<noteq> x2)"
  unfolding ghost_diff_def NI_def N_def by sep_auto

lemma preserve_interface_rule:
  assumes "<NI g1 x1 fs1 m1 i1 * NI g2 x2 fs2 m2 i2 * P> b <\<lambda>z. NI g1' x1 fs1' m1' i1' * NI g2' x2 fs2' m2' i2' * P' z>" "i1 + i2 = i1' + i2'"
  shows "<NI g1 x1 fs1 m1 i1 * NI g2 x2 fs2 m2 i2 * P> preserve_interface2 x1 x2 b <\<lambda>z. NI g1' x1 fs1' m1' i1' * NI g2' x2 fs2' m2' i2' * P' z * \<up>(i1 + i2 = i1' + i2')>"
  unfolding preserve_interface2_def using assms by sep_auto

lemma extends_rule:
  assumes "dom_fi i1 \<subseteq> dom_fi i2" "inf_fi i1 = inf_fi i2 on dom_fi i1" "outf_fi i1 = outf_fi i2 on -dom_fi i2"
  shows "<emp> extends i1 i2 <\<lambda>_. \<up>(i1 \<lesssim> i2)>"
  using assms unfolding extends_def contextual_extension_def by sep_auto

lemma close_N_rule:
  assumes "\<gamma> g x fs m"
  shows "<x \<mapsto>\<^sub>r fs> close_N x m <\<lambda>_. N g x fs m (fg {x} (\<lambda>_. edges x fs) (\<lambda>_. m))>"
  unfolding close_N_def N_def
  using assms
  apply sep_auto
  subgoal premises prems for a b
  proof -
    have "fg {x} (\<lambda>_. edges x fs) (\<lambda>_. m) \<noteq> bot"
      apply (rule fgI[where i="\<lambda>_. m"])
      using assms edges_not_refl by auto
    then show ?thesis
      using prems by simp
  qed
  done

lemma open_NI_rule:
  "<NI g x fs m i> open_NI x <\<lambda>_. x \<mapsto>\<^sub>r fs * \<up>(i \<noteq> bot \<and> \<gamma> g x fs m \<and> i = fi {x} (\<lambda>_. m) (\<lambda>y. edges x fs y m))>"
  unfolding open_N_def open_NI_def NI_def N_def
  apply sep_auto
  using int_fg_fg by simp

lemma peek_NI:
  "NI g x fs m i \<Longrightarrow>\<^sub>A NI g x fs m i * \<up>(i \<noteq> bot \<and> \<gamma> g x fs m \<and> i = fi {x} (\<lambda>_. m) (\<lambda>y. edges x fs y m))"
  unfolding open_N_def open_NI_def NI_def N_def
  apply sep_auto
  using int_fg_fg by simp

lemma peek_NI_rule:
  "<NI g x fs m i> peek_NI x <\<lambda>_. NI g x fs m i * \<up>(i \<noteq> bot \<and> \<gamma> g x fs m \<and> i = fi {x} (\<lambda>_. m) (\<lambda>y. edges x fs y m))>"
  using peek_NI unfolding peek_NI_def by sep_auto

lemma close_NI_rule:
  assumes "\<gamma> g x fs m"
  shows "<x \<mapsto>\<^sub>r fs> close_NI x m <\<lambda>_. \<exists>\<^sub>Ai. NI g x fs m i * \<up>(i \<noteq> bot \<and> i = fi {x} (\<lambda>_. m) (\<lambda>y. edges x fs y m))>"
  unfolding close_NI_def close_N_def NI_def N_def
  using assms
  apply (sep_auto)
  using assms def_fg_singleton'[of "\<lambda>_ y. edges x fs y" x "\<lambda>_. m"] edges_not_refl[of g x fs m] apply metis
  using int_fg_fg apply simp
  by (subst int_fg_fg, simp_all)

lemma fold_GrI_rule:
  assumes "i1 + i2 \<noteq> bot" "x \<notin> X" "finite X"
  shows "<NI g x fs m i1 * GrI \<eta> Fs X i2>
    fold_GrI x
    <\<lambda>_. GrI (\<lambda>y. if y \<in> {x} then g else \<eta> y)
             (\<lambda>y. if y \<in> {x} then fs else Fs y) ({x} \<union> X) (i1 + i2)>"
  unfolding fold_GrI_def
  apply sep_auto
  apply (rule ent_frame_fwd[OF sing_NI_GrI], frame_inference)
  apply (rule comp_GrI[of "{x}" X "i1 + i2" i1 i2 "\<lambda>_. g" "\<lambda>_. fs" \<eta> Fs, simplified])
  using assms by auto

lemma unfold_GrI_rule:
  assumes "x \<in> X" "X = dom_fi i"
  shows "<GrI \<eta> Fs X i> unfold_GrI x <\<lambda>_. \<exists>\<^sub>Ai' i1 m. NI (\<eta> x) x (Fs x) m i1 * \<up>(i1 \<noteq> bot \<and> i' \<noteq> bot \<and> i1 = fi {x} (\<lambda>_. m) (\<lambda>y. edges x (Fs x) y m) \<and> \<gamma> (\<eta> x) x (Fs x) m \<and> i = i1 + i') * GrI \<eta> Fs (X - {x}) i'>"
  apply (rule cons_pre_rule[OF unfold_GrI[where x=x]])
  using assms apply simp
  using assms apply simp
  apply sep_auto
  apply (rule cons_pre_rule[OF ent_frame_fwd[OF peek_NI]])
  apply frame_inference+
  unfolding unfold_GrI_def
  by sep_auto

end

end


subsection \<open>Consistency of sets of WOOT Messages \label{sec:consistency}\<close>

theory Consistency
  imports SortKeys Psi Sorting DistributedExecution
begin

definition insert_messages :: "('\<I>, '\<Sigma>) message set \<Rightarrow> ('\<I>, '\<Sigma>) insert_message set"
  where "insert_messages M = {x. Insert x \<in> M}"

lemma insert_insert_message:
  "insert_messages (M \<union> {Insert m}) = insert_messages M \<union> {m}"
  by (simp add:insert_messages_def, simp add:set_eq_iff)

definition delete_messages :: "('a, 's) message set \<Rightarrow> 'a delete_message set"
  where "delete_messages M = {x. Delete x \<in> M}"

fun depends_on where "depends_on M x y = (x \<in> M \<and> y \<in> M \<and> I x \<in> deps (Insert y))"

definition a_conditions ::
  "(('a :: linorder), 's) insert_message set \<Rightarrow> ('a extended \<Rightarrow> 'a position) \<Rightarrow> bool"
  where "a_conditions M a = (
    a \<turnstile> < a \<stileturn> \<and>
    (\<forall>m. m \<in> M \<longrightarrow> a (P m) < a (S m) \<and>
                   a \<lbrakk>I m\<rbrakk> = \<lbrakk>\<Psi> (a (P m), a (S m)) (I m)\<rbrakk>))"

definition consistent :: "('a :: linorder, 's) message set \<Rightarrow> bool"
  where "consistent M \<equiv>
    inj_on I (insert_messages M) \<and>
    (\<Union> (deps ` M) \<subseteq> (I ` insert_messages M)) \<and>
    wfP (depends_on (insert_messages M)) \<and>
    (\<exists>a. a_conditions (insert_messages M) a)"

lemma consistent_subset:
  assumes "consistent N"
  assumes "M \<subseteq> N"
  assumes "\<Union> (deps ` M) \<subseteq> (I ` insert_messages M)"
  shows "consistent M"
proof -
  have a:"insert_messages M \<subseteq> insert_messages N"
    using assms(2) insert_messages_def by blast
  hence b:"inj_on I (insert_messages M)"
    using assms(1) consistent_def inj_on_subset by blast
  have "wfP (depends_on (insert_messages N))"
    using assms(1) consistent_def by blast
  moreover have
    "depends_on (insert_messages M) \<le> depends_on (insert_messages N)"
    using a by auto
  ultimately have c:"wfP (depends_on (insert_messages M))"
    using a wf_subset [to_pred] by blast
  obtain a where "a_conditions (insert_messages N) a"
    using assms(1) consistent_def by blast
  hence "a_conditions (insert_messages M) a"
    by (meson a a_conditions_def subset_iff)
  thus ?thesis using b c assms(3) consistent_def by blast
qed

lemma pred_is_dep: "P m = \<lbrakk> i \<rbrakk> \<longrightarrow> i \<in> deps (Insert m)"
  by (metis Un_iff deps.simps(1) extended.set_intros extended.simps(27)
      extended_to_set.simps(1) insert_message.exhaust_sel)

lemma succ_is_dep: "S m = \<lbrakk> i \<rbrakk> \<longrightarrow> i \<in> deps (Insert m)"
  by (metis Un_insert_right deps.simps(1) extended_to_set.simps(1) insertI1
      insert_message.exhaust_sel)

lemma a_subset:
  fixes M N a
  assumes "M \<subseteq> N"
  assumes "a_conditions (insert_messages N) a"
  shows "a_conditions (insert_messages M) a"
  using assms by (simp add:a_conditions_def insert_messages_def, blast)

definition delete_maybe :: "'\<I>  \<Rightarrow> ('\<I>, '\<Sigma>) message set \<Rightarrow> '\<Sigma>  \<Rightarrow> '\<Sigma> option" where
  "delete_maybe i D s = (if Delete (DeleteMessage i) \<in> D then None else Some s)"

definition to_woot_character ::
  "('\<I>, '\<Sigma>) message set \<Rightarrow> ('\<I>, '\<Sigma>) insert_message \<Rightarrow> ('\<I>, '\<Sigma>) woot_character"
  where
    "to_woot_character D m = (
       case m of
         (InsertMessage l i u s) \<Rightarrow> InsertMessage l i u (delete_maybe i D s))"

lemma to_woot_character_keeps_i [simp]: "I (to_woot_character M m) = I m"
  by (cases m, simp add:to_woot_character_def)

lemma to_woot_character_keeps_i_lifted [simp]:
  "I ` to_woot_character M ` X = I ` X"
  by (metis (no_types, lifting) image_cong image_image to_woot_character_keeps_i)

lemma to_woot_character_keeps_P [simp]: "P (to_woot_character M m) = P m"
  by (cases m, simp add:to_woot_character_def)

lemma to_woot_character_keeps_S [simp]: "S (to_woot_character M m) = S m"
  by (cases m, simp add:to_woot_character_def)

lemma to_woot_character_insert_no_eff:
  "to_woot_character (insert (Insert m) M) = to_woot_character M"
  by (rule HOL.ext, simp add:delete_maybe_def to_woot_character_def insert_message.case_eq_if)

definition is_associated_string ::
  "('a, 's) message set \<Rightarrow> ('a :: linorder, 's) woot_character list \<Rightarrow> bool"
  where "is_associated_string M s \<equiv> (
    consistent M \<and>
    set s = to_woot_character M ` (insert_messages M) \<and>
    (\<forall>a. a_conditions (insert_messages M) a \<longrightarrow>
         sorted_wrt (<) (map a (ext_ids s))))"

fun is_certified_associated_string where
  "is_certified_associated_string M (Inr v) = is_associated_string M v" |
  "is_certified_associated_string M (Inl _) = False"

lemma associated_string_unique:
  assumes "is_associated_string M s"
  assumes "is_associated_string M t"
  shows "s = t"
  using assms
  apply (simp add:ext_ids_def is_associated_string_def consistent_def
         sorted_wrt_append)
  by (metis sort_set_unique)

lemma is_certified_associated_string_unique:
  assumes "is_certified_associated_string M s"
  assumes "is_certified_associated_string M t"
  shows "s = t"
  using assms by (case_tac s, case_tac [!] t, (simp add:associated_string_unique)+)

lemma empty_consistent: "consistent {}"
proof -
  have "a_conditions {} (\<lambda>x. (case x of \<turnstile> \<Rightarrow> \<turnstile> | \<stileturn> \<Rightarrow> \<stileturn>))"
    by (simp add: a_conditions_def)
  hence "\<exists>f. a_conditions {} f" by blast
  moreover have "wfP (depends_on {})" by (simp add: wfP_eq_minimal)
  ultimately show ?thesis by (simp add:consistent_def insert_messages_def)
qed

lemma empty_associated: "is_associated_string {} []"
  by (simp add:is_associated_string_def insert_messages_def empty_consistent
      ext_ids_def a_conditions_def)

text \<open>The empty set of messages is consistent and the associated string is the empty string.\<close>

end


theory weird_nat_add3acc_comm13
imports Main
        "$HIPSTER_HOME/IsaHipster"
begin

datatype Nat = Z | S "Nat"

fun add3acc :: "Nat => Nat => Nat => Nat" where
"add3acc (Z) (Z) z = z"
| "add3acc (Z) (S y2) z = add3acc Z y2 (S z)"
| "add3acc (S x2) y z = add3acc x2 (S y) z"

(*hipster add3acc *)

theorem x0 :
  "!! (x :: Nat) (y :: Nat) (z :: Nat) .
     (add3acc x y z) = (add3acc z y x)"
  by (tactic \<open>Subgoal.FOCUS_PARAMS (K (Tactic_Data.hard_tac @{context})) @{context} 1\<close>)

end


(*  Title:      Move.thy
    Author:     Sven Linker

  The move function shifts a view by the difference in position of the owner of the view.
  The lanes and owner itself are not changed.

*)

section\<open>Move a View according to Difference between Traffic Snapshots\<close>
text \<open>
In this section, we define a function to move a view according
to the changes between two traffic snapshots. The intuition is
that the view moves with the same speed as its owner. That is,
if we move a view \(v\) from \(ts\) to \(ts^\prime\), we
shift the extension of the view by the difference in the
position of the owner of \(v\).
\<close>

theory Move
  imports Traffic Views
begin

context traffic
begin

definition move::"traffic \<Rightarrow> traffic \<Rightarrow> view \<Rightarrow> view"
  where
    "move ts ts' v = \<lparr> ext = shift (ext v) ((pos ts' (own v)) - pos ts (own v)),
                       lan = lan v,
                       own =own v \<rparr>"

lemma move_keeps_length:"\<parallel>ext v\<parallel> = \<parallel>ext (move ts ts' v)\<parallel>"
  using real_int.shift_keeps_length by (simp add: move_def)

lemma move_keeps_lanes:"lan v = lan (move ts ts' v)" using move_def by simp

lemma move_keeps_owner:"own v = own (move ts ts' v)" using move_def by simp

lemma move_nothing :"move ts ts v = v" using real_int.shift_zero move_def by simp

lemma move_trans:
  "(ts \<^bold>\<Rightarrow> ts') \<and> (ts' \<^bold>\<Rightarrow>ts'') \<longrightarrow> move ts' ts'' (move ts ts' v) = move ts ts'' v"
proof
  assume assm:"(ts \<^bold>\<Rightarrow> ts') \<and> (ts' \<^bold>\<Rightarrow>ts'')"
  have
    "(pos ts'' (own v)) - pos ts (own v)
      = (pos ts'' (own v) + pos ts' (own v)) - ( pos ts (own v) + pos ts' (own v))"
    by simp
  have
    "move ts' ts'' (move ts ts' v) =
    \<lparr> ext =
    shift (ext (move ts ts' v))
      (pos ts'' (own (move ts ts' v)) - pos ts' (own (move ts ts' v))),
     lan = lan (move ts ts' v),
     own = own (move ts ts' v) \<rparr> "
    using move_def by blast
  hence "move ts' ts'' (move ts ts' v) =
 \<lparr> ext = shift (ext (move ts ts' v)) (pos ts'' (own v) - pos ts' (own  v)),
  lan = lan  v, own = own  v \<rparr> "
    using move_def by simp
  then show "move ts' ts'' (move ts ts' v) = move ts ts'' v"
  proof -
    have f2: "\<forall>x0 x1. (x1::real) + x0 = x0 + x1"
      by auto
    have
      "pos ts'' (own v)
          + -1*pos ts' (own v)+(pos ts' (own v) + -1*pos ts (own v))
        = pos ts'' (own v) + - 1 * pos ts (own v)"
      by auto
    then have
      "(shift (ext v) ((pos ts'' (own v)) + ( -1 *  pos ts (own v)))) =
       shift (shift  (ext v) (pos ts' (own v) + - 1 * pos ts (own v)))
          (pos ts'' (own v) + - 1 * pos ts' (own v))"
      by (metis f2 real_int.shift_additivity)
    then show ?thesis
      using move_def f2 by simp
  qed
qed

lemma move_stability_res:"(ts\<^bold>\<midarrow>r(c)\<^bold>\<rightarrow>ts') \<longrightarrow> move ts ts' v = v"
  and move_stability_clm: "(ts\<^bold>\<midarrow>c(c,n)\<^bold>\<rightarrow>ts') \<longrightarrow> move ts ts' v = v"
  and move_stability_wdr:"(ts\<^bold>\<midarrow>wdr(c,n)\<^bold>\<rightarrow>ts') \<longrightarrow> move ts ts' v = v"
  and move_stability_wdc:"(ts\<^bold>\<midarrow>wdc(c)\<^bold>\<rightarrow>ts') \<longrightarrow> move ts ts' v = v"
  using create_reservation_def create_claim_def withdraw_reservation_def
    withdraw_claim_def move_def move_nothing
  by (auto)+

end
end


section \<open> Minimal Mereology \<close>

(*<*)
theory MM
  imports M
begin
(*>*)

text \<open> Minimal mereology adds to ground mereology the axiom of weak supplementation.\footnote{
See @{cite "varzi_parts_1996"} and @{cite "casati_parts_1999"} p. 39. The name \emph{minimal mereology}
reflects the, controversial, idea that weak supplementation is analytic. See, for example, @{cite "simons_parts:_1987"}
p. 116, @{cite "varzi_extensionality_2008"} p. 110-1, and @{cite "cotnoir_is_2018"}. For general
discussion of weak supplementation see, for example @{cite "smith_mereology_2009"} pp. 507 and
@{cite "donnelly_using_2011"}.} \<close>

locale MM = M +
  assumes weak_supplementation: "PP y x \<Longrightarrow> (\<exists> z. P z x \<and> \<not> O z y)"

text \<open> The rest of this section considers three alternative axiomatizations of minimal mereology. The
first alternative axiomatization replaces improper with proper parthood in the consequent of weak
supplementation.\footnote{See @{cite "simons_parts:_1987"} p. 28.} \<close>

locale MM1 = M +
  assumes proper_weak_supplementation:
    "PP y x \<Longrightarrow> (\<exists> z. PP z x \<and> \<not> O z y)"

sublocale MM \<subseteq> MM1
proof
  fix x y
  show "PP y x \<Longrightarrow> (\<exists> z. PP z x \<and> \<not> O z y)"
  proof -
    assume "PP y x"
    hence "\<exists> z. P z x \<and> \<not> O z y" by (rule weak_supplementation)
    then obtain z where z: "P z x \<and> \<not> O z y"..
    hence "\<not> O z y"..
    from z have "P z x"..
    hence "P z x \<and> z \<noteq> x"
    proof
      show "z \<noteq> x"
      proof
        assume "z = x"
        hence "PP y z"
          using `PP y x` by (rule ssubst)
        hence "O y z" by (rule proper_implies_overlap)
        hence "O z y" by (rule overlap_symmetry)
        with `\<not> O z y` show "False"..
      qed
    qed
    with nip_eq have "PP z x"..
    hence "PP z x \<and> \<not> O z y"
      using `\<not> O z y`..
    thus "\<exists> z. PP z x \<and> \<not> O z y"..
  qed
qed

sublocale MM1 \<subseteq> MM
proof
  fix x y
  show weak_supplementation: "PP y x \<Longrightarrow> (\<exists> z. P z x \<and> \<not> O z y)"
  proof -
    assume "PP y x"
    hence "\<exists> z. PP z x \<and> \<not> O z y" by (rule proper_weak_supplementation)
    then obtain z where z: "PP z x \<and> \<not> O z y"..
    hence "PP z x"..
    hence "P z x" by (rule proper_implies_part)
    moreover from z have "\<not> O z y"..
    ultimately have "P z x \<and> \<not> O z y"..
    thus "\<exists> z. P z x \<and> \<not> O z y"..
  qed
qed

text \<open> The following two corollaries are sometimes found in the literature.\footnote{See @{cite "simons_parts:_1987"} p. 27. For the names \emph{weak company}
and \emph{strong company} see @{cite "cotnoir_non-wellfounded_2012"} p. 192-3 and @{cite "varzi_mereology_2016"}.} \<close>

context MM
begin

corollary weak_company: "PP y x \<Longrightarrow> (\<exists> z. PP z x \<and> z \<noteq> y)"
proof -
  assume "PP y x"
  hence "\<exists> z. PP z x \<and> \<not> O z y" by (rule proper_weak_supplementation)
  then obtain z where z: "PP z x \<and> \<not> O z y"..
  hence "PP z x"..
  from z have "\<not> O z y"..
  hence "z \<noteq> y" by (rule disjoint_implies_distinct)
  with `PP z x` have "PP z x \<and> z \<noteq> y"..
  thus "\<exists> z. PP z x \<and> z \<noteq> y"..
qed

corollary strong_company: "PP y x \<Longrightarrow> (\<exists> z. PP z x \<and> \<not> P z y)"
proof -
  assume "PP y x"
  hence "\<exists>z. PP z x \<and> \<not> O z y" by (rule proper_weak_supplementation)
  then obtain z where z: "PP z x \<and> \<not> O z y"..
  hence "PP z x"..
  from z have "\<not> O z y"..
  hence "\<not> P z y" by (rule disjoint_implies_not_part)
  with `PP z x` have  "PP z x \<and> \<not> P z y"..
  thus "\<exists> z. PP z x \<and> \<not> P z y"..
qed

end

text \<open> If weak supplementation is formulated in terms of nonidentical parthood, then the antisymmetry
of parthood is redundant, and we have the second alternative axiomatization of minimal mereology.\footnote{
See @{cite "cotnoir_antisymmetry_2010"} p. 399, @{cite "donnelly_using_2011"} p. 232,
@{cite "cotnoir_non-wellfounded_2012"} p. 193 and @{cite "obojska_remarks_2013"} pp. 235-6.} \<close>

locale MM2 = PM +
  assumes nip_eq: "PP x y \<longleftrightarrow> P x y \<and> x \<noteq> y"
  assumes weak_supplementation: "PP y x \<Longrightarrow> (\<exists> z. P z x \<and> \<not> O z y)"

sublocale MM2 \<subseteq> MM
proof
  fix x y
  show "PP x y \<longleftrightarrow> P x y \<and> x \<noteq> y" using nip_eq.
  show part_antisymmetry: "P x y \<Longrightarrow> P y x \<Longrightarrow> x = y"
  proof -
    assume "P x y"
    assume "P y x"
    show "x = y"
    proof (rule ccontr)
      assume "x \<noteq> y"
      with `P x y` have "P x y \<and> x \<noteq> y"..
      with nip_eq have "PP x y"..
      hence "\<exists> z. P z y \<and> \<not> O z x" by (rule weak_supplementation)
      then obtain z where z: "P z y \<and> \<not> O z x"..
      hence "\<not> O z x"..
      hence "\<not> P z x" by (rule disjoint_implies_not_part)
      from z have "P z y"..
      hence "P z x" using `P y x` by (rule part_transitivity)
      with `\<not> P z x` show "False"..
    qed
  qed
  show "PP y x \<Longrightarrow> \<exists>z. P z x \<and> \<not> O z y" using weak_supplementation.
qed

sublocale MM \<subseteq> MM2
proof
  fix x y
  show "PP x y \<longleftrightarrow> (P x y \<and> x \<noteq> y)" using nip_eq.
  show "PP y x \<Longrightarrow> \<exists>z. P z x \<and> \<not> O z y" using weak_supplementation.
qed

text \<open> Likewise, if proper parthood is adopted as primitive, then the asymmetry of proper parthood
is redundant in the context of weak supplementation, leading to the third alternative
axiomatization.\footnote{See @{cite "donnelly_using_2011"} p. 232 and @{cite "cotnoir_is_2018"}.} \<close>

locale MM3 =
  assumes part_eq: "P x y \<longleftrightarrow> PP x y \<or> x = y"
  assumes overlap_eq: "O x y \<longleftrightarrow> (\<exists> z. P z x \<and> P z y)"
  assumes proper_part_transitivity: "PP x y \<Longrightarrow> PP y z \<Longrightarrow> PP x z"
  assumes weak_supplementation: "PP y x \<Longrightarrow> (\<exists> z. P z x \<and> \<not> O z y)"
begin

lemma part_reflexivity: "P x x"
proof -
  have "x = x"..
  hence "PP x x \<or> x = x"..
  with part_eq show "P x x"..
qed

lemma proper_part_irreflexivity: "\<not> PP x x"
proof
  assume "PP x x"
  hence "\<exists> z. P z x \<and> \<not> O z x" by (rule weak_supplementation)
  then obtain z where z: "P z x \<and> \<not> O z x"..
  hence "\<not> O z x"..
  from z have "P z x"..
  with part_reflexivity have "P z z \<and> P z x"..
  hence "\<exists> v. P v z \<and> P v x"..
  with overlap_eq have "O z x"..
  with `\<not> O z x` show "False"..
qed

end

sublocale MM3 \<subseteq> M4
proof
  fix x y z
  show "P x y \<longleftrightarrow> PP x y \<or> x = y" using part_eq.
  show "O x y \<longleftrightarrow> (\<exists> z. P z x \<and> P z y)" using overlap_eq.
  show proper_part_irreflexivity: "PP x y \<Longrightarrow> \<not> PP y x"
  proof -
    assume "PP x y"
    show "\<not> PP y x"
    proof
      assume "PP y x"
      hence "PP y y" using `PP x y` by (rule proper_part_transitivity)
      with proper_part_irreflexivity show "False"..
    qed
  qed
  show "PP x y \<Longrightarrow> PP y z \<Longrightarrow> PP x z" using proper_part_transitivity.
qed

sublocale MM3 \<subseteq> MM
proof
  fix x y
  show "PP y x \<Longrightarrow> (\<exists> z. P z x \<and> \<not> O z y)" using weak_supplementation.
qed

sublocale MM \<subseteq> MM3
proof
  fix x y z
  show "P x y \<longleftrightarrow> (PP x y \<or> x = y)" using part_eq.
  show "O x y \<longleftrightarrow> (\<exists>z. P z x \<and> P z y)" using overlap_eq.
  show "PP x y \<Longrightarrow> PP y z \<Longrightarrow> PP x z" using proper_part_transitivity.
  show "PP y x \<Longrightarrow> \<exists>z. P z x \<and> \<not> O z y" using weak_supplementation.
qed

(*<*) end (*>*)


(*  Title:      HOL/BNF_Least_Fixpoint.thy
    Author:     Dmitriy Traytel, TU Muenchen
    Author:     Lorenz Panny, TU Muenchen
    Author:     Jasmin Blanchette, TU Muenchen
    Copyright   2012, 2013, 2014

Least fixpoint (datatype) operation on bounded natural functors.
*)

section \<open>Least Fixpoint (Datatype) Operation on Bounded Natural Functors\<close>

theory BNF_Least_Fixpoint
imports BNF_Fixpoint_Base
keywords
  "datatype" :: thy_defn and
  "datatype_compat" :: thy_defn
begin

lemma subset_emptyI: "(\<And>x. x \<in> A \<Longrightarrow> False) \<Longrightarrow> A \<subseteq> {}"
  by blast

lemma image_Collect_subsetI: "(\<And>x. P x \<Longrightarrow> f x \<in> B) \<Longrightarrow> f ` {x. P x} \<subseteq> B"
  by blast

lemma Collect_restrict: "{x. x \<in> X \<and> P x} \<subseteq> X"
  by auto

lemma prop_restrict: "\<lbrakk>x \<in> Z; Z \<subseteq> {x. x \<in> X \<and> P x}\<rbrakk> \<Longrightarrow> P x"
  by auto

lemma underS_I: "\<lbrakk>i \<noteq> j; (i, j) \<in> R\<rbrakk> \<Longrightarrow> i \<in> underS R j"
  unfolding underS_def by simp

lemma underS_E: "i \<in> underS R j \<Longrightarrow> i \<noteq> j \<and> (i, j) \<in> R"
  unfolding underS_def by simp

lemma underS_Field: "i \<in> underS R j \<Longrightarrow> i \<in> Field R"
  unfolding underS_def Field_def by auto

lemma bij_betwE: "bij_betw f A B \<Longrightarrow> \<forall>a\<in>A. f a \<in> B"
  unfolding bij_betw_def by auto

lemma f_the_inv_into_f_bij_betw:
  "bij_betw f A B \<Longrightarrow> (bij_betw f A B \<Longrightarrow> x \<in> B) \<Longrightarrow> f (the_inv_into A f x) = x"
  unfolding bij_betw_def by (blast intro: f_the_inv_into_f)

lemma ex_bij_betw: "|A| \<le>o (r :: 'b rel) \<Longrightarrow> \<exists>f B :: 'b set. bij_betw f B A"
  by (subst (asm) internalize_card_of_ordLeq) (auto dest!: iffD2[OF card_of_ordIso ordIso_symmetric])

lemma bij_betwI':
  "\<lbrakk>\<And>x y. \<lbrakk>x \<in> X; y \<in> X\<rbrakk> \<Longrightarrow> (f x = f y) = (x = y);
    \<And>x. x \<in> X \<Longrightarrow> f x \<in> Y;
    \<And>y. y \<in> Y \<Longrightarrow> \<exists>x \<in> X. y = f x\<rbrakk> \<Longrightarrow> bij_betw f X Y"
  unfolding bij_betw_def inj_on_def by blast

lemma surj_fun_eq:
  assumes surj_on: "f ` X = UNIV" and eq_on: "\<forall>x \<in> X. (g1 \<circ> f) x = (g2 \<circ> f) x"
  shows "g1 = g2"
proof (rule ext)
  fix y
  from surj_on obtain x where "x \<in> X" and "y = f x" by blast
  thus "g1 y = g2 y" using eq_on by simp
qed

lemma Card_order_wo_rel: "Card_order r \<Longrightarrow> wo_rel r"
  unfolding wo_rel_def card_order_on_def by blast

lemma Cinfinite_limit: "\<lbrakk>x \<in> Field r; Cinfinite r\<rbrakk> \<Longrightarrow> \<exists>y \<in> Field r. x \<noteq> y \<and> (x, y) \<in> r"
  unfolding cinfinite_def by (auto simp add: infinite_Card_order_limit)

lemma Card_order_trans:
  "\<lbrakk>Card_order r; x \<noteq> y; (x, y) \<in> r; y \<noteq> z; (y, z) \<in> r\<rbrakk> \<Longrightarrow> x \<noteq> z \<and> (x, z) \<in> r"
  unfolding card_order_on_def well_order_on_def linear_order_on_def
    partial_order_on_def preorder_on_def trans_def antisym_def by blast

lemma Cinfinite_limit2:
  assumes x1: "x1 \<in> Field r" and x2: "x2 \<in> Field r" and r: "Cinfinite r"
  shows "\<exists>y \<in> Field r. (x1 \<noteq> y \<and> (x1, y) \<in> r) \<and> (x2 \<noteq> y \<and> (x2, y) \<in> r)"
proof -
  from r have trans: "trans r" and total: "Total r" and antisym: "antisym r"
    unfolding card_order_on_def well_order_on_def linear_order_on_def
      partial_order_on_def preorder_on_def by auto
  obtain y1 where y1: "y1 \<in> Field r" "x1 \<noteq> y1" "(x1, y1) \<in> r"
    using Cinfinite_limit[OF x1 r] by blast
  obtain y2 where y2: "y2 \<in> Field r" "x2 \<noteq> y2" "(x2, y2) \<in> r"
    using Cinfinite_limit[OF x2 r] by blast
  show ?thesis
  proof (cases "y1 = y2")
    case True with y1 y2 show ?thesis by blast
  next
    case False
    with y1(1) y2(1) total have "(y1, y2) \<in> r \<or> (y2, y1) \<in> r"
      unfolding total_on_def by auto
    thus ?thesis
    proof
      assume *: "(y1, y2) \<in> r"
      with trans y1(3) have "(x1, y2) \<in> r" unfolding trans_def by blast
      with False y1 y2 * antisym show ?thesis by (cases "x1 = y2") (auto simp: antisym_def)
    next
      assume *: "(y2, y1) \<in> r"
      with trans y2(3) have "(x2, y1) \<in> r" unfolding trans_def by blast
      with False y1 y2 * antisym show ?thesis by (cases "x2 = y1") (auto simp: antisym_def)
    qed
  qed
qed

lemma Cinfinite_limit_finite:
  "\<lbrakk>finite X; X \<subseteq> Field r; Cinfinite r\<rbrakk> \<Longrightarrow> \<exists>y \<in> Field r. \<forall>x \<in> X. (x \<noteq> y \<and> (x, y) \<in> r)"
proof (induct X rule: finite_induct)
  case empty thus ?case unfolding cinfinite_def using ex_in_conv[of "Field r"] finite.emptyI by auto
next
  case (insert x X)
  then obtain y where y: "y \<in> Field r" "\<forall>x \<in> X. (x \<noteq> y \<and> (x, y) \<in> r)" by blast
  then obtain z where z: "z \<in> Field r" "x \<noteq> z \<and> (x, z) \<in> r" "y \<noteq> z \<and> (y, z) \<in> r"
    using Cinfinite_limit2[OF _ y(1) insert(5), of x] insert(4) by blast
  show ?case
    apply (intro bexI ballI)
    apply (erule insertE)
    apply hypsubst
    apply (rule z(2))
    using Card_order_trans[OF insert(5)[THEN conjunct2]] y(2) z(3)
    apply blast
    apply (rule z(1))
    done
qed

lemma insert_subsetI: "\<lbrakk>x \<in> A; X \<subseteq> A\<rbrakk> \<Longrightarrow> insert x X \<subseteq> A"
  by auto

lemmas well_order_induct_imp = wo_rel.well_order_induct[of r "\<lambda>x. x \<in> Field r \<longrightarrow> P x" for r P]

lemma meta_spec2:
  assumes "(\<And>x y. PROP P x y)"
  shows "PROP P x y"
  by (rule assms)

lemma nchotomy_relcomppE:
  assumes "\<And>y. \<exists>x. y = f x" "(r OO s) a c" "\<And>b. r a (f b) \<Longrightarrow> s (f b) c \<Longrightarrow> P"
  shows P
proof (rule relcompp.cases[OF assms(2)], hypsubst)
  fix b assume "r a b" "s b c"
  moreover from assms(1) obtain b' where "b = f b'" by blast
  ultimately show P by (blast intro: assms(3))
qed

lemma predicate2D_vimage2p: "\<lbrakk>R \<le> vimage2p f g S; R x y\<rbrakk> \<Longrightarrow> S (f x) (g y)"
  unfolding vimage2p_def by auto

lemma ssubst_Pair_rhs: "\<lbrakk>(r, s) \<in> R; s' = s\<rbrakk> \<Longrightarrow> (r, s') \<in> R"
  by (rule ssubst)

lemma all_mem_range1:
  "(\<And>y. y \<in> range f \<Longrightarrow> P y) \<equiv> (\<And>x. P (f x)) "
  by (rule equal_intr_rule) fast+

lemma all_mem_range2:
  "(\<And>fa y. fa \<in> range f \<Longrightarrow> y \<in> range fa \<Longrightarrow> P y) \<equiv> (\<And>x xa. P (f x xa))"
  by (rule equal_intr_rule) fast+

lemma all_mem_range3:
  "(\<And>fa fb y. fa \<in> range f \<Longrightarrow> fb \<in> range fa \<Longrightarrow> y \<in> range fb \<Longrightarrow> P y) \<equiv> (\<And>x xa xb. P (f x xa xb))"
  by (rule equal_intr_rule) fast+

lemma all_mem_range4:
  "(\<And>fa fb fc y. fa \<in> range f \<Longrightarrow> fb \<in> range fa \<Longrightarrow> fc \<in> range fb \<Longrightarrow> y \<in> range fc \<Longrightarrow> P y) \<equiv>
   (\<And>x xa xb xc. P (f x xa xb xc))"
  by (rule equal_intr_rule) fast+

lemma all_mem_range5:
  "(\<And>fa fb fc fd y. fa \<in> range f \<Longrightarrow> fb \<in> range fa \<Longrightarrow> fc \<in> range fb \<Longrightarrow> fd \<in> range fc \<Longrightarrow>
     y \<in> range fd \<Longrightarrow> P y) \<equiv>
   (\<And>x xa xb xc xd. P (f x xa xb xc xd))"
  by (rule equal_intr_rule) fast+

lemma all_mem_range6:
  "(\<And>fa fb fc fd fe ff y. fa \<in> range f \<Longrightarrow> fb \<in> range fa \<Longrightarrow> fc \<in> range fb \<Longrightarrow> fd \<in> range fc \<Longrightarrow>
     fe \<in> range fd \<Longrightarrow> ff \<in> range fe \<Longrightarrow> y \<in> range ff \<Longrightarrow> P y) \<equiv>
   (\<And>x xa xb xc xd xe xf. P (f x xa xb xc xd xe xf))"
  by (rule equal_intr_rule) (fastforce, fast)

lemma all_mem_range7:
  "(\<And>fa fb fc fd fe ff fg y. fa \<in> range f \<Longrightarrow> fb \<in> range fa \<Longrightarrow> fc \<in> range fb \<Longrightarrow> fd \<in> range fc \<Longrightarrow>
     fe \<in> range fd \<Longrightarrow> ff \<in> range fe \<Longrightarrow> fg \<in> range ff \<Longrightarrow> y \<in> range fg \<Longrightarrow> P y) \<equiv>
   (\<And>x xa xb xc xd xe xf xg. P (f x xa xb xc xd xe xf xg))"
  by (rule equal_intr_rule) (fastforce, fast)

lemma all_mem_range8:
  "(\<And>fa fb fc fd fe ff fg fh y. fa \<in> range f \<Longrightarrow> fb \<in> range fa \<Longrightarrow> fc \<in> range fb \<Longrightarrow> fd \<in> range fc \<Longrightarrow>
     fe \<in> range fd \<Longrightarrow> ff \<in> range fe \<Longrightarrow> fg \<in> range ff \<Longrightarrow> fh \<in> range fg \<Longrightarrow> y \<in> range fh \<Longrightarrow> P y) \<equiv>
   (\<And>x xa xb xc xd xe xf xg xh. P (f x xa xb xc xd xe xf xg xh))"
  by (rule equal_intr_rule) (fastforce, fast)

lemmas all_mem_range = all_mem_range1 all_mem_range2 all_mem_range3 all_mem_range4 all_mem_range5
  all_mem_range6 all_mem_range7 all_mem_range8

lemma pred_fun_True_id: "NO_MATCH id p \<Longrightarrow> pred_fun (\<lambda>x. True) p f = pred_fun (\<lambda>x. True) id (p \<circ> f)"
  unfolding fun.pred_map unfolding comp_def id_def ..

ML_file \<open>Tools/BNF/bnf_lfp_util.ML\<close>
ML_file \<open>Tools/BNF/bnf_lfp_tactics.ML\<close>
ML_file \<open>Tools/BNF/bnf_lfp.ML\<close>
ML_file \<open>Tools/BNF/bnf_lfp_compat.ML\<close>
ML_file \<open>Tools/BNF/bnf_lfp_rec_sugar_more.ML\<close>
ML_file \<open>Tools/BNF/bnf_lfp_size.ML\<close>

ML_file \<open>Tools/datatype_simprocs.ML\<close>

simproc_setup datatype_no_proper_subterm
  ("(x :: 'a :: size) = y") = \<open>K Datatype_Simprocs.no_proper_subterm_simproc\<close>

end