section \<open>Object-Free Categories\<close>

theory LR_Semigroup
  imports Main

begin

notation times (infixl "\<cdot>" 70)

subsection \<open>Relational Magmas and LR-Magmas\<close>

class relational_magma =
  fixes \<rho> ::"'a \<Rightarrow> 'a \<Rightarrow> 'a \<Rightarrow>bool"

begin

definition "\<Delta> x y = (\<exists>z. \<rho> z x y)"

definition "unitl e = ((\<exists>x. \<rho> x e x) \<and> (\<forall>x y. \<rho> y e x \<longrightarrow> y = x))"

definition "unitr e = ((\<exists>x. \<rho> x x e) \<and> (\<forall>x y. \<rho> y x e \<longrightarrow> y = x))"

abbreviation "unit e \<equiv> (unitl e \<or> unitr e)"

end

class unital_relational_magma = relational_magma +
  assumes unitl_ex: "\<forall>x.\<exists>e. unitl e \<and> \<Delta> e x"
  and unitr_ex: "\<forall>x.\<exists>e. unitr e \<and> \<Delta> x e"

begin

lemma unitl_idem: "unitl e \<Longrightarrow> \<rho> e e e"
proof-
  assume hyp: "unitl e"
  have "\<exists>e'. unitr e' \<and> \<Delta> e e'"
    using local.unitr_ex by auto
  hence "\<exists>e' z. unitr e' \<and> \<rho> z e e'"
    by (simp add: local.\<Delta>_def)
  hence "\<exists>e' z. unitr e' \<and> \<rho> z e e' \<and> z = e \<and> z = e'"
    using hyp local.unitl_def local.unitr_def by blast
  thus "\<rho> e e e"
    by simp
qed

lemma unitr_idem: "unitr e \<Longrightarrow> \<rho> e e e"
  by (metis local.\<Delta>_def local.unitl_def local.unitl_ex relational_magma.unitr_def)

lemma unit_idem: "unit e \<Longrightarrow> \<rho> e e e"
  using unitl_idem unitr_idem by blast

lemma unit_D: "unit e \<Longrightarrow> \<Delta> e e"
  using local.\<Delta>_def unit_idem by blast

lemma units_eq: "unit e\<^sub>1 \<Longrightarrow> unit e\<^sub>2 \<Longrightarrow> \<Delta> e\<^sub>1 e\<^sub>2 \<Longrightarrow> e\<^sub>1 = e\<^sub>2"
proof-
  assume hyp1: "unit e\<^sub>1"
  and hyp2: "unit e\<^sub>2"
  and hyp3: "\<Delta> e\<^sub>1 e\<^sub>2"
  hence "\<exists>x. \<rho> x e\<^sub>1 e\<^sub>2"
    by (simp add: local.\<Delta>_def)
  hence "\<exists>x. \<rho> x e\<^sub>1 e\<^sub>2 \<and> x = e\<^sub>1 \<and> x = e\<^sub>2"
    by (metis hyp1 hyp2 local.\<Delta>_def local.unitl_def local.unitl_ex local.unitr_def local.unitr_ex)
  thus "e\<^sub>1 = e\<^sub>2"
    by blast
qed

lemma units_iff: "unit e\<^sub>1 \<Longrightarrow> unit e\<^sub>2 \<Longrightarrow> (\<Delta> e\<^sub>1 e\<^sub>2 = (e\<^sub>1 = e\<^sub>2))"
  using unit_D units_eq by blast

end

class LR_magma = relational_magma +
fixes so :: "'a \<Rightarrow> 'a"
  and ta :: "'a \<Rightarrow> 'a"
  assumes Dlr: "\<Delta> x y \<Longrightarrow> (ta x = so y)"
  and l_absorb: "\<rho> x (so x) x"
  and r_absorb: "\<rho> x x (ta x)"
  and l_absorb_eq: "\<rho> y (so x) x \<Longrightarrow> x = y"
  and r_absorb_eq: "\<rho> y x (ta x) \<Longrightarrow> x = y"

begin

lemma lr_closed [simp]: "ta (so x) = so x"
proof-
  have "\<rho> x (so x) x"
    using local.l_absorb by force
  hence "\<Delta> (so x) x"
    using local.\<Delta>_def by blast
  thus ?thesis
    by (simp add: local.Dlr)
qed

lemma rl_closed [simp]: "so (ta x) = ta x"
  by (metis local.Dlr local.\<Delta>_def local.r_absorb)

lemma l_idem [simp]: "so (so x) = so x"
proof-
  have "so (so x) = so (ta (so x))"
    by simp
  also have "\<dots> = ta (so x)"
    using rl_closed by blast
  also have "\<dots> = so x"
    by simp
  finally show ?thesis.
qed

lemma r_idem [simp]: "ta (ta x) = ta x"
  by (metis lr_closed rl_closed)

lemma LR_fix: "(ta x = x) = (so x = x)"
  by (metis local.lr_closed local.rl_closed)

lemma lr_fix: "{x. so x = x} = {x. ta x = x}"
  by (simp add: LR_fix)

lemma l_idem_var: "\<rho> (so x) (so x) (so x)"
proof-
  have "\<rho> (so x) (so (so x)) (so x)"
    using local.l_absorb by blast
  thus ?thesis
    by simp
qed

lemma r_idem_var: "\<rho> (ta x) (ta x) (ta x)"
  by (metis local.l_absorb rl_closed)

lemma lr_comm: "\<rho> v (ta x) (so y) \<Longrightarrow> \<rho> w (so y) (ta x) \<Longrightarrow> v = w"
proof-
  assume h1: "\<rho> v (ta x) (so y)"
  and h2: "\<rho> w (so y) (ta x)"
  hence "ta (ta x) = so (so y)"
    using local.Dlr local.\<Delta>_def by blast
  hence b: "ta x = so y"
    by simp
  hence c: "v = ta x"
    by (metis h1 local.r_absorb_eq lr_closed)
  hence "w = ta x"
    by (metis b h2 local.r_absorb_eq r_idem)
  thus ?thesis
    by (simp add: c)
qed

lemma lr_comm_var: "\<rho> v (ta x) (so y) = \<rho> v (so y) (ta x)"
  using local.Dlr local.\<Delta>_def by force

lemma l_weak_twisted: "\<rho> u x y \<Longrightarrow> \<rho> v (so u) x \<Longrightarrow> \<rho> v x (so y)"
proof-
  assume h1: "\<rho> u x y"
  and h2: "\<rho> v (so u) x"
  hence a: "ta x = so y"
    using local.Dlr local.\<Delta>_def by blast
  hence "so u = so x"
    using h2 local.Dlr local.\<Delta>_def by fastforce
  hence "v = x"
    using h2 local.l_absorb_eq by auto
  thus ?thesis
    by (metis a local.r_absorb)
qed

lemma r_weak_twisted: "\<rho> u x y \<Longrightarrow>  \<rho> v y (ta u) \<Longrightarrow> \<rho> v (ta x) y"
  by (metis local.Dlr local.\<Delta>_def local.l_absorb local.r_absorb_eq rl_closed)

lemma l_comm_var: "\<rho> v (so x) (so y) = \<rho> v (so y) (so x)"
  using local.Dlr relational_magma.\<Delta>_def by fastforce

lemma r_comm_var: "\<rho> v (ta x) (ta y) = \<rho> v (ta y) (ta x)"
  by (metis local.l_comm_var rl_closed)

lemma l_export: "\<rho> u (so x) y \<Longrightarrow> \<rho> v (so x) (so y) \<Longrightarrow> so u = v"
  by (metis local.Dlr local.\<Delta>_def local.l_absorb_eq lr_closed)

lemma r_export: "\<rho> u x (ta y) \<Longrightarrow> \<rho> v (ta x) (ta y) \<Longrightarrow> ta u = v"
  by (metis local.Dlr local.\<Delta>_def local.r_absorb_eq rl_closed)

lemma "\<rho> x (so y) z \<Longrightarrow> so y = so z"
  using local.Dlr local.\<Delta>_def by fastforce

lemma "\<rho> x (so y) z \<Longrightarrow> \<exists>w. \<rho> w (so y) (so z)"
  using l_idem_var local.Dlr local.\<Delta>_def by fastforce

lemma "\<rho> x y (ta z) \<Longrightarrow> ta y = ta z"
  using local.Dlr local.\<Delta>_def by fastforce

lemma "\<rho> w y z \<Longrightarrow> \<rho> x y z \<Longrightarrow> w = x"
  nitpick
  oops

lemma "\<rho> v x y \<Longrightarrow> \<Delta> y z \<Longrightarrow> \<Delta> v z"
  nitpick
  oops

lemma "(\<forall>x y. ta x = so y \<longrightarrow> \<Delta> x y) \<Longrightarrow> (\<forall>v x y z. \<rho> v x y \<longrightarrow> \<Delta> y z \<longrightarrow> \<Delta> v z)"
  nitpick
  oops

end

sublocale LR_magma \<subseteq> rmc2: unital_relational_magma
  apply unfold_locales
  apply (metis local.Dlr local.\<Delta>_def local.l_absorb local.l_absorb_eq local.unitl_def)
  by (metis local.Dlr local.r_absorb local.r_absorb_eq local.unitr_def relational_magma.\<Delta>_def)

class coherent_relational_magma = relational_magma +
  assumes coherence: "\<rho> v x y \<Longrightarrow> \<Delta> y z \<Longrightarrow> \<Delta> v z"

class coherent_LR_magma = LR_magma +
  assumes lr_coherence: "ta x = so y \<Longrightarrow> \<Delta> x y"

begin

lemma coherence_eq: "\<Delta> x y = (ta x = so y)"
  using local.Dlr local.lr_coherence by blast

lemma "\<rho> w y z \<Longrightarrow> \<rho> x y z \<Longrightarrow> w = x"
  nitpick
  oops

end

subsection \<open>Partial Magmas\<close>

text \<open>Partial magmas are functional relational magmas.\<close>

class partial_magma = relational_magma +
  assumes functionality: "\<rho> w y z \<Longrightarrow> \<rho> x y z \<Longrightarrow> w = x"

begin

lemma "\<rho> v x y \<Longrightarrow> \<Delta> y z \<Longrightarrow> \<Delta> v z"
  nitpick
  oops

definition pcomp :: "'a \<Rightarrow> 'a \<Rightarrow> 'a" (infixl "\<otimes>" 70) where
  "x \<otimes> y = (THE z. \<rho> z x y)"

lemma functionality_var: "\<Delta> x y \<Longrightarrow> (\<exists>!z. \<rho> z x y)"
  using local.\<Delta>_def local.functionality by blast

lemma functionality_lem: "(\<exists>!z. \<rho> z x y) \<or> \<not>(\<Delta> x y)"
  using functionality_var by blast

lemma pcomp_def_var: "(\<Delta> x y \<and> x \<otimes> y = z) = \<rho> z x y"
  by (metis functionality_var pcomp_def relational_magma.\<Delta>_def the_equality)

lemma pcomp_def_var2: "\<Delta> x y \<Longrightarrow> ((x \<otimes> y = z) = \<rho> z x y)"
  using pcomp_def_var by blast

end

class unital_partial_magma = partial_magma + unital_relational_magma

begin

lemma p_unitl_ex: "\<forall>x.\<exists>e. unit e \<and> \<Delta> e x \<and> e \<otimes> x = x"
  by (metis (full_types) local.pcomp_def_var2 local.unitl_ex relational_magma.unitl_def)

lemma  p_unitr_ex: "\<forall>x.\<exists>e. unit e \<and> \<Delta> x e \<and> x \<otimes> e = x"
  by (metis (full_types) local.pcomp_def_var2 local.unitr_ex relational_magma.unitr_def)

lemma p_unit_idem: "unit e \<Longrightarrow> e \<otimes> e = e"
  using local.units_eq p_unitr_ex by blast

end

class partial_LR_magma = LR_magma + partial_magma

subsection \<open>Relational Semigroups\<close>

class relational_semigroup = relational_magma +
  assumes rel_assoc: "(\<exists>y. \<rho> y u v \<and> \<rho> x y w) = (\<exists>z. \<rho> z v w \<and> \<rho> x u z)"

class partial_semigroup = relational_semigroup + partial_magma

begin

text \<open>We verify the algebraic partial semigroup axioms. \<close>

lemma pcomp_assoc_delta: "(\<Delta> u v \<and> \<Delta> (u \<otimes> v) w) = (\<Delta> u (v \<otimes> w) \<and> \<Delta> v w)"
proof-
  have "(\<Delta> u v \<and> \<Delta> (u \<otimes> v) w) = (\<exists>x. \<Delta> u v \<and> \<Delta> x w \<and> x = u \<otimes> v)"
    by simp
  also have "\<dots> = (\<exists>x. \<rho> x u v \<and> \<Delta> x w)"
    by (metis local.pcomp_def_var)
  also have "\<dots> = (\<exists>x. \<rho> x v w \<and> \<Delta> u x)"
    by (meson local.pcomp_def_var local.rel_assoc)
  also have "\<dots> = (\<exists>x. \<Delta> v w \<and> x = v \<otimes> w \<and> \<Delta> u x)"
    by (metis local.pcomp_def_var)
  also have "\<dots> = (\<Delta> u (v \<otimes> w) \<and> \<Delta> v w)"
    by auto
  finally show ?thesis.
qed

lemma pcomp_assoc_prod: "\<Delta> x y \<and> \<Delta> (x \<otimes> y) z \<Longrightarrow> (x \<otimes> y) \<otimes> z = x \<otimes> (y \<otimes> z)"
  by (smt local.functionality_var local.pcomp_def_var local.rel_assoc)

end

class coherent_relational_semigroup = relational_semigroup + coherent_relational_magma

class of_semicategory = coherent_relational_semigroup + partial_semigroup

begin

lemma part_coherence: "\<Delta> x y \<Longrightarrow> \<Delta> y z \<Longrightarrow> \<Delta> (x \<otimes> y) z"
  using local.coherence local.pcomp_def_var by blast

lemma coherence_iff: "(\<Delta> x y \<and> \<Delta> y z) = (\<Delta> x y \<and> \<Delta> (x \<otimes> y) z)"
  using local.pcomp_assoc_delta part_coherence by blast

end

subsection \<open>Relational Monoids\<close>

class relational_monoid = relational_semigroup + unital_relational_magma

begin

lemma units_uniquel: "\<forall>x.\<exists>!e. unit e \<and> \<rho> x e x"

  by (metis local.\<Delta>_def local.rel_assoc local.unitl_ex local.units_eq relational_magma.unitl_def)

lemma units_uniquer: "\<forall>x.\<exists>!e. unit e \<and> \<rho> x x e"
  by (metis (no_types, hide_lams) local.\<Delta>_def local.rel_assoc local.unitl_ex local.unitr_ex relational_magma.unitl_def relational_magma.unitr_def)

lemma units_unique: "(\<forall>x y. \<Delta> x y) \<Longrightarrow> \<exists>!e. unit e"
  using local.unitl_ex local.units_iff by auto

text \<open>Next we define source and target operations.\<close>

definition source :: "'a \<Rightarrow> 'a" where
  "source x = (THE e. unit e \<and> \<rho> x e x)"

definition target :: "'a \<Rightarrow> 'a" where
  "target x = (THE e. unit e \<and> \<rho> x x e)"

text \<open>We can now verify the axioms of f-systems and lr-semigroups, as well as additional properties.\<close>

