theory SSL
imports "HOL-Library.Finite_Map"
begin

section \<open>Syntax and semantics\<close>

subsubsection \<open>Basic types and syntax.\<close>
text \<open>Linear ordered variables with an explicit nil element.\<close>
datatype var = Nil | Var nat

instantiation var :: linorder begin
fun less_eq_var :: "var \<Rightarrow> var \<Rightarrow> bool" where
  "less_eq_var Nil _ = True"
| "less_eq_var _ Nil = False"
| "less_eq_var (Var v1) (Var v2) = (v1 \<le> v2)"

fun less_var :: "var \<Rightarrow> var \<Rightarrow> bool" where
  "less_var Nil Nil = False"
| "less_var Nil _ = True"
| "less_var _ Nil = False"
| "less_var (Var v1) (Var v2) = (v1 < v2)"
instance apply standard apply (auto simp: elim!: less_eq_var.elims less_var.elims)
  by (metis less_eq_var.elims(3) nle_le var.inject var.simps(3))
end

text \<open>SSL formulae.\<close>
datatype form =
  Emp
| PointsTo var var  (infix "\<mapsto>\<^sub>s" 70)
| LS "var\<times>var"      ("ls_")
| Eq var var        (infix "=\<^sub>s" 70)
| NEq var var       (infix "\<noteq>\<^sub>s" 70)
| SepConj form form (infixl "\<^emph>" 80)
| Septraction form form (infix "-\<otimes>" 60)
| Conj form form    (infixl "\<and>\<^sub>s" 65)
| Disj form form    (infixl "\<or>\<^sub>s" 60)
| Neg form          ("\<not>\<^sub>s _")

abbreviation t :: form where "t \<equiv> Emp \<or>\<^sub>s \<not>\<^sub>sEmp"
abbreviation magic_wand :: "form \<Rightarrow> form \<Rightarrow> form" (infix "-\<^emph>" 60) where
  "magic_wand P Q \<equiv> \<not>\<^sub>s(P-\<otimes>\<not>\<^sub>sQ)"

fun size :: "form \<Rightarrow> nat" where
  "size Emp = 1"
| "size (PointsTo _ _) = 1"
| "size (LS _) = 1"
| "size (Eq _ _) = 1"
| "size (NEq _ _) = 1"
| "size (SepConj f1 f2) = size f1 + size f2 + 1"
| "size (Septraction f1 f2) = size f1 + size f2 + 1"
| "size (Conj f1 f2) = size f1 + size f2 + 1"
| "size (Disj f1 f2) = size f1 + size f2 + 1"
| "size (Neg f) = size f + 1"

fun atom :: "form \<Rightarrow> bool" where
  "atom Emp = True"
| "atom (PointsTo _ _) = True"
| "atom (LS _) = True"
| "atom (Eq _ _) = True"
| "atom (NEq _ _) = True"
| "atom _ = False"

fun fvs :: "form \<Rightarrow> var fset" where
  "fvs Emp = {||}"
| "fvs (PointsTo x y) = {|x,y|}"
| "fvs (LS (x,y)) = {|x,y|}"
| "fvs (Eq x y) = {|x,y|}"
| "fvs (NEq x y) = {|x,y|}"
| "fvs (SepConj P Q) = fvs P |\<union>| fvs Q"
| "fvs (Septraction P Q) = fvs P |\<union>| fvs Q"
| "fvs (Conj P Q) = fvs P |\<union>| fvs Q"
| "fvs (Disj P Q) = fvs P |\<union>| fvs Q"
| "fvs (Neg P) = fvs P"

type_synonym loc = nat
type_synonym stack = "var \<rightharpoonup> loc"
type_synonym heap = "loc \<rightharpoonup> loc"

text \<open>Models for SSL, cf. symbolic heap fragment.\<close>
typedef model =
  "{(s::stack,h::heap) |s h. finite (dom s) \<and> finite (dom h) \<and> (\<exists>l. s Nil = Some l \<and> l \<notin> dom h)}"
  \<comment> \<open>If stack or heap would be fmap, setup_lifting would break, so we hardcode the finite domain.\<close>
proof -
  define m :: "(stack\<times>heap)" where "m \<equiv> ([Nil\<mapsto>0],Map.empty)"
  then have "m \<in> {(s, h) |s h. finite (dom s)  \<and> finite (dom h) \<and> (\<exists>l. s var.Nil = Some l \<and> l \<notin> dom h)}"
    by simp
  then show ?thesis ..
qed

setup_lifting type_definition_model
lemmas [simp] = Rep_model_inverse Rep_model_inject
lemmas [simp, intro!] = Rep_model[unfolded mem_Collect_eq]

lift_definition stack :: "model \<Rightarrow> stack" is fst .
lift_definition heap :: "model \<Rightarrow> heap" is snd .

definition locs :: "heap \<Rightarrow> loc set" where
  "locs h = dom h \<union> ran h"
definition dangling :: "loc \<Rightarrow> heap \<Rightarrow> bool" where
  "dangling l h = (l \<in> (ran h - dom h))"

text \<open>Weak heap union\<close>
definition weak_heap_union :: "heap \<Rightarrow> heap \<Rightarrow> heap option" (infix "++" 60) where
  "h1 ++ h2 = (if dom h1 \<inter> dom h2 = {} then Some (h1 ++ h2) else None)"

lemma weak_heap_union_sym: "(((h1::heap) ++ h2)::heap option) = (h2 ++ h1)"
  unfolding weak_heap_union_def by (auto simp: map_add_comm)

lemma weak_heap_unionE: "h1 ++ h2 = Some h \<Longrightarrow> (dom h1 \<inter> dom h2 = {}) \<and> h=h1++h2"
  apply (auto simp: weak_heap_union_def)
  apply (metis disjoint_iff insertI1 insert_dom option.distinct(1))
  by (metis option.discI option.inject)

text \<open>Strong heap union\<close>
definition heap_union :: "heap \<Rightarrow> stack \<Rightarrow> heap \<Rightarrow> heap option" ("_ \<uplus>\<^sup>_ _") where
  "h1 \<uplus>\<^sup>s h2 = (if (dom h1 \<inter> ran h2) \<union> (dom h2 \<inter> ran h1) \<subseteq> ran s then h1 ++ h2 else None)"

lemma heap_union_sym: "h1 \<uplus>\<^sup>s h2 = h2 \<uplus>\<^sup>s h1"
  unfolding heap_union_def by (auto simp: weak_heap_union_sym)
lemma heap_union_sym_impl: "x = h1 \<uplus>\<^sup>s h2 \<Longrightarrow> x = h2 \<uplus>\<^sup>s h1"
  by (auto simp: heap_union_sym)
lemma heap_unionE: "h1 \<uplus>\<^sup>s h2 = Some h \<Longrightarrow> ((dom h1 \<inter> ran h2) \<union> (dom h2 \<inter> ran h1) \<subseteq> ran s) \<and>
  (dom h1 \<inter> dom h2 = {}) \<and> h=h1++h2"
  apply (auto simp: heap_union_def weak_heap_unionE)
  apply (meson IntI domI in_mono option.distinct(1))
  apply (meson IntI domI in_mono option.distinct(1))
  apply (metis disjoint_iff domIff option.distinct(1) weak_heap_union_def)
  by (metis option.inject option.simps(3) weak_heap_union_def)

lemma heap_union_model: "\<lbrakk>heap m = h; stack m = s; Some h = h1 \<uplus>\<^sup>s h2\<rbrakk> \<Longrightarrow> (s,h1) \<in>
  {(s::stack,h::heap) |s h. finite (dom s) \<and> finite (dom h) \<and> (\<exists>l. s Nil = Some l \<and> l \<notin> dom h)}"
  apply transfer apply (auto simp: heap_union_def weak_heap_union_def)
  apply (metis dom_map_add finite_Un option.discI option.inject weak_heap_union_def)
  by (metis UnCI domIff dom_map_add option.discI option.inject weak_heap_union_def)

lemma heap_union_model':
  "\<lbrakk>heap m = h; stack m = s; s Nil = Some l; Some h2 = h \<uplus>\<^sup>s h1; l \<notin> dom h1; finite (dom h1)\<rbrakk>
  \<Longrightarrow> (s,h2) \<in> {(s::stack,h::heap) |s h. finite (dom s) \<and> finite (dom h) \<and> (\<exists>l. s Nil = Some l \<and> l \<notin> dom h)}"
  apply transfer apply (auto simp: heap_union_def weak_heap_union_def)
  apply (metis dom_map_add finite_UnI option.discI option.inject snd_eqD weak_heap_union_def)
  by (metis UnE domIff dom_map_add option.distinct(1) option.inject snd_eqD weak_heap_union_def)

subsection \<open>Semantics\<close>
fun list_segment :: "nat \<Rightarrow> heap \<Rightarrow> loc \<Rightarrow> loc \<Rightarrow> bool" where
  "list_segment 0 _ _ _ = False"
| "list_segment (Suc 0) h l1 l2 = (h = [l1\<mapsto>l2])"
| "list_segment (Suc n) h l1 l2 = (\<exists>h' l1'. h=h'++[l1\<mapsto>l1'] \<and> l1\<notin>dom h' \<and> list_segment n h' l1' l2)"

fun satisfies :: "(stack\<times>heap) \<Rightarrow> form \<Rightarrow> bool" where
  "satisfies (s,h) Emp = (dom h = {})"
| "satisfies (s,h) (x=\<^sub>sy) = (dom h = {} \<and> (\<exists>x' y'. s x = Some x' \<and> s y = Some y' \<and> x'=y'))"
| "satisfies (s,h) (x\<noteq>\<^sub>sy) = (dom h = {} \<and> (\<exists>x' y'. s x = Some x' \<and> s y = Some y' \<and> x'\<noteq>y'))"
| "satisfies (s,h) (x\<mapsto>\<^sub>sy) = (\<exists>x' y'. s x = Some x' \<and> s y = Some y' \<and> h = [x'\<mapsto>y'])"
| "satisfies (s,h) (ls (x,y)) = (\<exists>lx ly. s x = Some lx \<and> s y = Some ly \<and>
    ((dom h = {} \<and> lx=ly) \<or> (\<exists>n. list_segment n h lx ly)))"
| "satisfies (s,h) (\<phi>1 \<and>\<^sub>s \<phi>2) = (satisfies (s,h) \<phi>1 \<and> satisfies (s,h) \<phi>2)"
| "satisfies (s,h) (\<phi>1 \<or>\<^sub>s \<phi>2) = (satisfies (s,h) \<phi>1 \<or> satisfies (s,h) \<phi>2)"
| "satisfies (s,h) (\<not>\<^sub>s \<phi>) = Not (satisfies (s,h) \<phi>)"
| "satisfies (s,h) (\<phi>1 \<^emph> \<phi>2) =
  (\<exists>h1 h2. Some h = (h1 \<uplus>\<^sup>s h2) \<and> satisfies (s,h1) \<phi>1 \<and> satisfies (s,h2) \<phi>2)"
| "satisfies (s,h) (\<phi>1 -\<otimes> \<phi>2) = (\<exists>h1 h2. finite (dom h1) \<and> (\<exists>l. s Nil = Some l \<and> l \<notin> dom h1) \<and>
  satisfies (s,h1) \<phi>1 \<and> (h \<uplus>\<^sup>s h1) = Some h2 \<and> satisfies (s,h2) \<phi>2)"

lift_definition satisfies_model :: "model \<Rightarrow> form \<Rightarrow> bool" (infix "\<Turnstile>" 51) is satisfies .

fun weak_satisfies :: "(stack\<times>heap) \<Rightarrow> form \<Rightarrow> bool" where
  "weak_satisfies (s,h) (\<phi>1 \<^emph> \<phi>2) =
  (\<exists>h1 h2. Some h = (weak_heap_union h1 h2) \<and> weak_satisfies (s,h1) \<phi>1 \<and> weak_satisfies (s,h2) \<phi>2)"
| "weak_satisfies (s,h) (\<phi>1 -\<otimes> \<phi>2) = (\<exists>h1 h2. finite (dom h1) \<and> (\<exists>l. s Nil = Some l \<and> l \<notin> dom h1)
  \<and> weak_satisfies (s,h1) \<phi>1 \<and> (h ++ h1) = Some h2 \<and> weak_satisfies (s,h2) \<phi>2)"
| "weak_satisfies (s,h) (\<phi>1 \<and>\<^sub>s \<phi>2) = (weak_satisfies (s,h) \<phi>1 \<and> weak_satisfies (s,h) \<phi>2)"
| "weak_satisfies (s,h) (\<phi>1 \<or>\<^sub>s \<phi>2) = (weak_satisfies (s,h) \<phi>1 \<or> weak_satisfies (s,h) \<phi>2)"
| "weak_satisfies (s,h) (\<not>\<^sub>s \<phi>) = Not (weak_satisfies (s,h) \<phi>)"
(*It's the same for the atoms.*)
| "weak_satisfies (s,h) \<phi> = satisfies (s,h) \<phi>"

lift_definition weak_satisfies_model :: "model \<Rightarrow> form \<Rightarrow> bool" (infix "\<Turnstile>\<^sub>w" 51) is weak_satisfies .

theorem weak_strong_atoms: "atom P \<Longrightarrow> satisfies (s,h) P \<longleftrightarrow> weak_satisfies (s,h) P"
  by (induction P) auto
lemma weak_strong_watom_model: "atom P \<Longrightarrow> m \<Turnstile> P \<longleftrightarrow> m \<Turnstile>\<^sub>w P"
  apply transfer' using weak_strong_atoms by fast

definition ssl_sat :: "var fset \<Rightarrow> form \<Rightarrow> bool" where
  "ssl_sat x \<phi> \<equiv> \<exists>s h. fset x=dom s \<and> fvs \<phi> |\<subseteq>| x \<and> satisfies (s,h) \<phi>"
definition ssl_entails :: "form \<Rightarrow> var set \<Rightarrow> form \<Rightarrow> bool" ("_ \<turnstile>\<^sub>_ _") where
  "\<phi> \<turnstile>\<^sub>x \<psi> \<equiv> \<forall>s h. x=dom s \<and> satisfies (s,h) \<phi> \<longrightarrow> satisfies (s,h) \<psi>"

fun positive :: "form \<Rightarrow> bool" where
  "positive (P \<^emph> Q) = (positive P \<and> positive Q)"
| "positive (P -\<otimes> Q) = (positive P \<and> positive Q)"
| "positive (P\<and>\<^sub>sQ) = (positive P \<and> positive Q)"
| "positive (P\<or>\<^sub>sQ) = (positive P \<and> positive Q)"
| "positive (\<not>\<^sub>s _) = False"
| "positive _ = True"

lemma list_segment_semantics: "list_segment n h l1 l2 \<Longrightarrow> l1 \<in> dom h \<and> l2 \<in> ran h \<and>
    (\<forall>l. (\<exists>x y. x\<noteq>y \<and> h x = Some l \<and> h y = Some l) \<longrightarrow> l=l2)
    \<and> ran h - dom h \<subseteq> {l2} \<and> dom h - ran h \<subseteq> {l1}
    \<and> (l1\<in>ran h \<longrightarrow> l1=l2)"
proof (induction n h l1 l2 rule: list_segment.induct)
  case (1 uu uv uw)
  then show ?case by simp
next
  case (2 h l1 l2)
  then have "h = [l1\<mapsto>l2]" by simp
  then show ?case by (auto simp: ran_def)
next
  case (3 v h l1 l2)
  then obtain h' l1' where h': "h=h'++[l1\<mapsto>l1']" "l1 \<notin> dom h'" "list_segment (Suc v) h' l1' l2"
    by auto
  from h'(1,2) have dom_ran: "dom h = dom h' \<union> {l1}" "ran h = ran h' \<union> {l1'}" by auto
  {
    fix l
    assume "(\<exists>x y. x \<noteq> y \<and> h x = Some l \<and> h y = Some l)"
    then obtain x y where xy: "x \<noteq> y \<and> h x = Some l \<and> h y = Some l" by auto
    with 3(1)[OF h'(3)] h'(1,2) have "x \<in> dom h' \<and> y \<in> dom h' \<Longrightarrow> h' x = Some l \<and> h' y = Some l"
      by (metis fun_upd_apply map_add_empty map_add_upd)
    with 3(1)[OF h'(3)] xy have both: "x \<in> dom h' \<and> y \<in> dom h' \<Longrightarrow> l = l2" by auto
    from xy 3(1)[OF h'(3)] h'(1,2) have l_l1':"\<not>(x \<in> dom h' \<and> y \<in> dom h') \<Longrightarrow> l = l1'"
      by auto (metis option.inject)+
    moreover from xy h'(1) have "\<not>(x \<in> dom h' \<and> y \<in> dom h') \<Longrightarrow> x\<in>dom h' \<or>y\<in>dom h'"
      apply auto apply (metis option.distinct(1)) by (metis option.distinct(1))
    ultimately have "\<not>(x \<in> dom h' \<and> y \<in> dom h') \<Longrightarrow> l1' \<in> ran h'" using xy h'(1) apply auto
      apply (smt (verit, best)  map_add_empty map_add_upd map_upd_Some_unfold ranI) by (metis ranI)
    with 3(1)[OF h'(3)] have "\<not>(x \<in> dom h' \<and> y \<in> dom h') \<Longrightarrow> l1' = l2" by simp
    with l_l1' have "\<not>(x \<in> dom h' \<and> y \<in> dom h') \<Longrightarrow> l=l2" by simp
    with both have "l=l2" by auto
  }
  then have "\<forall>l. (\<exists>x y. x \<noteq> y \<and> h x = Some l \<and> h y = Some l) \<longrightarrow> l = l2" by simp
  moreover from dom_ran 3(1)[OF h'(3)] have "l1 \<in> dom h" "l2 \<in> ran h" by auto
  moreover from dom_ran 3(1)[OF h'(3)] have "ran h - dom h \<subseteq> {l2}" by auto
  moreover from dom_ran 3(1)[OF h'(3)] have "dom h - ran h \<subseteq> {l1}" by auto
  moreover from dom_ran 3(1)[OF h'(3)] have "l1 \<in> ran h \<longrightarrow> l1 = l2" using h'(2) by auto
  ultimately show ?case by simp
qed

lemma positive_var_locations:
assumes "positive \<phi>" "weak_satisfies (s,h) \<phi>"
shows "(ran h - dom h \<subseteq> ran s) \<and> (\<forall>l. (\<exists>x y. x\<noteq>y \<and> h x = Some l \<and> h y = Some l) \<longrightarrow> l \<in> ran s) \<and>
  (dom h - ran h \<subseteq> ran s)"
using assms proof (induction \<phi> arbitrary: s h)
case Emp
  then have "h=Map.empty" by auto
  then have "ran h = {}" "dom h = {}" "\<forall>x. h x = None" by auto
  then show ?case by auto
next
  case (PointsTo x1 x2)
  then obtain y1 y2 where s: "s x1 = Some y1" "s x2 = Some y2" by auto
  with PointsTo have "h=[y1\<mapsto>y2]" by simp
  with s show ?case apply auto
    apply (smt (verit, ccfv_SIG) mem_Collect_eq option.simps(3) ran_def)
    by (metis option.discI ranI)
next
  case (LS x)
  obtain x1 x2 where "x=(x1,x2)" by fastforce
  with LS(2) obtain y1 y2 where y12: "s x1 = Some y1" "s x2 = Some y2"
    "((dom h = {} \<and> y1=y2) \<or> (\<exists>n. list_segment n h y1 y2))" by fastforce
  moreover {
    assume "\<exists>n. list_segment n h y1 y2"
    then obtain n where "list_segment n h y1 y2" by auto
    then have "y1 \<in> dom h \<and> y2 \<in> ran h \<and> (\<forall>l. (\<exists>x y. x \<noteq> y \<and> h x = Some l \<and> h y = Some l) \<longrightarrow> l = y2)
      \<and> ran h - dom h \<subseteq> {y2} \<and> dom h - ran h \<subseteq> {y1} \<and> (y1 \<in> ran h \<longrightarrow> y1 = y2)" using list_segment_semantics
      by simp
    with y12 have ?case by (auto intro: ranI)
  }
  moreover have "dom h = {} \<and> y1=y2 \<Longrightarrow> ?case" by simp
  ultimately show ?case by blast
next
  case (Eq x1 x2)
  then have "h=Map.empty" by auto
  then have "ran h = {}" "dom h = {}" "\<forall>x. h x = None" by auto
  then show ?case by auto
next
  case (NEq x1 x2)
  then have "h=Map.empty" by auto
  then have "ran h = {}" "dom h = {}" "\<forall>x. h x = None" by auto
  then show ?case by auto
next
  case (SepConj \<phi>1 \<phi>2)
  then obtain h1 h2 where h12: "h1 ++ h2 = Some h" "weak_satisfies (s,h1) \<phi>1" "weak_satisfies (s,h2) \<phi>2"
    by auto
  from SepConj(3) have pos: "positive \<phi>1" "positive \<phi>2" by simp_all
  from weak_heap_unionE[OF h12(1)] have "dom h1 \<inter> dom h2 = {}" "dom h = dom h1 \<union> dom h2" "ran h = ran h1 \<union> ran h2"
    by (auto simp: weak_heap_union_def ran_map_add)
  with SepConj(1)[OF pos(1) h12(2)] SepConj(2)[OF pos(2) h12(3)] show ?case apply auto
    by (smt (verit) Diff_iff \<open>dom h1 \<inter> dom h2 = {} \<and> h = h1 ++ h2\<close> disjoint_iff in_mono map_add_Some_iff ranI)
next
  case (Septraction \<phi>1 \<phi>2)
  then obtain h0 h1 where h01: "Some h1 = h0++h" "weak_satisfies (s,h0) \<phi>1" "weak_satisfies (s,h1) \<phi>2"
    by auto (metis weak_heap_union_sym)
  from Septraction(3) have pos: "positive \<phi>1" "positive \<phi>2" by simp_all
  from weak_heap_unionE[OF h01(1)[symmetric]] have dom_ran: "dom h0 \<inter> dom h = {}" "dom h1 = dom h0 \<union> dom h"
    "ran h1 = ran h \<union> ran h0" by (auto simp: ran_map_add)
  then have join: "(\<exists>x y. x\<noteq>y \<and> h x = Some l \<and> h y = Some l) \<longrightarrow> (\<exists>x y. x\<noteq>y \<and> h1 x = Some l \<and> h1 y = Some l)" for l
    by auto (metis \<open>dom h0 \<inter> dom h = {} \<and> h1 = h0 ++ h\<close> map_add_find_right)
  \<comment> \<open>For a dangling pointer l in h, it is either also dangling in h1 or a join point in h1
    or pointing to a source in h0.\<close>
  from dom_ran have "(h l = Some l' \<and> l' \<in> ran h - dom h) \<Longrightarrow> (l' \<in> ran h1 - dom h1 \<or>
    (\<exists>x y. x\<noteq>y \<and> h1 x = Some l' \<and> h1 y = Some l') \<or> l' \<in> dom h0 - ran h0)" for l l'
    by auto (smt (verit, ccfv_threshold) \<open>dom h0 \<inter> dom h = {} \<and> h1 = h0 ++ h\<close> disjoint_iff domI
      map_add_dom_app_simps(1) map_add_dom_app_simps(3) mem_Collect_eq ran_def)
  with Septraction(1)[OF pos(1) h01(2)] Septraction(2)[OF pos(2) h01(3)] join
  show ?case apply auto apply (smt (verit, ccfv_threshold) DiffI domD in_mono mem_Collect_eq ran_def)
  by (metis DiffI Un_iff \<open>dom h0 \<inter> dom h = {} \<and> h1 = h0 ++ h\<close> disjoint_iff domIff dom_map_add dom_ran(3) in_mono inf_sup_aci(5) option.distinct(1))
next
  case (Conj \<phi>1 \<phi>2)
  then have "weak_satisfies (s,h) \<phi>1" "weak_satisfies (s,h) \<phi>2" by auto
  from Conj(1)[OF _ this(1)] Conj(2)[OF _ this(2)] Conj(3) show ?case by auto
next
  case (Disj \<phi>1 \<phi>2)
  then have sat: "weak_satisfies (s,h) \<phi>1 \<or> weak_satisfies (s,h) \<phi>2" by auto
  from Disj(3) have "positive \<phi>1" "positive \<phi>2" by auto
  with sat Disj(1,2) show ?case by auto blast+
next
  case (Neg \<phi>)
  then show ?case by simp
qed

lemma positive_var_union:
  "\<lbrakk>weak_satisfies (s,h1) \<phi>1; weak_satisfies (s,h2) \<phi>2; positive \<phi>1; positive \<phi>2\<rbrakk> \<Longrightarrow>
  h1++h2 \<noteq> None \<longleftrightarrow> h1 \<uplus>\<^sup>s h2 \<noteq> None"
proof
  assume assms: "weak_satisfies (s, h1) \<phi>1" "weak_satisfies (s, h2) \<phi>2" "positive \<phi>1" "positive \<phi>2"
    "h1 ++ h2 \<noteq> None"
  {
    fix l
    assume l: "l \<in> locs h1 \<inter> locs h2"
    from assms(5) have "dom h1 \<inter> dom h2 = {}"
      by (auto simp: weak_heap_union_def) (meson disjoint_iff domI not_Some_eq)
    with l have "l \<in> ran h1 - dom h1 \<or> l \<in> ran h2 - dom h2" by (auto simp: locs_def)
    with positive_var_locations[OF assms(3,1)] positive_var_locations[OF assms(4,2)]
    have "l \<in> ran s" by auto
  }
  then have "locs h1 \<inter> locs h2 \<subseteq> ran s" by auto
  with assms(5) have "(dom h1 \<inter> ran h2) \<union> (dom h2 \<inter> ran h1) \<subseteq> ran s" by (auto simp: locs_def)
  with assms(5) show "h1 \<uplus>\<^sup>s h2 \<noteq> None" by (simp add: heap_union_def)
next
  assume "h1 \<uplus>\<^sup>s h2 \<noteq> None"
  then show "h1 ++ h2 \<noteq> None" by (auto simp: heap_union_def) (metis option.distinct(1))
qed

theorem positive_weak_strong: "positive \<phi> \<Longrightarrow> satisfies (s,h) \<phi> \<longleftrightarrow> weak_satisfies (s,h) \<phi>"
proof (induction \<phi> arbitrary: s h)
  case (SepConj \<phi>1 \<phi>2)
  then have pos: "positive \<phi>1" "positive \<phi>2" by auto
  show ?case proof
    assume "satisfies (s, h) (\<phi>1 \<^emph> \<phi>2)"
    then obtain h1 h2 where h12: "Some h = (h1 \<uplus>\<^sup>s h2) \<and> satisfies (s,h1) \<phi>1 \<and> satisfies (s,h2) \<phi>2"
      by auto
    then have "Some h = h1 ++ h2" apply (auto simp: heap_union_def)
      apply (metis IntI domI option.distinct(1) subsetD)
      by (metis IntI domI option.distinct(1) subsetD)
    with SepConj(1)[OF pos(1)] SepConj(2)[OF pos(2)] h12 show "weak_satisfies (s, h) (\<phi>1 \<^emph> \<phi>2)"
      by fastforce
  next
    assume "weak_satisfies (s, h) (\<phi>1 \<^emph> \<phi>2)"
    then obtain h1 h2 where h12: "Some h = h1 ++ h2 \<and> weak_satisfies (s,h1) \<phi>1
      \<and> weak_satisfies (s,h2) \<phi>2" by auto
    with positive_var_union pos have "Some h = h1 \<uplus>\<^sup>s h2" apply auto
      using heap_union_def positive_var_union by presburger
    with SepConj(1)[OF pos(1)] SepConj(2)[OF pos(2)] h12 show "satisfies (s, h) (\<phi>1 \<^emph> \<phi>2)"
      by fastforce
  qed
next
  case (Septraction \<phi>1 \<phi>2)
  then have pos: "positive \<phi>1" "positive \<phi>2" by auto
  show ?case proof
    assume "satisfies (s, h) (\<phi>1 -\<otimes> \<phi>2)"
    then obtain h1 h2 where h12: "finite (dom h1) \<and> (\<exists>l. s Nil = Some l \<and> l \<notin> dom h1)
      \<and> satisfies (s,h1) \<phi>1 \<and> (h \<uplus>\<^sup>s h1) = Some h2 \<and> satisfies (s,h2) \<phi>2"
      by auto
    then have "Some h2 = h ++ h1" by (auto simp: heap_union_def)
      (metis IntI domI option.distinct(1) subsetD)
    with Septraction(1)[OF pos(1)] Septraction(2)[OF pos(2)] h12
    show "weak_satisfies (s, h) (\<phi>1 -\<otimes> \<phi>2)" by fastforce
  next
    assume assm: "weak_satisfies (s, h) (\<phi>1 -\<otimes> \<phi>2)"
    then obtain h1 h2 where h12: "finite (dom h1) \<and> (\<exists>l. s Nil = Some l \<and> l \<notin> dom h1)
      \<and> weak_satisfies (s,h1) \<phi>1 \<and> (h ++ h1) = Some h2 \<and> weak_satisfies (s,h2) \<phi>2" by auto
    with positive_var_union pos have "h \<uplus>\<^sup>s h1 = Some h2" by (metis Septraction(3) assm heap_union_def)
    with Septraction(1)[OF pos(1)] Septraction(2)[OF pos(2)] h12 show "satisfies (s, h) (\<phi>1 -\<otimes> \<phi>2)"
      by fastforce
  qed
qed (simp_all)

end


(*
    Author:      René Thiemann
                 Akihisa Yamada
                 Jose Divasón
    License:     BSD
*)
(* with contributions from Alexander Bentkamp, Universität des Saarlandes *)

section \<open>Missing Vector Spaces\<close>

text \<open>This theory provides some lemmas which we required when working with vector spaces.\<close>

theory Missing_VectorSpace
imports
  VectorSpace
begin

lemma Diff_not_in: "a \<notin> A - {a}" by auto

context abelian_group begin

lemma finsum_restrict:
  assumes fA: "f : A \<rightarrow> carrier G"
      and restr: "restrict f A = restrict g A"
  shows "finsum G f A = finsum G g A"
proof (rule finsum_cong';rule?)
  fix a assume a: "a : A"
  have "f a = restrict f A a" using a by simp
  also have "... = restrict g A a" using restr by simp
  also have "... = g a" using a by simp
  finally show "f a = g a".
  thus "g a : carrier G" using fA a by force
qed

lemma minus_nonzero: "x : carrier G \<Longrightarrow> x \<noteq> \<zero> \<Longrightarrow> \<ominus> x \<noteq> \<zero>"
  using r_neg by force

end

lemma (in ordered_comm_monoid_add) positive_sum:
  assumes X : "finite X"
      and "f : X \<rightarrow> { y :: 'a. y \<ge> 0 }"
  shows "sum f X \<ge> 0 \<and> (sum f X = 0 \<longrightarrow> f ` X \<subseteq> {0})"
  using assms
proof (induct set:finite)
  case (insert x X)
    hence x0: "f x \<ge> 0" and sum0: "sum f X \<ge> 0" by auto
    hence "sum f (insert x X) \<ge> 0" using insert by auto
    moreover
    { assume "sum f (insert x X) = 0"
      hence "f x = 0" "sum f X = 0"
        using sum0 x0 insert add_nonneg_eq_0_iff by auto
    }
    ultimately show ?case using insert by blast
qed auto

lemma insert_union: "insert x X = X \<union> {x}" by auto

context vectorspace begin

lemmas lincomb_insert2 = lincomb_insert[unfolded insert_union[symmetric]]

lemma lincomb_restrict:
  assumes U: "U \<subseteq> carrier V"
      and a: "a : U \<rightarrow> carrier K"
      and restr: "restrict a U = restrict b U"
  shows "lincomb a U = lincomb b U"
proof -
  let ?f = "\<lambda>a u. a u \<odot>\<^bsub>V\<^esub> u"
  have fa: "?f a : U \<rightarrow> carrier V" using a U by auto
  have "restrict (?f a) U = restrict (?f b) U"
  proof
    fix u
    have "u : U \<Longrightarrow> a u = b u" using restr unfolding restrict_def by metis
    thus "restrict (?f a) U u = restrict (?f b) U u" by auto
  qed
  thus ?thesis
    unfolding lincomb_def using finsum_restrict[OF fa] by auto
qed

lemma lindep_span:
  assumes U: "U \<subseteq> carrier V" and finU: "finite U"
  shows "lin_dep U = (\<exists>u \<in> U. u \<in> span (U - {u}))" (is "?l = ?r")
proof
  assume l: "?l" show "?r"
  proof -
    from l[unfolded lin_dep_def]
    obtain A a u
    where finA: "finite A"
      and AU: "A \<subseteq> U"
      and aA: "a : A \<rightarrow> carrier K"
      and aA0: "lincomb a A = zero V"
      and uA: "u:A"
      and au0: "a u \<noteq> zero K" by auto
    define a' where "a' = (\<lambda>v. (if v : A then a v else zero K))"
    have a'U: "a' : U \<rightarrow> carrier K" unfolding a'_def using aA by auto
    have uU: "u : U" using uA AU by auto
    have a'u0: "a' u \<noteq> zero K" unfolding a'_def using au0 uA by auto
    define B where "B = U - A"
    have B: "B \<subseteq> carrier V" unfolding B_def using U by auto
    have UAB: "U = A \<union> B" unfolding B_def using AU by auto
    have finB: "finite B" using finU B_def by auto
    have AB: "A \<inter> B = {}" unfolding B_def by auto
    let ?f = "\<lambda>v. a v \<odot>\<^bsub>V\<^esub> v"
    have fA: "?f : A \<rightarrow> carrier V" unfolding a'_def using aA AU U by auto
    let ?f' = "\<lambda>v. a' v \<odot>\<^bsub>V\<^esub> v"
    have "restrict ?f A = restrict ?f' A" unfolding a'_def by auto
    hence finsum: "finsum V ?f' A = finsum V ?f A"
      using finsum_restrict[OF fA] by simp
    have f'A: "?f' : A \<rightarrow> carrier V"
    proof
      fix x assume xA: "x \<in> A"
      show "?f' x : carrier V" unfolding a'_def using aA xA AU U by auto
    qed
    have f'B: "?f' : B \<rightarrow> carrier V"
    proof
      fix x assume xB: "x : B"
      have "x \<notin> A" using a'U xB unfolding B_def by auto
      thus "?f' x : carrier V"using xB B unfolding a'_def by auto
    qed
    have sumB0: "finsum V ?f' B = zero V"
    proof -
      { fix B'
        have "finite B' \<Longrightarrow> B' \<subseteq> B \<Longrightarrow> finsum V ?f' B' = zero V"
        proof(induct set:finite)
          case (insert b B')
            have finB': "finite B'" and bB': "b \<notin> B'" using insert by auto
            have f'B': "?f' : B' \<rightarrow> carrier V" using f'B insert by auto
            have bA: "b \<notin> A" using insert unfolding B_def by auto
            have b: "b : carrier V" using insert B by auto
            have foo: "a' b \<odot>\<^bsub>V\<^esub> b \<in> carrier V" unfolding a'_def using bA b by auto
            have IH: "finsum V ?f' B' = zero V" using insert by auto
            show ?case
              unfolding finsum_insert[OF finB' bB' f'B' foo]
              using IH a'_def bA b by auto
         qed auto
      }
      thus ?thesis using finB by auto
    qed
    have a'A0: "lincomb a' U = zero V"
      unfolding UAB
      unfolding lincomb_def
      unfolding finsum_Un_disjoint[OF finA finB AB f'A f'B]
      unfolding finsum
      unfolding aA0[unfolded lincomb_def]
      unfolding sumB0 by simp
    have uU: "u:U" using uA AU by auto
    moreover have "u : span (U - {u})"
      using lincomb_isolate(2)[OF finU U a'U uU a'u0 a'A0].
    ultimately show ?r by auto
  qed
  next assume r: "?r" show "?l"
  proof -
    from r obtain u where uU: "u : U" and uspan: "u : span (U-{u})" by auto
    hence u: "u : carrier V" using U by auto
    have finUu: "finite (U-{u})" using finU by auto
    have Uu: "U-{u} \<subseteq> carrier V" using U by auto
    obtain a
      where ulin: "u = lincomb a (U-{u})"
        and a: "a : U-{u} \<rightarrow> carrier K"
      using uspan unfolding finite_span[OF finUu Uu] by auto
    show "?l" unfolding lin_dep_def
    proof(intro exI conjI)
      let ?a = "\<lambda>v. if v = u then \<ominus>\<^bsub>K\<^esub> one K else a v"
      show "?a : U \<rightarrow> carrier K" using a by auto
      hence a': "?a : U-{u}\<union>{u} \<rightarrow> carrier K" by auto
      have "U = U-{u}\<union>{u}" using uU by auto
      also have "lincomb ?a ... = ?a u \<odot>\<^bsub>V\<^esub> u \<oplus>\<^bsub>V\<^esub> lincomb ?a (U-{u})"
        unfolding lincomb_insert[OF finUu Uu a' Diff_not_in u] by auto
      also have "restrict a (U-{u}) = restrict ?a (U-{u})" by auto
        hence "lincomb ?a (U-{u}) = lincomb a (U-{u})"
          using lincomb_restrict[OF Uu a] by auto
      also have "?a u \<odot>\<^bsub>V\<^esub> u = \<ominus>\<^bsub>V\<^esub> u" using smult_minus_1[OF u] by simp
      also have "lincomb a (U-{u}) = u" using ulin..
      also have "\<ominus>\<^bsub>V\<^esub> u \<oplus>\<^bsub>V\<^esub> u = zero V" using l_neg[OF u].
      finally show "lincomb ?a U = zero V" by auto
    qed (insert uU finU, auto)
  qed
qed

lemma not_lindepD:
  assumes "~ lin_dep S"
      and "finite A" "A \<subseteq> S" "f : A \<rightarrow> carrier K" "lincomb f A = zero V"
    shows "f : A \<rightarrow> {zero K}"
  using assms unfolding lin_dep_def by blast

lemma span_mem:
  assumes E: "E \<subseteq> carrier V" and uE: "u : E" shows "u : span E"
  unfolding span_def
proof (rule,intro exI conjI)
  show "u = lincomb (\<lambda>_. one K) {u}" unfolding lincomb_def using uE E by auto
  show "{u} \<subseteq> E" using uE by auto
qed auto

lemma span_swap:
  assumes finE[simp]: "finite E"
      and E[simp]: "E \<subseteq> carrier V"
      and u[simp]: "u : carrier V"
      and usE: "u \<notin> span E"
      and v[simp]: "v : carrier V"
      and usEv: "u : span (insert v E)"
  shows "span (insert u E) \<subseteq> span (insert v E)" (is "?L \<subseteq> ?R")
proof -
  have Eu[simp]: "insert u E \<subseteq> carrier V" by auto
  have Ev[simp]: "insert v E \<subseteq> carrier V" by auto
  have finEu: "finite (insert u E)" and finEv: "finite (insert v E)"
    using finE by auto
  have uE: "u \<notin> E" using usE span_mem by force
  have vE: "v \<notin> E"
  proof
    assume "v : E"
    hence EvE: "insert v E = E" using insert_absorb by auto
    hence "u : span E" using usEv by auto
    thus "False" using usE by auto
  qed
  obtain ua
    where ua[simp]: "ua : (insert v E) \<rightarrow> carrier K"
      and uua: "u = lincomb ua (insert v E)"
    using usEv finite_span[OF finEv Ev]  by auto
  hence uaE[simp]: "ua : E \<rightarrow> carrier K" and [simp]: "ua v : carrier K"
    by auto

  show "?L \<subseteq> ?R"
  proof
    fix x assume "x : ?L"
    then obtain xa
    where xa: "xa : insert u E \<rightarrow> carrier K"
      and xxa: "x = lincomb xa (insert u E)"
      unfolding finite_span[OF finEu Eu] by auto
    hence xaE[simp]: "xa : E \<rightarrow> carrier K" and xau[simp]: "xa u : carrier K" by auto
    show "x : span (insert v E)"
      unfolding finite_span[OF finEv Ev]
    proof (rule,intro exI conjI)
      define a where "a = (\<lambda>e. xa u \<otimes>\<^bsub>K\<^esub> ua e)"
      define a' where "a' = (\<lambda>e. a e \<oplus>\<^bsub>K\<^esub> xa e)"
      define a'' where "a'' = (\<lambda>e. if e = v then xa u \<otimes>\<^bsub>K\<^esub> ua v else a' e)"
      have aE: "a : E \<rightarrow> carrier K" unfolding a_def using xau uaE u by blast
      hence a'E: "a' : E \<rightarrow> carrier K" unfolding a'_def using xaE by blast
      thus a'': "a'' : insert v E \<rightarrow> carrier K" unfolding a''_def by auto
      have restr: "restrict a' E = restrict a'' E"
        unfolding a''_def using vE by auto
      have "x = xa u \<odot>\<^bsub>V\<^esub> u \<oplus>\<^bsub>V\<^esub> lincomb xa E"
        using xxa lincomb_insert2 finE E xa uE u by auto
      also have
        "xa u \<odot>\<^bsub>V\<^esub> u = xa u \<odot>\<^bsub>V\<^esub> lincomb ua (insert v E)"
        using uua by auto
      also have "lincomb ua (insert v E) = ua v \<odot>\<^bsub>V\<^esub> v \<oplus>\<^bsub>V\<^esub> lincomb ua E"
        using lincomb_insert2 finE E ua vE v by auto
      also have "xa u \<odot>\<^bsub>V\<^esub> ... = xa u \<odot>\<^bsub>V\<^esub> (ua v \<odot>\<^bsub>V\<^esub> v) \<oplus>\<^bsub>V\<^esub> xa u \<odot>\<^bsub>V\<^esub> lincomb ua E"
        using smult_r_distr by auto
      also have "xa u \<odot>\<^bsub>V\<^esub> lincomb ua E = lincomb a E"
        unfolding a_def using lincomb_smult[OF E] by auto
      finally have "x = xa u \<odot>\<^bsub>V\<^esub> (ua v \<odot>\<^bsub>V\<^esub> v) \<oplus>\<^bsub>V\<^esub> (lincomb a E \<oplus>\<^bsub>V\<^esub> lincomb xa E)"
        using a_assoc xau v aE xaE by auto
      also have "lincomb a E \<oplus>\<^bsub>V\<^esub> lincomb xa E = lincomb a' E"
        unfolding a'_def using lincomb_sum[OF finE E aE xaE]..
      also have "... = lincomb a'' E"
        using lincomb_restrict[OF E a'E ] restr by auto
      finally have "x = ((xa u \<otimes>\<^bsub>K\<^esub> ua v) \<odot>\<^bsub>V\<^esub> v) \<oplus>\<^bsub>V\<^esub> lincomb a'' E"
        using smult_assoc1 by auto
      also have "xa u \<otimes>\<^bsub>K\<^esub> ua v = a'' v" unfolding a''_def by simp
      also have "(a'' v \<odot>\<^bsub>V\<^esub> v) \<oplus>\<^bsub>V\<^esub> lincomb a'' E = lincomb a'' (insert v E)"
        using lincomb_insert2[OF finE E a'' vE] by auto
      finally show "x = lincomb a'' (insert v E)".
    qed
  qed
qed

lemma basis_swap:
  assumes finE[simp]: "finite E"
      and u[simp]: "u : carrier V"
      and uE[simp]: "u \<notin> E"
      and b: "basis (insert u E)"
      and v[simp]: "v : carrier V"
      and uEv: "u : span (insert v E)"
  shows "basis (insert v E)"
  unfolding basis_def
proof (intro conjI)
  have Eu[simp]: "insert u E \<subseteq> carrier V"
   and spanEu: "carrier V = span (insert u E)"
   and indEu: "~ lin_dep (insert u E)"
    using b[unfolded basis_def] by auto
  hence E[simp]: "E \<subseteq> carrier V" by auto
  thus Ev[simp]: "insert v E \<subseteq> carrier V" using v by auto
  have finEu: "finite (insert u E)"
   and finEv: "finite (insert v E)" using finE by auto
  have usE: "u \<notin> span E"
  proof
    assume "u : span E"
    hence "u : span (insert u E - {u})" using uE by auto
    moreover have "u : insert u E" by auto
    ultimately have "lin_dep (insert u E)"
      unfolding lindep_span[OF Eu finEu] by auto
    thus "False" using b unfolding basis_def by auto
  qed

  obtain ua
    where ua[simp]: "ua : insert v E \<rightarrow> carrier K"
      and uua: "u = lincomb ua (insert v E)"
    using uEv finite_span[OF finEv Ev]  by auto
  hence uaE[simp]: "ua : E \<rightarrow> carrier K"
    and uav[simp]: "ua v : carrier K"
    by auto

  have vE: "v \<notin> E"
  proof
    assume "v : E"
    hence EvE: "insert v E = E" using insert_absorb by auto
    hence "u : span E" using uEv by auto
    thus "False" using usE by auto
  qed
  have vsE: "v \<notin> span E"
  proof
    assume "v : span E"
    then obtain va
      where va[simp]: "va : E \<rightarrow> carrier K"
        and vva: "v = lincomb va E"
      using finite_span[OF finE E] by auto
    define va' where "va' = (\<lambda>e. ua v \<otimes>\<^bsub>K\<^esub> va e)"
    define va'' where "va'' = (\<lambda>e. va' e \<oplus>\<^bsub>K\<^esub> ua e)"
    have va'[simp]: "va' : E \<rightarrow> carrier K"
      unfolding va'_def using uav va by blast
    hence va''[simp]: "va'' : E \<rightarrow> carrier K"
      unfolding va''_def using ua by blast
    from uua
    have "u = ua v \<odot>\<^bsub>V\<^esub> v \<oplus>\<^bsub>V\<^esub> lincomb ua E"
      using lincomb_insert2 vE by auto
    also have "ua v \<odot>\<^bsub>V\<^esub> v = ua v \<odot>\<^bsub>V\<^esub> (lincomb va E)"
      using vva by auto
    also have "... = lincomb va' E"
      unfolding va'_def using lincomb_smult by auto
    finally have "u = lincomb va'' E"
      unfolding va''_def
      using lincomb_sum[OF finE E] by auto
    hence "u : span E" using finite_span[OF finE E] va'' by blast
    hence "lin_dep (insert u E)" using lindep_span by simp
    then show False using indEu by auto
  qed

  have indE: "~ lin_dep E" using indEu subset_li_is_li by auto

  show "~ lin_dep (insert v E)" using lin_dep_iff_in_span[OF E indE v vE] vsE by auto

  show "span (insert v E) = carrier V" (is "?L = ?R")
  proof (rule)
    show "?L \<subseteq> ?R"
    proof
      have finEv: "finite (insert v E)" using finE by auto
      fix x assume "x : ?L"
      then obtain a
        where a: "a : insert v E \<rightarrow> carrier K"
          and x: "x = lincomb a (insert v E)"
        unfolding finite_span[OF finEv Ev] by auto
      from a have av: "a v : carrier K" by auto
      from a have a2: "a : E \<rightarrow> carrier K" by auto
      show "x : ?R"
        unfolding x
        unfolding lincomb_insert2[OF finE E a vE v]
        using lincomb_closed[OF E a2] av v
        by auto
    qed
    show "?R \<subseteq> ?L"
      using span_swap[OF finE E u usE v uEv] spanEu by auto
  qed
qed

lemma span_empty: "span {} = {zero V}"
  unfolding finite_span[OF finite.emptyI empty_subsetI]
  unfolding lincomb_def by simp

lemma span_self: assumes [simp]: "v : carrier V" shows "v : span {v}"
proof -
  have "v = lincomb (\<lambda>x. one K) {v}" unfolding lincomb_def by auto
  thus ?thesis using finite_span by auto
qed

lemma span_zero: "zero V : span U" unfolding span_def lincomb_def by force

definition emb where "emb f D x = (if x : D then f x else zero K)"

lemma emb_carrier[simp]: "f : D \<rightarrow> R \<Longrightarrow> emb f D : D \<rightarrow> R"
  apply rule unfolding emb_def by auto

lemma emb_restrict: "restrict (emb f D) D = restrict f D"
  apply rule unfolding restrict_def emb_def by auto

lemma emb_zero: "emb f D : X - D \<rightarrow> { zero K }"
  apply rule unfolding emb_def by auto

lemma lincomb_clean:
  assumes A: "A \<subseteq> carrier V"
    and Z: "Z \<subseteq> carrier V"
    and finA: "finite A"
    and finZ: "finite Z"
    and aA: "a : A \<rightarrow> carrier K"
    and aZ: "a : Z \<rightarrow> { zero K }"
  shows "lincomb a (A \<union> Z) = lincomb a A"
  using finZ Z aZ
proof(induct set:finite)
  case empty thus ?case by simp next
  case (insert z Z) show ?case
    proof (cases "z : A")
      case True hence "A \<union> insert z Z = A \<union> Z" by auto
        thus ?thesis using insert by simp next
      case False
        have finAZ: "finite (A \<union> Z)" using finA insert by simp
        have AZ: "A \<union> Z \<subseteq> carrier V" using A insert by simp
        have a: "a : insert z (A \<union> Z) \<rightarrow> carrier K" using insert aA by force
        have "a z = zero K" using insert by auto
        also have "... \<odot>\<^bsub>V\<^esub> z = zero V" using insert by auto
        also have "... \<oplus>\<^bsub>V\<^esub> lincomb a (A \<union> Z) = lincomb a (A \<union> Z)"
          using insert AZ aA by auto
        also have "... = lincomb a A" using insert by simp
        finally have "a z \<odot>\<^bsub>V\<^esub> z \<oplus>\<^bsub>V\<^esub> lincomb a (A \<union> Z) = lincomb a A".
        thus ?thesis
          using lincomb_insert2[OF finAZ AZ a] False insert by auto
    qed
qed

lemma span_add1:
  assumes U: "U \<subseteq> carrier V" and v: "v : span U" and w: "w : span U"
  shows "v \<oplus>\<^bsub>V\<^esub> w : span U"
proof -
  from v obtain a A
    where finA: "finite A"
      and va: "lincomb a A = v"
      and AU: "A \<subseteq> U"
      and a: "a : A \<rightarrow> carrier K"
    unfolding span_def by auto
  hence A: "A \<subseteq> carrier V" using U by auto
  from w obtain b B
    where finB: "finite B"
      and wb: "lincomb b B = w"
      and BU: "B \<subseteq> U"
      and b: "b : B \<rightarrow> carrier K"
    unfolding span_def by auto
  hence B: "B \<subseteq> carrier V" using U by auto

  have B_A: "B - A \<subseteq> carrier V" and A_B: "A - B \<subseteq> carrier V" using A B by auto

  have a': "emb a A : A \<union> B \<rightarrow> carrier K"
    apply (rule Pi_I) unfolding emb_def using a by auto
  hence a'A: "emb a A : A \<rightarrow> carrier K" by auto
  have a'Z: "emb a A : B - A \<rightarrow> { zero K }"
    apply (rule Pi_I) unfolding emb_def using a by auto

  have b': "emb b B : A \<union> B \<rightarrow> carrier K"
    apply (rule Pi_I) unfolding emb_def using b by auto
  hence b'B: "emb b B : B \<rightarrow> carrier K" by auto
  have b'Z: "emb b B : A - B \<rightarrow> { zero K }"
    apply (rule Pi_I) unfolding emb_def using b by auto

  show ?thesis
    unfolding span_def
    proof (rule,intro exI conjI)
      let ?v = "lincomb (emb a A) (A \<union> B)"
      let ?w = "lincomb (emb b B) (A \<union> B)"
      let ?ab = "\<lambda>u. (emb a A) u \<oplus>\<^bsub>K\<^esub> (emb b B) u"
      show finAB: "finite (A \<union> B)" using finA finB by auto
      show "A \<union> B \<subseteq> U" using AU BU by auto
      show "?ab : A \<union> B \<rightarrow> carrier K" using a' b' by auto
      have "v = ?v"
        using va lincomb_restrict[OF A a emb_restrict[symmetric]]
        using lincomb_clean[OF A B_A] a'A a'Z finA finB by simp
      moreover have "w = ?w"
        apply (subst Un_commute)
        using wb lincomb_restrict[OF B b emb_restrict[symmetric]]
        using lincomb_clean[OF B A_B] finA finB b'B b'Z by simp
      ultimately show "v \<oplus>\<^bsub>V\<^esub> w = lincomb ?ab (A \<union> B)"
        using lincomb_sum[OF finAB] A B a' b' by simp
    qed
qed

lemma span_neg:
  assumes U: "U \<subseteq> carrier V" and vU: "v : span U"
  shows "\<ominus>\<^bsub>V\<^esub> v : span U"
proof -
  have v: "v : carrier V" using vU U unfolding span_def by auto
  from vU[unfolded span_def]
  obtain a A
    where finA: "finite A"
      and AU: "A \<subseteq> U"
      and a: "a \<in> A \<rightarrow> carrier K"
      and va: "v = lincomb a A" by auto
  hence A: "A \<subseteq> carrier V" using U by simp
  let ?a = "\<lambda>u. \<ominus>\<^bsub>K\<^esub> one K \<otimes>\<^bsub>K\<^esub> a u"

  have "\<ominus>\<^bsub>V\<^esub> v = \<ominus>\<^bsub>K\<^esub> one K \<odot>\<^bsub>V\<^esub> v" using smult_minus_1_back[OF v].
  also have "... = \<ominus>\<^bsub>K\<^esub> one K \<odot>\<^bsub>V\<^esub> lincomb a A" using va by simp
  finally have main: "\<ominus>\<^bsub>V\<^esub> v = lincomb ?a A"
    unfolding lincomb_smult[OF A a R.a_inv_closed[OF R.one_closed]] by auto
  show ?thesis
    unfolding span_def
    apply rule
    using main a finA AU by force
qed

lemma span_closed[simp]: "U \<subseteq> carrier V \<Longrightarrow> v : span U \<Longrightarrow> v : carrier V"
  unfolding span_def by auto

lemma span_add:
  assumes U: "U \<subseteq> carrier V" and vU: "v : span U" and w[simp]: "w : carrier V"
  shows "w : span U \<longleftrightarrow> v \<oplus>\<^bsub>V\<^esub> w : span U" (is "?L \<longleftrightarrow> ?R")
proof
  show "?L \<Longrightarrow> ?R" using span_add1[OF U vU] by auto
  assume R: "?R" show "?L"
  proof -
    have v[simp]: "v : carrier V" using vU U by simp
    have "w = zero V \<oplus>\<^bsub>V\<^esub> w" using M.l_zero by auto
    also have "... = \<ominus>\<^bsub>V\<^esub> v \<oplus>\<^bsub>V\<^esub> v \<oplus>\<^bsub>V\<^esub> w" using M.l_neg by auto
    also have "... = \<ominus>\<^bsub>V\<^esub> v \<oplus>\<^bsub>V\<^esub> (v \<oplus>\<^bsub>V\<^esub> w)"
      using M.l_zero M.a_assoc M.a_closed by auto
    also have "... : span U" using span_neg[OF U vU] span_add1[OF U] R by auto
    finally show ?thesis.
  qed
qed

lemma lincomb_union:
  assumes U: "U \<subseteq> carrier V"
      and U'[simp]: "U' \<subseteq> carrier V"
      and disj: "U \<inter> U' = {}"
      and finU: "finite U"
      and finU': "finite U'"
      and a: "a : U \<union> U' \<rightarrow> carrier K"
    shows "lincomb a (U \<union> U') = lincomb a U \<oplus>\<^bsub>V\<^esub> lincomb a U'"
  using finU U disj a
proof (induct set:finite)
  case empty thus ?case by (subst(2) lincomb_def, simp) next
  case (insert u U) thus ?case
    unfolding Un_insert_left
    using lincomb_insert2 finU' insert a_assoc by auto
qed

lemma span_union1:
  assumes U: "U \<subseteq> carrier V" and U': "U' \<subseteq> carrier V" and UU': "span U = span U'"
      and W: "W \<subseteq> carrier V" and W': "W' \<subseteq> carrier V" and WW': "span W = span W'"
  shows "span (U \<union> W) \<subseteq> span (U' \<union> W')" (is "?L \<subseteq> ?R")
proof
  fix x assume "x : ?L"
  then obtain a A
    where finA: "finite A"
      and AUW: "A \<subseteq> U \<union> W"
      and x: "x = lincomb a A"
      and a: "a : A \<rightarrow> carrier K"
    unfolding span_def by auto
  let ?AU = "A \<inter> U" and ?AW = "A \<inter> W - U"
  have AU: "?AU \<subseteq> carrier V" using U by auto
  have AW: "?AW \<subseteq> carrier V" using W by auto
  have disj: "?AU \<inter> ?AW = {}" by auto
  have U'W': "U' \<union> W' \<subseteq> carrier V" using U' W' by auto

  have "?AU \<union> ?AW = A" using AUW by auto
  hence "x = lincomb a (?AU \<union> ?AW)" using x by auto
  hence "x = lincomb a ?AU \<oplus>\<^bsub>V\<^esub> lincomb a ?AW"
    using lincomb_union[OF AU AW disj] finA a by auto
  moreover
    have "lincomb a ?AU : span U" and "lincomb a ?AW : span W"
      unfolding span_def using AU a finA by auto
    hence "lincomb a ?AU : span U'" and "lincomb a ?AW : span W'"
      using UU' WW' by auto
    hence "lincomb a ?AU : ?R" and "lincomb a ?AW : ?R"
      using span_is_monotone[OF Un_upper1, of U']
      using span_is_monotone[OF Un_upper2, of W'] by auto
  ultimately
    show "x : ?R" using span_add1[OF U'W'] by auto
qed

lemma span_Un:
  assumes U: "U \<subseteq> carrier V" and U': "U' \<subseteq> carrier V" and UU': "span U = span U'"
      and W: "W \<subseteq> carrier V" and W': "W' \<subseteq> carrier V" and WW': "span W = span W'"
  shows "span (U \<union> W) = span (U' \<union> W')" (is "?L = ?R")
  using span_union1[OF assms]
  using span_union1[OF U' U UU'[symmetric] W' W WW'[symmetric]]
  by auto

lemma lincomb_zero:
  assumes U: "U \<subseteq> carrier V" and a: "a : U \<rightarrow> {zero K}"
  shows "lincomb a U = zero V"
  using U a
proof (induct U rule: infinite_finite_induct)
  case empty show ?case unfolding lincomb_def by auto next
  case (insert u U)
    hence "a \<in> insert u U \<rightarrow> carrier K" using zero_closed by force
    thus ?case using insert by (subst lincomb_insert2; auto)
qed (auto simp: lincomb_def)

end

context module
begin

lemma lincomb_empty[simp]: "lincomb a {} = \<zero>\<^bsub>M\<^esub>"
  unfolding lincomb_def by auto

end

context linear_map
begin

interpretation Ker: vectorspace K "(V.vs kerT)"
  using kerT_is_subspace
  using V.subspace_is_vs by blast

interpretation im: vectorspace K "(W.vs imT)"
  using imT_is_subspace
  using W.subspace_is_vs by blast

lemma Ke0_imp_inj:
assumes c: "carrier (V.vs kerT) = {\<zero>\<^bsub>V\<^esub>}"
shows "inj_on T (carrier V)"
proof (auto simp add: inj_on_def)
  fix x y
  assume x: "x \<in> carrier V" and y: "y \<in> carrier V"
  and Tx_Ty: "T x = T y"
  hence "T x \<ominus>\<^bsub>W\<^esub> T y = \<zero>\<^bsub>W\<^esub>" using W.module.M.minus_other_side by auto
  hence "T (x \<ominus>\<^bsub>V\<^esub> y) = \<zero>\<^bsub>W\<^esub>" by (simp add: x y)
  hence "x \<ominus>\<^bsub>V\<^esub> y \<in> carrier (V.vs kerT)" by (simp add: mod_hom.ker_def x y)
  hence "x \<ominus>\<^bsub>V\<^esub> y = \<zero>\<^bsub>V\<^esub>" using c by fast
  thus "x = y" by (simp add: x y)
qed

corollary Ke0_iff_inj: "inj_on T (carrier V) = (carrier (V.vs kerT) = {\<zero>\<^bsub>V\<^esub>})"
using inj_imp_Ker0 Ke0_imp_inj by auto

lemma inj_imp_dim_ker0:
assumes "inj_on T (carrier V)"
shows "vectorspace.dim K (V.vs kerT) = 0"
proof (unfold Ker.dim_def, rule Least_eq_0, rule exI[of _ "{}"])
    have Ker_rw: "carrier (V.vs kerT) = {\<zero>\<^bsub>V\<^esub>}"
      unfolding mod_hom.ker_def
      using assms inj_on_contraD by fastforce
    have "finite {}" by simp
    moreover have "card {} = 0" by simp
    moreover have "{} \<subseteq> carrier (V.vs kerT)" by simp
    moreover have "Ker.gen_set {}" unfolding Ker_rw by (simp add: Ker.span_empty)
    ultimately show "finite {} \<and> card {} = 0 \<and> {} \<subseteq> carrier (V.vs kerT) \<and> Ker.gen_set {}" by simp
qed

lemma dim_eq:
assumes fin_dim_V: "V.fin_dim"
and i: "inj_on T (carrier V)" and surj: "T` (carrier V) = carrier W"
shows "V.dim = W.dim"
proof -
  have dim0: "vectorspace.dim K (V.vs kerT) = 0"
    by (rule inj_imp_dim_ker0[OF i])
  have imT_W: "(imT) = carrier W"
    by (rule surj_imp_imT_carrier[OF surj])
  have rnt: "vectorspace.dim K (W.vs imT) + vectorspace.dim K (V.vs kerT) = V.dim"
    by (rule rank_nullity[OF fin_dim_V])
  hence "V.dim = vectorspace.dim K (W.vs imT)" using dim0 by auto
  also have "...  = W.dim" using imT_W by auto
  finally show ?thesis using fin_dim_V by auto
qed

lemma lincomb_linear_image:
assumes inj_T: "inj_on T (carrier V)"
assumes A_in_V: "A \<subseteq> carrier V" and a: "a \<in> (T`A) \<rightarrow> carrier K"
assumes f: "finite A"
shows "W.module.lincomb a (T`A) = T (V.module.lincomb (a \<circ> T) A)"
using f using A_in_V a
proof (induct A)
  case empty thus ?case by auto
next
  case (insert x A)
  have T_insert_rw: "T ` insert x A = insert (T x) (T` A)" by simp
  have "W.module.lincomb a (T ` insert x A) = W.module.lincomb a (insert (T x) (T` A))"
    unfolding T_insert_rw ..
  also have "... =  a (T x) \<odot>\<^bsub>W\<^esub> (T x) \<oplus>\<^bsub>W\<^esub> W.module.lincomb a (T` A)"
  proof (rule W.lincomb_insert2)
    show "finite (T ` A)" by (simp add: insert.hyps(1))
    show "T ` A \<subseteq> carrier W" using insert.prems(1) by auto
    show "a \<in> insert (T x) (T ` A) \<rightarrow> carrier K"
      using insert.prems(2) by blast
    show "T x \<notin> T ` A"
      by (meson inj_T inj_on_image_mem_iff_alt insert.hyps(2) insert.prems(1) insert_subset)
    show "T x \<in> carrier W" using insert.prems(1) by blast
  qed
  also have "... = a (T x) \<odot>\<^bsub>W\<^esub> (T x) \<oplus>\<^bsub>W\<^esub> (T (V.module.lincomb (a \<circ> T) A))"
    using insert.hyps(3) insert.prems(1) insert.prems(2) by fastforce
  also have "... = T (a (T x) \<odot>\<^bsub>V\<^esub> x) \<oplus>\<^bsub>W\<^esub> (T (V.module.lincomb (a \<circ> T) A))"
    using insert.prems(1) insert.prems(2) by auto
  also have "... = T ((a (T x) \<odot>\<^bsub>V\<^esub> x) \<oplus>\<^bsub>V\<^esub> (V.module.lincomb (a \<circ> T) A))"
  proof (rule T_add[symmetric])
    show "a (T x) \<odot>\<^bsub>V\<^esub> x \<in> carrier V" using insert.prems(1) insert.prems(2) by auto
    show "V.module.lincomb (a \<circ> T) A \<in> carrier V"
    proof (rule V.module.lincomb_closed)
      show "A \<subseteq> carrier V" using insert.prems(1) by blast
      show "a \<circ> T \<in> A \<rightarrow> carrier K" using coeff_in_ring insert.prems(2) by auto
    qed
  qed
  also have "... = T (V.module.lincomb (a \<circ> T) (insert x A))"
  proof (rule arg_cong[of _ _ T])
    have "a \<circ> T \<in> insert x A \<rightarrow> carrier K"
      using comp_def insert.prems(2) by auto
    then show "a (T x) \<odot>\<^bsub>V\<^esub> x \<oplus>\<^bsub>V\<^esub> V.module.lincomb (a \<circ> T) A
      = V.module.lincomb (a \<circ> T) (insert x A)"
      using V.lincomb_insert2 insert.hyps(1) insert.hyps(2) insert.prems(1) by force
  qed
  finally show ?case .
qed

lemma surj_fin_dim:
  assumes fd: "V.fin_dim" and surj: "T` (carrier V) = carrier W"
  shows image_fin_dim: "W.fin_dim"
    using rank_nullity_main(2)[OF fd surj] .

lemma linear_inj_image_is_basis:
assumes inj_T: "inj_on T (carrier V)" and surj: "T` (carrier V) = carrier W"
and basis_B: "V.basis B"
and fin_dim_V: "V.fin_dim"
shows "W.basis (T`B)"
proof (rule W.dim_li_is_basis)
  have lm: "linear_map K V W T" by intro_locales
  have inj_TB: "inj_on T B"
    by (meson basis_B inj_T subset_inj_on V.basis_def)
  show "W.fin_dim" by (rule surj_fin_dim[OF fin_dim_V surj])
  show "finite (T ` B)"
  proof (rule finite_imageI, rule V.fin[OF fin_dim_V])
    show "V.module.lin_indpt B" using basis_B unfolding V.basis_def by auto
    show "B \<subseteq> carrier V" using basis_B unfolding V.basis_def by auto
  qed
  show "T ` B \<subseteq> carrier W" using basis_B unfolding V.basis_def by auto
  show "W.dim \<le> card (T ` B)"
  proof -
    have d: "V.dim = W.dim" by (rule dim_eq[OF fin_dim_V inj_T surj])
    have "card (T` B) = card B" by (simp add: card_image inj_TB)
    also have "... = V.dim" using basis_B fin_dim_V V.basis_def V.dim_basis V.fin by auto
    finally show ?thesis using d by simp
  qed
  show "W.module.lin_indpt (T ` B)"
  proof (rule W.module.finite_lin_indpt2)
     show fin_TB: "finite (T ` B)" by fact
     show TB_W: "T ` B \<subseteq> carrier W" by fact
     fix a assume a: "a \<in> T ` B \<rightarrow> carrier K" and lc_a: "W.module.lincomb a (T ` B) = \<zero>\<^bsub>W\<^esub>"
     show "\<forall>v\<in>T ` B. a v = \<zero>\<^bsub>K\<^esub>"
     proof (rule ballI)
      fix v assume v: "v \<in> T ` B"
      have "W.module.lincomb a (T ` B) = T (V.module.lincomb (a \<circ> T) B)"
      proof (rule lincomb_linear_image[OF inj_T])
        show "B \<subseteq> carrier V" using V.vectorspace_axioms basis_B vectorspace.basis_def by blast
        show "a \<in> T ` B \<rightarrow> carrier K" by (simp add: a)
        show "finite B" using fin_TB finite_image_iff inj_TB by blast
      qed
      hence T_lincomb: "T (V.module.lincomb (a \<circ> T) B) = \<zero>\<^bsub>W\<^esub>" using lc_a by simp
      have lincomb_0: "V.module.lincomb (a \<circ> T) B = \<zero>\<^bsub>V\<^esub>"
      proof -
        have "a \<circ> T \<in> B \<rightarrow> carrier K"
          using a by auto
        then show ?thesis
          by (metis V.module.M.zero_closed V.module.lincomb_closed
            T_lincomb basis_B f0_is_0 inj_T inj_onD  V.basis_def)
      qed
      have "(a \<circ> T) \<in> B \<rightarrow> {\<zero>\<^bsub>K\<^esub>}"
      proof (rule V.not_lindepD[OF _ _ _ _ lincomb_0])
        show "V.module.lin_indpt B" using V.basis_def basis_B by blast
        show "finite B" using fin_TB finite_image_iff inj_TB by auto
        show "B \<subseteq> B" by auto
        show "a \<circ> T \<in> B \<rightarrow> carrier K" using a by auto
      qed
      thus "a v = \<zero>\<^bsub>K\<^esub>" using v by auto
    qed
  qed
qed

end

lemma (in vectorspace) dim1I:
assumes "gen_set {v}"
assumes "v \<noteq> \<zero>\<^bsub>V\<^esub>" "v \<in> carrier V"
shows "dim = 1"
proof -
  have "basis {v}" by (metis assms(1) assms(2) assms(3) basis_def empty_iff empty_subsetI
   finite.emptyI finite_lin_indpt2 insert_iff insert_subset insert_union lin_dep_iff_in_span
   span_empty)
  then show ?thesis using dim_basis by force
qed

lemma (in vectorspace) dim0I:
assumes "gen_set {\<zero>\<^bsub>V\<^esub>}"
shows "dim = 0"
proof -
  have "basis {}" unfolding basis_def using already_in_span assms finite_lin_indpt2 span_zero by auto
  then show ?thesis using dim_basis by force
qed

lemma (in vectorspace) dim_le1I:
assumes "gen_set {v}"
assumes "v \<in> carrier V"
shows "dim \<le> 1"
by (metis One_nat_def assms(1) assms(2) bot.extremum card.empty card.insert empty_iff finite.intros(1)
finite.intros(2) insert_subset vectorspace.gen_ge_dim vectorspace_axioms)

end


(*
  File:    More_Dirichlet_Misc.thy
  Author:  Manuel Eberl, TU München

  Generalised Dirichlet products and Legendre's identity, and a weighted sum
  of the Möbius \<mu> function
*)
section \<open>Miscellaneous material\<close>
theory More_Dirichlet_Misc
imports
  Prime_Distribution_Elementary_Library
  Prime_Number_Theorem.Prime_Counting_Functions
begin

subsection \<open>Generalised Dirichlet products\<close>

(* TODO: Move to Dirichlet_Series *)

definition dirichlet_prod' :: "(nat \<Rightarrow> 'a :: comm_semiring_1) \<Rightarrow> (real \<Rightarrow> 'a) \<Rightarrow> real \<Rightarrow> 'a" where
  "dirichlet_prod' f g x = sum_upto (\<lambda>m. f m * g (x / real m)) x"

lemma dirichlet_prod'_one_left:
  "dirichlet_prod' (\<lambda>n. if n = 1 then 1 else 0) f x = (if x \<ge> 1 then f x else 0)"
proof -
  have  "dirichlet_prod' (\<lambda>n. if n = 1 then 1 else 0) f x =
           (\<Sum>i | 0 < i \<and> real i \<le> x. (if i = Suc 0 then 1 else 0) * f (x / real i))"
    by (simp add: dirichlet_prod'_def sum_upto_def)
  also have "\<dots> = (\<Sum>i\<in>(if x \<ge> 1 then {1::nat} else {}). f x)"
    by (intro sum.mono_neutral_cong_right) (auto split: if_splits)
  also have "\<dots> = (if x \<ge> 1 then f x else 0)"
    by simp
  finally show ?thesis .
qed

lemma dirichlet_prod'_cong:
  assumes "\<And>n. n > 0 \<Longrightarrow> real n \<le> x \<Longrightarrow> f n = f' n"
  assumes "\<And>y. y \<ge> 1 \<Longrightarrow> y \<le> x \<Longrightarrow> g y = g' y"
  assumes "x = x'"
  shows   "dirichlet_prod' f g x = dirichlet_prod' f' g' x'"
  unfolding dirichlet_prod'_def
  by (intro sum_upto_cong' assms, (subst assms | simp add: assms field_simps)+)

(* 2.21 *)
lemma dirichlet_prod'_assoc:
  "dirichlet_prod' f (\<lambda>y. dirichlet_prod' g h y) x = dirichlet_prod' (dirichlet_prod f g) h x"
proof -
  have "dirichlet_prod' f (\<lambda>y. dirichlet_prod' g h y) x =
          (\<Sum>m | m > 0 \<and> real m \<le> x. \<Sum>n | n > 0 \<and> real n \<le> x / m. f m * g n * h (x / (m * n)))"
    by (simp add: algebra_simps dirichlet_prod'_def dirichlet_prod_def
                  sum_upto_def sum_distrib_left sum_distrib_right)
  also have "\<dots> = (\<Sum>(m,n)\<in>(SIGMA m:{m. m > 0 \<and> real m \<le> x}. {n. n > 0 \<and> real n \<le> x / m}).
                     f m * g n * h (x / (m * n)))"
    by (subst sum.Sigma) auto
  also have "\<dots> = (\<Sum>(mn, m)\<in>(SIGMA mn:{mn. mn > 0 \<and> real mn \<le> x}. {m. m dvd mn}).
                    f m * g (mn div m) * h (x / mn))"
    by (rule sum.reindex_bij_witness[of _ "\<lambda>(mn, m). (m, mn div m)" "\<lambda>(m, n). (m * n, m)"])
       (auto simp: case_prod_unfold field_simps dest: dvd_imp_le)
  also have "\<dots> = dirichlet_prod' (dirichlet_prod f g) h x"
    by (subst sum.Sigma [symmetric])
       (simp_all add: dirichlet_prod'_def dirichlet_prod_def sum_upto_def
                      algebra_simps sum_distrib_left sum_distrib_right)
  finally show ?thesis .
qed

(* 2.22 *)
lemma dirichlet_prod'_inversion1:
  assumes "\<forall>x\<ge>1. g x = dirichlet_prod' a f x" "x \<ge> 1"
          "dirichlet_prod a ainv = (\<lambda>n. if n = 1 then 1 else 0)"
  shows   "f x = dirichlet_prod' ainv g x"
proof -
  have "dirichlet_prod' ainv g x = dirichlet_prod' ainv (dirichlet_prod' a f) x"
    using assms by (intro dirichlet_prod'_cong) auto
  also have "\<dots> = dirichlet_prod' (\<lambda>n. if n = 1 then 1 else 0) f x"
    using assms by (simp add: dirichlet_prod'_assoc dirichlet_prod_commutes)
  also have "\<dots> = f x"
    using assms by (subst dirichlet_prod'_one_left) auto
  finally show ?thesis ..
qed

lemma dirichlet_prod'_inversion2:
  assumes "\<forall>x\<ge>1. f x = dirichlet_prod' ainv g x" "x \<ge> 1"
          "dirichlet_prod a ainv = (\<lambda>n. if n = 1 then 1 else 0)"
  shows   "g x = dirichlet_prod' a f x"
proof -
  have "dirichlet_prod' a f x = dirichlet_prod' a (dirichlet_prod' ainv g) x"
    using assms by (intro dirichlet_prod'_cong) auto
  also have "\<dots> = dirichlet_prod' (\<lambda>n. if n = 1 then 1 else 0) g x"
    using assms by (simp add: dirichlet_prod'_assoc dirichlet_prod_commutes)
  also have "\<dots> = g x"
    using assms by (subst dirichlet_prod'_one_left) auto
  finally show ?thesis ..
qed

lemma dirichlet_prod'_inversion:
  assumes "dirichlet_prod a ainv = (\<lambda>n. if n = 1 then 1 else 0)"
  shows   "(\<forall>x\<ge>1. g x = dirichlet_prod' a f x) \<longleftrightarrow> (\<forall>x\<ge>1. f x = dirichlet_prod' ainv g x)"
  using dirichlet_prod'_inversion1[of g a f _ ainv] dirichlet_prod'_inversion2[of f ainv g _ a]
        assms by blast

lemma dirichlet_prod'_inversion':
  assumes "a 1 * y = 1"
  defines "ainv \<equiv> dirichlet_inverse a y"
  shows   "(\<forall>x\<ge>1. g x = dirichlet_prod' a f x) \<longleftrightarrow> (\<forall>x\<ge>1. f x = dirichlet_prod' ainv g x)"
  unfolding ainv_def
  by (intro dirichlet_prod'_inversion dirichlet_prod_inverse assms)

(* 3.11 *)
lemma dirichlet_prod'_floor_conv_sum_upto:
  "dirichlet_prod' f (\<lambda>x. real_of_int (floor x)) x = sum_upto (\<lambda>n. sum_upto f (x / n)) x"
proof -
  have [simp]: "sum_upto (\<lambda>_. 1 :: real) x = real (nat \<lfloor>x\<rfloor>)" for x
    by (simp add: sum_upto_altdef)
  show ?thesis
    using sum_upto_dirichlet_prod[of "\<lambda>n. 1::real" f] sum_upto_dirichlet_prod[of f "\<lambda>n. 1::real"]
    by (simp add: dirichlet_prod'_def dirichlet_prod_commutes)
qed

lemma (in completely_multiplicative_function) dirichlet_prod_self:
  "dirichlet_prod f f n = f n * of_nat (divisor_count n)"
proof (cases "n = 0")
  case False
  have "dirichlet_prod f f n = (\<Sum>(r, d) | r * d = n. f (r * d))"
    by (simp add: dirichlet_prod_altdef2 mult)
  also have "\<dots> = (\<Sum>(r, d) | r * d = n. f n)"
    by (intro sum.cong) auto
  also have "\<dots> = f n * of_nat (card {(r, d). r * d = n})"
    by (simp add: mult.commute)
  also have "bij_betw fst {(r, d). r * d = n} {r. r dvd n}"
    by (rule bij_betwI[of _ _ _ "\<lambda>r. (r, n div r)"]) (use False in auto)
  hence "card {(r, d). r * d = n} = card {r. r dvd n}"
    by (rule bij_betw_same_card)
  also have "\<dots> = divisor_count n"
    by (simp add: divisor_count_def)
  finally show ?thesis .
qed auto

lemma completely_multiplicative_imp_moebius_mu_inverse:
  fixes f :: "nat \<Rightarrow> 'a :: {comm_ring_1}"
  assumes "completely_multiplicative_function f"
  shows   "dirichlet_prod f (\<lambda>n. moebius_mu n * f n) n = (if n = 1 then 1 else 0)"
proof -
  interpret completely_multiplicative_function f by fact
  have [simp]: "fds f \<noteq> 0" by (auto simp: fds_eq_iff)
  have "dirichlet_prod f (\<lambda>n. moebius_mu n * f n) n =
          (\<Sum>(r, d) | r * d = n. moebius_mu r * f (r * d))"
    by (subst dirichlet_prod_commutes)
       (simp add: fds_eq_iff fds_nth_mult fds_nth_fds dirichlet_prod_altdef2 mult_ac mult)
  also have "\<dots> = (\<Sum>(r, d) | r * d = n. moebius_mu r * f n)"
    by (intro sum.cong) auto
  also have "\<dots> = dirichlet_prod moebius_mu (\<lambda>_. 1) n * f n"
    by (simp add: dirichlet_prod_altdef2 sum_distrib_right case_prod_unfold mult)
  also have "dirichlet_prod moebius_mu (\<lambda>_. 1) n = fds_nth (fds moebius_mu * fds_zeta) n"
    by (simp add: fds_nth_mult)
  also have "fds moebius_mu * fds_zeta = 1"
    by (simp add: mult_ac fds_zeta_times_moebius_mu)
  also have "fds_nth 1 n * f n = fds_nth 1 n"
    by (auto simp: fds_eq_iff fds_nth_one)
  finally show ?thesis by (simp add: fds_nth_one)
qed

(* 2.23 *)
lemma dirichlet_prod_inversion_completely_multiplicative:
  fixes a :: "nat \<Rightarrow> 'a :: comm_ring_1"
  assumes "completely_multiplicative_function a"
  shows   "(\<forall>x\<ge>1. g x = dirichlet_prod' a f x) \<longleftrightarrow>
             (\<forall>x\<ge>1. f x = dirichlet_prod' (\<lambda>n. moebius_mu n * a n) g x)"
  by (intro dirichlet_prod'_inversion ext completely_multiplicative_imp_moebius_mu_inverse assms)

lemma divisor_sigma_conv_dirichlet_prod:
  "divisor_sigma x n = dirichlet_prod (\<lambda>n. real n powr x) (\<lambda>_. 1) n"
proof (cases "n = 0")
  case False
  have "fds (divisor_sigma x) = fds_shift x fds_zeta * fds_zeta"
    using fds_divisor_sigma[of x] by (simp add: mult_ac)
  thus ?thesis using False by (auto simp: fds_eq_iff fds_nth_mult)
qed simp_all

subsection \<open>Legendre's identity\<close>

definition legendre_aux :: "real \<Rightarrow> nat \<Rightarrow> nat" where
  "legendre_aux x p = (if prime p then (\<Sum>m | m > 0 \<and> real (p ^ m) \<le> x. nat \<lfloor>x / p ^ m\<rfloor>) else 0)"

lemma legendre_aux_not_prime [simp]: "\<not>prime p \<Longrightarrow> legendre_aux x p = 0"
  by (simp add: legendre_aux_def)

lemma legendre_aux_eq_0:
  assumes "real p > x"
  shows   "legendre_aux x p = 0"
proof (cases "prime p")
  case True
  have [simp]: "\<not>real p ^ m \<le> x" if "m > 0" for m
  proof -
    have "x < real p ^ 1" using assms by simp
    also have "\<dots> \<le> real p ^ m"
      using prime_gt_1_nat[OF True] that by (intro power_increasing) auto
    finally show ?thesis by auto
  qed
  from assms have *: "{m. m > 0 \<and> real (p ^ m) \<le> x} = {}"
    using prime_gt_1_nat[OF True] by auto
  show ?thesis unfolding legendre_aux_def
    by (subst *) auto
qed (auto simp: legendre_aux_def)

lemma legendre_aux_posD:
  assumes "legendre_aux x p > 0"
  shows   "prime p" "real p \<le> x"
proof -
  show "real p \<le> x" using legendre_aux_eq_0[of x p] assms
    by (cases "real p \<le> x") auto
qed (use assms in \<open>auto simp: legendre_aux_def split: if_splits\<close>)

lemma exponents_le_finite:
  assumes "p > (1 :: nat)" "k > 0"
  shows   "finite {i. real (p ^ (k * i + l)) \<le> x}"
proof (rule finite_subset)
  show "{i. real (p ^ (k * i + l)) \<le> x} \<subseteq> {..nat \<lfloor>x\<rfloor>}"
  proof safe
    fix i assume i: "real (p ^ (k * i + l)) \<le> x"
    have "i < 2 ^ i" by (induction i) auto
    also from assms have "i \<le> k * i + l" by (cases k) auto
    hence "2 ^ i \<le> (2 ^ (k * i + l) :: nat)"
      using assms by (intro power_increasing) auto
    also have "\<dots> \<le> p ^ (k * i + l)" using assms by (intro power_mono) auto
    also have "real \<dots> \<le> x" using i by simp
    finally show "i \<le> nat \<lfloor>x\<rfloor>" by linarith
  qed
qed auto

lemma finite_sum_legendre_aux:
  assumes "prime p"
  shows   "finite {m. m > 0 \<and> real (p ^ m) \<le> x}"
  by (rule finite_subset[OF _ exponents_le_finite[where k = 1 and l = 0 and p = p]])
     (use assms prime_gt_1_nat[of p] in auto)

lemma legendre_aux_set_eq:
  assumes "prime p" "x \<ge> 1"
  shows   "{m. m > 0 \<and> real (p ^ m) \<le> x} = {0<..nat \<lfloor>log (real p) x\<rfloor>}"
  using prime_gt_1_nat[OF assms(1)] assms
  by (auto simp: le_nat_iff le_log_iff le_floor_iff powr_realpow)

lemma legendre_aux_altdef1:
  "legendre_aux x p = (if prime p \<and> x \<ge> 1 then
                         (\<Sum>m\<in>{0<..nat \<lfloor>log (real p) x\<rfloor>}. nat \<lfloor>x / p ^ m\<rfloor>) else 0)"
proof (cases "prime p \<and> x < 1")
  case False
  thus ?thesis using legendre_aux_set_eq[of p x] by (auto simp: legendre_aux_def)
next
  case True
  have [simp]: "\<not>(real p ^ m \<le> x)" for m
  proof -
    have "x < real 1" using True by simp
    also have "real 1 \<le> real (p ^ m)"
      unfolding of_nat_le_iff by (intro one_le_power) (use prime_gt_1_nat[of p] True in auto)
    finally show "\<not>(real p ^ m \<le> x)" by auto
  qed
  have "{m. m > 0 \<and> real (p ^ m) \<le> x} = {}" by simp
  with True show ?thesis by (simp add: legendre_aux_def)
qed

lemma legendre_aux_altdef2:
  assumes "x \<ge> 1" "prime p" "real p ^ Suc k > x"
  shows   "legendre_aux x p = (\<Sum>m\<in>{0<..k}. nat \<lfloor>x / p ^ m\<rfloor>)"
proof -
  have "legendre_aux x p = (\<Sum>m | m > 0 \<and> real (p ^ m) \<le> x. nat \<lfloor>x / p ^ m\<rfloor>)"
    using assms by (simp add: legendre_aux_def)
  also have "\<dots> = (\<Sum>m\<in>{0<..k}. nat \<lfloor>x / p ^ m\<rfloor>)"
  proof (intro sum.mono_neutral_left)
    show "{m. 0 < m \<and> real (p ^ m) \<le> x} \<subseteq> {0<..k}"
    proof safe
      fix m assume "m > 0" "real (p ^ m) \<le> x"
      hence "real p ^ m \<le> x" by simp
      also note \<open>x < real p ^ Suc k\<close>
      finally show "m \<in> {0<..k}" using \<open>m > 0\<close>
        using prime_gt_1_nat[OF \<open>prime p\<close>] by (subst (asm) power_strict_increasing_iff) auto
    qed
  qed (use prime_gt_0_nat[of p] assms in \<open>auto simp: field_simps\<close>)
  finally show ?thesis .
qed

(* 3.14 *)
theorem legendre_identity:
  "sum_upto ln x = prime_sum_upto (\<lambda>p. legendre_aux x p * ln p) x"
proof -
  define S where "S = (SIGMA p:{p. prime p \<and> real p \<le> x}. {i. i > 0 \<and> real (p ^ i) \<le> x})"

  have prime_power_leD: "real p \<le> x" if "real p ^ i \<le> x" "prime p" "i > 0" for p i
  proof -
    have "real p ^ 1 \<le> real p ^ i"
      using that prime_gt_1_nat[of p] by (intro power_increasing) auto
    also have "\<dots> \<le> x" by fact
    finally show "real p \<le> x" by simp
  qed

  have "sum_upto ln x = sum_upto (\<lambda>n. mangoldt n * real (nat \<lfloor>x / real n\<rfloor>)) x"
    by (rule sum_upto_ln_conv_sum_upto_mangoldt)
  also have "\<dots> = (\<Sum>(p, i) | prime p \<and> 0 < i \<and> real (p ^ i) \<le> x.
                     ln p * real (nat \<lfloor>x / real (p ^ i)\<rfloor>))"
    by (subst sum_upto_primepows[where g = "\<lambda>p i. ln p * real (nat \<lfloor>x / real (p ^ i)\<rfloor>)"])
       (auto simp: mangoldt_non_primepow)
  also have "\<dots> = (\<Sum>(p,i)\<in>S. ln p * real (nat \<lfloor>x / p ^ i\<rfloor>))"
    using prime_power_leD by (intro sum.cong refl) (auto simp: S_def)
  also have "\<dots> = (\<Sum>p | prime p \<and> real p \<le> x. \<Sum>i | i > 0 \<and> real (p ^ i) \<le> x.
                     ln p * real (nat \<lfloor>x / p ^ i\<rfloor>))"
  proof (unfold S_def, subst sum.Sigma)
    have "{p. prime p \<and> real p \<le> x} \<subseteq> {..nat \<lfloor>x\<rfloor>}"
      by (auto simp: le_nat_iff le_floor_iff)
    thus "finite {p. prime p \<and> real p \<le> x}"
      by (rule finite_subset) auto
  next
    show "\<forall>p\<in>{p. prime p \<and> real p \<le> x}. finite {i. 0 < i \<and> real (p ^ i) \<le> x}"
      by (intro ballI finite_sum_legendre_aux) auto
  qed auto
  also have "\<dots> = (\<Sum>p | prime p \<and> real p \<le> x. ln p *
                    real (\<Sum>i | i > 0 \<and> real (p ^ i) \<le> x. (nat \<lfloor>x / p ^ i\<rfloor>)))"
    by (simp add: sum_distrib_left)
  also have "\<dots> = (\<Sum>p | prime p \<and> real p \<le> x. ln p * real (legendre_aux x p))"
    by (intro sum.cong refl) (auto simp: legendre_aux_def)
  also have "\<dots> = prime_sum_upto (\<lambda>p. ln p * real (legendre_aux x p)) x"
    by (simp add: prime_sum_upto_def)
  finally show ?thesis by (simp add: mult_ac)
qed

lemma legendre_identity':
  "fact (nat \<lfloor>x\<rfloor>) = (\<Prod>p | prime p \<and> real p \<le> x. p ^ legendre_aux x p)"
proof -
  have fin: "finite {p. prime p \<and> real p \<le> x}"
    by (rule finite_subset[of _ "{..nat \<lfloor>x\<rfloor>}"]) (auto simp: le_nat_iff le_floor_iff)
  have "real (fact (nat \<lfloor>x\<rfloor>)) = exp (sum_upto ln x)"
    by (subst sum_upto_ln_conv_ln_fact) auto
  also have "sum_upto ln x = prime_sum_upto (\<lambda>p. legendre_aux x p * ln p) x"
    by (rule legendre_identity)
  also have "exp \<dots> = (\<Prod>p | prime p \<and> real p \<le> x. exp (ln (real p) * legendre_aux x p))"
    unfolding prime_sum_upto_def using fin by (subst exp_sum) (auto simp: mult_ac)
  also have "\<dots> = (\<Prod>p | prime p \<and> real p \<le> x. real (p ^ legendre_aux x p))"
  proof (intro prod.cong refl)
    fix p assume "p \<in> {p. prime p \<and> real p \<le> x}"
    hence "p > 0" using prime_gt_0_nat[of p] by auto
    from \<open>p > 0\<close> have "exp (ln (real p) * legendre_aux x p) = real p powr real (legendre_aux x p)"
      by (simp add: powr_def)
    also from \<open>p > 0\<close> have "\<dots> = real (p ^ legendre_aux x p)"
      by (subst powr_realpow) auto
    finally show "exp (ln (real p) * legendre_aux x p) = \<dots>" .
  qed
  also have "\<dots> = real (\<Prod>p | prime p \<and> real p \<le> x. p ^ legendre_aux x p)"
    by simp
  finally show ?thesis unfolding of_nat_eq_iff .
qed

subsection \<open>A weighted sum of the Möbius \<open>\<mu>\<close> function\<close>

(* TODO: Move to Dirichlet_Series? *)

(* 3.13 *)
context
  fixes M :: "real \<Rightarrow> real"
  defines "M \<equiv> (\<lambda>x. sum_upto (\<lambda>n. moebius_mu n / n) x)"
begin

lemma abs_sum_upto_moebius_mu_over_n_less:
  assumes x: "x \<ge> 2"
  shows   "\<bar>M x\<bar> < 1"
proof -
  have "x * sum_upto (\<lambda>n. moebius_mu n / n) x - sum_upto (\<lambda>n. moebius_mu n * frac (x / n)) x =
          sum_upto (\<lambda>n. moebius_mu n * (x / n - frac (x / n))) x"
    by (subst mult.commute[of x])
       (simp add: sum_upto_def sum_distrib_right sum_subtractf ring_distribs)
  also have "(\<lambda>n. x / real n - frac (x / real n)) = (\<lambda>n. of_int (floor (x / real n)))"
    by (simp add: frac_def)
  also have "sum_upto (\<lambda>n. moebius_mu n * real_of_int \<lfloor>x / real n\<rfloor>) x =
               real_of_int (sum_upto (\<lambda>n. moebius_mu n * \<lfloor>x / real n\<rfloor>) x)"
    by (simp add: sum_upto_def)
  also have "\<dots> = 1"
    using x by (subst sum_upto_moebius_times_floor_linear) auto
  finally have eq: "x * M x = 1 + sum_upto (\<lambda>n. moebius_mu n * frac (x / n)) x"
    by (simp add: M_def)

  have "x * \<bar>M x\<bar> = \<bar>x * M x\<bar>"
    using x by (simp add: abs_mult)
  also note eq
  also have "\<bar>1 + sum_upto (\<lambda>n. moebius_mu n * frac (x / n)) x\<bar> \<le>
               1 + \<bar>sum_upto (\<lambda>n. moebius_mu n * frac (x / n)) x\<bar>"
    by linarith
  also have "\<bar>sum_upto (\<lambda>n. moebius_mu n * frac (x / n)) x\<bar> \<le>
               sum_upto (\<lambda>n. \<bar>moebius_mu n * frac (x / n)\<bar>) x"
    unfolding sum_upto_def by (rule sum_abs)
  also have "\<dots> \<le> sum_upto (\<lambda>n. frac (x / n)) x"
    unfolding sum_upto_def by (intro sum_mono) (auto simp: moebius_mu_def abs_mult)
  also have "\<dots> = (\<Sum>n\<in>{0<..nat \<lfloor>x\<rfloor>}. frac (x / n))"
    by (simp add: sum_upto_altdef)
  also have "{0<..nat \<lfloor>x\<rfloor>} = insert 1 {1<..nat \<lfloor>x\<rfloor>}"
    using x by (auto simp: le_nat_iff le_floor_iff)
  also have "(\<Sum>n\<in>\<dots>. frac (x / n)) = frac x + (\<Sum>n\<in>{1<..nat \<lfloor>x\<rfloor>}. frac (x / n))"
    by (subst sum.insert) auto
  also have "(\<Sum>n\<in>{1<..nat \<lfloor>x\<rfloor>}. frac (x / n)) < (\<Sum>n\<in>{1<..nat \<lfloor>x\<rfloor>}. 1)"
    using x by (intro sum_strict_mono frac_lt_1) auto
  also have "\<dots> = nat \<lfloor>x\<rfloor> - 1" by simp
  also have "1 + (frac x + real (nat \<lfloor>x\<rfloor> - 1)) = x"
    using x by (subst of_nat_diff) (auto simp: le_nat_iff le_floor_iff frac_def)
  finally have "x * \<bar>M x\<bar> < x * 1" by simp
  with x show "\<bar>M x\<bar> < 1"
    by (subst (asm) mult_less_cancel_left_pos) auto
qed

lemma sum_upto_moebius_mu_over_n_eq:
  assumes "x < 2"
  shows   "M x = (if x \<ge> 1 then 1 else 0)"
proof (cases "x \<ge> 1")
  case True
  have "M x = (\<Sum>n\<in>{n. n > 0 \<and> real n \<le> x}. moebius_mu n / n)"
    by (simp add: M_def sum_upto_def)
  also from assms True have "{n. n > 0 \<and> real n \<le> x} = {1}"
    by auto
  thus ?thesis using True by (simp add: M_def sum_upto_def)
next
  case False
  have "M x = (\<Sum>n\<in>{n. n > 0 \<and> real n \<le> x}. moebius_mu n / n)"
    by (simp add: M_def sum_upto_def)
  also from False have "{n. n > 0 \<and> real n \<le> x} = {}"
    by auto
  finally show ?thesis using False by (simp add: M_def)
qed

lemma abs_sum_upto_moebius_mu_over_n_le: "\<bar>M x\<bar> \<le> 1"
  using sum_upto_moebius_mu_over_n_eq[of x] abs_sum_upto_moebius_mu_over_n_less[of x]
  by (cases "x < 2") auto

end

end


section \<open>Relational Model of Cylindric Kleene and Liberation Lattices\<close>

theory Rel_Model
  imports Main

begin

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

notation relcomp (infixl ";" 75)

lemma relcomp_def: "(a,b) \<in> R ; S = (\<exists>c. (a,c) \<in> R \<and> (c,b) \<in> S)"
  by blast

lemma subid_meet_distl: "P \<subseteq> Id \<Longrightarrow> P ; (R \<inter> S) = P ; R \<inter> P ; S"
  by blast

lemma subid_meet_distr: "P \<subseteq> Id \<Longrightarrow> (R \<inter> S) ; P = R ; P \<inter> S ; P"
  by blast

text \<open>First we define equality up to variable i and prove properties.\<close>

definition eq_upto :: "'a \<Rightarrow> ('a \<Rightarrow> 'b) \<Rightarrow> ('a \<Rightarrow> 'b) \<Rightarrow> bool" where
  "eq_upto i f g = (\<forall>j. i \<noteq> j \<longrightarrow> f j = g j)"

lemma eq_upto_ref: "eq_upto i f f"
  unfolding eq_upto_def by simp

lemma eq_upto_sym: "eq_upto i f g = eq_upto i g f"
  unfolding eq_upto_def by force

lemma eq_upto_trans: "eq_upto i f g \<Longrightarrow> eq_upto i g h \<Longrightarrow> eq_upto i f h"
  unfolding eq_upto_def by force

lemma eq_upto_Id: "i \<noteq> j \<Longrightarrow> (eq_upto i f g \<and> eq_upto j f g) = (f = g)"
  unfolding eq_upto_def by force

lemma eq_upto_fun: "(\<forall>k. k \<noteq> i \<and> k \<noteq> j \<longrightarrow> a k = b k) \<Longrightarrow> \<exists>c.\<forall>k. (k \<noteq> i \<longrightarrow> a k = c k) \<and> (k \<noteq> j \<longrightarrow> c k = b k)"
proof-
  fix k
  assume h1: "\<forall>k. k \<noteq> i \<and> k \<noteq> j \<longrightarrow> a k = b k"
  hence "\<exists>c. c = (\<lambda>k. if k = i then b k else a k) \<and> (\<forall>k. (k \<noteq> i \<longrightarrow> a k = c k) \<and> (k \<noteq> j \<longrightarrow> c k = b k))"
    by simp
  thus "\<exists>c.\<forall>k. (k \<noteq> i \<longrightarrow> a k = c k) \<and> (k \<noteq> j \<longrightarrow> c k = b k)"
    by metis
qed

lemma eq_upto_comm: "(\<exists>c. eq_upto i a c \<and> eq_upto j c b) = (\<exists>c. eq_upto j a c \<and> eq_upto i c b)"
proof-
  have "(\<exists>c. eq_upto i a c \<and> eq_upto j c b) = (\<exists>c.\<forall>k. (k \<noteq> i \<longrightarrow> a k = c k) \<and> (k \<noteq> j \<longrightarrow> c k = b k))"
    unfolding eq_upto_def by auto
  also have "... = (\<forall>k. k \<noteq> i \<and> k \<noteq> j \<longrightarrow> a k = b k)"
    by (auto simp: eq_upto_fun)
  also have "... = (\<exists>c.\<forall>k. (k \<noteq> j \<longrightarrow> a k = c k) \<and> (k \<noteq> i \<longrightarrow> c k = b k))"
    by (auto simp: eq_upto_fun)
  also have "... = (\<exists>c. eq_upto j a c \<and> eq_upto i c b)"
    unfolding eq_upto_def by auto
  finally show ?thesis.
qed

definition eq_uptop :: "'a \<Rightarrow> (('a \<Rightarrow> 'b) \<times> ('a \<Rightarrow> 'b)) \<Rightarrow> (('a \<Rightarrow> 'b) \<times> ('a \<Rightarrow> 'b)) \<Rightarrow> bool" where
  "eq_uptop i fp gp = (\<forall>j. i \<noteq> j \<longrightarrow> ((fst fp) j = (fst gp) j \<and> (snd fp) j = (snd gp) j))"

lemma eq_uptop_upto [simp]: "eq_uptop i (f,g) (h,k) = (eq_upto i f h \<and> eq_upto i g k)"
  unfolding eq_uptop_def eq_upto_def by force

lemma eq_uptop_ref: "eq_uptop i (f,g) (f,g)"
  unfolding eq_uptop_upto by (simp add: eq_upto_ref)

lemma eq_uptop_sym: "eq_uptop i (f,g) (h,k) = eq_uptop i (h,k) (f,g)"
  unfolding eq_uptop_upto by (simp add: eq_upto_sym)

lemma eq_uptop_trans: "eq_uptop i (f,g) (h,k) \<Longrightarrow> eq_uptop i (h,k) (l,m) \<Longrightarrow> eq_uptop i (f,g) (l,m)"
  unfolding eq_uptop_upto by (meson eq_upto_trans)

text \<open>Next we define relational cylindrification.\<close>

definition cyl :: "'a \<Rightarrow> ('a,'b) crel \<Rightarrow> ('a,'b) crel" where
  "cyl i R = {(f,g). \<exists>h k. (\<forall>j. i \<noteq> j \<longrightarrow> (f j = h j \<and> g j = k j)) \<and> (h,k) \<in> R}"

lemma cyl_eq_uptop1: "cyl i R = {fp. \<exists>gp. eq_uptop i fp gp \<and> gp \<in> R}"
  unfolding cyl_def eq_uptop_def by (safe, auto)

lemma cyl_eq_uptop2: "cyl i R = {(f,g). \<exists>h k. eq_uptop i (f,g) (h,k) \<and> (h,k) \<in> R}"
  unfolding cyl_def eq_uptop_def by simp

lemma cyl_Id: "cyl i Id = {(f,g). eq_upto i f g}"
  unfolding cyl_def Id_def eq_upto_def by fastforce

lemma cyl_Id_var: "(a,b) \<in> cyl i Id = eq_upto i a b"
  by (simp add: cyl_Id)

lemma cyl_id_rel: "cyl i Id ; R = {(a,b). \<exists>c. eq_upto i a c \<and> (c,b) \<in> R}"
proof-
  {fix a b
  have "(a,b) \<in> cyl i Id ; R = (\<exists>c. (a,c) \<in> cyl i Id \<and> (c,b) \<in> R)"
    by force
  also have "... = (\<exists>c. eq_upto i a c \<and> (c,b) \<in> R)"
    unfolding cyl_Id by simp
  finally have "(a,b) \<in> cyl i Id ; R = (\<exists>c. eq_upto i a c \<and> (c,b) \<in> R)".}
  thus ?thesis
    by blast
qed

lemma rel_cyl_id: "R ; cyl i Id = {(a,b). \<exists>c. (a,c) \<in> R \<and> eq_upto i c b}"
proof-
  {fix a b
  have "(a,b) \<in> R ; cyl i Id  = (\<exists>c. (a,c) \<in> R \<and> (c,b) \<in> cyl i Id)"
    by force
  also have "... = (\<exists>c. (a,c) \<in> R \<and> eq_upto i c b)"
    unfolding cyl_Id by simp
  finally have "(a,b) \<in> R ; cyl i Id = (\<exists>c. (a,c) \<in> R \<and> eq_upto i c b)".}
  thus ?thesis
    by blast
qed

text \<open>We prove the fundamental identity of relational cylindrification and cylindrification of the identity.\<close>

lemma cyl_Id_rep: "cyl i R = cyl i Id ; R ; cyl i Id"
proof-
  {fix a b
  have "(a,b) \<in> cyl i Id ; R ; cyl i Id = (\<exists>c d. (a,c) \<in> cyl i Id \<and> (c,d) \<in> R \<and> (d,b) \<in> cyl i Id)"
    by blast
  also have "... = (\<exists>c d. eq_upto i a c \<and> (c,d) \<in> R \<and> eq_upto i d b)"
    unfolding cyl_Id by simp
  also have "... = (\<exists>c d. eq_uptop i (a,b) (c,d) \<and> (c,d) \<in> R)"
    by (meson eq_upto_sym eq_uptop_upto)
  also have "... = ((a,b) \<in> cyl i R)"
    by (simp add: cyl_eq_uptop2)
  finally have "(a,b) \<in> cyl i Id ; R ; cyl i Id = ((a,b) \<in> cyl i R)".}
  thus ?thesis
    by force
qed

text \<open>We derive the axioms of liberation l-monoids by using this fundamental identity.\<close>

lemma cyl_Id_emp [simp]: "cyl i Id ; {} = {}"
  by simp

lemma Id_cyl_Id: "Id \<subseteq> cyl i Id"
  using cyl_eq_uptop1 eq_uptop_ref by fastforce

lemma cyl_Id_inter: "cyl i Id ; (R \<inter> cyl i Id ; S) = cyl i Id ; R \<inter> cyl i Id ; S"
proof-
  {fix a b
    have "(a,b) \<in> cyl i Id ; (R \<inter> cyl i Id ; S) = (\<exists>c. eq_upto i a c \<and> (c,b) \<in> R \<and> (\<exists>d. eq_upto i c d \<and> (d,b) \<in> S))"
      unfolding cyl_Id by force
    also have "... = (\<exists>c. eq_upto i a c \<and> (c,b) \<in> R \<and> (\<exists>d. eq_upto i a d \<and> (d,b) \<in> S))"
      by (meson eq_upto_sym eq_upto_trans)
    also have "... = ((a,b) \<in> cyl i Id ; R \<inter> cyl i Id ; S)"
      by (smt Int_Collect cyl_id_rel mem_Collect_eq prod.simps(2))
    finally have "((a,b) \<in> cyl i Id ; (R \<inter> cyl i Id ; S)) = ((a,b) \<in> cyl i Id ; R \<inter> cyl i Id ; S)"
      by blast}
  thus ?thesis
    by blast
qed

lemma inter_cyl_Id: "(R \<inter> S; cyl i Id) ; cyl i Id = R ; cyl i Id \<inter> S ; cyl i Id"
proof-
  {fix a b
    have "(a,b) \<in> (R \<inter> S; cyl i Id) ; cyl i Id = (\<exists>c. (a,c) \<in> R \<and> (\<exists>d. (a,d) \<in> S \<and> eq_upto i d c) \<and> eq_upto i c b)"
      unfolding cyl_Id by force
    also have "... = (\<exists>c. (a,c) \<in> R \<and> (\<exists>d. (a,d) \<in> S \<and> eq_upto i d b) \<and> eq_upto i c b)"
      by (meson eq_upto_sym eq_upto_trans)
    also have "... = ((a,b) \<in> R ; cyl i Id \<inter> S ; cyl i Id)"
      by (smt Int_iff mem_Collect_eq rel_cyl_id split_conv)
    finally have "(a,b) \<in> (R \<inter> S; cyl i Id) ; cyl i Id = ((a,b) \<in> R ; cyl i Id \<inter> S ; cyl i Id)"
      by blast}
  thus ?thesis
    by blast
qed

lemma cyl_Id_idem [simp]: "cyl i Id ; cyl i Id = cyl i Id"
  by (metis R_O_Id cyl_Id_rep)

lemma cyl_Id_comm: "cyl i Id ; cyl j Id = cyl j Id ; cyl i Id"
proof-
  {fix a b :: "'a \<Rightarrow> 'b"
  have "(a,b) \<in> cyl i Id ; cyl j Id = (\<exists>c. eq_upto i a c \<and> eq_upto j c b)"
    by (simp add: cyl_Id relcomp.simps)
  also have "... = (\<exists>c. eq_upto j a c \<and> eq_upto i c b)"
    by (simp add: eq_upto_comm)
  also have "... = ((a,b) \<in> cyl j Id ; cyl i Id)"
    by (simp add: cyl_Id relcomp.simps)
  finally have "(a,b) \<in> cyl i Id ; cyl j Id = ((a,b) \<in> cyl j Id ; cyl i Id)".}
  thus ?thesis
    by blast
qed

lemma cyl_Id_Id: "i \<noteq> j \<Longrightarrow> cyl i Id \<inter> cyl j Id = Id"
proof-
  assume h: "i \<noteq> j"
  {fix a b :: "'a \<Rightarrow> 'b"
  have "(a,b) \<in> cyl i Id \<inter> cyl j Id = (eq_upto i a b \<and> eq_upto j a b)"
    unfolding cyl_Id by simp
  also have "... = (a = b)"
    by (simp add: eq_upto_Id h)
  finally have "(a,b) \<in> cyl i Id \<inter> cyl j Id = ((a,b) \<in> Id)"
    by simp}
  thus ?thesis
    by force
qed

lemma cyl_Id_inter_distl: "cyl i Id ; (cyl j Id \<inter> cyl k Id) = cyl i Id ; cyl j Id \<inter> cyl i Id ; cyl k Id"
proof-
  {fix a b :: "'a \<Rightarrow> 'b"
  have "(a,b) \<in> cyl i Id ; (cyl j Id \<inter> cyl k Id) = (\<exists>c. eq_upto i a c \<and> eq_upto j c b \<and> eq_upto k c b)"
    unfolding relcomp_def cyl_Id by simp
  also have "... = ((\<exists>c. eq_upto i a c \<and> eq_upto j c b) \<and> (\<exists>c. eq_upto i a c \<and> eq_upto k c b))"
    by (smt eq_upto_def)
  also have "... = ((a,b) \<in> cyl i Id ; cyl j Id \<inter> cyl i Id ; cyl k Id)"
    unfolding relcomp_def cyl_Id by force
  finally have "(a,b) \<in> cyl i Id ; (cyl j Id \<inter> cyl k Id) = ((a,b) \<in> cyl i Id ; cyl j Id \<inter> cyl i Id ; cyl k Id)".}
  thus ?thesis
    by force
qed

lemma cyl_Id_inter_disrl: "(cyl i Id \<inter> cyl j Id) ; cyl k Id = cyl i Id ; cyl k Id \<inter> cyl j Id ; cyl k Id"
proof-
  {fix a b :: "'a \<Rightarrow> 'b"
  have "(a,b) \<in> (cyl i Id \<inter> cyl j Id) ; cyl k Id = (\<exists>c. eq_upto i a c \<and> eq_upto j a c \<and> eq_upto k c b)"
    unfolding relcomp_def cyl_Id by simp
  also have "... = ((\<exists>c. eq_upto i a c \<and> eq_upto k c b) \<and> (\<exists>c. eq_upto j a c \<and> eq_upto k c b))"
    by (smt eq_upto_def)
  also have "... = ((a,b) \<in> cyl i Id ; cyl k Id \<inter> cyl j Id ; cyl k Id)"
    unfolding relcomp_def cyl_Id by force
  finally have "(a,b) \<in> (cyl i Id \<inter> cyl j Id) ; cyl k Id = ((a,b) \<in> cyl i Id ; cyl k Id \<inter> cyl j Id ; cyl k Id)".}
  thus ?thesis
    by force
qed

text \<open>Finally we provide three counterexamples and provide a relationship that is used in the definition of assignments.\<close>

lemma "cyl i Id ; cyl j Id = cyl i Id \<union> cyl j Id"
  (*nitpick*)
  oops

lemma "trancl (cyl i Id \<union> cyl j Id) = (cyl i Id \<union> cyl j Id)"
  (*nitpick*)
  oops

lemma "cyl i Id \<union> cyl j Id \<subseteq> cyl i Id ; cyl j Id"
  using Id_cyl_Id by fastforce

lemma "P \<subseteq> Id \<Longrightarrow> cyl i Id ; (cyl i P \<inter> Id) = cyl i P"
  by (smt Id_cyl_Id O_assoc R_O_Id cyl_Id_inter cyl_Id_rep dual_order.trans inf.orderE inf_commute inter_cyl_Id)

lemma "cyl i Id ; (cyl i R \<inter> Id) = cyl i R"
  (*nitpick*)
  oops

lemma "cyl i Id = Id"
  (*nitpick*)
  oops

lemma cyl_Id_comp: "cyl i (cyl j Id) = cyl i Id ; cyl j Id"
proof-
  have "cyl i (cyl j Id) = cyl i Id ; cyl j Id ; cyl i Id"
    by (meson cyl_Id_rep)
  also have "... = cyl i Id ; cyl i Id ; cyl j Id"
    by (metis O_assoc cyl_Id_comm)
  also have "... = cyl i Id ; cyl j Id"
    by simp
  finally show ?thesis.
qed

lemma cyl_Id_interp: "cyl i (cyl j Id \<inter> cyl k Id) = (cyl i Id ; cyl j Id) \<inter> (cyl i Id ; cyl k Id)"
  by (metis R_O_Id cyl_Id_Id cyl_Id_comp cyl_Id_inter_distl inf.idem)

text \<open>We prove a property of frames.\<close>

lemma "R \<inter> cyl i Id = {(a,b) \<in> R. \<exists>c. a = fun_upd b i c}"
  unfolding cyl_def Id_def fun_upd_def by force

lemma cyl_Id_meet_pres: "cyl i Id ; cyl j Id \<inter> cyl i Id ; cyl k Id \<subseteq> cyl i (cyl j Id \<inter> cyl k Id)"
  by (metis R_O_Id cyl_Id_Id cyl_Id_comp cyl_Id_inter_distl inf.idem set_eq_subset)

end