lemma source_unit: "unit (source x)"
  unfolding source_def by (metis (mono_tags, lifting) theI' units_uniquel)

lemma target_unit: "unit (target x)"
  unfolding target_def by (metis (mono_tags, lifting) theI' units_uniquer)

lemma source_absorbl: "\<rho> x (source x) x"
  unfolding source_def by (smt theI' units_uniquel)

lemma target_absorbr: "\<rho> x x (target x)"
  unfolding target_def by (smt theI units_uniquer)

lemma source_target_Def: "\<Delta> x y \<Longrightarrow> target x = source y"
  by (metis (mono_tags) local.rel_assoc local.unitr_ex local.units_eq relational_magma.\<Delta>_def source_absorbl source_unit target_absorbr target_unit)

text \<open>Units can now be characterised as fixpoints.\<close>

lemma unitl_source: "unitl x = (source x = x)"
  by (metis (full_types) local.unitl_ex local.unitl_idem local.units_eq source_absorbl source_unit units_uniquel)

lemma unitr_target: "unitr x = (target x = x)"
  by (metis (full_types) local.unitl_ex local.unitr_ex local.units_eq relational_magma.unitl_def target_absorbr target_unit)

text \<open>The following statements formalise equivalent properties of coherence.\<close>

lemma coherent1: "(\<forall>v x y z. \<rho> v x y \<longrightarrow> \<Delta> y z \<longrightarrow> \<Delta> v z) = (\<forall>e x y. unit e \<longrightarrow> \<rho> x x e \<longrightarrow> \<rho> y e y \<longrightarrow> \<Delta> x y)"
  apply standard
  using local.\<Delta>_def apply blast
  by (metis local.\<Delta>_def local.rel_assoc source_absorbl source_target_Def target_absorbr unitr_target)

lemma coherent2: "(\<forall>e x y. unit e \<longrightarrow> \<rho> x x e \<longrightarrow> \<rho> y e y \<longrightarrow> \<Delta> x y) = (\<forall>x y. target x = source y \<longrightarrow> \<Delta> x y)"
  apply standard
  apply (metis source_absorbl source_unit target_absorbr)
  by (metis (full_types) local.unit_D relational_magma.\<Delta>_def source_target_Def)

end

class partial_monoid = relational_monoid + partial_magma

begin

text \<open>Using the syntax for definedness and composition in partial monoids, we
can now derive algebraic versions of the relational properties above.\<close>

lemma alg_units_uniquel: "\<forall>x.\<exists>!e. unit e \<and> \<Delta> e x \<and> e \<otimes> x = x"
  by (simp add: local.pcomp_def_var units_uniquel)

lemma alg_units_uniquer: "\<forall>x.\<exists>!e. unit e \<and> \<Delta> x e \<and> x \<otimes> e = x"
  by (simp add: local.pcomp_def_var units_uniquer)

end

class coherent_relational_monoid = relational_monoid + coherent_relational_magma

begin

text \<open>The following statements formalise again coherence properties.\<close>

lemma coherence_conv: "\<rho> v x y \<Longrightarrow> (\<Delta> v z = \<Delta> y z)"
  by (metis (full_types) local.coherence local.rel_assoc relational_magma.\<Delta>_def)

lemma coherence_alt: "unit e \<Longrightarrow> \<rho> x x e \<Longrightarrow> \<rho> y e y \<Longrightarrow> \<Delta> x y"
  using coherence_conv local.\<Delta>_def by blast

lemma coherence_iff: "\<Delta> x y = (\<exists>e. unit e \<and> \<Delta> x e \<and> \<Delta> e y)"
  by (metis coherence_conv local.source_target_Def local.target_absorbr local.unitl_ex local.units_eq)

lemma coherence_conv2: "target x = source y \<Longrightarrow> \<Delta> x y"
  using coherence_alt local.coherent2 by blast

lemma coherence_iff2: "(target x = source y) = \<Delta> x y"
  using coherence_alt local.coherent2 local.source_target_Def by blast

end

class of_category = of_semicategory + partial_monoid

subsection \<open>Relational LR-Semigroups\<close>

class LR_semigroup = LR_magma + relational_semigroup

sublocale relational_monoid \<subseteq> rmc: LR_semigroup _  source target
  apply unfold_locales
      apply (simp_all add: source_absorbl target_absorbr \<Delta>_def source_target_Def)
   apply (metis local.source_target_Def local.source_unit local.unit_D local.unitl_source local.unitr_target relational_magma.unitl_def)
  by (metis local.source_target_Def local.target_unit local.unit_D local.unitr_target relational_magma.\<Delta>_def relational_magma.unitr_def)

sublocale LR_semigroup \<subseteq> rmc22: relational_monoid..

sublocale monoid_mult \<subseteq> mmlr: LR_semigroup "\<lambda>x y z. x = y \<cdot> z" "\<lambda>x. 1" "\<lambda>y. 1"
  by unfold_locales (simp_all add: mult_assoc)

context LR_semigroup
begin

lemma l_strong_local: "\<rho> v x y \<Longrightarrow> so v = so x"
proof-
  assume hyp: "\<rho> v x y"
  hence "\<rho> v (so v) v \<and> \<rho> v x y"
    by (simp add: local.l_absorb)
  hence "\<exists>w. \<rho> w (so v) x \<and> \<rho> v w y"
    using local.rel_assoc by blast
  hence "ta (so v) = so x"
    using local.Dlr local.\<Delta>_def by blast
  thus ?thesis
    by simp
qed

lemma r_strong_local: "\<rho> v x y \<Longrightarrow> ta v = ta y"
  by (metis local.Dlr local.r_absorb local.rel_assoc relational_magma.\<Delta>_def)

lemma l_local: "\<rho> v x y \<Longrightarrow> \<rho> w x (so y) \<Longrightarrow> so v = so w"
  by (simp add: l_strong_local)

lemma r_local: "\<rho> v x y \<Longrightarrow> \<rho> w (ta x) y \<Longrightarrow> ta v = ta w"
  by (simp add: r_strong_local)

lemma r_twisted: "\<rho> u x y \<Longrightarrow> (\<rho> v (ta x) y = \<rho> v y (ta u))"
  apply standard
proof -
  assume a1: "\<rho> u x y"
  assume "\<rho> v (ta x) y"
  then have "v = y"
    using local.Dlr local.\<Delta>_def local.l_absorb_eq by force
  then show "\<rho> v y (ta u)"
    using a1 local.r_absorb r_strong_local by presburger
next
  assume h1: "\<rho> u x y"
  and "\<rho> v y (ta u)"
  thus "\<rho> v (ta x) y"
    using local.r_weak_twisted by auto
qed

lemma l_twisted: "\<rho> u x y \<Longrightarrow> (\<rho> v x (so y) = \<rho> v (so u) x)"
  apply standard
  apply (metis l_strong_local local.Dlr local.l_absorb local.r_absorb_eq relational_magma.\<Delta>_def)
  by (simp add: local.l_weak_twisted)

lemma "\<rho> x y z \<Longrightarrow> \<rho> x' y z \<Longrightarrow> so x = so x'"
  by (simp add: l_strong_local)

lemma coherence_iff: "(\<forall>x y. \<Delta> x y = (ta x = so y)) = (\<forall>v x y z. \<rho> v x y \<longrightarrow> \<Delta> y z \<longrightarrow> \<Delta> v z)"
  apply standard
  apply (simp add: r_strong_local)
  by (metis local.Dlr local.r_absorb local.rmc2.unitl_ex relational_magma.unitl_def)

end

class coherent_LR_semigroup = LR_semigroup + coherent_LR_magma

begin

lemma "\<rho> v x y \<Longrightarrow> \<Delta> y z \<Longrightarrow> \<Delta> v z"
  by (simp add: local.coherence_eq local.r_strong_local)

end

class partial_LR_semigroup = LR_semigroup + partial_semigroup

begin

lemma pl_absorb [simp]: "so x \<otimes> x = x"
  using local.l_absorb local.pcomp_def_var by auto

lemma pr_absorb [simp]: "x \<otimes> ta x = x"
  using local.pcomp_def_var local.r_absorb by auto

end

class LR_category = coherent_LR_semigroup + partial_semigroup

begin

lemma pl_local: "ta x = so y \<Longrightarrow> so (x \<otimes> y) = so x"
  using local.coherence_eq local.l_strong_local local.pcomp_def_var2 by blast

lemma pr_local: "ta x = so y \<Longrightarrow> ta (x \<otimes> y) = ta y"
  using local.coherence_eq local.pcomp_def_var2 local.r_strong_local by blast

lemma p_assoc: "ta x = so y \<Longrightarrow> ta y = so z \<Longrightarrow> (x \<otimes> y) \<otimes> z = x \<otimes> (y \<otimes> z)"
  by (simp add: local.coherence_eq local.pcomp_assoc_prod pr_local)

end

sublocale LR_category \<subseteq> lrof: of_category
  by unfold_locales (simp add: local.coherence_eq local.r_strong_local)

sublocale of_category \<subseteq> oflr: LR_category _ source target
  apply unfold_locales
  using local.coherence local.coherent1 local.coherent2 by blast

text \<open>The next two sublocale statements relate coherent relational monoids and LR-semigroups.\<close>

class LR_cat2 = partial_magma +
fixes l :: "'a \<Rightarrow> 'a"
  and r :: "'a \<Rightarrow> 'a"
  assumes Dlr: "\<Delta> x y = (r x = l y)"
  and lr_clo [simp]: "r (l x) = l x"
  and rl_clo [simp]: "l (r x) = r x"
  and l_abs [simp]: "l x \<otimes> x = x"
  and r_abs [simp]: "x \<otimes> r x = x"
  and l_loc: "r x = l y \<Longrightarrow> l (x \<otimes> y) = l x"
  and r_loc: "r x = l y \<Longrightarrow> r (x \<otimes> y) = r y"
  and assoc: "r x = l y \<Longrightarrow> r y = l z \<Longrightarrow> x \<otimes> (y \<otimes> z) = (x \<otimes> y) \<otimes> z"

begin

lemma assoc_def: "(\<Delta> u v \<and> \<Delta> (u \<otimes> v) w) = (\<Delta> u (v \<otimes> w) \<and> \<Delta> v w)"
  using local.Dlr local.l_loc local.r_loc by auto

end

sublocale LR_cat2 \<subseteq> lrred1: LR_category _ l r
  apply unfold_locales
        apply (simp_all add: local.Dlr)
  using local.Dlr local.l_abs local.lr_clo local.pcomp_def_var apply blast
  using local.Dlr local.pcomp_def_var apply fastforce
  using local.pcomp_def_var apply force+
  by (smt local.Dlr local.assoc local.assoc_def local.pcomp_def_var)

sublocale LR_category \<subseteq> lrrde2: LR_cat2 _ so ta
  apply unfold_locales
         apply (simp_all add: pl_local pr_local p_assoc coherence_eq)
  using local.l_absorb local.pcomp_def_var apply blast
  using local.pcomp_def_var local.r_absorb by blast

text \<open>The next two sublocale statements relate object_free categories and LR-categories.\<close>

sublocale of_category \<subseteq> ofrl1: LR_cat2 _ source target ..

sublocale LR_cat2 \<subseteq> ofrl2: of_category..

subsection \<open>Categories\<close>

locale category =
  fixes id :: "'objects \<Rightarrow> 'arrows"
  and dom :: "'arrows \<Rightarrow> 'objects"
  and cod :: "'arrows \<Rightarrow> 'objects"
  and comp :: "'arrows \<Rightarrow> 'arrows \<Rightarrow> 'arrows" (infixl "\<odot>" 70)
assumes dom_id [simp]: "dom (id X) = X"
and cod_id [simp]: "cod (id X) = X"
and id_dom [simp]: "id (dom f) \<odot> f = f"
and id_cod [simp]: "f \<odot> id (cod f) = f"
and dom_loc [simp]: "cod f = dom g \<Longrightarrow> dom (f \<odot> g) = dom f"
and cod_loc [simp]: "cod f = dom g \<Longrightarrow> cod (f \<odot> g) = cod g"
and assoc: "cod f = dom g \<Longrightarrow> cod g = dom h \<Longrightarrow> (f \<odot> g) \<odot> h = f \<odot> (g \<odot> h)"

begin

lemma "cod f = dom g \<Longrightarrow> dom (f \<odot> g) = dom (f \<odot> id (dom g))"
  by simp

abbreviation "Lc f \<equiv> id (dom f)"

abbreviation "Rc f \<equiv> id (cod f)"

abbreviation "Rel \<equiv> \<lambda>f g h. Rc g = Lc h \<and> f = g \<odot> h"

end

sublocale category \<subseteq> catlr: LR_category Rel Lc Rc
  apply unfold_locales
         apply simp_all
  apply (simp add: relational_magma.\<Delta>_def)
   apply (metis cod_loc dom_id dom_loc local.assoc)
  by (simp add: relational_magma.\<Delta>_def)

typedef (overloaded) 'a lr_objects = "{(x::'a::LR_category). so x = x}"
  by (meson mem_Collect_eq rl_closed)

setup_lifting type_definition_lr_objects

lemma Lfix_coerce [simp]: "Abs_lr_objects (so (Rep_lr_objects X)) = X"
  by (metis (mono_tags, lifting) CollectD Rep_lr_objects Rep_lr_objects_inverse)

lemma Rfix_coerce [simp]: "Abs_lr_objects (ta (Rep_lr_objects X)) = X"
  by (metis (mono_tags, lifting) CollectD Rep_lr_objects Rep_lr_objects_inverse lr_closed)

(*sublocale LR_category \<subseteq> lrcat: category Rep_lr_objects "Abs_lr_objects \<circ> L" "Abs_lr_objects \<circ> R" "(\<otimes>)"
  apply unfold_locales
        apply (simp_all add: Abs_lr_objects_inverse Abs_lr_objects_inject)
    apply (simp add: LR_category_class.LR_dom_local)
   apply (simp add: LR_category_class.LR_cod_local)
  by (simp add: LR_category_class.LR_assoc)*)

subsection \<open>f-Systems\<close>

class f_system = semigroup_mult +
  fixes L :: "'a \<Rightarrow> 'a"
  and R :: "'a \<Rightarrow> 'a"
assumes f1: "L (R x) = R x"
and f2: "R (L x) = L x"
and f3: "L x \<cdot> x = x"
and f4: "x \<cdot> R x = x"
and f5: "L (x \<cdot> y) = L (x \<cdot> L y)"
and f6: "R (x \<cdot> y) = R (R x \<cdot> y)"
and f7: "L x \<cdot> R y = R y \<cdot> L x"
and f8: "R x \<cdot> y = y \<cdot> R (x \<cdot> y)"

begin

lemma "L (x \<cdot> y) = L x"
  nitpick
  oops

end

subsection \<open>Zero\<close>

class relational_magma_zero = relational_magma + zero +
  assumes zerol: "\<rho> 0 0 x"
  and zeror: "\<rho> 0 x 0"

class relational_semigroup_zero = relational_semigroup + relational_magma_zero

begin

lemma rel_semigroup_total: "\<Delta> x y"
proof-
  have "\<rho> 0 x 0 \<and> \<rho> 0 y 0"
    by (simp add: local.zeror)
  hence "\<exists>z. \<rho> 0 x z \<and> \<rho> z y 0"
    by blast
  hence "\<exists>z. \<rho> 0 z 0 \<and> \<rho> z x y"
    using local.rel_assoc by blast
  thus "\<Delta> x y"
    using local.\<Delta>_def by blast
qed

end

class relational_monoid_zero = relational_monoid + relational_magma_zero

begin

text \<open>The next statements yield weak notions of unit.\<close>

lemma "unitl e \<Longrightarrow> (\<exists>x. \<rho> x e x) \<and> (\<forall>x. \<rho> x e x \<or> \<rho> 0 e x)"
  using local.units_uniquel local.zeror by blast

lemma "unitr e \<Longrightarrow> (\<exists>x. \<rho> x x e) \<and> (\<forall>x. \<rho> x x e \<or> \<rho> 0 x e)"
  by (metis local.units_uniquel local.units_uniquer local.zeror)

text \<open>The next statement shows that every relational monoid with zero has one single unit.\<close>

lemma "unit e \<Longrightarrow> unit e' \<Longrightarrow> D e e'\<Longrightarrow> e = e'"
  using local.units_uniquel local.zeror by auto

lemma "\<exists>!e. unit e"
  using local.units_uniquer local.zerol by blast

end

class partial_monoid_zero = relational_monoid_zero + partial_monoid

begin

lemma "unit 0"
  nitpick
  oops

lemma "\<not> unit 0"
  nitpick
  oops

lemma "\<rho> x 0 y \<Longrightarrow> x = 0"
  by (simp add: local.functionality local.zerol)

end

end


theory CVP_p

imports Main
        "poly-reductions/Karp21/Reductions"
        (*"poly-reducrions/Karp21/Three_Sat_To_Set_Cover"*)
        Lattice_int
        Subset_Sum

begin

text \<open>This file provides the reduction proof of Subset Sum to CVP in $\ell_p$.
  I could not find general p-norms (maybe not yet defined?)
  Proof can be easily adjusted by changing the locale variables.\<close>

definition pth_p_norm_vec :: "nat \<Rightarrow> ('a::{abs, power, comm_monoid_add}) vec \<Rightarrow> 'a" where
  "pth_p_norm_vec p v = (\<Sum>i<dim_vec v. \<bar>v$i\<bar>^p)"

locale fixed_p =
fixes p::nat (*p\<ge>1 is necessary to define a proper norm*)
assumes p_def: "p\<ge>1"
begin

definition "p_norm_vec \<equiv> pth_p_norm_vec p"

text \<open>The CVP  in $l_2$\<close>

text \<open>The closest vector problem.\<close>
definition is_closest_vec :: "int_lattice \<Rightarrow> int vec \<Rightarrow> int vec \<Rightarrow> bool" where
  "is_closest_vec L b v \<equiv> (is_lattice L) \<and>
    (\<forall>x\<in>L. p_norm_vec (x - b) \<ge> p_norm_vec (v - b) \<and> v\<in>L)"

text \<open>The decision problem associated with solving CVP exactly.\<close>
definition gap_cvp :: "(int_lattice \<times> int vec \<times> real) set" where
  "gap_cvp \<equiv> {(L, b, r). (is_lattice L) \<and> (\<exists>v\<in>L. of_int (p_norm_vec (v - b)) \<le> r^p)}"

(*Reminder: p_norm_vec is the p-th power of the p_norm!*)

text \<open>Reduction function for Subset Sum to CVP in euclidean norm\<close>

definition gen_basis_p :: "int vec \<Rightarrow> int mat" where
  "gen_basis_p as = mat (dim_vec as + 1) (dim_vec as) (\<lambda> (i, j). if i = 0 then as$j
    else (if i = j + 1 then 2 else 0))"

definition gen_t_p :: "int vec \<Rightarrow> int \<Rightarrow> int vec" where
  "gen_t_p as s = vec (dim_vec as + 1) ((\<lambda> i. 1)(0:= s))"

definition reduce_cvp_subset_sum_p ::
  "((int vec) * int) \<Rightarrow> (int_lattice * (int vec) * real)" where
  "reduce_cvp_subset_sum_p \<equiv> (\<lambda> (as,s).
    (gen_lattice (gen_basis_p as), gen_t_p as s, root p (dim_vec as)))"

text \<open>Lemmas for Proof\<close>

lemma vec_lambda_eq[intro]: "(\<forall>i<n. a i = b i) \<longrightarrow> vec n a = vec n b"
by auto

lemma eq_fun_applic: assumes "x = y" shows "f x = f y"
using assms by auto

lemma sum_if_zero:
  assumes "finite A" "i\<in>A"
  shows "(\<Sum>j\<in>A. (if i = j then a j else 0)) = a i"
proof -
  have "(\<Sum>x\<in>A. if x = i then a x else 0) =
  (if i = i then a i else 0) + (\<Sum>x\<in>A - {i}. if x = i then a x else 0)"
  using sum.remove[OF assms, of "(\<lambda>x. if x = i then a x else 0)"] by auto
  then show ?thesis by (simp add: assms(1))
qed

lemma set_compr_elem:
  assumes "finite A" "a\<in>A"
  shows "{f i | i. i\<in>A} = {f a} \<union> {f i | i. i\<in>A-{a}}"
by (safe, use assms in \<open>auto\<close>)

lemma Bx_rewrite:
  assumes x_dim: "dim_vec as = dim_vec x"
  shows "(gen_basis_p as) *\<^sub>v x =
    vec (dim_vec as + 1) (\<lambda> i. if i = 0 then (x \<bullet> as)
    else (2 * x$(i-1)))"
    (is "?init_vec = ?goal_vec")
proof -
  define n::nat where n_def: "n = dim_vec as"
  have "vec n (\<lambda>j. (as $ j)) \<bullet>  x = (x \<bullet> as)"
    unfolding n_def scalar_prod_def using x_dim by (simp add: mult.commute)
  then show ?thesis
    unfolding gen_basis_p_def reduce_cvp_subset_sum_p_def gen_t_p_def
  proof (intro eq_vecI, auto simp add: n_def, goal_cases)
    case (1 i)
    have "(\<Sum>ia = 0..<dim_vec x.
      vec (dim_vec as) (\<lambda>j.  (if i = (Suc j) then 2 else 0)) $ ia * x $ ia) =
      (\<Sum>ia<n.  (if i = ia+1 then 2 * (x $ ia) else 0))"
      by (intro sum.cong, auto simp add: n_def x_dim)
    also have "\<dots> = (\<Sum>ib\<in>{1..<n+1}.
         (if i = ib then 2 * (x $ (ib-1)) else 0))"
    proof -
      have eq: "(\<lambda>ib.  (if i = ib then 2 * x $ (ib - 1) else 0)) \<circ> (+) 1
          = (\<lambda>ia.  (if i = ia + 1 then 2 * x $ ia else 0))"
      by auto
      then show ?thesis
        by (subst sum.atLeastLessThan_shift_0[
            of "(\<lambda>ib.  (if i = ib then 2 * x $ (ib - 1) else 0))" 1 "n+1"])
          (subst eq, use lessThan_atLeast0 in \<open>auto\<close>)
    qed
    also have "\<dots> = 2 *  (x $ (i-1))"
    proof -
      have finite: "finite {1..<n+1}" by auto
      have is_in: "i \<in> {1..<n+1}" using 1 by (auto simp add: n_def)
      show ?thesis
      by (subst sum_if_zero[OF finite is_in, of "(\<lambda>k. 2 * (x $ (k-1)))"], auto)
    qed
    finally show ?case unfolding scalar_prod_def by auto
  qed
qed

lemma Bx_s_rewrite:
  assumes x_dim: "dim_vec as = dim_vec x"
  shows "(gen_basis_p as) *\<^sub>v x - (gen_t_p as s) =
    vec (dim_vec as + 1) (\<lambda> i. if i = 0 then  (x \<bullet> as - s) else  (2 * x$(i-1) - 1))"
    (is "?init_vec = ?goal_vec")
unfolding gen_t_p_def by (subst  Bx_rewrite[OF assms], auto)

lemma p_norm_vec_Bx_s:
  assumes x_dim: "dim_vec as = dim_vec x"
  shows "p_norm_vec ((gen_basis_p as) *\<^sub>v x - (gen_t_p as s)) =
     \<bar>x \<bullet> as - s\<bar>^p + (\<Sum>i=1..<dim_vec as +1. \<bar>2*x$(i-1)-1\<bar>^p)"
proof -
  let ?init_vec = "(gen_basis_p as) *\<^sub>v x - (gen_t_p as s)"
  let ?goal_vec = "vec (dim_vec as + 1) (\<lambda> i. if i = 0 then (x \<bullet> as - s)
       else  (2 * x$(i-1) - 1))"
  have "p_norm_vec ?init_vec = p_norm_vec ?goal_vec" using Bx_s_rewrite[OF x_dim] by auto
  also have "\<dots> = (\<Sum>i\<in>{0..<dim_vec as+1}. \<bar>?goal_vec$i\<bar>^p)"
    unfolding p_norm_vec_def pth_p_norm_vec_def by (metis atLeast0LessThan dim_vec)
  also have "\<dots> = \<bar>x \<bullet> as - s\<bar>^p + (\<Sum>i\<in>{1..<dim_vec as+1}. \<bar>2*x$(i-1)-1\<bar>^p)"
  proof -
    have subs: "{0}\<subseteq>{0..<dim_vec as+1}" by auto
    have "{0..<dim_vec as +1} = {0} \<union> {1..<dim_vec as +1}" by auto
    then show ?thesis by (subst sum.subset_diff[OF subs],auto)
  qed
  finally show ?thesis by blast
qed

find_theorems sum name: split

text \<open>gen_basis_p actually generates a basis which is spans the int_lattice (by definition) and
  is linearly independent.\<close>

lemma is_indep_gen_basis_p:
  "is_indep (real_of_int_mat (gen_basis_p as))"
unfolding is_indep_def
proof (safe, goal_cases)
case (1 z)
  let ?n = "dim_vec as"
  have z_dim: "dim_vec z = ?n" using 1(2) unfolding gen_basis_p_def by auto
  have dim_row: "dim_row (gen_basis_p as) = ?n + 1" unfolding gen_basis_p_def by auto
  have eq: "(real_of_int_mat (gen_basis_p as)) *\<^sub>v z = vec (?n + 1) (\<lambda> i. if i = 0
    then z \<bullet> (real_of_int_vec as) else (2 * z$(i-1)))"
  (is "(real_of_int_mat (gen_basis_p as)) *\<^sub>v z = ?goal_vec")
  proof -
    have scal_prod_com: "z \<bullet> real_of_int_vec as = real_of_int_vec as \<bullet> z"
      using comm_scalar_prod[of "real_of_int_vec as" ?n z] z_dim
      by (metis carrier_dim_vec index_map_vec(2) real_of_int_vec_def)
    have *: "row (of_int_hom.mat_hom (mat (?n+1) (?n) (\<lambda>x.
      (case x of (i, j) \<Rightarrow> if i = 0 then as $ j
                           else if i = j + 1 then 2 else 0)))) i =
      (if i=0 then real_of_int_vec as else vec ?n (\<lambda>j. if i = j + 1 then 2 else 0))"
    (is "?row = ?vec")
    if "i<?n+1" for i
    using that by (auto simp add: real_of_int_vec_def)
    then have row_prod: "?row i \<bullet> z =
      (if i = 0 then (real_of_int_vec as) \<bullet> z else 2 * z $ (i - 1))"
    if "i<?n+1" for i
    using that proof (subst *[OF that], auto, goal_cases)
    case 1
      have plus_2: "(i-1 = j) = (i = j+1)" for j using 1 that by auto
      have finite: "finite {0..<?n}" and elem: "i-1 \<in> {0..<?n}" using that 1 by auto
      have vec: "vec (dim_vec as) (\<lambda>j. if i = j+1 then 2 else 0) $ ia =
        (if i = ia+1 then 2 else 0)" if "ia<?n" for ia
        using index_vec that by blast
      then have "(\<Sum>ia = 0..<dim_vec z.
        vec (dim_vec as) (\<lambda>j. if i = Suc j then 2 else 0) $ ia * z $ ia) =
        (\<Sum>ia = 0..<dim_vec as. (if i = ia+1 then 2 else 0) * z $ ia)"
        using z_dim by auto
      also have "\<dots> = (\<Sum>ia = 0..<dim_vec as. (if i = ia+1 then 2 * z $ ia else 0))"
        proof -
          have "(\<forall>n. (0 = (if i = n + 1 then 2 else 0) * z $ n \<or> n + 1 = i) \<and>
            (2 * z $ n = (if i = n + 1 then 2 else 0) * z $ n \<or> n + 1 \<noteq> i)) \<or>
            (\<Sum>n = 0..<dim_vec as. (if i = n + 1 then 2 else 0) * z $ n) =
            (\<Sum>n = 0..<dim_vec as. if i = n + 1 then 2 * z $ n else 0)" by simp
          then show ?thesis by (metis (no_types))
        qed
      also have "\<dots> = 2*z$(i- Suc 0)"
        using plus_2 by (smt (verit, ccfv_SIG) One_nat_def sum_if_zero[OF finite elem,
          of "(\<lambda>j. 2*z$j)"] sum.cong)
      finally show ?case unfolding scalar_prod_def by blast
    qed
    have "?row i \<bullet> z = (if i = 0 then (z \<bullet> real_of_int_vec as) else 2 * z $ (i - 1))"
    if "i<?n+1" for i using that row_prod that by (subst scal_prod_com) auto
    then show ?thesis
      unfolding real_of_int_mat_def gen_basis_p_def mult_mat_vec_def by auto
  qed
  have "\<dots> = 0\<^sub>v (?n + 1)" using 1(1) dim_row by (subst eq[symmetric], auto)
  then have "2 * z$(i-1) = 0" if "0<i" and "i<?n +1" for i
    using that by (smt (verit, best) cancel_comm_monoid_add_class.diff_cancel
      empty_iff index_vec index_zero_vec(1) insert_iff not_less_zero zero_less_diff)
  then have "z$i = 0" if "i<?n" for i using that by force
  then show ?case using 1 z_dim unfolding gen_basis_p_def by auto
qed

text \<open>The Gap-CVP is NP-hard in l_infty.\<close>

lemma well_defined_reduction:
  assumes "(as, s) \<in> subset_sum"
  shows "reduce_cvp_subset_sum_p (as, s) \<in> gap_cvp"
proof -
  obtain x where
    x_dim: "dim_vec x = dim_vec as" and
    x_binary: "\<forall>i<dim_vec x. x $ i \<in> {0, 1}" and
    x_lin_combo: "x \<bullet> as = s"
    using assms unfolding subset_sum_def by blast
  define L where L_def: "L = fst (reduce_cvp_subset_sum_p (as, s))"
  define b where b_def: "b = fst (snd (reduce_cvp_subset_sum_p (as, s)))"
  define r where r_def: "r = snd (snd (reduce_cvp_subset_sum_p (as, s)))"
  (*have "(L,b,r) = reduce_cvp_subset_sum_p (as, s)" using L_def b_def r_def by auto*)
  define B where "B = gen_basis_p as"
  define n where n_def: "n = dim_vec as"
  have "r = root p n" unfolding n_def
    by (simp add: r_def reduce_cvp_subset_sum_p_def)
  then have r_alt: "r^p = n" using p_def by auto
  have init_eq_goal: "B *\<^sub>v x - b =
    vec (n+1) (\<lambda> i. if i = 0 then (x \<bullet> as - s) else (2 * x$(i-1) - 1))"
    (is "?init_vec = ?goal_vec")
  unfolding B_def b_def reduce_cvp_subset_sum_p_def
  by (auto simp add: Bx_s_rewrite[OF x_dim[symmetric]] n_def)
  have "p_norm_vec (B *\<^sub>v x - b) =
    \<bar>x \<bullet> as - s\<bar>^p + (\<Sum>i=1..<n+1. \<bar>2*x$(i-1)-1\<bar>^p)"
  unfolding B_def b_def reduce_cvp_subset_sum_p_def
  by (auto simp add: p_norm_vec_Bx_s[OF x_dim[symmetric]] n_def)
  also have  "\<dots> \<le> r^p" (is "?left \<le> r^p")
  proof -
    have elem: "x$(i-1)\<in>{0,1}" if "0<i \<and> i<n+1" for i
      using that x_binary x_dim n_def
      by (smt (verit) add_diff_cancel_right' diff_diff_left diff_less_mono2
      less_add_same_cancel2 less_imp_add_positive less_one linorder_neqE_nat
      nat_1_add_1 not_add_less2)
    then have eq_1:  "\<bar>2*x$(i-1)-1\<bar>^p = 1" if "0<i \<and> i<n+1" for i
      using elem[OF that] by auto
    have eq_0: "\<bar>x \<bullet> as - s\<bar> ^ p = 0" using x_lin_combo p_def by auto
    have "?left = real_of_int ((\<Sum>i = 1..<n + 1. 1))" using eq_0 eq_1 by auto
    then have "?left \<le> n" by auto
    then show ?thesis using r_alt by linarith
  qed
  finally have "p_norm_vec (?init_vec) \<le> r^p" by blast
  moreover have "B *\<^sub>v x\<in>L"
  proof -
    have "dim_vec x = dim_col (gen_basis_p as)" unfolding gen_basis_p_def using x_dim by auto
    then show ?thesis
      unfolding L_def reduce_cvp_subset_sum_p_def gen_lattice_def B_def by auto
  qed
  ultimately have witness: "\<exists>v\<in>L. p_norm_vec (v - b) \<le> r^p" by auto
  have is_indep: "is_indep (real_of_int_mat B)"
    unfolding B_def using is_indep_gen_basis_p[of as] by simp
  have L_int_lattice: "is_lattice L" unfolding L_def reduce_cvp_subset_sum_p_def
    using is_lattice_gen_lattice[OF is_indep] unfolding B_def by auto
  show ?thesis unfolding gap_cvp_def using L_int_lattice witness L_def b_def r_def by force
qed

lemma NP_hardness_reduction:
  assumes "reduce_cvp_subset_sum_p (as, s) \<in> gap_cvp"
  shows "(as, s) \<in> subset_sum"
proof -
  define n where "n = dim_vec as"
  define B where "B = gen_basis_p as"
  define L where "L = gen_lattice B"
  define b where "b = gen_t_p as s"
  define r where "r = root p n"
  have rp_eq_n: "r^p = n" unfolding r_def using p_def by (simp)
  have ex_v: "\<exists>v\<in>L. p_norm_vec (v - b) \<le> r^p" and is_int_lattice: "is_lattice L"
    using assms unfolding gap_cvp_def reduce_cvp_subset_sum_p_def L_def B_def b_def r_def n_def
    by auto
  then obtain v where v_in_L:"v\<in>L" and ineq:"p_norm_vec (v - b) \<le> r^p" by blast
  have "\<exists>zs::int vec. v = B *\<^sub>v zs \<and> dim_vec zs = dim_vec as"
  using v_in_L unfolding L_def gen_lattice_def B_def gen_basis_p_def by auto
  then obtain zs::"int vec" where v_def: "v = B *\<^sub>v  zs"
    and zs_dim: "dim_vec zs = dim_vec as" by blast
  have init_eq_goal: "v - b =
    vec (n+1) (\<lambda> i. if i = 0 then (zs \<bullet> as - s) else (2 * zs$(i-1) - 1))"
    (is "?init_vec = ?goal_vec")
  unfolding v_def B_def b_def using Bx_s_rewrite[OF zs_dim[symmetric]] n_def by simp
  have p_norm_vec_ineq: "p_norm_vec (v-b) = \<bar>zs \<bullet> as - s\<bar>^p + (\<Sum>i=1..<n+1. \<bar>2*zs$(i-1)-1\<bar>^p)"
  unfolding v_def B_def b_def using p_norm_vec_Bx_s[OF zs_dim[symmetric]] n_def by simp
  define hide_sum where "hide_sum = (\<Sum>i=1..<n+1. \<bar>2*zs$(i-1)-1\<bar>^p)"
  have sum_le_rp: "\<bar>zs \<bullet> as - s\<bar>^p + hide_sum \<le> r^p"
  unfolding hide_sum_def using ineq  by (subst p_norm_vec_ineq[symmetric])
  then have sum_le_rp_int: " (\<bar>zs \<bullet> as - s\<bar> ^ p + hide_sum) \<le> int n"
    unfolding rp_eq_n by linarith
  moreover have zs_ge_n: "hide_sum \<ge> n"
  proof -
    have "\<bar>2*zs$(i-1)-1\<bar>\<ge>1" if "i\<in>{1..<n+1}" for i using that by presburger
    then have "(\<Sum>i=1..<n+1. \<bar>2*zs$(i-1)-1\<bar>^p) \<ge> (\<Sum>i=1..<n+1. 1^p)"
      by (smt (verit, ccfv_SIG) linordered_semidom_class.power_mono sum_mono)
    then show ?thesis unfolding hide_sum_def by auto
  qed
  ultimately have zs_part: "hide_sum = n"
    unfolding rp_eq_n
    by (smt (verit, ccfv_threshold) abs_triangle_ineq2_sym abs_zero power_abs zero_less_power)
  then have "(\<Sum>i=1..<n+1. \<bar>2*zs$(i-1)-1\<bar>^p) = n" unfolding hide_sum_def by simp
  then have as_part: "\<bar>zs \<bullet> as - s\<bar>=0"
    using sum_le_rp_int unfolding hide_sum_def
    by (smt (verit, best) zero_less_power)
  have "\<forall>i<n. zs $ i \<in> {0, 1}"
  proof -
    have zs_ge_1:"\<bar>2*zs$(i-1)-1\<bar>\<ge>1" if "i\<in>{1..<n+1}" for i using that by presburger
    then have zsp_ge_1:"\<bar>2*zs$(i-1)-1\<bar>^p\<ge>1" if "i\<in>{1..<n+1}" for i using that by auto
    have "\<bar>2*zs$(i-1)-1\<bar> = 1" if "i\<in>{1..<n+1}" for i
    proof (subst ccontr, goal_cases)
      case 1
      then have i_gt_1: "\<bar>2*zs$(i-1)-1\<bar> > 1" using that by presburger
      then have ip_gt_1: "\<bar>2*zs$(i-1)-1\<bar>^p > 1"
        using p_def by auto
      then have gt_n: "int (n - 1) + \<bar>2 * zs $ (i - 1) - 1\<bar> ^ p > n" by auto
      have ineq1:"(\<Sum>j=1..<n+1. \<bar>2*zs$(j-1)-1\<bar>^p) =
        (\<Sum>j\<in>{1..<n+1}-{i}. \<bar>2*zs$(j-1)-1\<bar>^p) + (\<bar>2*zs$(i-1)-1\<bar>^p)"
        using that by (subst sum.subset_diff[of "{i}"], auto)
      also have ineq2: "\<dots> \<ge> (\<Sum>j\<in>{1..<n+1}-{i}. 1) + (\<bar>2*zs$(i-1)-1\<bar>^p)"
        by (smt (verit, ccfv_SIG) DiffD1 sum_mono zsp_ge_1)
      also have ineq3: "(\<Sum>j\<in>{1..<n+1}-{i}. 1) = n - 1"
        by (metis Diff_empty add_diff_cancel_right' card_Diff_insert card_atLeastLessThan
          card_eq_sum empty_iff that)
      finally have ineq4: "(\<Sum>i=1..<n+1. \<bar>2*zs$(i-1)-1\<bar>^p) \<ge>  n - 1 + (\<bar>2*zs$(i-1)-1\<bar>^p)"
        using ineq1 ineq2 ineq3 by (smt (z3) of_nat_1 of_nat_sum sum_mono)
      then have "(\<Sum>i=1..<n+1. \<bar>2*zs$(i-1)-1\<bar>^p) >  n"
        by (subst order.strict_trans2[OF gt_n ineq4], simp)
      then show False using zs_part unfolding hide_sum_def  by auto
    qed auto
    then have "zs$(i-1) = 0 \<or> zs$(i-1) = 1" if "i\<in>{1..<n+1}" for i
      using that by force
    then have "zs$i = 0 \<or> zs$i = 1" if "i<n" for i using that
      by (metis One_nat_def Suc_eq_plus1 atLeastLessThan_iff diff_Suc_1 le_eq_less_or_eq
        less_Suc0 not_less_eq)
    then show ?thesis by simp
  qed
  moreover have "zs \<bullet> as = s" using as_part by auto
  ultimately have "(\<forall>i<dim_vec zs. zs $ i \<in> {0, 1}) \<and> zs \<bullet> as = s \<and> dim_vec zs = dim_vec as"
     using zs_dim n_def by auto
  then show ?thesis unfolding subset_sum_def gap_cvp_def by auto
qed

lemma "is_reduction reduce_cvp_subset_sum_p subset_sum gap_cvp"
unfolding is_reduction_def
proof (safe, goal_cases)
  case (1 as s)
  then show ?case using well_defined_reduction by auto
next
  case (2 as s)
  then show ?case using NP_hardness_reduction by auto
qed

end

end


section \<open>\isaheader{Example for Foreach-Loops}\<close>
theory Foreach_Refine
imports
  Collections.Refine_Dflt_Only_ICF
begin

text \<open>
  This example presents the usage of the foreach loop.
  We define a simple foreach loop that looks for the largest element with
  a given property. Ordered loops are used to be sure to find the largest one.
\<close>

subsection \<open>Definition\<close>

definition find_max_invar where
  "find_max_invar P S it \<sigma> =
     (case \<sigma> of None \<Rightarrow> (\<forall>x \<in> S - it. \<not>(P x))
             | Some y \<Rightarrow> (P y \<and> y \<in> S-it \<and> (\<forall>x \<in> S - it - {y}. \<not>(P x))))"

definition find_max :: "('a::{linorder} \<Rightarrow> bool) \<Rightarrow> 'a set \<Rightarrow> ('a option) nres" where
  "find_max P S \<equiv>
   FOREACHoci ((\<ge>)) (find_max_invar P S) S
     (\<lambda>\<sigma>. \<sigma> = None) (\<lambda>x _. RETURN (if P x then Some x else None)) None"

subsection \<open>Correctness\<close>
text \<open>As simple correctness property, we show:
  If the algorithm returns the maximal element satisfying \<open>P\<close>.
\<close>
lemma find_max_correct:
  fixes S:: "'a::{linorder} set"
  assumes "finite S"
  shows "find_max P S \<le> SPEC (\<lambda>\<sigma>. case \<sigma> of None \<Rightarrow> \<forall>x\<in>S. \<not>(P x)
                                          | Some y \<Rightarrow> (P y \<and> y \<in> S \<and> (\<forall>x\<in>S. P x \<longrightarrow> y \<ge> x)))"
  unfolding find_max_def
proof (rule FOREACHoci_rule)
  show "finite S" by fact
next
  show "find_max_invar P S S None"
  unfolding find_max_invar_def by simp
next
  fix x it \<sigma>
  assume "\<sigma> = None"
         "x \<in> it"
         "it \<subseteq> S"
         "find_max_invar P S it \<sigma>"
         "\<forall>y\<in>it - {x}. y \<le> x"
         "\<forall>y\<in>S - it. x \<le> y"

  from \<open>find_max_invar P S it \<sigma>\<close> \<open>\<sigma> = None\<close>
  have not_P_others: "\<forall>x\<in>S - it. \<not> P x"
    by (simp add: find_max_invar_def)

  from \<open>x \<in> it\<close> \<open>it \<subseteq> S\<close> have "x \<in> S" by blast

  show "RETURN (if P x then Some x else None) \<le> SPEC (find_max_invar P S (it - {x}))"
    using not_P_others \<open>x \<in> S\<close>
    by (auto simp add: find_max_invar_def)
next
  fix \<sigma>
  assume "find_max_invar P S {} \<sigma>"
  thus "case \<sigma> of None \<Rightarrow> \<forall>x\<in>S. \<not> P x
        | Some y \<Rightarrow> P y \<and> y \<in> S \<and> (\<forall>x\<in>S. P x \<longrightarrow> x \<le> y)"
    by (cases \<sigma>, auto simp add: find_max_invar_def)
next
  fix it \<sigma>
  assume "it \<noteq> {}"
         "it \<subseteq> S"
         "find_max_invar P S it \<sigma>"
         "\<sigma> \<noteq> None"
         "\<forall>x\<in>it. \<forall>y\<in>S - it. x \<le> y"

  from \<open>\<sigma> \<noteq> None\<close> obtain y where \<sigma>_eq[simp]: "\<sigma> = Some y" by auto
  from \<open>find_max_invar P S it \<sigma>\<close>
    have y_props[simp]: "P y" "y \<in> S" "y \<notin> it" and not_P: "\<forall>x\<in>S - it - {y}. \<not> P x"
    by (simp_all add: find_max_invar_def)

  { fix x
    assume "x \<in> S" "P x"
    with not_P have "x \<in> it \<or> x = y" by auto
    with \<open>\<forall>x\<in>it. \<forall>y\<in>S - it. x \<le> y\<close> y_props have "x \<le> y" by auto
  } note less_eq_y = this

  show "case \<sigma> of None \<Rightarrow> \<forall>x\<in>S. \<not> P x
        | Some y \<Rightarrow> P y \<and> y \<in> S \<and> (\<forall>x\<in>S. P x \<longrightarrow> x \<le> y)"
   by (simp add: find_max_invar_def Ball_def less_eq_y)
qed

subsection \<open>Data Refinement and Determinization\<close>
text \<open>
  Next, we use automatic data refinement and transfer to generate an
  executable algorithm using a red-black-tree.
\<close>
schematic_goal find_max_impl_refine_aux:
  assumes invar_S: "rs.invar S"
  shows "RETURN (?f) \<le> (find_max P (rs.\<alpha> S))"
  unfolding find_max_def
  by (refine_transfer
    RBTSetImpl.rs.rev_iterateoi_correct[unfolded set_iterator_rev_linord_def,
    OF invar_S])

concrete_definition find_max_impl for P S uses find_max_impl_refine_aux

lemma find_max_impl_refine:
  assumes invar_S: "rs.invar S"
  shows "RETURN (find_max_impl P S) \<le> (find_max P (rs.\<alpha> S))"
  using assms by (rule find_max_impl.refine)

subsubsection \<open>Executable Code\<close>

lemma find_max_impl_correct :
assumes invar_S: "rs.invar S"
shows "case find_max_impl P S of None \<Rightarrow> \<forall>x\<in>rs.\<alpha> S. \<not>(P x)
                               | Some y \<Rightarrow> (P y \<and> y \<in> (rs.\<alpha> S)
                                 \<and> (\<forall>x\<in>rs.\<alpha> S. P x \<longrightarrow> y \<ge> x))"
proof -
  note find_max_impl_refine [of S P, OF invar_S]
  also note find_max_correct [OF RBTSetImpl.rs.finite[of S, OF invar_S], of P]
  finally show ?thesis by simp
qed

text \<open>Finally, we can generate code\<close>
export_code find_max_impl checking SML
export_code find_max_impl checking OCaml?
export_code find_max_impl checking Haskell?
export_code find_max_impl checking Scala

end


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

  Shapiro's Tauberian theorem
  (see Section 4.6 of Apostol's Introduction to Analytic Number Theory)
*)
section \<open>Shapiro's Tauberian Theorem\<close>
theory Shapiro_Tauberian
imports
  More_Dirichlet_Misc
  Prime_Number_Theorem.Prime_Counting_Functions
  Prime_Distribution_Elementary_Library
begin

subsection \<open>Proof\<close>

text \<open>
  Given an arithmeticla function $a(n)$, Shapiro's Tauberian theorem relates the sum
  $\sum_{n\leq x} a(n)$ to the weighted sums $\sum_{n\leq x} a(n) \lfloor\frac{x}{n}\rfloor$
  and $\sum_{n\leq x} a(n)/n$.

  More precisely, it shows that if $\sum_{n\leq x} a(n) \lfloor\frac{x}{n}\rfloor = x\ln x + O(x)$,
  then:
  \<^item> $\sum_{n\leq x} \frac{a(n)}{n} = \ln x + O(1)$
  \<^item> $\sum_{n\leq x} a(n) \leq Bx$ for some constant $B\geq 0$ and all $x\geq 0$
  \<^item> $\sum_{n\leq x} a(n) \geq Cx$ for some constant $C>0$ and all $x\geq 1/C$
\<close>

locale shapiro_tauberian =
  fixes a :: "nat \<Rightarrow> real" and A S T :: "real \<Rightarrow> real"
  defines "A \<equiv> sum_upto (\<lambda>n. a n / n)"
  defines "S \<equiv> sum_upto a"
  defines "T \<equiv> (\<lambda>x. dirichlet_prod' a floor x)"
  assumes a_nonneg:      "\<And>n. n > 0 \<Longrightarrow> a n \<ge> 0"
  assumes a_asymptotics: "(\<lambda>x. T x - x * ln x) \<in> O(\<lambda>x. x)"
begin

lemma fin: "finite X" if "X \<subseteq> {n. real n \<le> x}" for X x
  by (rule finite_subset[of _ "{..nat \<lfloor>x\<rfloor>}"]) (use that in \<open>auto simp: le_nat_iff le_floor_iff\<close>)

lemma S_mono: "S x \<le> S y" if "x \<le> y" for x y
  unfolding S_def sum_upto_def using that by (intro sum_mono2 fin[of _ y] a_nonneg) auto

lemma split:
  fixes f :: "nat \<Rightarrow> real"
  assumes "\<alpha> \<in> {0..1}"
  shows   "sum_upto f x = sum_upto f (\<alpha>*x) + (\<Sum>n | n > 0 \<and> real n \<in> {\<alpha>*x<..x}. f n)"
proof (cases "x > 0")
  case False
  hence *: "{n. n > 0 \<and> real n \<le> x} = {}" "{n. n > 0 \<and> real n \<in> {\<alpha>*x<..x}} = {}"
    using mult_right_mono[of \<alpha> 1 x] assms by auto
  have "\<alpha> * x \<le> 0"
    using False assms by (intro mult_nonneg_nonpos) auto
  hence **: "{n. n > 0 \<and> real n \<le> \<alpha> * x} = {}"
    by auto
  show ?thesis
    unfolding sum_upto_def * ** by auto
next
  case True
  have "sum_upto f x = (\<Sum>n | n > 0 \<and> real n \<le> x. f n)"
    by (simp add: sum_upto_def)
  also have "{n. n > 0 \<and> real n \<le> x} =
                {n. n > 0 \<and> real n \<le> \<alpha>*x} \<union> {n. n > 0 \<and> real n \<in> {\<alpha>*x<..x}}"
    using assms True mult_right_mono[of \<alpha> 1 x] by (force intro: order_trans)
  also have "(\<Sum>n\<in>\<dots>. f n) = sum_upto f (\<alpha>*x) + (\<Sum>n | n > 0 \<and> real n \<in> {\<alpha>*x<..x}. f n)"
    by (subst sum.union_disjoint) (auto intro: fin simp: sum_upto_def)
  finally show ?thesis .
qed

lemma S_diff_T_diff: "S x - S (x / 2) \<le> T x - 2 * T (x / 2)"
proof -
  note fin = fin[of _ x]
  have T_diff_eq:
    "T x - 2 * T (x / 2) = sum_upto (\<lambda>n. a n * (\<lfloor>x / n\<rfloor> - 2 * \<lfloor>x / (2 * n)\<rfloor>)) (x / 2) +
        (\<Sum>n | n > 0 \<and> real n \<in> {x/2<..x}. a n * \<lfloor>x / n\<rfloor>)"
    unfolding T_def dirichlet_prod'_def
    by (subst split[where \<alpha> = "1/2"])
       (simp_all add: sum_upto_def sum_subtractf ring_distribs
                      sum_distrib_left sum_distrib_right mult_ac)

  have "S x - S (x / 2) = (\<Sum>n | n > 0 \<and> real n \<in> {x/2<..x}. a n)"
    unfolding S_def by (subst split[where \<alpha> = "1 / 2"]) (auto simp: sum_upto_def)
  also have "\<dots> = (\<Sum>n | n > 0 \<and> real n \<in> {x/2<..x}. a n * \<lfloor>x / n\<rfloor>)"
  proof (intro sum.cong)
    fix n assume "n \<in> {n. n > 0 \<and> real n \<in> {x/2<..x}}"
    hence "x / n \<ge> 1" "x / n < 2" by (auto simp: field_simps)
    hence "\<lfloor>x / n\<rfloor> = 1" by linarith
    thus "a n = a n * \<lfloor>x / n\<rfloor>" by simp
  qed auto
  also have "\<dots> = 0 + \<dots>" by simp
  also have "0 \<le> sum_upto (\<lambda>n. a n * (\<lfloor>x / n\<rfloor> - 2 * \<lfloor>x / (2 * n)\<rfloor>)) (x / 2)"
    unfolding sum_upto_def
  proof (intro sum_nonneg mult_nonneg_nonneg a_nonneg)
    fix n assume "n \<in> {n. n > 0 \<and> real n \<le> x / 2}"
    hence "x / real n \<ge> 2" by (auto simp: field_simps)
    thus "real_of_int (\<lfloor>x / n\<rfloor> - 2 * \<lfloor>x / (2 * n)\<rfloor>) \<ge> 0"
      using le_mult_floor[of 2 "x / (2 * n)"] by (simp add: mult_ac)
  qed auto
  also have "\<dots> + (\<Sum>n | n > 0 \<and> real n \<in> {x/2<..x}. a n * \<lfloor>x / n\<rfloor>) = T x - 2 * T (x / 2)"
    using T_diff_eq ..
  finally show "S x - S (x / 2) \<le> T x - 2 * T (x / 2)" by simp
qed

lemma
  shows diff_bound_strong: "\<exists>c\<ge>0. \<forall>x\<ge>0. x * A x - T x \<in> {0..c*x}"
    and asymptotics:       "(\<lambda>x. A x - ln x) \<in> O(\<lambda>_. 1)"
    and upper:             "\<exists>c\<ge>0. \<forall>x\<ge>0. S x \<le> c * x"
    and lower:             "\<exists>c>0. \<forall>x\<ge>1/c. S x \<ge> c * x"
    and bigtheta:          "S \<in> \<Theta>(\<lambda>x. x)"
proof -
  \<comment> \<open>We first prove the third case, i.\,e.\ the upper bound for \<open>S\<close>.\<close>
  have "(\<lambda>x. S x - S (x / 2)) \<in> O(\<lambda>x. T x - 2 * T (x / 2))"
  proof (rule le_imp_bigo_real)
    show "eventually (\<lambda>x. S x - S (x / 2) \<ge> 0) at_top"
      using eventually_ge_at_top[of 0]
    proof eventually_elim
      case (elim x)
      thus ?case using S_mono[of "x / 2" x] by simp
    qed
  next
    show "eventually (\<lambda>x. S x - S (x / 2) \<le> 1 * (T x - 2 * T (x / 2))) at_top"
      using S_diff_T_diff by simp
  qed auto
  also have "(\<lambda>x. T x - 2 * T (x / 2)) \<in> O(\<lambda>x. x)"
  proof -
    have "(\<lambda>x. T x - 2 * T (x / 2)) =
            (\<lambda>x. (T x - x * ln x) - 2 * (T (x / 2) - (x / 2) * ln (x / 2))
              + x * (ln x - ln (x / 2)))" by (simp add: algebra_simps)
    also have "\<dots> \<in> O(\<lambda>x. x)"
    proof (rule sum_in_bigo, rule sum_in_bigo)
      show "(\<lambda>x. T x - x * ln x) \<in> O(\<lambda>x. x)" by (rule a_asymptotics)
    next
      have "(\<lambda>x. T (x / 2) - (x / 2) * ln (x / 2)) \<in> O(\<lambda>x. x / 2)"
        using a_asymptotics by (rule landau_o.big.compose) real_asymp+
      thus "(\<lambda>x. 2 * (T (x / 2) - x / 2 * ln (x / 2))) \<in> O(\<lambda>x. x)"
        unfolding cmult_in_bigo_iff by (subst (asm) landau_o.big.cdiv) auto
    qed real_asymp+
    finally show ?thesis .
  qed
  finally have S_diff_bigo: "(\<lambda>x. S x - S (x / 2)) \<in> O(\<lambda>x. x)" .

  obtain c1 where c1: "c1 \<ge> 0" "\<And>x. x \<ge> 0 \<Longrightarrow> S x \<le> c1 * x"
  proof -
    from S_diff_bigo have "(\<lambda>n. S (real n) - S (real n / 2)) \<in> O(\<lambda>n. real n)"
      by (rule landau_o.big.compose) real_asymp
    from natfun_bigoE[OF this, of 1] obtain c
      where "c > 0" "\<forall>n\<ge>1. \<bar>S (real n) - S (real n / 2)\<bar> \<le> c * real n" by auto
    hence c: "S (real n) - S (real n / 2) \<le> c * real n" if "n \<ge> 1" for n
      using S_mono[of "real n" "2 * real n"] that by auto
    have c_twopow: "S (2 ^ Suc n / 2) - S (2 ^ n / 2) \<le> c * 2 ^ n" for n
      using c[of "2 ^ n"] by simp

    have S_twopow_le: "S (2 ^ k) \<le> 2 * c * 2 ^ k" for k
    proof -
      have [simp]: "{0<..Suc 0} = {1}" by auto
      have "(\<Sum>r<Suc k. S (2 ^ Suc r / 2) - S (2 ^ r / 2)) \<le> (\<Sum>r<Suc k. c * 2 ^ r)"
        by (intro sum_mono c_twopow)
      also have "(\<Sum>r<Suc k. S (2 ^ Suc r / 2) - S (2 ^ r / 2)) = S (2 ^ k)"
        by (subst sum_lessThan_telescope) (auto simp: S_def sum_upto_altdef)
      also have "(\<Sum>r<Suc k. c * 2 ^ r) = c * (\<Sum>r<Suc k. 2 ^ r)"
        unfolding sum_distrib_left ..
      also have "(\<Sum>r<Suc k. 2 ^ r :: real) = 2^Suc k - 1"
        by (subst geometric_sum) auto
      also have "c * \<dots> \<le> c * 2 ^ Suc k"
        using \<open>c > 0\<close> by (intro mult_left_mono) auto
      finally show "S (2 ^ k) \<le> 2 * c * 2 ^ k" by simp
    qed

    have S_le: "S x \<le> 4 * c * x" if "x \<ge> 0" for x
    proof (cases "x \<ge> 1")
      case False
      with that have "x \<in> {0..<1}" by auto
      thus ?thesis using \<open>c > 0\<close> by (auto simp: S_def sum_upto_altdef)
    next
      case True
      hence x: "x \<ge> 1" by simp
      define n where "n = nat \<lfloor>log 2 x\<rfloor>"
      have "2 powr real n \<le> 2 powr (log 2 x)"
        unfolding n_def using x by (intro powr_mono) auto
      hence ge: "2 ^ n \<le> x" using x by (subst (asm) powr_realpow) auto

      have "2 powr real (Suc n) > 2 powr (log 2 x)"
        unfolding n_def using x by (intro powr_less_mono) linarith+
      hence less: "2 ^ (Suc n) > x" using x by (subst (asm) powr_realpow) auto

      have "S x \<le> S (2 ^ Suc n)"
        using less by (intro S_mono) auto
      also have "\<dots> \<le> 2 * c * 2 ^ Suc n"
        by (intro S_twopow_le)
      also have "\<dots> = 4 * c * 2 ^ n"
        by simp
      also have "\<dots> \<le> 4 * c * x"
        by (intro mult_left_mono ge) (use x \<open>c > 0\<close> in auto)
      finally show "S x \<le> 4 * c * x" .
    qed

    with that[of "4 * c"] and \<open>c > 0\<close> show ?thesis by auto
  qed
  thus "\<exists>c\<ge>0. \<forall>x\<ge>0. S x \<le> c * x" by auto

  \<comment> \<open>The asymptotics of \<open>A\<close> follows from this immediately:\<close>
  have a_strong: "x * A x - T x \<in> {0..c1 * x}" if x: "x \<ge> 0" for x
  proof -
    have "sum_upto (\<lambda>n. a n * frac (x / n)) x \<le> sum_upto (\<lambda>n. a n * 1) x" unfolding sum_upto_def
      by (intro sum_mono mult_left_mono a_nonneg) (auto intro: less_imp_le frac_lt_1)
    also have "\<dots> = S x" unfolding S_def by simp
    also from x have "\<dots> \<le> c1 * x" by (rule c1)
    finally have "sum_upto (\<lambda>n. a n * frac (x / n)) x \<le> c1 * x" .
    moreover have "sum_upto (\<lambda>n. a n * frac (x / n)) x \<ge> 0"
      unfolding sum_upto_def by (intro sum_nonneg mult_nonneg_nonneg a_nonneg) auto
    ultimately have "sum_upto (\<lambda>n. a n * frac (x / n)) x \<in> {0..c1*x}" by auto
    also have "sum_upto (\<lambda>n. a n * frac (x / n)) x = x * A x - T x"
      by (simp add: T_def A_def sum_upto_def sum_subtractf frac_def algebra_simps
                    sum_distrib_left sum_distrib_right dirichlet_prod'_def)
    finally show ?thesis .
  qed
  thus "\<exists>c\<ge>0. \<forall>x\<ge>0. x * A x - T x \<in> {0..c*x}"
    using \<open>c1 \<ge> 0\<close> by (intro exI[of _ c1]) auto
  hence "(\<lambda>x. x * A x - T x) \<in> O(\<lambda>x. x)"
    using a_strong \<open>c1 \<ge> 0\<close>
    by (intro le_imp_bigo_real[of c1] eventually_mono[OF eventually_ge_at_top[of 1]]) auto
  from this and a_asymptotics have "(\<lambda>x. (x * A x - T x) + (T x - x * ln x)) \<in> O(\<lambda>x. x)"
    by (rule sum_in_bigo)
  hence "(\<lambda>x. x * (A x - ln x)) \<in> O(\<lambda>x. x * 1)"
    by (simp add: algebra_simps)
  thus bigo: "(\<lambda>x. A x - ln x) \<in> O(\<lambda>x. 1)"
    by (subst (asm) landau_o.big.mult_cancel_left) auto

  \<comment> \<open>It remains to show the lower bound for \<open>S\<close>.\<close>
  define R where "R = (\<lambda>x. A x - ln x)"
  obtain M where M: "\<And>x. x \<ge> 1 \<Longrightarrow> \<bar>R x\<bar> \<le> M"
  proof -
    have "(\<lambda>n. R (real n)) \<in> O(\<lambda>_. 1)"
      using bigo unfolding R_def by (rule landau_o.big.compose) real_asymp
    from natfun_bigoE[OF this, of 0] obtain M where M: "M > 0" "\<And>n. \<bar>R (real n)\<bar> \<le> M"
      by auto

    have "\<bar>R x\<bar> \<le> M + ln 2" if x: "x \<ge> 1" for x
    proof -
      define n where "n = nat \<lfloor>x\<rfloor>"
      have "\<bar>R x - R (real n)\<bar> = ln (x / n)"
        using x by (simp add: R_def A_def sum_upto_altdef n_def ln_div)
      also {
        have "x \<le> real n + 1"
          unfolding n_def by linarith
        also have "1 \<le> real n"
          using x unfolding n_def by simp
        finally have "ln (x / n) \<le> ln 2"
          using x by (simp add: field_simps)
      }
      finally have "\<bar>R x\<bar> \<le> \<bar>R (real n)\<bar> + ln 2"
        by linarith
      also have "\<bar>R (real n)\<bar> \<le> M"
        by (rule M)
      finally show "\<bar>R x\<bar> \<le> M + ln 2" by simp
    qed
    with that[of "M + ln 2"] show ?thesis by blast
  qed
  have "M \<ge> 0" using M[of 1] by simp

  have A_diff_ge: "A x - A (\<alpha>*x) \<ge> -ln \<alpha> - 2 * M"
    if \<alpha>: "\<alpha> \<in> {0<..<1}" and "x \<ge> 1 / \<alpha>" for x \<alpha> :: real
  proof -
    from that have "1 < inverse \<alpha> * 1" by (simp add: field_simps)
    also have "\<dots> \<le> inverse \<alpha> * (\<alpha> * x)"
      using \<open>x \<ge> 1 / \<alpha>\<close> and \<alpha> by (intro mult_left_mono) (auto simp: field_simps)
    also from \<alpha> have "\<dots> = x" by simp
    finally have "x > 1" .
    note x = this \<open>x >= 1 / \<alpha>\<close>

    have "-ln \<alpha> - M - M \<le> -ln \<alpha> - \<bar>R x\<bar> - \<bar>R (\<alpha>*x)\<bar>"
      using x \<alpha> by (intro diff_mono M) (auto simp: field_simps)
    also have "\<dots> \<le> -ln \<alpha> + R x - R (\<alpha>*x)"
      by linarith
    also have "\<dots> = A x - A (\<alpha>*x)"
      using \<alpha> x by (simp add: R_def ln_mult)
    finally show "A x - A (\<alpha>*x) \<ge> -ln \<alpha> - 2 * M" by simp
  qed

  define \<alpha> where "\<alpha> = exp (-2*M-1)"
  have "\<alpha> \<in> {0<..<1}"
    using \<open>M \<ge> 0\<close> by (auto simp: \<alpha>_def)

  have S_ge: "S x \<ge> \<alpha> * x" if x: "x \<ge> 1 / \<alpha>" for x
  proof -
    have "1 = -ln \<alpha> - 2 * M"
      by (simp add: \<alpha>_def)
    also have "\<dots> \<le> A x - A (\<alpha>*x)"
      by (intro A_diff_ge) fact+
    also have "\<dots> = (\<Sum>n | n > 0 \<and> real n \<in> {\<alpha>*x<..x}. a n / n)"
      unfolding A_def using \<open>\<alpha> \<in> {0<..<1}\<close> by (subst split[where \<alpha> = \<alpha>]) auto
    also have "\<dots> \<le> (\<Sum>n | n > 0 \<and> real n \<in> {\<alpha>*x<..x}. a n / (\<alpha>*x))"
      using x \<open>\<alpha> \<in> {0<..<1}\<close> by (intro sum_mono divide_left_mono a_nonneg) auto
    also have "\<dots> = (\<Sum>n | n > 0 \<and> real n \<in> {\<alpha>*x<..x}. a n) / (\<alpha>*x)"
      by (simp add: sum_divide_distrib)
    also have "\<dots> \<le> S x / (\<alpha>*x)"
      using x \<open>\<alpha> \<in> {0<..<1}\<close> unfolding S_def sum_upto_def
      by (intro divide_right_mono sum_mono2 a_nonneg) (auto simp: field_simps)
    finally show "S x \<ge> \<alpha> * x"
      using \<open>\<alpha> \<in> {0<..<1}\<close> x by (simp add: field_simps)
  qed
  thus "\<exists>c>0. \<forall>x\<ge>1/c. S x \<ge> c * x"
    using \<open>\<alpha> \<in> {0<..<1}\<close> by (intro exI[of _ \<alpha>]) auto

  have S_nonneg: "S x \<ge> 0" for x
    unfolding S_def sum_upto_def by (intro sum_nonneg a_nonneg) auto
  have "eventually (\<lambda>x. \<bar>S x\<bar> \<ge> \<alpha> * \<bar>x\<bar>) at_top"
    using eventually_ge_at_top[of "max 0 (1 / \<alpha>)"]
  proof eventually_elim
    case (elim x)
    with S_ge[of x] elim show ?case by auto
  qed
  hence "S \<in> \<Omega>(\<lambda>x. x)"
    using \<open>\<alpha> \<in> {0<..<1}\<close> by (intro landau_omega.bigI[of \<alpha>]) auto
  moreover have "S \<in> O(\<lambda>x. x)"
  proof (intro bigoI eventually_mono[OF eventually_ge_at_top[of 0]])
    fix x :: real assume "x \<ge> 0"
    thus "norm (S x) \<le> c1 * norm x"
      using c1(2)[of x] by (auto simp: S_nonneg)
  qed
  ultimately show "S \<in> \<Theta>(\<lambda>x. x)"
    by (intro bigthetaI)
qed

end

subsection \<open>Applications to the Chebyshev functions\<close>

(* 3.16 *)
text \<open>
  We can now apply Shapiro's Tauberian theorem to \<^term>\<open>\<psi>\<close> and \<^term>\<open>\<theta>\<close>.
\<close>
lemma dirichlet_prod_mangoldt1_floor_bigo:
  includes prime_counting_notation
  shows "(\<lambda>x. dirichlet_prod' (\<lambda>n. ind prime n * ln n) floor x - x * ln x) \<in> O(\<lambda>x. x)"
proof -
  \<comment> \<open>This is a perhaps somewhat roundabout way of proving this statement. We show this using
      the asymptotics of \<open>\<MM>\<close>: $\mathfrak{M}(x) = \ln x + O(1)$

      We proved this before (which was a bit of work, but not that much).
      Apostol, on the other hand, shows the following statement first and then deduces the
      asymptotics of \<open>\<MM>\<close> with Shapiro's Tauberian theorem instead. This might save a bit of
      work, but it is probably negligible.\<close>
  define R where "R = (\<lambda>x. sum_upto (\<lambda>i. ind prime i * ln i * frac (x / i)) x)"
  have *: "R x \<in> {0..ln 4 * x}" if "x \<ge> 1" for x
  proof -
    have "R x \<le> \<theta> x"
      unfolding R_def prime_sum_upto_altdef1 sum_upto_def \<theta>_def
      by (intro sum_mono) (auto simp: ind_def less_imp_le[OF frac_lt_1] dest!: prime_gt_1_nat)
    also have "\<dots> < ln 4 * x"
      by (rule \<theta>_upper_bound) fact+
    finally have "R x \<le> ln 4 * x" by auto
    moreover have "R x \<ge> 0" unfolding R_def sum_upto_def
      by (intro sum_nonneg mult_nonneg_nonneg) (auto simp: ind_def)
    ultimately show ?thesis by auto
  qed
  have "eventually (\<lambda>x. \<bar>R x\<bar> \<le> ln 4 * \<bar>x\<bar>) at_top"
    using eventually_ge_at_top[of 1] by eventually_elim (use * in auto)
  hence "R \<in> O(\<lambda>x. x)" by (intro landau_o.bigI[of "ln 4"]) auto

  have "(\<lambda>x. dirichlet_prod' (\<lambda>n. ind prime n * ln n) floor x - x * ln x) =
          (\<lambda>x. x * (\<MM> x - ln x) - R x)"
    by (auto simp: primes_M_def dirichlet_prod'_def prime_sum_upto_altdef1 sum_upto_def
                   frac_def sum_subtractf sum_distrib_left sum_distrib_right algebra_simps R_def)
  also have "\<dots> \<in> O(\<lambda>x. x)"
  proof (rule sum_in_bigo)
    have "(\<lambda>x. x * (\<MM> x - ln x)) \<in> O(\<lambda>x. x * 1)"
      by (intro landau_o.big.mult mertens_bounded) auto
    thus "(\<lambda>x. x * (\<MM> x - ln x)) \<in> O(\<lambda>x. x)" by simp
  qed fact+
  finally show ?thesis .
qed

lemma dirichlet_prod'_mangoldt_floor_asymptotics:
  "(\<lambda>x. dirichlet_prod' mangoldt floor x - x * ln x + x) \<in> O(ln)"
proof -
  have "dirichlet_prod' mangoldt floor = (\<lambda>x. sum_upto ln x)"
    unfolding sum_upto_ln_conv_sum_upto_mangoldt dirichlet_prod'_def
    by (intro sum_upto_cong' ext) auto
  hence "(\<lambda>x. dirichlet_prod' mangoldt floor x - x * ln x + x) = (\<lambda>x. sum_upto ln x - x * ln x + x)"
    by simp
  also have "\<dots> \<in> O(ln)"
    by (rule sum_upto_ln_stirling_weak_bigo)
  finally show "(\<lambda>x. dirichlet_prod' mangoldt (\<lambda>x. real_of_int \<lfloor>x\<rfloor>) x - x * ln x + x) \<in> O(ln)" .
qed

(* 4.9 *)
interpretation \<psi>: shapiro_tauberian mangoldt "sum_upto (\<lambda>n. mangoldt n / n)" primes_psi
  "dirichlet_prod' mangoldt floor"
proof unfold_locales
  have "dirichlet_prod' mangoldt floor = (\<lambda>x. sum_upto ln x)"
    unfolding sum_upto_ln_conv_sum_upto_mangoldt dirichlet_prod'_def
    by (intro sum_upto_cong' ext) auto
  hence "(\<lambda>x. dirichlet_prod' mangoldt floor x - x * ln x + x) = (\<lambda>x. sum_upto ln x - x * ln x + x)"
    by simp
  also have "\<dots> \<in> O(ln)"
    by (rule sum_upto_ln_stirling_weak_bigo)
  also have "ln \<in> O(\<lambda>x::real. x)" by real_asymp
  finally have "(\<lambda>x. dirichlet_prod' mangoldt (\<lambda>x. real_of_int \<lfloor>x\<rfloor>) x - x * ln x + x - x)
                   \<in> O(\<lambda>x. x)" by (rule sum_in_bigo) auto
  thus "(\<lambda>x. dirichlet_prod' mangoldt (\<lambda>x. real_of_int \<lfloor>x\<rfloor>) x - x * ln x) \<in> O(\<lambda>x. x)" by simp
qed (simp_all add: primes_psi_def mangoldt_nonneg)

thm \<psi>.asymptotics \<psi>.upper \<psi>.lower

(* 4.10 *)
interpretation \<theta>: shapiro_tauberian "\<lambda>n. ind prime n * ln n"
  "sum_upto (\<lambda>n. ind prime n * ln n / n)" primes_theta "dirichlet_prod' (\<lambda>n. ind prime n * ln n) floor"
proof unfold_locales
  fix n :: nat show "ind prime n * ln n \<ge> 0"
    by (auto simp: ind_def dest: prime_gt_1_nat)
next
  show "(\<lambda>x. dirichlet_prod' (\<lambda>n. ind prime n * ln n) floor x - x * ln x) \<in> O(\<lambda>x. x)"
    by (rule dirichlet_prod_mangoldt1_floor_bigo)
qed (simp_all add: primes_theta_def mangoldt_nonneg prime_sum_upto_altdef1[abs_def])

thm \<theta>.asymptotics \<theta>.upper \<theta>.lower

(* 4.11 *)
lemma sum_upto_\<psi>_x_over_n_asymptotics:
        "(\<lambda>x. sum_upto (\<lambda>n. primes_psi (x / n)) x - x * ln x + x) \<in> O(ln)"
  and sum_upto_\<theta>_x_over_n_asymptotics:
        "(\<lambda>x. sum_upto (\<lambda>n. primes_theta (x / n)) x - x * ln x) \<in> O(\<lambda>x. x)"
  using dirichlet_prod_mangoldt1_floor_bigo dirichlet_prod'_mangoldt_floor_asymptotics
  by (simp_all add: dirichlet_prod'_floor_conv_sum_upto primes_theta_def
                    primes_psi_def prime_sum_upto_altdef1)

end


theory GeneralTriangle
imports Complex_Main
begin

section \<open>Type definitions\<close>

text \<open>Since we are only considering acute-angled triangles, we define \<open>angles\<close> as numbers from the real interval $[0\ldots 90]$.\<close>

abbreviation "angles \<equiv> { x::real . 0 \<le> x \<and> x \<le> 90 }"

text \<open>Triangles are represented as lists consisting of exactly three angles
which add up to 180\textdegree. As we consider triangles up to similarity, we
assume the angles to be given in ascending order.

Isabelle expects us to prove that the type is not empty, which we do by an example.

\<close>

definition
  "triangle =
    { l . l \<in> lists angles \<and>
                    length l = 3 \<and>
                    sum_list l = 180 \<and>
                    sorted l
                    }"

typedef triangle = triangle
  unfolding triangle_def
  apply (rule_tac x = "[45,45,90]" in exI)
  apply auto
  done

text \<open>For convenience, the following lemma gives us easy access to the three angles
of a triangle and their properties.\<close>

lemma unfold_triangle:
  obtains a b c
  where "Rep_triangle t = [a,b,c]"
    and "a \<in> angles"
    and "b \<in> angles"
    and "c \<in> angles"
    and "a + b + c = 180"
    and "a \<le> b"
    and "b \<le> c"
proof-
  obtain a b c where
  "a = Rep_triangle t ! 0" and "b = Rep_triangle t ! 1" and "c = Rep_triangle t ! 2"
    using Rep_triangle[of t]
    by (auto simp add:triangle_def)
  hence "Rep_triangle t = [a,b,c]"
    using Rep_triangle[of t]
    apply (auto simp add:triangle_def)
    apply (cases "Rep_triangle t", auto)
    apply (case_tac "list", auto)
    apply (case_tac "lista", auto)
    done
  with that show thesis
    using Rep_triangle[of t]
    by (auto simp add:triangle_def)
qed

section \<open>Property definitions\<close>

text \<open>Two angles can be considered too similar if they differ by less than
15\textdegree. This number is obtained heuristically by a field experiment with
an 11th grade class and was chosen that statistically, 99\% will consider the
angles as different.\<close>

definition similar_angle :: "real \<Rightarrow> real \<Rightarrow> bool"  (infix "\<sim>" 50)
  where "similar_angle x y = (abs (x - y) < 15)"

text \<open>The usual definitions of right-angled and isosceles, using the just
introduced similarity for comparison of angles.\<close>

definition right_angled
  where "right_angled l = (\<exists> x \<in> set (Rep_triangle l). x \<sim> 90)"

definition isosceles
  where "isosceles l = ((Rep_triangle l) ! 0 \<sim> (Rep_triangle l) ! 1 \<or>
                        (Rep_triangle l) ! 1 \<sim> (Rep_triangle l) ! (Suc 1))"

text \<open>A triangle is special if it is isosceles or right-angled, and general
if not. Equilateral triangle are isosceles and thus not mentioned on their own
here.\<close>

definition special
  where "special t = (isosceles t \<or> right_angled t)"

definition general
  where "general t = (\<not> special t)"

section \<open>The Theorem\<close>

theorem "\<exists>! t. general t"
txt \<open>The proof proceeds in two steps: There is a general triangle, and it is
       unique. For the first step we give the triangle (angles 45\textdegree,
       60\textdegree and 75\textdegree), show that it is a triangle and that it
       is general.\<close>
proof
  have is_t [simp]: "[45, 60, 75] \<in> triangle" by (auto simp add: triangle_def)
  show "general (Abs_triangle [45,60,75])" (is "general ?t")
  by (auto simp add:general_def special_def isosceles_def right_angled_def
                    Abs_triangle_inverse similar_angle_def)
next
  txt \<open>For the second step, we give names to the three angles and
         successively find upper bounds to them.\<close>
  fix t
  obtain a b c where
    abc: "Rep_triangle t = [a,b,c]"
    and "a \<in> angles" and "b \<in> angles" and "c \<in> angles"
    and "a \<le> b" and "b \<le> c"
    and "a + b + c = 180"
  by (rule unfold_triangle)

  assume "general t"
  hence ni: "\<not> isosceles t" and nra: "\<not> right_angled t"
    by (auto simp add: general_def special_def)

  have "\<not> c \<sim> 90" using nra abc
    by (auto simp add:right_angled_def)
  hence "c \<le> 75" using \<open>c \<in> angles\<close>
    by (auto simp add:similar_angle_def)

  have "\<not> b \<sim> c" using ni abc
    by (auto simp add:isosceles_def)
  hence "b \<le> 60" using \<open>b \<le> c\<close> and \<open>c \<le> 75\<close>
    by (auto simp add:similar_angle_def)

  have "\<not> a \<sim> b" using ni abc
    by (auto simp add:isosceles_def)
  hence "a \<le> 45" using \<open>a \<le> b\<close> and \<open>b \<le> 60\<close>
    by (auto simp add:similar_angle_def)

  txt \<open>The upper bound is actually the value, or we would not have a triangle\<close>
  have "\<not> (c < 75 \<or> b < 60 \<or> a < 45)"
  proof
    assume "c < 75 \<or> b < 60 \<or> a < 45"
    hence "a + b + c < 180" using \<open>c \<le> 75\<close> \<open>b \<le> 60\<close> \<open>a \<le> 45\<close>
                            and \<open>a \<in> angles\<close> \<open>b \<in> angles\<close> \<open>c \<in> angles\<close>
      by auto
    thus False using \<open>a + b + c = 180\<close> by auto
  qed
  hence "c = 75" and "b = 60" and "a = 45"
    using \<open>c \<le> 75\<close> \<open>b \<le> 60\<close> \<open>a \<le> 45\<close>
    by auto

  txt \<open>And this concludes the proof.\<close>
  hence "Abs_triangle (Rep_triangle t) = Abs_triangle [45, 60, 75]"
    using abc by simp
  thus "t = Abs_triangle [45, 60, 75]" by (simp add: Rep_triangle_inverse)
qed

end


theory E2_3
  imports Main
begin

fun count :: "'a \<Rightarrow> 'a list \<Rightarrow> nat" where
  "count x [] = 0" |
  "count x (y # xs) = If (x = y) (Suc (count x xs)) (count x xs)"

value "count (1::nat) [1, 2, 3, 1, 3, 1]"

lemma count_lt : "count x xs \<le> length xs"
  apply(induction xs)
  apply(auto)
  done

end


section {* Example Verification Proofs with KAT *}

theory VC_KAT_Examples
  imports VC_KAT GCD "$ISABELLE_HOME/src/HOL/Eisbach/Eisbach"
begin

lemma euclid:
  "PRE (\<lambda>s::nat store. s ''x'' = x \<and> s ''y'' = y)
   (WHILE (\<lambda>s. s ''y'' \<noteq> 0) INV (\<lambda>s. gcd (s ''x'') (s ''y'') = gcd x y)
    DO
     (''z'' ::= (\<lambda>s. s ''y''));
     (''y'' ::= (\<lambda>s. s ''x'' mod s ''y''));
     (''x'' ::= (\<lambda>s. s ''z''))
    OD)
   POST (\<lambda>s. s ''x'' = gcd x y)"
  apply (rule sH_while_inv)
  apply simp_all
  apply force
  apply (intro rel_kat.H_seq)
  apply (subst H_assign, simp)+
  apply (intro H_assign_var)
  using gcd_red_nat by auto

lemma maximum:
  "PRE (\<lambda>s:: nat store. True)
   (IF (\<lambda>s. s ''x'' \<ge> s ''y'')
    THEN (''z'' ::= (\<lambda>s. s ''x''))
    ELSE (''z'' ::= (\<lambda>s. s ''y''))
    FI)
   POST (\<lambda>s. s ''z'' = max (s ''x'') (s ''y''))"
  by (simp only: sH_cond_iff H_assign_iff, auto)

lemma integer_division:
  "PRE (\<lambda>s::nat store. s ''x'' \<ge> 0)
    (''q'' ::= (\<lambda>s. 0));
    (''r'' ::= (\<lambda>s. s ''x''));
    (WHILE (\<lambda>s. s ''y'' \<le> s ''r'') INV (\<lambda>s. s ''x'' = s ''q'' * s ''y'' + s ''r'' \<and> s ''r'' \<ge> 0)
     DO
      (''q'' ::= (\<lambda>s. s ''q'' + 1));
      (''r'' ::= (\<lambda>s. s ''r'' - s ''y''))
      OD)
   POST (\<lambda>s. s ''x'' = s ''q'' * s ''y'' + s ''r'' \<and> s ''r'' \<ge> 0 \<and> s ''r'' < s ''y'')"
  apply (intro rel_kat.H_seq, subst sH_while_inv, simp_all)
  apply auto[1]
  apply (intro rel_kat.H_seq)
  by (subst H_assign, simp_all)+

lemma imp_reverse:
  "PRE (\<lambda>s:: 'a list store. s ''x'' = X)
   (''y'' ::= (\<lambda>s. []));
   (WHILE (\<lambda>s. s ''x'' \<noteq> []) INV (\<lambda>s. rev (s ''x'') @ s ''y'' = rev X)
    DO
     (''y'' ::= (\<lambda>s. hd (s ''x'') # s ''y''));
     (''x'' ::= (\<lambda>s. tl (s ''x'')))
    OD)
   POST (\<lambda>s. s ''y''= rev X )"
  apply (intro rel_kat.H_seq, rule sH_while_inv, auto, rule rel_kat.H_seq)
  apply (rule H_assign_var, auto)+
  by (metis append.simps(1) append.simps(2) append_assoc hd_Cons_tl rev.simps(2))

(* with a vcg *)

named_theorems hl_intro

declare sH_while_inv [hl_intro]
  rel_kat.H_seq [hl_intro]
  H_assign_var [hl_intro]
  rel_kat.H_cond [hl_intro]

method hoare = (rule hl_intro; hoare?)

lemma euclid2:
  "PRE (\<lambda>s::nat store. s ''x'' = x \<and> s ''y'' = y)
   (WHILE (\<lambda>s. s ''y'' \<noteq> 0) INV (\<lambda>s. gcd (s ''x'') (s ''y'') = gcd x y)
    DO
     (''z'' ::= (\<lambda>s. s ''y''));
     (''y'' ::= (\<lambda>s. s ''x'' mod s ''y''));
     (''x'' ::= (\<lambda>s. s ''z''))
    OD)
   POST (\<lambda>s. s ''x'' = gcd x y)"
   apply hoare
  using gcd_red_nat by auto

lemma maximum2:
  "PRE (\<lambda>s:: nat store. True)
   (IF (\<lambda>s. s ''x'' \<ge> s ''y'')
    THEN (''z'' ::= (\<lambda>s. s ''x''))
    ELSE (''z'' ::= (\<lambda>s. s ''y''))
    FI)
   POST (\<lambda>s. s ''z'' = max (s ''x'') (s ''y''))"
by auto

lemma imp_reverse2:
  "PRE (\<lambda>s:: 'a list store. s ''x'' = X)
   (''y'' ::= (\<lambda>s. []));
   (WHILE (\<lambda>s. s ''x'' \<noteq> []) INV (\<lambda>s. rev (s ''x'') @ s ''y'' = rev X)
    DO
     (''y'' ::= (\<lambda>s. hd (s ''x'') # s ''y''));
     (''x'' ::= (\<lambda>s. tl (s ''x'')))
    OD)
   POST (\<lambda>s. s ''y''= rev X )"
   apply hoare
   apply auto
   by (metis (no_types, lifting) Cons_eq_appendI append_eq_append_conv2 hd_Cons_tl rev.simps(2) self_append_conv)

end


section \<open>General Priority Search Trees\<close>

theory PST_General
imports
  "HOL-Data_Structures.Tree2"
  Prio_Map_Specs
begin

text \<open>\noindent
  We show how to implement priority maps
  by augmented binary search trees. That is, the basic data structure is some
  arbitrary binary search tree, e.g.\ a red-black tree, implementing the map
  from @{typ 'a} to @{typ 'b} by storing pairs \<open>(k,p)\<close> in each node. At this
  point we need to assume that the keys are also linearly ordered. To
  implement \<open>getmin\<close> efficiently we annotate/augment each node with another pair
  \<open>(k',p')\<close>, the intended result of \<open>getmin\<close> when applied to that subtree. The
  specification of \<open>getmin\<close> tells us that \<open>(k',p')\<close> must be in that subtree and
  that \<open>p'\<close> is the minimal priority in that subtree. Thus the annotation can be
  computed by passing the \<open>(k',p')\<close> with the minimal \<open>p'\<close> up the tree. We will
  now make this more precise for balanced binary trees in general.

  We assume that our trees are either leaves of the form @{term Leaf} or nodes
  of the form @{term "Node l (kp, b) r"} where \<open>l\<close> and \<open>r\<close> are subtrees, \<open>kp\<close> is
  the contents of the node (a key-priority pair) and \<open>b\<close> is some additional
  balance information (e.g.\ colour, height, size, \dots). Augmented nodes are
  of the form \<^term>\<open>Node l (kp, (b,kp')) r\<close>.
\<close>

type_synonym ('k,'p,'c) pstree = "(('k\<times>'p) \<times> ('c \<times> ('k \<times> 'p))) tree"

text \<open>
  The following invariant states that a node annotation is actually a minimal
  key-priority pair for the node's subtree.
\<close>

fun invpst :: "('k,'p::linorder,'c) pstree \<Rightarrow> bool" where
  "invpst Leaf = True"
| "invpst (Node l (x, _,mkp) r) \<longleftrightarrow> invpst l \<and> invpst r
    \<and> is_min2 mkp (set (inorder l @ x # inorder r))"

text \<open>The implementation of \<open>getmin\<close> is trivial:\<close>

fun pst_getmin where
"pst_getmin (Node _ (_, _,a) _) = a"

lemma pst_getmin_ismin:
  "invpst t \<Longrightarrow> t\<noteq>Leaf \<Longrightarrow> is_min2 (pst_getmin t) (set_tree t)"
by (cases t rule: pst_getmin.cases) auto

text \<open>
  It remains to upgrade the existing map operations to work with augmented nodes.
  Therefore we now show how to transform any function definition on un-augmented
  trees into one on trees augmented with \<open>(k',p')\<close> pairs. A defining equation
  \<open>f pats = e\<close> for the original type of nodes is transformed into an equation
  \<open>f pats' = e'\<close> on the augmented type of nodes as follows:
  \<^item> Every pattern @{term "Node l (kp, b) r"} in \<open>pats\<close> and \<open>e\<close> is replaced by
    @{term "Node l (kp, (b,DUMMY)) r"} to obtain \<open>pats'\<close> and \<open>e\<^sub>2\<close>.
  \<^item> To obtain \<open>e'\<close>, every expression @{term "Node l (kp, b) r"} in \<open>e\<^sub>2\<close> is
    replaced by \<open>mkNode l kp b r\<close> where:
\<close>

definition "min2 \<equiv> \<lambda>(k,p) (k',p'). if p\<le>p' then (k,p) else (k',p')"

definition "min_kp a l r \<equiv> case (l,r) of
  (Leaf,Leaf) \<Rightarrow> a
| (Leaf,Node _ (_, (_,kpr)) _) \<Rightarrow> min2 a kpr
| (Node _ (_, (_,kpl)) _,Leaf) \<Rightarrow> min2 a kpl
| (Node _ (_, (_,kpl)) _,Node _ (_, (_,kpr)) _) \<Rightarrow> min2 a (min2 kpl kpr)"

definition "mkNode c l a r \<equiv> Node l (a, (c,min_kp a l r)) r"

text \<open>
  Note that this transformation does not affect the asymptotic complexity
  of \<open>f\<close>. Therefore the priority search tree operations have the same complexity
  as the underlying search tree operations, i.e.\ typically logarithmic
  (\<open>update\<close>, \<open>delete\<close>, \<open>lookup\<close>) and constant time (\<open>empty\<close>, \<open>is_empty\<close>).
\<close>

text \<open>It is straightforward to show that @{const mkNode} preserves the invariant:\<close>

lemma is_min2_Empty[simp]: "\<not>is_min2 x {}"
by (auto simp: is_min2_def)

lemma is_min2_singleton[simp]: "is_min2 a {b} \<longleftrightarrow> b=a"
by (auto simp: is_min2_def)

lemma is_min2_insert:
  "is_min2 x (insert y ys)
  \<longleftrightarrow> (y=x \<and> (\<forall>z\<in>ys. snd x \<le> snd z)) \<or> (snd x \<le> snd y \<and> is_min2 x ys)"
by (auto simp: is_min2_def)

lemma is_min2_union:
  "is_min2 x (ys \<union> zs)
  \<longleftrightarrow> (is_min2 x ys \<and> (\<forall>z\<in>zs. snd x \<le> snd z))
    \<or> ((\<forall>y\<in>ys. snd x \<le> snd y) \<and> is_min2 x zs)"
by (auto simp: is_min2_def)

lemma is_min2_min2_insI: "is_min2 y ys \<Longrightarrow> is_min2 (min2 x y) (insert x ys)"
by (auto simp: is_min2_def min2_def split: prod.split)

lemma is_min2_mergeI:
  "is_min2 x xs \<Longrightarrow> is_min2 y ys \<Longrightarrow> is_min2 (min2 x y) (xs \<union> ys)"
by (auto simp: is_min2_def min2_def split: prod.split)

theorem invpst_mkNode[simp]: "invpst (mkNode c l a r) \<longleftrightarrow> invpst l \<and> invpst r"
apply (cases l rule: invpst.cases;
       cases r rule: invpst.cases;
       simp add: mkNode_def min_kp_def)
  subgoal using is_min2_min2_insI by blast
 subgoal by (auto intro!: is_min2_min2_insI simp: insert_commute)
subgoal by (smt Un_insert_left Un_insert_right is_min2_mergeI is_min2_min2_insI
                sup_assoc)
done

end


theory WordArraySpec
  imports "HOL-Word.Word" Word_Lib.HOL_Lemmas
begin

type_synonym u32 = "32 word"

datatype ('a, 'b) LoopResult = Iterate 'a | Break 'b
section \<open> List helper lemmas \<close>

lemma take_1_drop:
  "i < length xs \<Longrightarrow> take (Suc 0) (drop i xs) = [xs ! i]"
  apply (induct xs arbitrary: i)
   apply (simp add: take_Suc_conv_app_nth)
  by (simp add: drop_Suc_nth)

lemma take_drop_Suc:
  "i < l \<and> i < length xs \<Longrightarrow>
    take (l - i) (drop i xs) = (xs ! i) # take (l - Suc i) (drop (Suc i) xs)"
  apply clarsimp
  by (metis Cons_nth_drop_Suc Suc_diff_Suc take_Suc_Cons)

section \<open> wordarray\_length specification \<close>

definition w_length :: "u32 list \<Rightarrow> nat"
  where
"w_length w = length w"

subsection \<open> Correctness \<close>

lemma w_length_length_eq:
  "w_length xs = length xs"
  by (simp add: w_length_def)

section \<open> wordarray\_get specification \<close>

definition w_get :: "u32 list \<Rightarrow> nat \<Rightarrow> u32"
  where
"w_get w i = (if length w \<le> i then 0 else w ! i)"

subsection \<open> Correctness \<close>

lemma w_get_get_eq:
  "i < length xs \<Longrightarrow> w_get xs i = xs ! i"
  by (simp add: w_get_def)

section \<open> wordarray\_put2 specification \<close>

definition w_put :: "u32 list \<Rightarrow> nat \<Rightarrow>
                      u32 \<Rightarrow> u32 list"
  where
"w_put w i v = w[i := v]"

subsection \<open> Correctness \<close>

lemma w_put_listupdate_eq:
  "w_put xs i v= xs[i := v]"
  by (simp add: w_put_def)

section \<open> wordarray\_fold\_no\_break specification \<close>

definition w_fold :: "u32 list \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> (u32 \<Rightarrow> 'a \<Rightarrow> 'b \<Rightarrow> 'a) \<Rightarrow>
                      'a \<Rightarrow> 'b \<Rightarrow> 'a"
  where
"w_fold w frm to f acc obs =
  (if to \<le> frm
    then acc
  else
    fold (\<lambda>x y. f x y obs)
    (take (to - frm) (drop frm w)) acc)"

subsection \<open>w\_fold helper lemmas \<close>

lemma w_fold_step: "\<lbrakk>frm < length xs; frm < to\<rbrakk> \<Longrightarrow>
  w_fold xs frm to f acc obsv = w_fold xs (Suc frm) to f (f (xs ! frm) acc obsv) obsv"
  by (simp add: w_fold_def take_drop_Suc)

lemma w_fold_preserve:
  "\<lbrakk>frm \<le> i; i < min (length xs) to; w_fold xs frm to f acc obsv = w_fold xs i to f nacc obsv\<rbrakk> \<Longrightarrow>
   w_fold xs frm to f acc obsv = w_fold xs (Suc i) to f (f (xs ! i) nacc obsv) obsv "
  apply (simp add: w_fold_def)
  apply safe
   apply (simp add: take_drop_Suc)
   apply (simp add: take_drop_Suc)
  done

lemma w_fold_end:
  "\<lbrakk>frm \<le> i; i \<ge> min (length xs) to; w_fold xs frm to f acc obsv = w_fold xs i to f nacc obsv\<rbrakk> \<Longrightarrow>
   w_fold xs frm to f acc obsv = nacc "
  apply (simp add: w_fold_def)
  done

subsection \<open> w\_fold test \<close>

primrec summer :: "u32 \<Rightarrow> u32 \<Rightarrow> unit \<Rightarrow> u32" where
"summer elem acc () = elem + acc"

value "w_fold [0, 1, 2, 3, 4, 5] 1 1 summer 0 ()"

subsection \<open> Correctness \<close>

lemma w_fold_fold_eq_whole:
  "w_fold xs 0 (length xs) f acc obsv = fold (\<lambda>a b. f a b obsv) xs acc"
  apply (simp add: w_fold_def)
  done

lemma w_fold_fold_eq_slice:
  "w_fold xs frm to f acc obsv = fold (\<lambda>a b. f a b obsv) (take (to - frm) (drop frm xs)) acc"
  apply (simp add: w_fold_def)
  done

section \<open> wordarray\_fold specification \<close>
definition w_fold_break :: "u32 list \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow>
                            (u32 \<Rightarrow> 'a \<Rightarrow> 'b \<Rightarrow> ('a, 'c) LoopResult ) \<Rightarrow>
                            'a \<Rightarrow> 'b \<Rightarrow> ('a, 'c) LoopResult"
  where
"w_fold_break w frm to f acc obs =
  (if to \<le> frm
    then (Iterate acc)
  else
    fold (\<lambda>x y. (case y of
                    Iterate acc \<Rightarrow> f x acc obs |
                    Break acc \<Rightarrow> Break acc))
    (take (to - frm) (drop frm w)) (Iterate acc))"

section \<open> wordarray\_map\_no\_break specification \<close>

definition w_map :: "u32 list \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> (u32 \<Rightarrow> 'a \<Rightarrow> 'b \<Rightarrow> u32 \<times> 'a) \<Rightarrow>
                      'a \<Rightarrow> 'b \<Rightarrow> u32 list \<times> 'a"
  where
"w_map w frm to f acc obs =
  (if to \<le> frm
    then (w, acc)
  else
    let (ys, vacc) =
      fold (\<lambda>x (xs, vacc').
        let (y, vacc'') = f x vacc' obs
         in (xs @ [y], vacc''))
        (take (to - frm) (drop frm w)) ([], acc)
     in ((take frm w) @ ys @ (drop to w), vacc))"

subsection \<open> w\_map helper lemmas \<close>

lemma w_map_bounds:
  "to \<ge> length xs \<Longrightarrow> w_map xs frm to f acc obsv = w_map xs frm (length xs) f acc obsv"
  apply (simp add: w_map_def)
  done
lemma w_map_internal:
  "length (fst (fold (\<lambda>x p. (fst p @ [fst (f x (snd p) obsv)], snd (f x (snd p) obsv))) xs (ls, acc)))
    = length ls + length xs"
  apply (induct rule: rev_induct)
   apply simp
  apply (simp add: split_def)
  done

lemma w_map_length:
  "length (fst (w_map xs frm to f acc obsv)) = length xs"
  apply (induct rule: rev_induct)
   apply (simp add: w_map_def)
  apply (clarsimp simp add: w_map_def)
  apply (case_tac "frm > length xs")
   apply simp
  apply (case_tac "frm = length xs") thm split_def
   apply (simp add: split_def)
  apply simp
  apply (case_tac "to < length xs")
   apply simp
   apply (simp add: split_def)
  apply (case_tac "to = length xs")
   apply simp
   apply (simp add: split_def)
  apply simp
  apply (simp add: split_def)
  done

lemma w_map_length_same:
  "length xs = length ys \<Longrightarrow> length (fst (w_map xs frm to f acc obsv))
    = length (fst (w_map ys frm' to' f' acc' obsv'))"
  apply (induct xs arbitrary: ys rule: rev_induct)
   apply simp
   apply (simp add: w_map_def)
  by (simp add: w_map_length)

lemma w_map_length_Cons:
  "length (fst (w_map (x # xs) frm to f acc obsv))
    = Suc (length (fst (w_map xs frm' to' f' acc' obsv')))"
  apply (induct xs)
   apply (subst w_map_length)
   apply (subst w_map_length)
   apply simp
  apply (subst w_map_length)
  apply (subst w_map_length)
  apply simp
  done

lemma w_map_length_append:
  "length (fst (w_map (xs @ [x]) frm to f acc obsv))
    = Suc (length (fst (w_map xs frm' to' f' acc' obsv')))"
  apply (induct xs)
   apply (subst w_map_length)
   apply (subst w_map_length)
   apply simp
  apply (subst w_map_length)
  apply (subst w_map_length)
  apply simp
  done

lemma w_map_append_list:
  "to \<le> length xs \<Longrightarrow>
    fst (w_map (xs @ ys) frm to f acc obsv) = fst (w_map xs frm to f acc obsv) @ ys"
  apply (simp add: w_map_def)
  apply clarsimp
  apply (simp add: split_def)
  done

lemma w_map_append_acc:
  "to \<le> length xs \<Longrightarrow>
    snd (w_map (xs @ ys) frm to f acc obsv) = snd (w_map xs frm to f acc obsv)"
  apply (simp add: w_map_def)
  apply (simp add: split_def)
  done

lemmas w_map_append = w_map_append_list w_map_append_acc

lemma w_map_step_list:
  "frm \<le> to \<Longrightarrow> fst (w_map xs frm (Suc to) f acc obsv) =
  (fst (w_map xs frm to f acc obsv))[to := fst (f (xs ! to) (snd (w_map xs frm to f acc obsv)) obsv)]"
  apply (induct xs rule: rev_induct)
   apply (simp add: w_map_def)
  apply (case_tac "to \<ge> length xs")
   apply (case_tac "to \<ge> length (xs @ [x])")
    apply (subst (asm) w_map_length[where frm = frm and to = to and f = "f" and acc = acc and obsv = obsv,symmetric])
    apply simp
    apply (subgoal_tac "length (fst (w_map (xs @ [x]) frm to f acc obsv)) = Suc (length xs)")
     apply simp
     apply (subst w_map_def)
     apply (subst w_map_def)
     apply simp
    apply (simp add: w_map_length)
   apply (subgoal_tac "to = length xs")
  defer
    apply simp
   defer
   apply simp
   apply (simp (no_asm) add: w_map_def)
   apply (rule conjI)
    apply clarsimp
    apply (simp add: split_def)
   apply clarsimp
   apply (simp add: split_def)
   apply (subst upd_conv_take_nth_drop)
    apply simp
    apply (subst w_map_internal)
    apply simp
   apply simp
   apply (subgoal_tac "length (fst (fold (\<lambda>x p. (fst p @ [fst (f x (snd p) obsv)], snd (f x (snd p) obsv))) (drop frm xs) ([], acc))) = length xs - frm")
    apply simp
   apply (subst w_map_internal)
   apply simp
  apply simp
  apply (subgoal_tac "snd (w_map (xs @ [x]) frm to f acc obsv) = snd (w_map xs frm to f acc obsv)")
   apply simp
   apply (subgoal_tac "(xs @ [x]) ! to = xs ! to")
    apply simp
    apply (subst w_map_append)
     apply linarith
    apply (subst w_map_append)
     apply simp
    apply clarsimp
    apply (subst list_update_append1)
     apply (simp add: w_map_length)
    apply simp
   apply (simp add: nth_append)
  apply (simp add: w_map_append)
  done

lemma w_map_step_acc:
  "\<lbrakk>frm \<le> to; Suc to \<le> length xs\<rbrakk>
    \<Longrightarrow> snd (w_map xs frm (Suc to) f acc obsv)
      = snd (f (xs ! to) (snd (w_map xs frm to f acc obsv)) obsv)"
  apply (induct xs rule: rev_induct)
   apply (clarsimp simp add: w_map_def)
  apply clarsimp
  apply (case_tac "Suc to \<le> length xs")
   apply (simp add: w_map_append)
   apply (simp add: nth_append)
  apply (simp add: nth_append)
  apply (simp add: w_map_def)
  apply (simp add: split_def)
  done

lemmas w_map_step = w_map_step_list w_map_step_acc

lemma w_map_endpoint:
  "to < length xs \<Longrightarrow> fst (w_map xs frm to f acc obsv) ! to = xs ! to"
  apply (induct xs rule: rev_induct)
  apply (simp add: w_map_def)
  apply clarsimp
  apply (simp add: w_map_append)
  apply (case_tac "to = length xs")
   apply simp
   apply (metis w_map_length nth_append_length)
  apply (subgoal_tac "to < length xs")
   apply simp
   apply (simp add: w_map_length nth_append)
  apply arith
  done

subsection \<open> Correctness \<close>

lemma no_update_acc:
  "\<lbrakk>\<forall>x ob a. snd (f x a ob) = a; xs \<noteq> []\<rbrakk>
    \<Longrightarrow> snd (fold (\<lambda>x p. (fst p @ [fst (f x (snd p) obsv)], snd p)) xs ([], acc)) = acc"
  apply (induct xs rule: rev_induct)
   apply simp
  apply simp
  apply (case_tac "xs = []")
   apply simp
  apply simp
  done

lemma w_map_map_eq_whole:
  "\<lbrakk>\<forall>x ob a. snd (f x a ob) = a \<rbrakk>
    \<Longrightarrow> fst (w_map xs 0 (length xs) f acc obsv) = map (\<lambda>x. fst (f x acc obsv)) xs"
  apply (induct xs rule: rev_induct)
   apply (simp add: w_map_def)
  apply simp
  apply (subst w_map_step)
   apply simp
  apply (subst w_map_append)
   apply simp
  apply (subst list_update_append)
  apply (subst w_map_length)
  apply simp
  apply (subst w_map_append)
   apply simp
  apply (simp (no_asm) add: w_map_def)
  apply (simp add: split_def)
  apply clarsimp
  apply (subgoal_tac "snd (fold (\<lambda>x p. (fst p @ [fst (f x (snd p) obsv)], snd p)) xs ([], acc)) = acc")
   apply simp
  apply (rule no_update_acc)
   apply simp
  apply simp
  done

section \<open> wordarray\_map specification \<close>

definition w_map_break :: "u32 list \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow>
                      (u32 \<Rightarrow> 'a \<Rightarrow> 'b \<Rightarrow> (u32 \<times> 'a, 'c) LoopResult) \<Rightarrow>
                      'a \<Rightarrow> 'b \<Rightarrow> (u32 list \<times> 'a, 'c) LoopResult"
  where
"w_map_break w frm to f acc obs =
  (if to \<le> frm
    then Iterate (w, acc)
  else
   let ret = fold
      (\<lambda>x r.
        case r of
            Iterate (xs, vacc) \<Rightarrow>
              let r' = f x vacc obs
               in
                  (case r' of
                      Iterate (x', vacc') \<Rightarrow> Iterate (xs @ [x'], vacc') |
                      Break v \<Rightarrow> Break v) |
            Break v \<Rightarrow> Break v)
      (take (to - frm) (drop frm w))  (Iterate ([], acc))
   in
     case ret of
          Iterate (ys, acc') \<Rightarrow> Iterate ((take frm w) @ ys @ (drop to w), acc') |
          Break v \<Rightarrow> Break v)"
end