chapter \<open>Addition, Sequences and their Concatenation\<close>

theory OrdArith imports Rank
begin

section \<open>Generalised Addition --- Also for Ordinals\<close>
text \<open>Source: Laurence Kirby, Addition and multiplication of sets
      Math. Log. Quart. 53, No. 1, 52-65 (2007) / DOI 10.1002/malq.200610026
      @{url "http://faculty.baruch.cuny.edu/lkirby/mlqarticlejan2007.pdf"}\<close>

definition
  hadd      :: "hf \<Rightarrow> hf \<Rightarrow> hf"           (infixl "@+" 65)  where
    "hadd x \<equiv> hmemrec (\<lambda>f z. x \<squnion> RepFun z f)"

lemma hadd: "x @+ y = x \<squnion> RepFun y (\<lambda>z. x @+ z)"
  by (metis def_hmemrec RepFun_ecut hadd_def order_refl)

lemma hmem_hadd_E:
  assumes l: "l \<^bold>\<in> x @+ y"
  obtains "l \<^bold>\<in> x" | z where "z \<^bold>\<in> y" "l = x @+ z"
  using l
  by (auto simp: hadd [of x y])

lemma hadd_0_right [simp]: "x @+ 0 = x"
  by (subst hadd) simp

lemma hadd_hinsert_right: "x @+ hinsert y z = hinsert (x @+ y) (x @+ z)"
  by (metis hadd hunion_hinsert_right RepFun_hinsert)

lemma hadd_succ_right [simp]: "x @+ succ y = succ (x @+ y)"
  by (metis hadd_hinsert_right succ_def)

lemma not_add_less_right: "\<not> (x @+ y < x)"
  apply (induct y, auto)
  apply (metis less_supI1 hadd order_less_le)
  done

lemma not_add_mem_right: "\<not> (x @+ y \<^bold>\<in> x)"
  by (metis hadd hmem_not_refl hunion_iff)

lemma hadd_0_left [simp]: "0 @+ x = x"
  by (induct x) (auto simp: hadd_hinsert_right)

lemma hadd_succ_left [simp]: "Ord y \<Longrightarrow> succ x @+ y = succ (x @+ y)"
  by (induct y rule: Ord_induct2) auto

lemma hadd_assoc: "(x @+ y) @+ z = x @+ (y @+ z)"
  by (induct z) (auto simp: hadd_hinsert_right)

lemma RepFun_hadd_disjoint: "x \<sqinter> RepFun y ((@+) x) = 0"
  by (metis hf_equalityI RepFun_iff hinter_iff not_add_mem_right hmem_hempty)

subsection \<open>Cancellation laws for addition\<close>

lemma Rep_le_Cancel: "x \<squnion> RepFun y ((@+) x) \<le> x \<squnion> RepFun z ((@+) x)
                      \<Longrightarrow> RepFun y ((@+) x) \<le> RepFun z ((@+) x)"
  by (auto simp add: not_add_mem_right)

lemma hadd_cancel_right [simp]: "x @+ y = x @+ z \<longleftrightarrow> y=z"
proof (induct y arbitrary: z rule: hmem_induct)
  case (step y z) show ?case
  proof auto
    assume eq: "x @+ y = x @+ z"
    hence  "RepFun y ((@+) x) = RepFun z ((@+) x)"
      by (metis hadd Rep_le_Cancel order_antisym order_refl)
    thus  "y = z"
      by (metis hf_equalityI RepFun_iff step)
  qed
qed

lemma RepFun_hadd_cancel: "RepFun y (\<lambda>z. x @+ z) = RepFun z (\<lambda>z. x @+ z) \<longleftrightarrow> y=z"
  by (metis hadd hadd_cancel_right)

lemma hadd_hmem_cancel [simp]: "x @+ y \<^bold>\<in> x @+ z \<longleftrightarrow> y \<^bold>\<in> z"
  apply (auto simp: hadd [of _ y] hadd [of _ z] not_add_mem_right)
  apply (metis hmem_not_refl hunion_iff)
  apply (metis hadd hadd_cancel_right)
  done

lemma ord_of_add: "ord_of (i+j) = ord_of i @+ ord_of j"
  by (induct j) auto

lemma Ord_hadd: "Ord x \<Longrightarrow> Ord y \<Longrightarrow> Ord (x @+ y)"
  by (induct x rule: Ord_induct2) auto

lemma hmem_self_hadd [simp]: "k1 \<^bold>\<in> k1 @+ k2 \<longleftrightarrow> 0 \<^bold>\<in> k2"
  by (metis hadd_0_right hadd_hmem_cancel)

lemma hadd_commute: "Ord x \<Longrightarrow> Ord y \<Longrightarrow> x @+ y = y @+ x"
  by (induct x rule: Ord_induct2) auto

lemma hadd_cancel_left [simp]: "Ord x \<Longrightarrow> y @+ x = z @+ x \<longleftrightarrow> y=z"
  by (induct x rule: Ord_induct2) auto

subsection \<open>The predecessor function\<close>

definition pred :: "hf \<Rightarrow> hf"
  where "pred x \<equiv> (THE y. succ y = x \<or> x=0 \<and> y=0)"

lemma pred_succ [simp]: "pred (succ x) = x"
  by (simp add: pred_def)

lemma pred_0 [simp]: "pred 0 = 0"
  by (simp add: pred_def)

lemma succ_pred [simp]: "Ord x \<Longrightarrow> x \<noteq> 0 \<Longrightarrow> succ (pred x) = x"
  by (metis Ord_cases pred_succ)

lemma pred_mem [simp]: "Ord x \<Longrightarrow> x \<noteq> 0 \<Longrightarrow> pred x \<^bold>\<in> x"
  by (metis succ_iff succ_pred)

lemma Ord_pred [simp]: "Ord x \<Longrightarrow> Ord (pred x)"
  by (metis Ord_in_Ord pred_0 pred_mem)

lemma hadd_pred_right: "Ord y \<Longrightarrow> y \<noteq> 0 \<Longrightarrow> x @+ pred y = pred (x @+ y)"
  by (metis hadd_succ_right pred_succ succ_pred)

lemma Ord_pred_HUnion: "Ord(k) \<Longrightarrow> pred k = \<Squnion>k"
  by (metis HUnion_hempty Ordinal.Ord_pred pred_0 pred_succ)

section \<open>A Concatentation Operation for Sequences\<close>

definition shift :: "hf \<Rightarrow> hf \<Rightarrow> hf"
  where "shift f delta = \<lbrace>v . u \<^bold>\<in> f, \<exists>n y. u = \<langle>n, y\<rangle> \<and> v = \<langle>delta @+ n, y\<rangle>\<rbrace>"

lemma shiftD: "x \<^bold>\<in> shift f delta \<Longrightarrow> \<exists>u. u \<^bold>\<in> f \<and> x = \<langle>delta @+ hfst u, hsnd u\<rangle>"
  by (auto simp: shift_def hsplit_def)

lemma hmem_shift_iff: "\<langle>m, y\<rangle> \<^bold>\<in> shift f delta \<longleftrightarrow> (\<exists>n. m = delta @+ n \<and> \<langle>n, y\<rangle> \<^bold>\<in> f)"
  by (auto simp: shift_def hrelation_def is_hpair_def)

lemma hmem_shift_add_iff [simp]: "\<langle>delta @+ n, y\<rangle> \<^bold>\<in> shift f delta \<longleftrightarrow> \<langle>n, y\<rangle> \<^bold>\<in> f"
  by (metis hadd_cancel_right hmem_shift_iff)

lemma hrelation_shift [simp]: "hrelation (shift f delta)"
  by (auto simp: shift_def hrelation_def hsplit_def)

lemma app_shift [simp]: "app (shift f k) (k @+ j) = app f j"
  by (simp add: app_def)

lemma hfunction_shift_iff [simp]: "hfunction (shift f delta) = hfunction f"
  by (auto simp: hfunction_def hmem_shift_iff)

lemma hdomain_shift_add: "hdomain (shift f delta) = \<lbrace>delta @+ n . n \<^bold>\<in> hdomain f\<rbrace>"
  by  (rule hf_equalityI) (force simp add: hdomain_def hmem_shift_iff)

definition seq_append :: "hf \<Rightarrow> hf \<Rightarrow> hf \<Rightarrow> hf"
  where "seq_append k f g \<equiv> hrestrict f k \<squnion> shift g k"

lemma hrelation_seq_append [simp]: "hrelation (seq_append k f g)"
  by (simp add: seq_append_def)

lemma Seq_append: "Seq s1 k1 \<Longrightarrow> Seq s2 k2 \<Longrightarrow> Seq (seq_append k1 s1 s2) (k1 @+ k2)"
  apply (auto simp: Seq_def seq_append_def)
  apply (metis hdomain_restr hdomain_shift_disjoint hfunction_hunion hfunction_restr hfunction_shift_iff inf_absorb2 seq_append_def)
  apply (simp add: hdomain_shift_add)
  apply (metis hmem_hadd_E rev_hsubsetD)
  apply (erule hmem_hadd_E, assumption, auto)
  apply (metis Seq_def Seq_iff_app hdomainI hmem_shift_add_iff)
  done

lemma app_hunion1: "x \<^bold>\<notin> hdomain g \<Longrightarrow> app (f \<squnion> g) x = app f x"
  by (auto simp: app_def) (metis hdomainI)

lemma app_hunion2: "x \<^bold>\<notin> hdomain f \<Longrightarrow> app (f \<squnion> g) x = app g x"
  by (auto simp: app_def) (metis hdomainI)

lemma Seq_append_app1: "Seq s k \<Longrightarrow> l \<^bold>\<in> k \<Longrightarrow> app (seq_append k s s') l = app s l"
  apply (auto simp: Seq_def seq_append_def)
  apply (metis app_hunion1 hdomain_shift_disjoint hemptyE hinter_iff app_hrestrict)
  done

lemma Seq_append_app2: "Seq s1 k1 \<Longrightarrow> Seq s2 k2 \<Longrightarrow> l = k1 @+ j \<Longrightarrow> app (seq_append k1 s1 s2) l = app s2 j"
  by (metis seq_append_def app_hunion2 app_shift hdomain_restr hinter_iff not_add_mem_right)

section \<open>Nonempty sequences indexed by ordinals\<close>

definition OrdDom where
 "OrdDom r \<equiv> \<forall>x y. \<langle>x,y\<rangle> \<^bold>\<in> r \<longrightarrow> Ord x"

lemma OrdDom_insf: "\<lbrakk>OrdDom s; Ord k\<rbrakk> \<Longrightarrow> OrdDom (insf s (succ k) y)"
  by (auto simp: insf_def OrdDom_def)

lemma OrdDom_hunion [simp]: "OrdDom (s1 \<squnion> s2) \<longleftrightarrow> OrdDom s1 \<and> OrdDom s2"
  by (auto simp: OrdDom_def)

lemma OrdDom_hrestrict: "OrdDom s \<Longrightarrow> OrdDom (hrestrict s A)"
  by (auto simp: OrdDom_def)

lemma OrdDom_shift: "\<lbrakk>OrdDom s; Ord k\<rbrakk> \<Longrightarrow> OrdDom (shift s k)"
  by (auto simp: OrdDom_def shift_def Ord_hadd)

text \<open>A sequence of positive length ending with @{term y}\<close>
definition LstSeq :: "hf \<Rightarrow> hf \<Rightarrow> hf \<Rightarrow> bool"
  where "LstSeq s k y \<equiv> Seq s (succ k) \<and> Ord k \<and> \<langle>k,y\<rangle> \<^bold>\<in> s \<and> OrdDom s"

lemma LstSeq_imp_Seq_same: "LstSeq s k y \<Longrightarrow> Seq s k"
  by (metis LstSeq_imp_Seq_succ Seq_succ_D)

lemma LstSeq_imp_Ord: "LstSeq s k y \<Longrightarrow> Ord k"
  by (metis LstSeq_def)

lemma LstSeq_trunc: "LstSeq s k y \<Longrightarrow> l \<^bold>\<in> k \<Longrightarrow> LstSeq s l (app s l)"
  apply (auto simp: LstSeq_def Seq_iff_app)
  apply (metis Ord_succ Seq_Ord_D mem_succ_iff)
  apply (metis Ord_in_Ord)
  done

lemma LstSeq_insf: "LstSeq s k z \<Longrightarrow> LstSeq (insf s (succ k) y) (succ k) y"
  by (metis OrdDom_insf LstSeq_def Ord_succ_iff Seq_imp_eq_app Seq_insf Seq_succ_iff app_insf_Seq)

lemma app_insf_LstSeq: "LstSeq s k z \<Longrightarrow> app (insf s (succ k) y) (succ k) = y"
  by (metis LstSeq_imp_Seq_succ app_insf_Seq)

lemma app_insf2_LstSeq: "LstSeq s k z \<Longrightarrow> k' \<noteq> succ k \<Longrightarrow> app (insf s (succ k) y) k' = app s k'"
  by (metis LstSeq_imp_Seq_succ app_insf2_Seq)

lemma app_insf_LstSeq_if: "LstSeq s k z \<Longrightarrow> app (insf s (succ k) y) k' = (if k' = succ k then y else app s k')"
  by (metis app_insf2_LstSeq app_insf_LstSeq)

lemma LstSeq_append_app1:
  "LstSeq s k y \<Longrightarrow> l \<^bold>\<in> succ k \<Longrightarrow> app (seq_append (succ k) s s') l = app s l"
  by (metis LstSeq_imp_Seq_succ Seq_append_app1)

lemma LstSeq_append_app2:
  "\<lbrakk>LstSeq s1 k1 y1; LstSeq s2 k2 y2; l = succ k1 @+ j\<rbrakk>
   \<Longrightarrow> app (seq_append (succ k1) s1 s2) l = app s2 j"
   by (metis LstSeq_imp_Seq_succ Seq_append_app2)

lemma Seq_append_pair:
  "\<lbrakk>Seq s1 k1; Seq s2 (succ n);  \<langle>n, y\<rangle> \<^bold>\<in> s2; Ord n\<rbrakk> \<Longrightarrow> \<langle>k1 @+ n, y\<rangle> \<^bold>\<in> (seq_append k1 s1 s2)"
  by (metis hmem_shift_add_iff hunion_iff seq_append_def)

lemma Seq_append_OrdDom: "\<lbrakk>Ord k; OrdDom s1; OrdDom s2\<rbrakk> \<Longrightarrow> OrdDom (seq_append k s1 s2)"
  by (auto simp: seq_append_def OrdDom_hrestrict OrdDom_shift)

lemma LstSeq_append:
  "\<lbrakk>LstSeq s1 k1 y1; LstSeq s2 k2 y2\<rbrakk> \<Longrightarrow> LstSeq (seq_append (succ k1) s1 s2) (succ (k1 @+ k2)) y2"
  apply (auto simp: LstSeq_def Seq_append Ord_hadd Seq_append_pair)
  apply (metis Seq_append hadd_succ_left hadd_succ_right)
  apply (metis Seq_append_pair hadd_succ_left)
  apply (metis Ord_succ Seq_append_OrdDom)
  done

lemma LstSeq_app [simp]: "LstSeq s k y \<Longrightarrow> app s k = y"
  by (metis LstSeq_def Seq_imp_eq_app)

subsection \<open>Sequence-building operators\<close>

definition Builds :: "(hf \<Rightarrow> bool) \<Rightarrow> (hf \<Rightarrow> hf \<Rightarrow> hf \<Rightarrow> bool) \<Rightarrow> hf \<Rightarrow> hf \<Rightarrow> bool"
  where "Builds B C s l \<equiv> B (app s l) \<or> (\<exists>m \<^bold>\<in> l. \<exists>n \<^bold>\<in> l. C (app s l) (app s m) (app s n))"

definition BuildSeq :: "(hf \<Rightarrow> bool) \<Rightarrow> (hf \<Rightarrow> hf \<Rightarrow> hf \<Rightarrow> bool) \<Rightarrow> hf \<Rightarrow> hf \<Rightarrow> hf \<Rightarrow> bool"
  where "BuildSeq B C s k y \<equiv> LstSeq s k y \<and> (\<forall>l \<^bold>\<in> succ k. Builds B C s l)"

lemma BuildSeqI: "LstSeq s k y \<Longrightarrow> (\<And>l. l \<^bold>\<in> succ k \<Longrightarrow> Builds B C s l) \<Longrightarrow> BuildSeq B C s k y"
  by (simp add: BuildSeq_def)

lemma BuildSeq_imp_LstSeq: "BuildSeq B C s k y \<Longrightarrow> LstSeq s k y"
  by (metis BuildSeq_def)

lemma BuildSeq_imp_Seq: "BuildSeq B C s k y \<Longrightarrow> Seq s (succ k)"
  by (metis LstSeq_imp_Seq_succ BuildSeq_imp_LstSeq)

lemma BuildSeq_conj_distrib:
 "BuildSeq (\<lambda>x. B x \<and> P x) (\<lambda>x y z. C x y z \<and> P x) s k y \<longleftrightarrow>
  BuildSeq B C s k y \<and> (\<forall>l \<^bold>\<in> succ k. P (app s l))"
  by (auto simp: BuildSeq_def Builds_def)

lemma BuildSeq_mono:
  assumes y: "BuildSeq B C s k y"
      and B: "\<And>x. B x \<Longrightarrow> B' x" and C: "\<And>x y z. C x y z \<Longrightarrow> C' x y z"
  shows "BuildSeq B' C' s k y"
using y
  by (auto simp: BuildSeq_def Builds_def intro!: B C)

lemma BuildSeq_trunc:
  assumes b: "BuildSeq B C s k y"
      and l: "l \<^bold>\<in> k"
  shows "BuildSeq B C s l (app s l)"
proof -
  { fix j
    assume j: "j \<^bold>\<in> succ l"
    have k: "Ord k"
      by (metis BuildSeq_imp_LstSeq LstSeq_def b)
    hence "Builds B C s j"
      by (metis BuildSeq_def OrdmemD b hballE hsubsetD j l succ_iff)
 }
 thus ?thesis using b l
  by (auto simp: BuildSeq_def LstSeq_trunc)
qed

subsection \<open>Showing that Sequences can be Constructed\<close>

lemma Builds_insf: "Builds B C s l \<Longrightarrow> LstSeq s k z \<Longrightarrow> l \<^bold>\<in> succ k \<Longrightarrow> Builds B C (insf s (succ k) y) l"
by (auto simp: HBall_def hmem_not_refl Builds_def app_insf_LstSeq_if simp del: succ_iff)
   (metis hmem_not_sym)

lemma BuildSeq_insf:
  assumes b: "BuildSeq B C s k z"
      and m: "m \<^bold>\<in> succ k"
      and n: "n \<^bold>\<in> succ k"
      and y: "B y \<or> C y (app s m) (app s n)"
shows "BuildSeq B C (insf s (succ k) y) (succ k) y"
proof (rule BuildSeqI)
  show "LstSeq (insf s (succ k) y) (succ k) y"
  by (metis BuildSeq_imp_LstSeq LstSeq_insf b)
next
  fix l
  assume l: "l \<^bold>\<in> succ (succ k)"
  thus "Builds B C (insf s (succ k) y) l"
  proof
    assume l: "l = succ k"
    have "B (app (insf s l y) l) \<or> C (app (insf s l y) l) (app (insf s l y) m) (app (insf s l y) n)"
      by (metis BuildSeq_imp_Seq app_insf_Seq_if b hmem_not_refl l m n y)
    thus "Builds B C (insf s (succ k) y) l" using m n
      by (auto simp: Builds_def l)
  next
    assume l: "l \<^bold>\<in> succ k"
    have  "LstSeq s k z"
      by (metis BuildSeq_imp_LstSeq b)
    thus "Builds B C (insf s (succ k) y) l" using b l
      by (metis hballE Builds_insf BuildSeq_def)
  qed
qed

lemma BuildSeq_insf1:
  assumes b: "BuildSeq B C s k z"
      and y: "B y"
  shows "BuildSeq B C (insf s (succ k) y) (succ k) y"
by (metis BuildSeq_insf b succ_iff y)

lemma BuildSeq_insf2:
  assumes b: "BuildSeq B C s k z"
      and m: "m \<^bold>\<in> k"
      and n: "n \<^bold>\<in> k"
      and y: "C y (app s m) (app s n)"
  shows "BuildSeq B C (insf s (succ k) y) (succ k) y"
  by (metis BuildSeq_insf b m n succ_iff y)

lemma BuildSeq_append:
  assumes s1: "BuildSeq B C s1 k1 y1" and s2: "BuildSeq B C s2 k2 y2"
  shows "BuildSeq B C (seq_append (succ k1) s1 s2) (succ (k1 @+ k2)) y2"
proof (rule BuildSeqI)
  show "LstSeq (seq_append (succ k1) s1 s2) (succ (k1 @+ k2)) y2"
    using assms
    by (metis BuildSeq_imp_LstSeq LstSeq_append)
next
  fix l
  have s1L: "LstSeq s1 k1 y1"
   and s1BC: "\<And>l. l \<^bold>\<in> succ k1 \<Longrightarrow> Builds B C s1 l"
   and s2L: "LstSeq s2 k2 y2"
   and s2BC: "\<And>l. l \<^bold>\<in> succ k2 \<Longrightarrow> Builds B C s2 l"
    using s1 s2 by (auto simp: BuildSeq_def)
  assume l: "l \<^bold>\<in> succ (succ (k1 @+ k2))"
  hence  "l \<^bold>\<in> succ k1 @+ succ k2"
    by (metis LstSeq_imp_Ord hadd_succ_left hadd_succ_right s2L)
  thus "Builds B C (seq_append (succ k1) s1 s2) l"
  proof (rule hmem_hadd_E)
    assume l1: "l \<^bold>\<in> succ k1"
    hence "B (app s1 l) \<or> (\<exists>m\<^bold>\<in>l. \<exists>n\<^bold>\<in>l. C (app s1 l) (app s1 m) (app s1 n))" using s1BC
      by (simp add: Builds_def)
    thus ?thesis
    proof
      assume "B (app s1 l)"
      thus ?thesis
        by (metis Builds_def LstSeq_append_app1 l1 s1L)
    next
      assume "\<exists>m\<^bold>\<in>l. \<exists>n\<^bold>\<in>l. C (app s1 l) (app s1 m) (app s1 n)"
      then obtain m n where mn: "m \<^bold>\<in> l" "n \<^bold>\<in> l" and C: "C (app s1 l) (app s1 m) (app s1 n)"
        by blast
      also have "m \<^bold>\<in> succ k1" "n \<^bold>\<in> succ k1"
        by (metis LstSeq_def Ord_trans l1 mn s1L succ_iff)+
      ultimately have "C (app (seq_append (succ k1) s1 s2) l)
                         (app (seq_append (succ k1) s1 s2) m)
                         (app (seq_append (succ k1) s1 s2) n)"
        using s1L l1
        by (simp add: LstSeq_append_app1)
      thus "Builds B C (seq_append (succ k1) s1 s2) l" using mn
        by (auto simp: Builds_def)
    qed
  next
    fix z
    assume z: "z \<^bold>\<in> succ k2" and l2: "l = succ k1 @+ z"
    hence "B (app s2 z) \<or> (\<exists>m\<^bold>\<in>z. \<exists>n\<^bold>\<in>z. C (app s2 z) (app s2 m) (app s2 n))" using s2BC
      by (simp add: Builds_def)
    thus ?thesis
    proof
      assume "B (app s2 z)"
      thus ?thesis
        by (metis Builds_def LstSeq_append_app2 l2 s1L s2L)
    next
      assume "\<exists>m\<^bold>\<in>z. \<exists>n\<^bold>\<in>z. C (app s2 z) (app s2 m) (app s2 n)"
      then obtain m n where mn: "m \<^bold>\<in> z" "n \<^bold>\<in> z" and C: "C (app s2 z) (app s2 m) (app s2 n)"
        by blast
      also have "m \<^bold>\<in> succ k2" "n \<^bold>\<in> succ k2" using mn
        by (metis LstSeq_def Ord_trans z s2L succ_iff)+
      ultimately have "C (app (seq_append (succ k1) s1 s2) l)
                         (app (seq_append (succ k1) s1 s2) (succ k1 @+ m))
                         (app (seq_append (succ k1) s1 s2) (succ k1 @+ n))"
        using s1L s2L l2 z
        by (simp add: LstSeq_append_app2)
      thus "Builds B C (seq_append (succ k1) s1 s2) l" using mn l2
        by (auto simp: Builds_def HBall_def)
    qed
  qed
qed

lemma BuildSeq_combine:
  assumes b1: "BuildSeq B C s1 k1 y1" and b2: "BuildSeq B C s2 k2 y2"
      and y: "C y y1 y2"
  shows "BuildSeq B C (insf (seq_append (succ k1) s1 s2) (succ (succ (k1 @+ k2))) y) (succ (succ (k1 @+ k2))) y"
proof -
  have k2: "Ord k2"  using b2
    by (auto simp: BuildSeq_def LstSeq_def)
  show ?thesis
  proof (rule BuildSeq_insf [where m=k1 and n="succ(k1@+k2)"])
    show "BuildSeq B C (seq_append (succ k1) s1 s2) (succ (k1 @+ k2)) y2"
      by (rule BuildSeq_append [OF b1 b2])
  next
    show "k1 \<^bold>\<in> succ (succ (k1 @+ k2))" using k2
      by (metis hadd_0_right hmem_0_Ord hmem_self_hadd succ_iff)
  next
    show "succ (k1 @+ k2) \<^bold>\<in> succ (succ (k1 @+ k2))"
      by (metis succ_iff)
  next
    have [simp]: "app (seq_append (succ k1) s1 s2) k1 = y1"
      by (metis b1 BuildSeq_imp_LstSeq LstSeq_app LstSeq_append_app1 succ_iff)
    have [simp]: "app (seq_append (succ k1) s1 s2) (succ (k1 @+ k2)) = y2"
      by (metis b1 b2 k2 BuildSeq_imp_LstSeq LstSeq_app LstSeq_append_app2 hadd_succ_left)
    show "B y \<or>
          C y (app (seq_append (succ k1) s1 s2) k1)
              (app (seq_append (succ k1) s1 s2) (succ (k1 @+ k2)))"
      using y by simp
  qed
qed

lemma LstSeq_1: "LstSeq \<lbrace>\<langle>0, y\<rangle>\<rbrace> 0 y"
 by (auto simp: LstSeq_def One_hf_eq_succ Seq_ins OrdDom_def)

lemma BuildSeq_1: "B y \<Longrightarrow> BuildSeq B C \<lbrace>\<langle>0, y\<rangle>\<rbrace> 0 y"
  by (auto simp: BuildSeq_def Builds_def LstSeq_1)

lemma BuildSeq_exI: "B t \<Longrightarrow> \<exists>s k. BuildSeq B C s k t"
  by (metis BuildSeq_1)

subsection \<open>Proving Properties of Given Sequences\<close>

lemma BuildSeq_induct [consumes 1, case_names B C]:
  assumes major: "BuildSeq B C s k a"
      and B: "\<And>x. B x \<Longrightarrow> P x"
      and C: "\<And>x y z. C x y z \<Longrightarrow> P y \<Longrightarrow> P z \<Longrightarrow> P x"
  shows "P a"
proof -
  have "Ord k" using assms
    by (auto simp: BuildSeq_def LstSeq_def)
  hence "\<And>a s. BuildSeq B C s k a \<Longrightarrow> P a"
    by (induction k rule: Ord_induct) (metis BuildSeq_trunc BuildSeq_succ_E B C)
  thus ?thesis
    by (metis major)
qed

definition BuildSeq2 :: "[[hf,hf] \<Rightarrow> bool, [hf,hf,hf,hf,hf,hf] \<Rightarrow> bool, hf, hf, hf, hf] \<Rightarrow> bool"
  where "BuildSeq2 B C s k y y' \<equiv>
         BuildSeq (\<lambda>p. \<exists>x x'. p = \<langle>x,x'\<rangle> \<and> B x x')
                  (\<lambda>p q r. \<exists>x x' y y' z z'. p = \<langle>x,x'\<rangle> \<and> q = \<langle>y,y'\<rangle> \<and> r = \<langle>z,z'\<rangle> \<and> C x x' y y' z z')
                  s k \<langle>y,y'\<rangle>"

lemma BuildSeq2_combine:
  assumes b1: "BuildSeq2 B C s1 k1 y1 y1'" and b2: "BuildSeq2 B C s2 k2 y2 y2'"
      and y: "C y y' y1 y1' y2 y2'"
  shows "BuildSeq2 B C (insf (seq_append (succ k1) s1 s2) (succ (succ (k1 @+ k2))) \<langle>y, y'\<rangle>)
                       (succ (succ (k1 @+ k2))) y y'"
  using assms
  apply (unfold BuildSeq2_def)
  apply (blast intro: BuildSeq_combine)
  done

lemma BuildSeq2_1: "B y y' \<Longrightarrow> BuildSeq2 B C \<lbrace>\<langle>0, y, y'\<rangle>\<rbrace> 0 y y'"
  by (auto simp: BuildSeq2_def BuildSeq_1)

lemma BuildSeq2_induct [consumes 1, case_names B C]:
  assumes "BuildSeq2 B C s k a a'"
      and B: "\<And>x x'. B x x' \<Longrightarrow> P x x'"
      and C: "\<And>x x' y y' z z'. C x x' y y' z z' \<Longrightarrow> P y y' \<Longrightarrow> P z z' \<Longrightarrow> P x x'"
  shows "P a a'"
using assms
apply (simp add: BuildSeq2_def)
apply (drule BuildSeq_induct [where P = "\<lambda>\<langle>x,x'\<rangle>. P x x'"])
apply (auto intro: B C)
done

definition BuildSeq3
   :: "[[hf,hf,hf] \<Rightarrow> bool, [hf,hf,hf,hf,hf,hf,hf,hf,hf] \<Rightarrow> bool, hf, hf, hf, hf, hf] \<Rightarrow> bool"
  where "BuildSeq3 B C s k y y' y'' \<equiv>
         BuildSeq (\<lambda>p. \<exists>x x' x''. p = \<langle>x,x',x''\<rangle> \<and> B x x' x'')
                  (\<lambda>p q r. \<exists>x x' x'' y y' y'' z z' z''.
                           p = \<langle>x,x',x''\<rangle> \<and> q = \<langle>y,y',y''\<rangle> \<and> r = \<langle>z,z',z''\<rangle> \<and>
                           C x x' x'' y y' y'' z z' z'')
                  s k \<langle>y,y',y''\<rangle>"

lemma BuildSeq3_combine:
  assumes b1: "BuildSeq3 B C s1 k1 y1 y1' y1''" and b2: "BuildSeq3 B C s2 k2 y2 y2' y2''"
      and y: "C y y' y'' y1 y1' y1'' y2 y2' y2''"
  shows "BuildSeq3 B C (insf (seq_append (succ k1) s1 s2) (succ (succ (k1 @+ k2))) \<langle>y, y', y''\<rangle>)
                       (succ (succ (k1 @+ k2))) y y' y''"
  using assms
  apply (unfold BuildSeq3_def)
  apply (blast intro: BuildSeq_combine)
  done

lemma BuildSeq3_1: "B y y' y'' \<Longrightarrow> BuildSeq3 B C \<lbrace>\<langle>0, y, y', y''\<rangle>\<rbrace> 0 y y' y''"
  by (auto simp: BuildSeq3_def BuildSeq_1)

lemma BuildSeq3_exI: "B t t' t'' \<Longrightarrow> \<exists>s k. BuildSeq3 B C s k t t' t''"
  by (metis BuildSeq3_1)

lemma BuildSeq3_induct [consumes 1, case_names B C]:
  assumes "BuildSeq3 B C s k a a' a''"
      and B: "\<And>x x' x''. B x x' x'' \<Longrightarrow> P x x' x''"
      and C: "\<And>x x' x'' y y' y'' z z' z''. C x x' x'' y y' y'' z z' z'' \<Longrightarrow> P y y' y'' \<Longrightarrow> P z z' z'' \<Longrightarrow> P x x' x''"
  shows "P a a' a''"
using assms
apply (simp add: BuildSeq3_def)
apply (drule BuildSeq_induct [where P = "\<lambda>\<langle>x,x',x''\<rangle>. P x x' x''"])
apply (auto intro: B C)
done

section \<open>A Unique Predecessor for every non-empty set\<close>

lemma Rep_hf_0 [simp]: "Rep_hf 0 = 0"
  by (metis Abs_hf_inverse HF.HF_def UNIV_I Zero_hf_def image_empty set_encode_empty)

lemma hmem_imp_less: "x \<^bold>\<in> y \<Longrightarrow> Rep_hf x < Rep_hf y"
apply (auto simp: hmem_def hfset_def set_decode_def Abs_hf_inverse)
apply (metis div_less even_zero le_less_trans less_two_power not_less)
done

lemma hsubset_imp_le: "x \<le> y \<Longrightarrow> Rep_hf x \<le> Rep_hf y"
  apply (auto simp: less_eq_hf_def hmem_def hfset_def Abs_hf_inverse)
  apply (cases x rule: Abs_hf_cases)
  apply (cases y rule: Abs_hf_cases, auto)
  apply (rule subset_decode_imp_le)
  apply (auto simp: Abs_hf_inverse [OF UNIV_I])
  apply (metis Abs_hf_inverse UNIV_I imageE imageI)
  done

lemma diff_hmem_imp_less: assumes "x \<^bold>\<in> y" shows "Rep_hf (y - \<lbrace>x\<rbrace>) < Rep_hf y"
proof -
  have  "Rep_hf (y - \<lbrace>x\<rbrace>) \<le> Rep_hf y"
    by (metis hdiff_iff hsubsetI hsubset_imp_le)
  moreover
  have "Rep_hf (y - \<lbrace>x\<rbrace>) \<noteq> Rep_hf y" using assms
    by (metis Rep_hf_inject hdiff_iff hinsert_iff)
  ultimately show ?thesis
    by (metis le_neq_implies_less)
qed

definition least :: "hf \<Rightarrow> hf"
  where "least a \<equiv> (THE x. x \<^bold>\<in> a \<and> (\<forall>y. y \<^bold>\<in> a \<longrightarrow> Rep_hf x \<le> Rep_hf y))"

lemma least_equality:
  assumes "x \<^bold>\<in> a" and "\<And>y. y \<^bold>\<in> a \<Longrightarrow> Rep_hf x \<le> Rep_hf y"
  shows "least a = x"
unfolding least_def
apply (rule the_equality)
apply (metis assms)
apply (metis Rep_hf_inverse assms eq_iff)
done

lemma nonempty_imp_ex_least: "a \<noteq> 0 \<Longrightarrow> \<exists>x. x \<^bold>\<in> a \<and> (\<forall>y. y \<^bold>\<in> a \<longrightarrow> Rep_hf x \<le> Rep_hf y)"
proof (induction a rule: hf_induct)
  case 0 thus ?case by simp
next
  case (hinsert u v)
  show ?case
    proof (cases "v=0")
     case True thus ?thesis
       by (rule_tac x=u in exI, simp)
    next
      case False
      thus ?thesis
        by (metis dual_order.trans eq_iff hinsert.IH(2) hmem_hinsert
                  less_eq_insert1_iff linear)
    qed
qed

lemma least_hmem: "a \<noteq> 0 \<Longrightarrow> least a \<^bold>\<in> a"
apply (frule nonempty_imp_ex_least, clarify)
apply (rule leastI2_order, auto)
done

end


(*
  File: Group_Sort.thy
  Author: Manuel Eberl <manuel@pruvisto.org>

  A sorting algorithm that sorts values according to a key function and groups equivalent
  elements using a commutative and associative binary operation.
*)
section \<open>Sorting and grouping factors\<close>

theory Group_Sort
imports Main "HOL-Library.Multiset"
begin

text \<open>
  For the reification of products of powers of primitive functions such as
  @{term "\<lambda>x. x * ln x ^2"} into a canonical form, we need to be able to sort the factors
  according to the growth of the primitive function it contains and merge terms with the same
  function by adding their exponents. The following locale defines such an operation in a
  general setting; we can then instantiate it for our setting.

  The locale takes as parameters a key function @{term "f"} that sends list elements into a
  linear ordering that determines the sorting order, a @{term "merge"} function to merge to
  equivalent (w.r.t. @{term "f"}) elements into one, and a list reduction function @{term "g"}
  that reduces a list to a single value. This function must be invariant w.r.t. the order of
  list elements and be compatible with merging of equivalent elements. In our case, this list
  reduction function will be the product of all list elements.
\<close>

locale groupsort =
  fixes f :: "'a \<Rightarrow> ('b::linorder)"
  fixes merge :: "'a \<Rightarrow> 'a \<Rightarrow> 'a"
  fixes g :: "'a list \<Rightarrow> 'c"
  assumes f_merge: "f x = f y \<Longrightarrow> f (merge x y) = f x"
  assumes g_cong: "mset xs = mset ys \<Longrightarrow> g xs = g ys"
  assumes g_merge: "f x = f y \<Longrightarrow> g [x,y] = g [merge x y]"
  assumes g_append_cong: "g xs1 = g xs2 \<Longrightarrow> g ys1 = g ys2 \<Longrightarrow> g (xs1 @ ys1) = g (xs2 @ ys2)"
begin

context
begin

private function part_aux ::
  "'b \<Rightarrow> 'a list \<Rightarrow> ('a list) \<times> ('a list) \<times> ('a list) \<Rightarrow> ('a list) \<times> ('a list) \<times> ('a list)"
where
  "part_aux p [] (ls, eq, gs) = (ls, eq, gs)"
| "f x < p \<Longrightarrow> part_aux p (x#xs) (ls, eq, gs) = part_aux p xs (x#ls, eq, gs)"
| "f x > p \<Longrightarrow> part_aux p (x#xs) (ls, eq, gs) = part_aux p xs (ls, eq, x#gs)"
| "f x = p \<Longrightarrow> part_aux p (x#xs) (ls, eq, gs) = part_aux p xs (ls, eq@[x], gs)"
proof (clarify, goal_cases)
  case prems: (1 P p xs ls eq gs)
  show ?case
  proof (cases xs)
    fix x xs' assume "xs = x # xs'"
    thus ?thesis using prems by (cases "f x" p rule: linorder_cases) auto
  qed (auto intro: prems(1))
qed simp_all
termination by (relation "Wellfounded.measure (size \<circ> fst \<circ> snd)") simp_all

private lemma groupsort_locale: "groupsort f merge g" by unfold_locales

private lemmas part_aux_induct = part_aux.induct[split_format (complete), OF groupsort_locale]

private definition part where "part p xs = part_aux (f p) xs ([], [p], [])"

private lemma part:
  "part p xs = (rev (filter (\<lambda>x. f x < f p) xs),
     p # filter (\<lambda>x. f x = f p) xs, rev (filter (\<lambda>x. f x > f p) xs))"
proof-
  {
    fix p xs ls eq gs
    have "fst (part_aux p xs (ls, eq, gs)) = rev (filter (\<lambda>x. f x < p) xs) @ ls"
      by (induction p xs ls eq gs rule: part_aux_induct) simp_all
  } note A = this
  {
    fix p xs ls eq gs
    have "snd (snd (part_aux p xs (ls, eq, gs))) = rev (filter (\<lambda>x. f x > p) xs) @ gs"
      by (induction p xs ls eq gs rule: part_aux_induct) simp_all
  } note B = this
  {
    fix p xs ls eq gs
    have "fst (snd (part_aux p xs (ls, eq, gs))) = eq @ filter (\<lambda>x. f x = p) xs"
      by (induction p xs ls eq gs rule: part_aux_induct) auto
  } note C = this
  note ABC = A B C
  from ABC[of "f p" xs "[]" "[p]" "[]"] show ?thesis unfolding part_def
    by (intro prod_eqI) simp_all
qed

private function sort :: "'a list \<Rightarrow> 'a list" where
  "sort [] = []"
| "sort (x#xs) = (case part x xs of (ls, eq, gs) \<Rightarrow> sort ls @ eq @ sort gs)"
by pat_completeness simp_all
termination by (relation "Wellfounded.measure length") (simp_all add: part less_Suc_eq_le)

private lemma filter_mset_union:
  assumes "\<And>x. x \<in># A \<Longrightarrow> P x \<Longrightarrow> Q x \<Longrightarrow> False"
  shows "filter_mset P A + filter_mset Q A = filter_mset (\<lambda>x. P x \<or> Q x) A" (is "?lhs = ?rhs")
  using assms by (auto simp add: count_eq_zero_iff intro!: multiset_eqI) blast

private lemma multiset_of_sort: "mset (sort xs) = mset xs"
proof (induction xs rule: sort.induct)
  case (2 x xs)
  let ?M = "\<lambda>oper. {#y:# mset xs. oper (f y) (f x)#}"
  from 2 have "mset (sort (x#xs)) = ?M (<) + ?M (=) + ?M (>) + {#x#}"
    by (simp add: part Multiset.union_assoc mset_filter)
  also have "?M (<) + ?M (=) + ?M (>) = mset xs"
    by ((subst filter_mset_union, force)+, subst multiset_eq_iff, force)
  finally show ?case by simp
qed simp

private lemma g_sort: "g (sort xs) = g xs"
  by (intro g_cong multiset_of_sort)

private lemma set_sort: "set (sort xs) = set xs"
  using arg_cong[OF multiset_of_sort[of xs], of "set_mset"] by (simp only: set_mset_mset)

private

private lemma sorted_sort: "sorted (map f (sort xs))"
apply (induction xs rule: sort.induct)
apply simp
apply (simp only: sorted_append sort.simps part map_append split)
apply (intro conjI TrueI)
using sorted_map_same by (auto simp: set_sort)

private fun group where
  "group [] = []"
| "group (x#xs) = (case partition (\<lambda>y. f y = f x) xs of (xs', xs'') \<Rightarrow>
                     fold merge xs' x # group xs'')"

private lemma f_fold_merge: "(\<And>y. y \<in> set xs \<Longrightarrow> f y = f x) \<Longrightarrow> f (fold merge xs x) = f x"
  by (induction xs rule: rev_induct) (auto simp: f_merge)

private lemma f_group: "x \<in> set (group xs) \<Longrightarrow> \<exists>x'\<in>set xs. f x = f x'"
proof (induction xs rule: group.induct)
  case (2 x' xs)
  hence "x = fold merge [y\<leftarrow>xs . f y = f x'] x' \<or> x \<in> set (group [xa\<leftarrow>xs . f xa \<noteq> f x'])"
    by (auto simp: o_def)
  thus ?case
  proof
    assume "x = fold merge [y\<leftarrow>xs . f y = f x'] x'"
    also have "f ... = f x'" by (rule f_fold_merge) simp
    finally show ?thesis by simp
  next
    assume "x \<in> set (group [xa\<leftarrow>xs . f xa \<noteq> f x'])"
    from 2(1)[OF _ this] have "\<exists>x'\<in>set [xa\<leftarrow>xs . f xa \<noteq> f x']. f x = f x'" by (simp add: o_def)
    thus ?thesis by force
  qed
qed simp

private lemma sorted_group: "sorted (map f xs) \<Longrightarrow> sorted (map f (group xs))"
proof (induction xs rule: group.induct)
  case (2 x xs)
  {
    fix x' assume x': "x' \<in> set (group [y\<leftarrow>xs . f y \<noteq> f x])"
    with f_group obtain x'' where x'': "x'' \<in> set xs" "f x' = f x''" by force
    have "f (fold merge [y\<leftarrow>xs . f y = f x] x) = f x"
      by (subst f_fold_merge) simp_all
    also from 2(2) x'' have "... \<le> f x'" by (auto)
    finally have "f (fold merge [y\<leftarrow>xs . f y = f x] x) \<le> f x'" .
  }
  moreover from 2(2) have "sorted (map f (group [xa\<leftarrow>xs . f xa \<noteq> f x]))"
    by (intro 2 sorted_filter) (simp_all add: o_def)
  ultimately show ?case by (simp add: o_def)
qed simp_all

private lemma distinct_group: "distinct (map f (group xs))"
proof (induction xs rule: group.induct)
  case (2 x xs)
  have "distinct (map f (group [xa\<leftarrow>xs . f xa \<noteq> f x]))" by (intro 2) (simp_all add: o_def)
  moreover have "f (fold merge [y\<leftarrow>xs . f y = f x] x) \<notin> set (map f (group [xa\<leftarrow>xs . f xa \<noteq> f x]))"
    by (rule notI, subst (asm) f_fold_merge) (auto dest: f_group)
  ultimately show ?case by (simp add: o_def)
qed simp

private lemma g_fold_same:
  assumes "\<And>z. z \<in> set xs \<Longrightarrow> f z = f x"
  shows   "g (fold merge xs x # ys) = g (x#xs@ys)"
using assms
proof (induction xs arbitrary: x)
  case (Cons y xs)
  have "g (x # y # xs @ ys) = g (y # x # xs @ ys)" by (intro g_cong) (auto simp: add_ac)
  also have "y # x # xs @ ys = [y,x] @ xs @ ys" by simp
  also from Cons.prems have "g ... = g ([merge y x] @ xs @ ys)"
    by (intro g_append_cong g_merge) auto
  also have "[merge y x] @ xs @ ys = merge y x # xs @ ys" by simp
  also from Cons.prems have "g ... = g (fold merge xs (merge y x) # ys)"
    by (intro Cons.IH[symmetric]) (auto simp: f_merge)
  also have "... = g (fold merge (y # xs) x # ys)" by simp
  finally show ?case by simp
qed simp

private lemma g_group: "g (group xs) = g xs"
proof (induction xs rule: group.induct)
  case (2 x xs)
  have "g (group (x#xs)) = g (fold merge [y\<leftarrow>xs . f y = f x] x # group [xa\<leftarrow>xs . f xa \<noteq> f x])"
    by (simp add: o_def)
  also have "... = g (x # [y\<leftarrow>xs . f y = f x] @ group [y\<leftarrow>xs . f y \<noteq> f x])"
    by (intro g_fold_same) simp_all
  also have "... = g ((x # [y\<leftarrow>xs . f y = f x]) @ group [y\<leftarrow>xs . f y \<noteq> f x])" (is "_ = ?A") by simp
  also from 2 have "g (group [y\<leftarrow>xs . f y \<noteq> f x]) = g [y\<leftarrow>xs . f y \<noteq> f x]" by (simp add: o_def)
  hence "?A = g ((x # [y\<leftarrow>xs . f y = f x]) @ [y\<leftarrow>xs . f y \<noteq> f x])"
    by (intro g_append_cong) simp_all
  also have "... = g (x#xs)" by (intro g_cong) (simp_all)
  finally show ?case .
qed simp

function group_part_aux ::
  "'b \<Rightarrow> 'a list \<Rightarrow> ('a list) \<times> 'a \<times> ('a list) \<Rightarrow> ('a list) \<times> 'a \<times> ('a list)"
where
  "group_part_aux p [] (ls, eq, gs) = (ls, eq, gs)"
| "f x < p \<Longrightarrow> group_part_aux p (x#xs) (ls, eq, gs) = group_part_aux p xs (x#ls, eq, gs)"
| "f x > p \<Longrightarrow> group_part_aux p (x#xs) (ls, eq, gs) = group_part_aux p xs (ls, eq, x#gs)"
| "f x = p \<Longrightarrow> group_part_aux p (x#xs) (ls, eq, gs) = group_part_aux p xs (ls, merge x eq, gs)"
proof (clarify, goal_cases)
  case prems: (1 P p xs ls eq gs)
  show ?case
  proof (cases xs)
    fix x xs' assume "xs = x # xs'"
    thus ?thesis using prems by (cases "f x" p rule: linorder_cases) auto
  qed (auto intro: prems(1))
qed simp_all
termination by (relation "Wellfounded.measure (size \<circ> fst \<circ> snd)") simp_all

private lemmas group_part_aux_induct =
  group_part_aux.induct[split_format (complete), OF groupsort_locale]

definition group_part where "group_part p xs = group_part_aux (f p) xs ([], p, [])"

private lemma group_part:
  "group_part p xs = (rev (filter (\<lambda>x. f x < f p) xs),
     fold merge (filter (\<lambda>x. f x = f p) xs) p, rev (filter (\<lambda>x. f x > f p) xs))"
proof-
  {
    fix p xs ls eq gs
    have "fst (group_part_aux p xs (ls, eq, gs)) = rev (filter (\<lambda>x. f x < p) xs) @ ls"
      by (induction p xs ls eq gs rule: group_part_aux_induct) simp_all
  } note A = this
  {
    fix p xs ls eq gs
    have "snd (snd (group_part_aux p xs (ls, eq, gs))) = rev (filter (\<lambda>x. f x > p) xs) @ gs"
      by (induction p xs ls eq gs rule: group_part_aux_induct) simp_all
  } note B = this
  {
    fix p xs ls eq gs
    have "fst (snd (group_part_aux p xs (ls, eq, gs))) =
            fold merge (filter (\<lambda>x. f x = p) xs) eq"
      by (induction p xs ls eq gs rule: group_part_aux_induct) auto
  } note C = this
  note ABC = A B C
  from ABC[of "f p" xs "[]" "p" "[]"] show ?thesis unfolding group_part_def
    by (intro prod_eqI) simp_all
qed

function group_sort :: "'a list \<Rightarrow> 'a list" where
  "group_sort [] = []"
| "group_sort (x#xs) = (case group_part x xs of (ls, eq, gs) \<Rightarrow> group_sort ls @ eq # group_sort gs)"
by pat_completeness simp_all
termination by (relation "Wellfounded.measure length") (simp_all add: group_part less_Suc_eq_le)

private lemma group_append:
  assumes "\<And>x y. x \<in> set xs \<Longrightarrow> y \<in> set ys \<Longrightarrow> f x \<noteq> f y"
  shows   "group (xs @ ys) = group xs @ group ys"
using assms
proof (induction xs arbitrary: ys rule: length_induct)
  case (1 xs')
  hence IH: "\<And>x xs ys. length xs < length xs' \<Longrightarrow> (\<And>x y. x \<in> set xs \<Longrightarrow> y \<in> set ys \<Longrightarrow> f x \<noteq> f y)
                \<Longrightarrow> group (xs @ ys) = group xs @ group ys" by blast
  show ?case
  proof (cases xs')
    case (Cons x xs)
    note [simp] = this
    have "group (xs' @ ys) = fold merge [y\<leftarrow>xs@ys . f y = f x] x #
            group ([xa\<leftarrow>xs . f xa \<noteq> f x] @ [xa\<leftarrow>ys . f xa \<noteq> f x])" by (simp add: o_def)
    also from 1(2) have "[y\<leftarrow>xs@ys . f y = f x] = [y\<leftarrow>xs . f y = f x]"
      by (force simp: filter_empty_conv)
    also from 1(2) have "[xa\<leftarrow>ys . f xa \<noteq> f x] = ys" by (force simp: filter_id_conv)
    also have "group ([xa\<leftarrow>xs . f xa \<noteq> f x] @ ys) =
               group [xa\<leftarrow>xs . f xa \<noteq> f x] @ group ys" using 1(2)
      by (intro IH) (simp_all add: less_Suc_eq_le)
    finally show ?thesis by (simp add: o_def)
  qed simp
qed

private lemma group_empty_iff [simp]: "group xs = [] \<longleftrightarrow> xs = []"
  by (induction xs rule: group.induct) auto

lemma group_sort_correct: "group_sort xs = group (sort xs)"
proof (induction xs rule: group_sort.induct)
  case (2 x xs)
  have "group_sort (x#xs) =
          group_sort (rev [xa\<leftarrow>xs . f xa < f x]) @ group (x#[xa\<leftarrow>xs . f xa = f x]) @
          group_sort (rev [xa\<leftarrow>xs . f x < f xa])" by (simp add: group_part)
  also have "group_sort (rev [xa\<leftarrow>xs . f xa < f x]) = group (sort (rev [xa\<leftarrow>xs . f xa < f x]))"
    by (rule 2) (simp_all add: group_part)
  also have "group_sort (rev [xa\<leftarrow>xs . f xa > f x]) = group (sort (rev [xa\<leftarrow>xs . f xa > f x]))"
    by (rule 2) (simp_all add: group_part)
  also have "group (x#[xa\<leftarrow>xs . f xa = f x]) @ group (sort (rev [xa\<leftarrow>xs . f xa > f x])) =
             group ((x#[xa\<leftarrow>xs . f xa = f x]) @ sort (rev [xa\<leftarrow>xs . f xa > f x]))"
    by (intro group_append[symmetric]) (auto simp: set_sort)
  also have "group (sort (rev [xa\<leftarrow>xs . f xa < f x])) @ ... =
             group (sort (rev [xa\<leftarrow>xs . f xa < f x]) @ (x#[xa\<leftarrow>xs . f xa = f x]) @
                 sort (rev [xa\<leftarrow>xs . f xa > f x]))"
    by (intro group_append[symmetric]) (auto simp: set_sort)
  also have "sort (rev [xa\<leftarrow>xs . f xa < f x]) @ (x#[xa\<leftarrow>xs . f xa = f x]) @
                 sort (rev [xa\<leftarrow>xs . f xa > f x]) = sort (x # xs)" by (simp add: part)
  finally show ?case .
qed simp

lemma sorted_group_sort: "sorted (map f (group_sort xs))"
  by (auto simp: group_sort_correct intro!: sorted_group sorted_sort)

lemma g_group_sort: "g (group_sort xs) = g xs"
  by (simp add: group_sort_correct g_group g_sort)

lemmas [simp del] = group_sort.simps group_part_aux.simps

end
end

end


theory Chapter09_2_Typechecking
imports Chapter09_1_Language
begin

inductive typecheck :: "type env => expr => type => bool"
where tc_var [simp]: "lookup gam x = Some t ==> typecheck gam (Var x) t"
    | tc_zero [simp]: "typecheck gam Zero Nat"
    | tc_suc [simp]: "typecheck gam e Nat ==> typecheck gam (Suc e) Nat"
    | tc_rec [simp]: "typecheck gam et Nat ==> typecheck gam e0 t ==>
                typecheck (extend (extend gam t) Nat) es t ==> typecheck gam (Rec et e0 es) t"
    | tc_lam [simp]: "typecheck (extend gam t1) e t2 ==> typecheck gam (Lam t1 e) (Arrow t1 t2)"
    | tc_appl [simp]: "typecheck gam e1 (Arrow t2 t) ==> typecheck gam e2 t2 ==>
                typecheck gam (Appl e1 e2) t"

inductive_cases [elim!]: "typecheck gam (Var x) t"
inductive_cases [elim!]: "typecheck gam Zero t"
inductive_cases [elim!]: "typecheck gam (Suc e) t"
inductive_cases [elim!]: "typecheck gam (Rec et e0 es) t"
inductive_cases [elim!]: "typecheck gam (Lam t1 e) t"
inductive_cases [elim!]: "typecheck gam (Appl e1 e2) t"

lemma [simp]: "typecheck (extend_at n gam t') e t ==> n in gam ==> typecheck gam e' t' ==>
                          typecheck gam (subst e' n e) t"
by (induction "extend_at n gam t'" e t arbitrary: n gam t' e' rule: typecheck.induct, fastforce+)

end


theory HoareLogicTutorial
imports Main "~~/src/HOL/Hoare/Hoare_Logic"
begin

(* The minimum of two integers x and y: *)
lemma Min: "VARS (z :: int)
 {True}
 IF x \<le> y THEN z := x ELSE z := y FI
 { z = min x y }"
  apply vcg
  apply (simp add: min_def)
  done

(* Iteratively copy an integer variable x to y: *)
lemma Copy: "VARS (a :: int) y
 {0 \<le> x}
 a := x; y := 0;
 WHILE a \<noteq> 0
 INV { x=y+a }
 DO y := y + 1 ; a := a - 1 OD
 {x = y}"
apply vcg_simp
done

(* Multiplication *)
lemma Multipl: "VARS (z :: int) i
{0 \<le> y}
i := y;
z := 0;
WHILE i \<noteq> 0
INV { z = (y - i) * x }
DO
  z := z + x;
  i := i - 1
OD
{z = x * y}"
  apply vcg
  apply (auto simp add: algebra_simps)
  done

(* Iterative multiplication through addition: *)
lemma Multi: "VARS (a :: int) z
 {0 \<le> y}
 a := 0; z := 0;
 WHILE a \<noteq> y
 INV {z = x * a}
 DO
   z := z + x ;
   a := a + 1
 OD
 {z = x * y}"
(* "Replace Inv with your invariant." *)
  apply vcg_simp
  apply (erule conjE)
  apply (simp add: distrib_left)
  done

(* A factorial algorithm: *)
lemma DownFact: "VARS (z :: nat) (y::nat)
 {True}
 z := x; y := 1;
 WHILE z > 0
 INV { Inv }
 DO
   y := y * z;
   z := z - 1
 OD
 {y = fact x}"
(* "Replace Inv with your invariant." *)
oops

(* Integer division of x by y: *)
lemma Div: "VARS (r :: int) d
 {y \<noteq> 0}
 r := x; d := 0;
 WHILE y \<le> r
 INV { Inv }
 DO
  r := r - y;
  d := d + 1
 OD
 { Postcondition }"
(* "Replace Inv with your invariant." *)
(* "Replace Postcondition with your postcondition." *)
oops

end


theory Ex2_1
  imports Main
begin

datatype 'a tree = Leaf (nval  :'a) | Node (nval : 'a) (lft : "'a tree") (rgt : "'a tree")

primrec preOrder :: "'a tree \<Rightarrow> 'a list " where
  "preOrder (Leaf val) = [val]"|
  "preOrder (Node val lt rt) =  val # preOrder lt @ preOrder rt"

primrec postOrder :: "'a tree \<Rightarrow> 'a list" where
  "postOrder (Leaf val) = [val]"|
  "postOrder (Node val lt rt) = postOrder lt @ postOrder rt @ [val]"

primrec inOrder :: "'a tree  \<Rightarrow> 'a list" where
  "inOrder (Leaf val) = [val]"|
  "inOrder (Node val lt rt) = inOrder lt @ val # inOrder rt"

primrec mirror :: "'a tree \<Rightarrow> 'a tree" where
  "mirror (Leaf val) = (Leaf val)"|
  "mirror (Node val lt rt) = Node val (mirror rt) (mirror lt)"

(*lemma "preOrder (mirror xt) = rev (preOrder xt)"  quickcheck *)

lemma "let xt = Node (1::int) (Node 2 (Leaf 3) (Leaf 4)) (Leaf 5)  in preOrder (mirror xt) = rev (preOrder xt) \<Longrightarrow> False" by simp

lemma "preOrder (mirror xt) = rev (postOrder xt)"
proof (induct xt)
  case (Leaf x)
  then show ?case by simp
next
  case (Node x1a xt1 xt2)
  assume hyp1:" preOrder (mirror xt1) = rev (postOrder xt1)"
     and hyp2:"preOrder (mirror xt2) = rev (postOrder xt2)"
  then show ?case by simp
qed

lemma "postOrder (mirror xt) = rev (preOrder xt)"
proof (induct xt)
  case (Leaf x)
  then show ?case by simp
next
  case (Node x1a xt1 xt2)
  then show ?case by simp
qed

lemma "let xt =  Node (1::int) (Node 2 (Leaf 3) (Leaf 4)) (Leaf 5)   in preOrder (mirror xt) = rev (inOrder xt) \<Longrightarrow> False" by simp

lemma "let xt =  Node (1::int) (Node 2 (Leaf 3) (Leaf 4)) (Leaf 5)   in inOrder (mirror xt) = rev (preOrder xt) \<Longrightarrow> False" by simp

lemma "let xt =  Node (1::int) (Node 2 (Leaf 3) (Leaf 4)) (Leaf 5)   in postOrder (mirror xt) = rev (postOrder xt) \<Longrightarrow> False" by simp

lemma "let xt =  Node (1::int) (Node 2 (Leaf 3) (Leaf 4)) (Leaf 5)   in postOrder (mirror xt) = rev (inOrder xt) \<Longrightarrow> False" by simp

lemma "let xt =  Node (1::int) (Node 2 (Leaf 3) (Leaf 4)) (Leaf 5)   in inOrder (mirror xt) = rev (postOrder xt) \<Longrightarrow> False" by simp

lemma "inOrder (mirror xt) = rev (inOrder xt)"
proof (induct xt)
  case (Leaf x)
  then show ?case by simp
next
  case (Node x1a xt1 xt2)
  then show ?case by simp
qed

definition root :: "'a tree \<Rightarrow> 'a" where
  "root xt = nval xt"

primrec leftmost :: "'a tree \<Rightarrow> 'a" where
  "leftmost (Leaf val) = val"|
  "leftmost (Node _ lt _) = leftmost lt"

primrec rightmost :: "'a tree \<Rightarrow> 'a" where
  "rightmost (Leaf val) = val"|
  "rightmost (Node _ _ rt) = rightmost rt"

lemma helper1 : "length (inOrder xt) > 0"
proof (cases xt)
  case (Leaf x1)
  then show ?thesis  by simp
next
  case (Node x21 x22 x23)
  then show ?thesis by simp
qed

theorem "last (inOrder xt) = rightmost xt"
proof (induct xt)
  case (Leaf x)
  then show ?case by simp
next
  case (Node x1a xt1 xt2)
  assume hyp:"last (inOrder xt2) = rightmost xt2"
  have "last (inOrder (Node x1a xt1 xt2)) = last (inOrder xt1 @ x1a  #  inOrder xt2)" by simp
  also have "\<dots> = last (inOrder xt2)" using helper1 by auto
  finally show ?case using hyp by auto
qed

lemma helper2 : "length xs > 0 \<Longrightarrow> hd (xs @ ys) = hd xs" by (induct xs, auto)

theorem "hd (inOrder xt) = leftmost xt"
proof (induct xt)
  case (Leaf x)
  then show ?case by simp
next
  case (Node x1a xt1 xt2)
  assume hyp:"hd (inOrder xt1) = leftmost xt1"
  have " hd (inOrder (Node x1a xt1 xt2)) = hd (inOrder xt1 @ x1a # inOrder xt2)" by simp
  also have "\<dots> = hd (inOrder xt1)" using helper1 helper2 by auto
  then show ?case using hyp by auto
qed

theorem "hd (preOrder xt) = last (postOrder xt)"
proof (induct xt)
  case (Leaf x)
  then show ?case by simp
next
  case (Node x1a xt1 xt2)
  then show ?case by simp
qed

theorem "hd (preOrder xt)  = root xt"
proof (induct xt)
  case (Leaf x)
  then show ?case by (auto simp add : root_def)
next
  case (Node x1a xt1 xt2)
  then show ?case by (auto simp add: root_def)
qed

lemma "let xt = Node (1 :: int) (Leaf 2) (Leaf 3) in (hd (inOrder xt) = root xt) \<Longrightarrow> False" by (simp add : root_def)

theorem "last (postOrder xt) = root xt" by (induct xt, auto simp add : root_def)

github-repos/isabelle/SvenWille-ExerciseSolutions_New/ExerciseSolutions_New-b8243e7a669846c64e2f5520dae88ff41265d233/Isabelle/2. Trees and other inductive data types/Ex2_1.thy


(* Title:      Domain Semirings
   Author:     Victor B. F. Gomes, Walter Guttmann, Peter Höfner, Georg Struth, Tjark Weber
   Maintainer: Walter Guttmann <walter.guttman at canterbury.ac.nz>
               Georg Struth <g.struth at sheffield.ac.uk>
               Tjark Weber <tjark.weber at it.uu.se>
*)

section \<open>Domain Semirings\<close>

theory Domain_Semiring
imports Kleene_Algebra.Kleene_Algebra

begin

subsection \<open>Domain Semigroups and Domain Monoids\<close>

class domain_op =
  fixes domain_op :: "'a \<Rightarrow> 'a" ("d")

text \<open>First we define the class of domain semigroups. Axioms are taken from~\<^cite>\<open>"DesharnaisJipsenStruth"\<close>.\<close>

class domain_semigroup = semigroup_mult + domain_op +
  assumes dsg1 [simp]: "d x \<cdot> x = x"
  and dsg2 [simp]: "d (x \<cdot> d y) = d (x \<cdot> y)"
  and dsg3 [simp]: "d (d x \<cdot> y) = d x \<cdot> d y"
  and dsg4: "d x \<cdot> d y = d y \<cdot> d x"

begin

lemma domain_invol [simp]: "d (d x) = d x"
proof -
  have "d (d x) = d (d (d x \<cdot> x))"
    by simp
  also have "... = d (d x \<cdot> d x)"
    using dsg3 by presburger
  also have "... = d (d x \<cdot> x)"
    by simp
  finally show ?thesis
    by simp
qed

text \<open>The next lemmas show that domain elements form semilattices.\<close>

lemma dom_el_idem [simp]: "d x \<cdot> d x = d x"
proof -
  have "d x \<cdot> d x = d (d x \<cdot> x)"
    using dsg3 by presburger
  thus ?thesis
    by simp
qed

lemma dom_mult_closed [simp]: "d (d x \<cdot> d y) = d x \<cdot> d y"
  by simp

lemma dom_lc3 [simp]: "d x \<cdot> d (x \<cdot> y) = d (x \<cdot> y)"
proof -
  have "d x \<cdot> d (x \<cdot> y) = d (d x \<cdot> x \<cdot> y)"
    using dsg3 mult_assoc by presburger
  thus ?thesis
    by simp
qed

lemma d_fixpoint: "(\<exists>y. x = d y) \<longleftrightarrow> x = d x"
  by auto

lemma d_type: "\<forall>P. (\<forall>x. x = d x \<longrightarrow> P x) \<longleftrightarrow> (\<forall>x. P (d x))"
  by (metis domain_invol)

text \<open>We define the semilattice ordering on domain semigroups and explore the semilattice of domain elements from the order point of view.\<close>

definition ds_ord :: "'a \<Rightarrow> 'a \<Rightarrow> bool" (infix "\<sqsubseteq>" 50) where
  "x \<sqsubseteq> y \<longleftrightarrow> x = d x \<cdot> y"

lemma ds_ord_refl: "x \<sqsubseteq> x"
  by (simp add: ds_ord_def)

lemma ds_ord_trans: "x \<sqsubseteq> y \<Longrightarrow> y \<sqsubseteq> z \<Longrightarrow> x \<sqsubseteq> z"
proof -
  assume "x \<sqsubseteq> y" and a: "y \<sqsubseteq> z"
  hence b: "x = d x \<cdot> y"
    using ds_ord_def by blast
  hence "x = d x \<cdot> d y \<cdot> z"
    using a ds_ord_def mult_assoc by force
  also have "... = d (d x \<cdot> y) \<cdot> z"
    by simp
  also have "... = d x \<cdot> z"
    using b by auto
  finally show ?thesis
    using ds_ord_def by blast
qed

lemma ds_ord_antisym: "x \<sqsubseteq> y \<Longrightarrow> y \<sqsubseteq> x \<Longrightarrow> x = y"
proof -
  assume a: "x \<sqsubseteq> y" and "y \<sqsubseteq> x"
  hence b: "y = d y \<cdot> x"
    using ds_ord_def by auto
  have "x = d x \<cdot> d y \<cdot> x"
    using a b ds_ord_def mult_assoc by force
  also have "... = d y \<cdot> x"
    by (metis (full_types) b dsg3 dsg4)
  thus ?thesis
    using b calculation by presburger
qed

text \<open>This relation is indeed an order.\<close>

sublocale ds: ordering \<open>(\<sqsubseteq>)\<close> \<open>\<lambda>x y. x \<sqsubseteq> y \<and> x \<noteq> y\<close>
proof
  show \<open>x \<sqsubseteq> y \<and> x \<noteq> y \<longleftrightarrow> x \<sqsubseteq> y \<and> x \<noteq> y\<close> for x y
    by (rule refl)
  show "x \<sqsubseteq> x" for x
    by (rule ds_ord_refl)
  show "x \<sqsubseteq> y \<Longrightarrow> y \<sqsubseteq> z \<Longrightarrow> x \<sqsubseteq> z" for x y z
    by (rule ds_ord_trans)
  show "x \<sqsubseteq> y \<Longrightarrow> y \<sqsubseteq> x \<Longrightarrow> x = y" for x y
    by (rule ds_ord_antisym)
qed

declare ds.refl [simp]

lemma ds_ord_eq: "x \<sqsubseteq> d x \<longleftrightarrow> x = d x"
  by (simp add: ds_ord_def)

lemma "x \<sqsubseteq> y \<Longrightarrow> z \<cdot> x \<sqsubseteq> z \<cdot> y"
(*nitpick [expect=genuine]*)
oops

lemma ds_ord_iso_right: "x \<sqsubseteq> y \<Longrightarrow> x \<cdot> z \<sqsubseteq> y \<cdot> z"
proof -
  assume "x \<sqsubseteq> y"
  hence a: "x = d x \<cdot> y"
    by (simp add: ds_ord_def)
  hence "x \<cdot> z = d x \<cdot> y \<cdot> z"
    by auto
  also have "... = d (d x \<cdot> y \<cdot> z) \<cdot> d x \<cdot> y \<cdot> z"
    using dsg1 mult_assoc by presburger
  also have "... = d (x \<cdot> z) \<cdot> d x \<cdot> y \<cdot> z"
    using a by presburger
  finally show ?thesis
    using ds_ord_def dsg4 mult_assoc by auto
qed

text \<open>The order on domain elements could as well be defined based on multiplication/meet.\<close>

lemma ds_ord_sl_ord: "d x \<sqsubseteq> d y \<longleftrightarrow> d x \<cdot> d y = d x"
  using ds_ord_def by auto

lemma ds_ord_1: "d (x \<cdot> y) \<sqsubseteq> d x"
  by (simp add: ds_ord_sl_ord dsg4)

lemma ds_subid_aux: "d x \<cdot> y \<sqsubseteq> y"
  by (simp add: ds_ord_def mult_assoc)

lemma "y \<cdot> d x \<sqsubseteq> y"
(*nitpick [expect=genuine]*)
oops

lemma ds_dom_iso: "x \<sqsubseteq> y \<Longrightarrow> d x \<sqsubseteq> d y"
proof -
  assume "x \<sqsubseteq> y"
  hence "x = d x \<cdot> y"
    by (simp add: ds_ord_def)
  hence "d x = d (d x \<cdot> y)"
    by presburger
  also have "... = d x \<cdot> d y"
    by simp
  finally show ?thesis
    using ds_ord_sl_ord by auto
qed

lemma ds_dom_llp: "x \<sqsubseteq> d y \<cdot> x \<longleftrightarrow> d x \<sqsubseteq> d y"
proof
  assume "x \<sqsubseteq> d y \<cdot> x"
  hence "x = d y \<cdot> x"
    by (simp add: ds_subid_aux ds.antisym)
  hence "d x = d (d y \<cdot> x)"
    by presburger
  thus "d x \<sqsubseteq> d y"
    using ds_ord_sl_ord dsg4 by force
next
  assume "d x \<sqsubseteq> d y"
  thus "x \<sqsubseteq> d y \<cdot> x"
    by (metis (no_types) ds_ord_iso_right dsg1)
qed

lemma ds_dom_llp_strong: "x = d y \<cdot> x \<longleftrightarrow> d x \<sqsubseteq> d y"
  using ds.eq_iff
  by (simp add: ds_dom_llp ds.eq_iff ds_subid_aux)

definition refines :: "'a \<Rightarrow> 'a \<Rightarrow> bool"
  where "refines x y \<equiv> d y \<sqsubseteq> d x \<and> (d y) \<cdot> x \<sqsubseteq> y"

lemma refines_refl: "refines x x"
  using refines_def by simp

lemma refines_trans: "refines x y \<Longrightarrow> refines y z \<Longrightarrow> refines x z"
  unfolding refines_def
  by (metis domain_invol ds.trans dsg1 dsg3 ds_ord_def)

lemma refines_antisym: "refines x y \<Longrightarrow> refines y x \<Longrightarrow> x = y"
  apply (rule ds.antisym)
   apply (simp_all add: refines_def)
   apply (metis ds_dom_llp_strong)
  apply (metis ds_dom_llp_strong)
  done

sublocale ref: ordering "refines" "\<lambda>x y. (refines x y \<and> x \<noteq> y)"
proof
  show "\<And>x y. refines x y \<and> x \<noteq> y \<longleftrightarrow> refines x y \<and> x \<noteq> y"
    ..
  show "\<And>x. refines x x"
    by (rule refines_refl)
  show "\<And>x y z. refines x y \<Longrightarrow> refines y z \<Longrightarrow> refines x z"
    by (rule refines_trans)
  show "\<And>x y. refines x y \<Longrightarrow> refines y x \<Longrightarrow> x = y"
    by (rule refines_antisym)
qed

end

text \<open>We expand domain semigroups to domain monoids.\<close>

class domain_monoid = monoid_mult + domain_semigroup
begin

lemma dom_one [simp]: "d 1 = 1"
proof -
  have "1 = d 1 \<cdot> 1"
    using dsg1 by presburger
  thus ?thesis
    by simp
qed

lemma ds_subid_eq: "x \<sqsubseteq> 1 \<longleftrightarrow> x = d x"
  by (simp add: ds_ord_def)

end

subsection \<open>Domain Near-Semirings\<close>

text \<open>The axioms for domain near-semirings are taken from~\<^cite>\<open>"DesharnaisStruthAMAST"\<close>.\<close>

class domain_near_semiring = ab_near_semiring + plus_ord + domain_op +
  assumes dns1 [simp]: "d x \<cdot> x = x"
  and dns2 [simp]: "d (x \<cdot> d y) = d(x \<cdot> y)"
  and dns3 [simp]: "d (x + y) = d x + d y"
  and dns4: "d x \<cdot> d y = d y \<cdot> d x"
  and dns5 [simp]: "d x \<cdot> (d x + d y) = d x"

begin

text \<open>Domain near-semirings are automatically dioids; addition is idempotent.\<close>

subclass near_dioid
proof
  show "\<And>x. x + x = x"
  proof -
    fix x
    have a: "d x = d x \<cdot> d (x + x)"
      using dns3 dns5 by presburger
    have "d (x + x) = d (x + x + (x + x)) \<cdot> d (x + x)"
      by (metis (no_types) dns3  dns4 dns5)
    hence "d (x + x) = d (x + x) + d (x + x)"
      by simp
    thus "x + x = x"
      by (metis a dns1 dns4 distrib_right')
  qed
qed

text \<open>Next we prepare to show that domain near-semirings are domain semigroups.\<close>

lemma dom_add_closed [simp]: "d (d x + d y) = d x + d y"
proof -
  have "d (d x + d y) = d (d x) + d (d y)"
    by simp
  thus ?thesis
    by (metis dns1 dns2 dns3 dns4)
qed

lemma dom_absorp_2 [simp]: "d x + d x \<cdot> d y = d x"
proof -
  have "d x + d x \<cdot> d y = d x \<cdot> d x + d x \<cdot> d y"
    by (metis add_idem' dns5)
  also have "... = (d x + d y) \<cdot> d x"
    by (simp add: dns4)
  also have "... = d x \<cdot> (d x + d y)"
    by (metis dom_add_closed dns4)
  finally show ?thesis
    by simp
qed

lemma dom_1: "d (x \<cdot> y) \<le> d x"
proof -
  have "d (x \<cdot> y) = d (d x \<cdot> d (x \<cdot> y))"
    by (metis dns1 dns2 mult_assoc)
  also have "... \<le> d (d x) + d (d x \<cdot> d (x \<cdot> y))"
    by simp
  also have "... = d (d x + d x \<cdot> d (x \<cdot> y))"
    using dns3  by presburger
  also have "... = d (d x)"
    by simp
  finally show ?thesis
    by (metis dom_add_closed add_idem')
qed

lemma dom_subid_aux2: "d x \<cdot> y \<le> y"
proof -
  have "d x \<cdot> y \<le> d (x + d y) \<cdot> y"
    by (simp add: mult_isor)
  also have "... = (d x + d (d y)) \<cdot> d y \<cdot> y"
    using dns1 dns3 mult_assoc by presburger
  also have "... = (d y + d y \<cdot> d x) \<cdot> y"
    by (simp add: dns4 add_commute)
  finally show ?thesis
    by simp
qed

lemma dom_glb: "d x \<le> d y \<Longrightarrow> d x \<le> d z \<Longrightarrow> d x \<le> d y \<cdot> d z"
  by (metis dns5 less_eq_def mult_isor)

lemma dom_glb_eq: "d x \<le> d y \<cdot> d z \<longleftrightarrow> d x \<le> d y \<and> d x \<le> d z"
proof -
  have "d x \<le> d z \<longrightarrow> d x \<le> d z"
    by meson
  then show ?thesis
    by (metis (no_types) dom_absorp_2 dom_glb dom_subid_aux2 local.dual_order.trans local.join.sup.coboundedI2)
qed

lemma dom_ord: "d x \<le> d y \<longleftrightarrow> d x \<cdot> d y = d x"
proof
  assume "d x \<le> d y"
  hence "d x + d y = d y"
    by (simp add: less_eq_def)
  thus "d x \<cdot> d y = d x"
    by (metis dns5)
next
  assume "d x \<cdot> d y = d x"
  thus "d x \<le> d y"
    by (metis dom_subid_aux2)
qed

lemma dom_export [simp]: "d (d x \<cdot> y) = d x \<cdot> d y"
proof (rule order.antisym)
  have "d (d x \<cdot> y) = d (d (d x \<cdot> y)) \<cdot> d (d x \<cdot> y)"
    using dns1 by presburger
  also have "... = d (d x \<cdot> d y) \<cdot> d (d x \<cdot> y)"
    by (metis dns1 dns2 mult_assoc)
  finally show a: "d (d x \<cdot> y) \<le> d x \<cdot> d y"
    by (metis (no_types) dom_add_closed dom_glb dom_1 add_idem' dns2 dns4)
  have "d (d x \<cdot> y) = d (d x \<cdot> y) \<cdot> d x"
    using a dom_glb_eq dom_ord by force
  hence "d x \<cdot> d y = d (d x \<cdot> y) \<cdot> d y"
    by (metis dns1 dns2 mult_assoc)
  thus "d x \<cdot> d y \<le> d (d x \<cdot> y)"
    using a dom_glb_eq dom_ord by auto
qed

subclass domain_semigroup
 by (unfold_locales, auto simp: dns4)

text \<open>We compare the domain semigroup ordering with that of the dioid.\<close>

lemma two_orders: "x \<sqsubseteq> y \<Longrightarrow> x \<le> y"
  by (metis dom_subid_aux2 ds_ord_def)

lemma "x \<le> y \<Longrightarrow> x \<sqsubseteq> y"
(*nitpick [expect=genuine]*)
oops

text \<open>Next we prove additional properties.\<close>

lemma dom_subdist: "d x \<le> d (x + y)"
  by simp

lemma dom_distrib: "d x + d y \<cdot> d z = (d x + d y) \<cdot> (d x + d z)"
proof -
  have "(d x + d y) \<cdot> (d x + d z) = d x \<cdot> (d x + d z) + d y \<cdot> (d x + d z)"
    using distrib_right' by blast
  also have "... = d x + (d x + d z) \<cdot> d y"
    by (metis (no_types) dns3 dns5 dsg4)
  also have "... = d x + d x \<cdot> d y + d z \<cdot> d y"
    using add_assoc' distrib_right' by presburger
  finally show ?thesis
    by (simp add: dsg4)
qed

lemma dom_llp1: "x \<le> d y \<cdot> x \<Longrightarrow> d x \<le> d y"
proof -
  assume "x \<le> d y \<cdot> x"
  hence "d x \<le> d (d y \<cdot> x)"
    using dom_iso by blast
  also have "... = d y \<cdot> d x"
    by simp
  finally show "d x \<le> d y"
    by (simp add: dom_glb_eq)
qed

lemma dom_llp2: "d x \<le> d y \<Longrightarrow> x \<le> d y \<cdot> x"
  using d_two_orders local.ds_dom_llp two_orders by blast

lemma dom_llp: "x \<le> d y \<cdot> x \<longleftrightarrow> d x \<le> d y"
  using dom_llp1 dom_llp2 by blast

end

text \<open>We expand domain near-semirings by an additive unit, using slightly different axioms.\<close>

class domain_near_semiring_one = ab_near_semiring_one + plus_ord + domain_op +
  assumes dnso1 [simp]: "x + d x \<cdot> x = d x \<cdot> x"
  and dnso2 [simp]: "d (x \<cdot> d y) = d (x \<cdot> y)"
  and dnso3 [simp]: "d x + 1 = 1"
  and dnso4 [simp]: "d (x + y) = d x + d y"
  and dnso5: "d x \<cdot> d y = d y \<cdot> d x"

begin

text \<open>The previous axioms are derivable.\<close>

subclass domain_near_semiring
proof
  show a: "\<And>x. d x \<cdot> x = x"
    by (metis add_commute local.dnso3 local.distrib_right' local.dnso1 local.mult_onel)
  show "\<And>x y. d (x \<cdot> d y) = d (x \<cdot> y)"
    by simp
  show "\<And>x y. d (x + y) = d x + d y"
    by simp
  show "\<And>x y. d x \<cdot> d y = d y \<cdot> d x"
    by (simp add: dnso5)
  show "\<And>x y. d x \<cdot> (d x + d y) = d x"
  proof -
    fix x y
    have "\<And>x. 1 + d x = 1"
      using add_commute dnso3 by presburger
    thus "d x \<cdot> (d x + d y) = d x"
      by (metis (no_types) a dnso2 dnso4 dnso5 distrib_right' mult_onel)
  qed
qed

subclass domain_monoid ..

lemma dom_subid: "d x \<le> 1"
  by (simp add: less_eq_def)

end

text \<open>We add a left unit of multiplication.\<close>

class domain_near_semiring_one_zerol = ab_near_semiring_one_zerol + domain_near_semiring_one +
  assumes dnso6 [simp]: "d 0 = 0"

begin

lemma domain_very_strict: "d x = 0 \<longleftrightarrow> x = 0"
  by (metis annil dns1 dnso6)

lemma dom_weakly_local: "x \<cdot> y = 0 \<longleftrightarrow> x \<cdot> d y = 0"
proof -
  have "x \<cdot> y = 0 \<longleftrightarrow> d (x \<cdot> y) = 0"
    by (simp add: domain_very_strict)
  also have "... \<longleftrightarrow> d (x \<cdot> d y) = 0"
    by simp
  finally show ?thesis
    using domain_very_strict by blast
qed

end

subsection \<open>Domain Pre-Dioids\<close>

text \<open>
  Pre-semirings with one and a left zero are automatically dioids.
  Hence there is no point defining domain pre-semirings separately from domain dioids. The axioms
are once again from~\<^cite>\<open>"DesharnaisStruthAMAST"\<close>.
\<close>

class domain_pre_dioid_one = pre_dioid_one + domain_op +
  assumes dpd1 : "x \<le> d x \<cdot> x"
  and dpd2 [simp]: "d (x \<cdot> d y) = d (x \<cdot> y)"
  and dpd3 [simp]: "d x \<le> 1"
  and dpd4 [simp]: "d (x + y) = d x + d y"

begin

text \<open>We prepare to show that every domain pre-dioid with one is a domain near-dioid with one.\<close>

lemma dns1'' [simp]: "d x \<cdot> x = x"
proof (rule order.antisym)
  show "d x \<cdot> x \<le> x"
    using dpd3  mult_isor by fastforce
  show "x \<le> d x \<cdot> x "
    by (simp add: dpd1)
qed

lemma d_iso: "x \<le> y \<Longrightarrow> d x \<le> d y"
  by (metis dpd4 less_eq_def)

lemma domain_1'': "d (x \<cdot> y) \<le> d x"
proof -
  have "d (x \<cdot> y) = d (x \<cdot> d y)"
    by simp
  also have "... \<le> d (x \<cdot> 1)"
    by (meson d_iso dpd3 mult_isol)
  finally show ?thesis
    by simp
qed

lemma domain_export'' [simp]: "d (d x \<cdot> y) = d x \<cdot> d y"
proof (rule order.antisym)
  have one: "d (d x \<cdot> y) \<le> d x"
    by (metis dpd2 domain_1'' mult_onel)
  have two: "d (d x \<cdot> y) \<le> d y"
    using d_iso dpd3 mult_isor by fastforce
  have "d (d x \<cdot> y) = d (d (d x \<cdot> y)) \<cdot> d (d x \<cdot> y)"
    by simp
  also have "... = d (d x \<cdot> y) \<cdot> d (d x \<cdot> y)"
    by (metis dns1'' dpd2 mult_assoc)
  thus "d (d x \<cdot> y) \<le> d x \<cdot> d y"
    using mult_isol_var one two by force
next
  have "d x \<cdot> d y \<le> 1"
    by (metis dpd3  mult_1_right mult_isol order.trans)
  thus "d x \<cdot> d y \<le> d (d x \<cdot> y)"
    by (metis dns1'' dpd2 mult_isol mult_oner)
qed

lemma dom_subid_aux1'': "d x \<cdot> y \<le> y"
proof -
  have "d x \<cdot> y \<le> 1 \<cdot> y"
    using dpd3 mult_isor by blast
  thus ?thesis
    by simp
qed

lemma dom_subid_aux2'': "x \<cdot> d y \<le> x"
  using dpd3 mult_isol by fastforce

lemma d_comm: "d x \<cdot> d y = d y \<cdot> d x"
proof (rule order.antisym)
  have "d x \<cdot> d y = (d x \<cdot> d y) \<cdot> (d x \<cdot> d y)"
    by (metis dns1'' domain_export'')
  thus "d x \<cdot> d y \<le> d y \<cdot> d x"
    by (metis dom_subid_aux1'' dom_subid_aux2'' mult_isol_var)
next
  have "d y \<cdot> d x = (d y \<cdot> d x) \<cdot> (d y \<cdot> d x)"
    by (metis dns1'' domain_export'')
  thus "d y \<cdot> d x \<le> d x \<cdot> d y"
    by (metis dom_subid_aux1'' dom_subid_aux2'' mult_isol_var)
qed

subclass domain_near_semiring_one
  by (unfold_locales, auto simp: d_comm local.join.sup.absorb2)

lemma domain_subid: "x \<le> 1 \<Longrightarrow> x \<le> d x"
  by (metis dns1 mult_isol mult_oner)

lemma d_preserves_equation: "d y \<cdot> x \<le> x \<cdot> d z \<longleftrightarrow> d y \<cdot> x = d y \<cdot> x \<cdot> d z"
  by (metis dom_subid_aux2'' order.antisym local.dom_el_idem local.dom_subid_aux2 local.order_prop local.subdistl mult_assoc)

lemma d_restrict_iff: "(x \<le> y) \<longleftrightarrow> (x \<le> d x \<cdot> y)"
  by (metis dom_subid_aux2 dsg1 less_eq_def order_trans subdistl)

lemma d_restrict_iff_1: "(d x \<cdot> y \<le> z) \<longleftrightarrow> (d x \<cdot> y \<le> d x \<cdot> z)"
  by (metis dom_subid_aux2 domain_1'' domain_invol dsg1 mult_isol_var order_trans)

end

text \<open>We add once more a left unit of multiplication.\<close>

class domain_pre_dioid_one_zerol = domain_pre_dioid_one + pre_dioid_one_zerol +
  assumes dpd5 [simp]: "d 0 = 0"

begin

subclass domain_near_semiring_one_zerol
  by (unfold_locales, simp)

end

subsection \<open>Domain Semirings\<close>

text \<open>We do not consider domain semirings without units separately at the moment. The axioms are taken from from~\<^cite>\<open>"DesharnaisStruthSCP"\<close>\<close>

class domain_semiringl = semiring_one_zerol + plus_ord + domain_op +
  assumes dsr1 [simp]: "x + d x \<cdot> x = d x \<cdot> x"
  and dsr2 [simp]: "d (x \<cdot> d y) = d (x \<cdot> y)"
  and dsr3 [simp]: "d x + 1 = 1"
  and dsr4 [simp]: "d 0 = 0"
  and dsr5 [simp]: "d (x + y) = d x + d y"

begin

text \<open>Every domain semiring is automatically a domain pre-dioid with one and left zero.\<close>

subclass dioid_one_zerol
  by (standard, metis add_commute dsr1 dsr3 distrib_left mult_oner)

subclass domain_pre_dioid_one_zerol
  by (standard, auto simp: less_eq_def)

end

class domain_semiring = domain_semiringl + semiring_one_zero

subsection \<open>The Algebra of Domain Elements\<close>

text \<open>We show that the domain elements of a domain semiring form a distributive lattice. Unfortunately we cannot prove this within the type class of domain semirings.\<close>

typedef (overloaded)  'a d_element = "{x :: 'a :: domain_semiring. x = d x}"
  by (rule_tac x = 1 in exI, simp add: domain_subid ds.eq_iff)

setup_lifting type_definition_d_element

instantiation d_element :: (domain_semiring) bounded_lattice

begin

lift_definition less_eq_d_element :: "'a d_element \<Rightarrow> 'a d_element \<Rightarrow> bool" is "(\<le>)" .

lift_definition less_d_element :: "'a d_element \<Rightarrow> 'a d_element \<Rightarrow> bool" is "(<)" .

lift_definition bot_d_element :: "'a d_element" is 0
  by simp

lift_definition top_d_element :: "'a d_element" is 1
  by simp

lift_definition inf_d_element :: "'a d_element \<Rightarrow> 'a d_element \<Rightarrow> 'a d_element" is "(\<cdot>)"
  by (metis dsg3)

lift_definition sup_d_element :: "'a d_element \<Rightarrow> 'a d_element \<Rightarrow> 'a d_element" is "(+)"
  by simp

instance
  apply (standard; transfer)
  apply (simp add: less_le_not_le)+
  apply (metis dom_subid_aux2'')
  apply (metis dom_subid_aux2)
  apply (metis dom_glb)
  apply simp+
  by (metis dom_subid)

end

instance d_element :: (domain_semiring) distrib_lattice
  by (standard, transfer, metis dom_distrib)

subsection \<open>Domain Semirings with a Greatest Element\<close>

text \<open>If there is a greatest element in the semiring, then we have another equality.\<close>

class domain_semiring_top = domain_semiring + order_top

begin

notation top ("\<top>")

end

subsection \<open>Forward Diamond Operators\<close>

context domain_semiringl

begin

text \<open>We define a forward diamond operator over a domain semiring. A more modular consideration is not given at the moment.\<close>

definition fd :: "'a \<Rightarrow> 'a \<Rightarrow> 'a" ("( |_\<rangle> _)" [61,81] 82) where
  "|x\<rangle> y = d (x \<cdot> y)"

lemma fdia_d_simp [simp]: "|x\<rangle> d y = |x\<rangle> y"
  by (simp add: fd_def)

lemma fdia_dom [simp]: "|x\<rangle> 1 = d x"
  by (simp add: fd_def)

lemma fdia_add1: "|x\<rangle> (y + z) = |x\<rangle> y + |x\<rangle> z"
  by (simp add: fd_def distrib_left)

lemma fdia_add2: "|x + y\<rangle> z = |x\<rangle> z + |y\<rangle> z"
  by (simp add: fd_def distrib_right)

lemma fdia_mult: "|x \<cdot> y\<rangle> z = |x\<rangle> |y\<rangle> z"
  by (simp add: fd_def mult_assoc)

lemma fdia_one [simp]: "|1\<rangle> x = d x"
  by (simp add: fd_def)

lemma fdemodalisation1: "d z \<cdot> |x\<rangle> y = 0 \<longleftrightarrow> d z \<cdot> x \<cdot> d y = 0"
proof -
  have "d z \<cdot> |x\<rangle> y = 0 \<longleftrightarrow> d z \<cdot> d (x \<cdot> y) = 0"
    by (simp add: fd_def)
  also have "... \<longleftrightarrow> d z \<cdot> x \<cdot> y = 0"
    by (metis annil dnso6 dsg1 dsg3 mult_assoc)
  finally show ?thesis
    using dom_weakly_local by auto
qed

lemma fdemodalisation2: "|x\<rangle> y \<le> d z \<longleftrightarrow> x \<cdot> d y \<le> d z \<cdot> x"
proof
  assume "|x\<rangle> y \<le> d z"
  hence a: "d (x \<cdot> d y) \<le> d z"
    by (simp add: fd_def)
  have "x \<cdot> d y = d (x \<cdot> d y) \<cdot> x \<cdot> d y"
    using dsg1 mult_assoc by presburger
  also have "... \<le> d z \<cdot> x \<cdot> d y"
    using a calculation dom_llp2 mult_assoc by auto
  finally show "x \<cdot> d y \<le> d z \<cdot> x"
    using dom_subid_aux2'' order_trans by blast
next
  assume "x \<cdot> d y \<le> d z \<cdot> x"
  hence "d (x \<cdot> d y) \<le> d (d z \<cdot> d x)"
    using dom_iso by fastforce
  also have "... \<le> d (d z)"
    using domain_1'' by blast
  finally show "|x\<rangle> y \<le> d z"
    by (simp add: fd_def)
qed

lemma fd_iso1: "d x \<le> d y \<Longrightarrow> |z\<rangle> x \<le> |z\<rangle> y"
  using fd_def local.dom_iso local.mult_isol by fastforce

lemma fd_iso2: "x \<le> y \<Longrightarrow> |x\<rangle> z \<le> |y\<rangle> z"
  by (simp add: fd_def dom_iso mult_isor)

lemma fd_zero_var [simp]: "|0\<rangle> x = 0"
  by (simp add: fd_def)

lemma fd_subdist_1: "|x\<rangle> y \<le> |x\<rangle> (y + z)"
  by (simp add: fd_iso1)

lemma fd_subdist_2: "|x\<rangle> (d y \<cdot> d z) \<le> |x\<rangle> y"
  by (simp add: fd_iso1 dom_subid_aux2'')

lemma fd_subdist: "|x\<rangle> (d y \<cdot> d z) \<le> |x\<rangle> y \<cdot> |x\<rangle> z"
  using fd_def fd_iso1 fd_subdist_2 dom_glb dom_subid_aux2 by auto

lemma fdia_export_1: "d y \<cdot> |x\<rangle> z = |d y \<cdot> x\<rangle> z"
  by (simp add: fd_def mult_assoc)

end

context domain_semiring

begin

end

subsection \<open>Domain Kleene Algebras\<close>

text \<open>We add the Kleene star to our considerations. Special domain axioms are not needed.\<close>

class domain_left_kleene_algebra = left_kleene_algebra_zerol + domain_semiringl

begin

lemma dom_star [simp]: "d (x\<^sup>\<star>) = 1"
proof -
  have "d (x\<^sup>\<star>) = d (1 + x \<cdot> x\<^sup>\<star>)"
    by simp
  also have "... = d 1 + d (x \<cdot> x\<^sup>\<star>)"
    using dns3 by blast
  finally show ?thesis
    using add_commute local.dsr3 by auto
qed

lemma fdia_star_unfold [simp]: "|1\<rangle> y + |x\<rangle> |x\<^sup>\<star>\<rangle> y = |x\<^sup>\<star>\<rangle> y"
proof -
  have "|1\<rangle> y + |x\<rangle> |x\<^sup>\<star>\<rangle> y = |1 + x \<cdot> x\<^sup>\<star>\<rangle> y"
    using local.fdia_add2 local.fdia_mult by presburger
  thus ?thesis
    by simp
qed

lemma fdia_star_unfoldr [simp]: "|1\<rangle> y + |x\<^sup>\<star>\<rangle> |x\<rangle> y = |x\<^sup>\<star>\<rangle> y"
proof -
  have "|1\<rangle> y + |x\<^sup>\<star>\<rangle> |x\<rangle> y = |1 + x\<^sup>\<star> \<cdot> x\<rangle> y"
    using fdia_add2 fdia_mult by presburger
  thus ?thesis
    by simp
qed

lemma fdia_star_unfold_var [simp]: "d y + |x\<rangle> |x\<^sup>\<star>\<rangle> y = |x\<^sup>\<star>\<rangle> y"
proof -
  have "d y + |x\<rangle> |x\<^sup>\<star>\<rangle> y = |1\<rangle> y + |x\<rangle> |x\<^sup>\<star>\<rangle> y"
    by simp
  also have "... = |1 + x \<cdot> x\<^sup>\<star>\<rangle> y"
    using fdia_add2 fdia_mult by presburger
  finally show ?thesis
    by simp
qed

lemma fdia_star_unfoldr_var [simp]: "d y + |x\<^sup>\<star>\<rangle> |x\<rangle> y = |x\<^sup>\<star>\<rangle> y"
proof -
  have "d y + |x\<^sup>\<star>\<rangle> |x\<rangle> y = |1\<rangle> y + |x\<^sup>\<star>\<rangle> |x\<rangle> y"
    by simp
  also have "... = |1 + x\<^sup>\<star> \<cdot> x\<rangle> y"
    using fdia_add2 fdia_mult by presburger
  finally show ?thesis
    by simp
qed

lemma fdia_star_induct_var: "|x\<rangle> y \<le> d y \<Longrightarrow> |x\<^sup>\<star>\<rangle> y \<le> d y"
proof -
  assume a1: "|x\<rangle> y \<le> d y"
  hence "x \<cdot> d y \<le> d y \<cdot> x"
    by (simp add: fdemodalisation2)
  hence "x\<^sup>\<star> \<cdot> d y \<le> d y \<cdot> x\<^sup>\<star>"
    by (simp add: star_sim1)
  thus ?thesis
    by (simp add: fdemodalisation2)
qed

lemma fdia_star_induct: "d z + |x\<rangle> y \<le> d y \<Longrightarrow> |x\<^sup>\<star>\<rangle> z \<le> d y"
proof -
  assume a: "d z + |x\<rangle> y \<le> d y"
  hence b: "d z \<le> d y" and c: "|x\<rangle> y \<le> d y"
    apply (simp add: local.join.le_supE)
    using a by auto
  hence d: "|x\<^sup>\<star>\<rangle> z \<le> |x\<^sup>\<star>\<rangle> y"
    using fd_def fd_iso1 by auto
  have "|x\<^sup>\<star>\<rangle> y \<le> d y"
    using c fdia_star_induct_var by blast
  thus ?thesis
    using d by fastforce
qed

lemma fdia_star_induct_eq: "d z + |x\<rangle> y = d y \<Longrightarrow> |x\<^sup>\<star>\<rangle> z \<le> d y"
  by (simp add: fdia_star_induct)

end

class domain_kleene_algebra = kleene_algebra + domain_semiring

begin

subclass domain_left_kleene_algebra ..

end

end


(*  Title:      HOL/ex/ThreeDivides.thy
    Author:     Benjamin Porter, 2005
*)

section \<open>Three Divides Theorem\<close>

theory ThreeDivides
imports Main "~~/src/HOL/Library/LaTeXsugar"
begin

subsection \<open>Abstract\<close>

text \<open>
The following document presents a proof of the Three Divides N theorem
formalised in the Isabelle/Isar theorem proving system.

{\em Theorem}: $3$ divides $n$ if and only if $3$ divides the sum of all
digits in $n$.

{\em Informal Proof}:
Take $n = \sum{n_j * 10^j}$ where $n_j$ is the $j$'th least
significant digit of the decimal denotation of the number n and the
sum ranges over all digits. Then $$ (n - \sum{n_j}) = \sum{n_j * (10^j
- 1)} $$ We know $\forall j\; 3|(10^j - 1) $ and hence $3|LHS$,
therefore $$\forall n\; 3|n \Longleftrightarrow 3|\sum{n_j}$$
\<open>\<box>\<close>
\<close>

subsection \<open>Formal proof\<close>

subsubsection \<open>Miscellaneous summation lemmas\<close>

text \<open>If $a$ divides \<open>A x\<close> for all x then $a$ divides any
sum over terms of the form \<open>(A x)*(P x)\<close> for arbitrary $P$.\<close>

lemma div_sum:
  fixes a::nat and n::nat
  shows "\<forall>x. a dvd A x \<Longrightarrow> a dvd (\<Sum>x<n. A x * D x)"
proof (induct n)
  case 0 show ?case by simp
next
  case (Suc n)
  from Suc
  have "a dvd (A n * D n)" by (simp add: dvd_mult2)
  with Suc
  have "a dvd ((\<Sum>x<n. A x * D x) + (A n * D n))" by (simp add: dvd_add)
  thus ?case by simp
qed

subsubsection \<open>Generalised Three Divides\<close>

text \<open>This section solves a generalised form of the three divides
problem. Here we show that for any sequence of numbers the theorem
holds. In the next section we specialise this theorem to apply
directly to the decimal expansion of the natural numbers.\<close>

text \<open>Here we show that the first statement in the informal proof is
true for all natural numbers. Note we are using @{term "D i"} to
denote the $i$'th element in a sequence of numbers.\<close>

lemma digit_diff_split:
  fixes n::nat and nd::nat and x::nat
  shows "n = (\<Sum>x\<in>{..<nd}. (D x)*((10::nat)^x)) \<Longrightarrow>
             (n - (\<Sum>x<nd. (D x))) = (\<Sum>x<nd. (D x)*(10^x - 1))"
by (simp add: sum_diff_distrib diff_mult_distrib2)

text \<open>Now we prove that 3 always divides numbers of the form $10^x - 1$.\<close>
lemma three_divs_0:
  shows "(3::nat) dvd (10^x - 1)"
proof (induct x)
  case 0 show ?case by simp
next
  case (Suc n)
  let ?thr = "(3::nat)"
  have "?thr dvd 9" by simp
  moreover
  have "?thr dvd (10*(10^n - 1))" by (rule dvd_mult) (rule Suc)
  hence "?thr dvd (10^(n+1) - 10)" by (simp add: nat_distrib)
  ultimately
  have"?thr dvd ((10^(n+1) - 10) + 9)"
    by (simp only: ac_simps) (rule dvd_add)
  thus ?case by simp
qed

text \<open>Expanding on the previous lemma and lemma \<open>div_sum\<close>.\<close>
lemma three_divs_1:
  fixes D :: "nat \<Rightarrow> nat"
  shows "3 dvd (\<Sum>x<nd. D x * (10^x - 1))"
  by (subst mult.commute, rule div_sum) (simp add: three_divs_0 [simplified])

text \<open>Using lemmas \<open>digit_diff_split\<close> and
\<open>three_divs_1\<close> we now prove the following lemma.
\<close>
lemma three_divs_2:
  fixes nd::nat and D::"nat\<Rightarrow>nat"
  shows "3 dvd ((\<Sum>x<nd. (D x)*(10^x)) - (\<Sum>x<nd. (D x)))"
proof -
  from three_divs_1 have "3 dvd (\<Sum>x<nd. D x * (10 ^ x - 1))" .
  thus ?thesis by (simp only: digit_diff_split)
qed

text \<open>
We now present the final theorem of this section. For any
sequence of numbers (defined by a function @{term "D :: (nat\<Rightarrow>nat)"}),
we show that 3 divides the expansive sum $\sum{(D\;x)*10^x}$ over $x$
if and only if 3 divides the sum of the individual numbers
$\sum{D\;x}$.
\<close>
lemma three_div_general:
  fixes D :: "nat \<Rightarrow> nat"
  shows "(3 dvd (\<Sum>x<nd. D x * 10^x)) = (3 dvd (\<Sum>x<nd. D x))"
proof
  have mono: "(\<Sum>x<nd. D x) \<le> (\<Sum>x<nd. D x * 10^x)"
    by (rule sum_mono) simp
  txt \<open>This lets us form the term
         @{term "(\<Sum>x<nd. D x * 10^x) - (\<Sum>x<nd. D x)"}\<close>

  {
    assume "3 dvd (\<Sum>x<nd. D x)"
    with three_divs_2 mono
    show "3 dvd (\<Sum>x<nd. D x * 10^x)"
      by (blast intro: dvd_diffD)
  }
  {
    assume "3 dvd (\<Sum>x<nd. D x * 10^x)"
    with three_divs_2 mono
    show "3 dvd (\<Sum>x<nd. D x)"
      by (blast intro: dvd_diffD1)
  }
qed

subsubsection \<open>Three Divides Natural\<close>

text \<open>This section shows that for all natural numbers we can
generate a sequence of digits less than ten that represent the decimal
expansion of the number. We then use the lemma \<open>three_div_general\<close> to prove our final theorem.\<close>

text \<open>\medskip Definitions of length and digit sum.\<close>

text \<open>This section introduces some functions to calculate the
required properties of natural numbers. We then proceed to prove some
properties of these functions.

The function \<open>nlen\<close> returns the number of digits in a natural
number n.\<close>

fun nlen :: "nat \<Rightarrow> nat"
where
  "nlen 0 = 0"
| "nlen x = 1 + nlen (x div 10)"

text \<open>The function \<open>sumdig\<close> returns the sum of all digits in
some number n.\<close>

definition
  sumdig :: "nat \<Rightarrow> nat" where
  "sumdig n = (\<Sum>x < nlen n. n div 10^x mod 10)"

text \<open>Some properties of these functions follow.\<close>

lemma nlen_zero:
  "0 = nlen x \<Longrightarrow> x = 0"
  by (induct x rule: nlen.induct) auto

lemma nlen_suc:
  "Suc m = nlen n \<Longrightarrow> m = nlen (n div 10)"
  by (induct n rule: nlen.induct) simp_all

text \<open>The following lemma is the principle lemma required to prove
our theorem. It states that an expansion of some natural number $n$
into a sequence of its individual digits is always possible.\<close>

lemma exp_exists:
  "m = (\<Sum>x<nlen m. (m div (10::nat)^x mod 10) * 10^x)"
proof (induct "nlen m" arbitrary: m)
  case 0 thus ?case by (simp add: nlen_zero)
next
  case (Suc nd)
  obtain c where mexp: "m = 10*(m div 10) + c \<and> c < 10"
    and cdef: "c = m mod 10" by simp
  show "m = (\<Sum>x<nlen m. m div 10^x mod 10 * 10^x)"
  proof -
    from \<open>Suc nd = nlen m\<close>
    have "nd = nlen (m div 10)" by (rule nlen_suc)
    with Suc have
      "m div 10 = (\<Sum>x<nd. m div 10 div 10^x mod 10 * 10^x)" by simp
    with mexp have
      "m = 10*(\<Sum>x<nd. m div 10 div 10^x mod 10 * 10^x) + c" by simp
    also have
      "\<dots> = (\<Sum>x<nd. m div 10 div 10^x mod 10 * 10^(x+1)) + c"
      by (subst sum_distrib_left) (simp add: ac_simps)
    also have
      "\<dots> = (\<Sum>x<nd. m div 10^(Suc x) mod 10 * 10^(Suc x)) + c"
      by (simp add: div_mult2_eq[symmetric])
    also have
      "\<dots> = (\<Sum>x\<in>{Suc 0..<Suc nd}. m div 10^x  mod 10 * 10^x) + c"
      by (simp only: sum_shift_bounds_Suc_ivl)
         (simp add: atLeast0LessThan)
    also have
      "\<dots> = (\<Sum>x<Suc nd. m div 10^x mod 10 * 10^x)"
      by (simp add: atLeast0LessThan[symmetric] sum_head_upt_Suc cdef)
    also note \<open>Suc nd = nlen m\<close>
    finally
    show "m = (\<Sum>x<nlen m. m div 10^x mod 10 * 10^x)" .
  qed
qed

text \<open>\medskip Final theorem.\<close>

text \<open>We now combine the general theorem \<open>three_div_general\<close>
and existence result of \<open>exp_exists\<close> to prove our final
theorem.\<close>

theorem three_divides_nat:
  shows "(3 dvd n) = (3 dvd sumdig n)"
proof (unfold sumdig_def)
  have "n = (\<Sum>x<nlen n. (n div (10::nat)^x mod 10) * 10^x)"
    by (rule exp_exists)
  moreover
  have "3 dvd (\<Sum>x<nlen n. (n div (10::nat)^x mod 10) * 10^x) =
        (3 dvd (\<Sum>x<nlen n. n div 10^x mod 10))"
    by (rule three_div_general)
  ultimately
  show "3 dvd n = (3 dvd (\<Sum>x<nlen n. n div 10^x mod 10))" by simp
qed

end


(*  Title:      HOL/ex/PER.thy
    Author:     Oscar Slotosch and Markus Wenzel, TU Muenchen
*)

section \<open>Partial equivalence relations\<close>

theory PER
imports Main
begin

text \<open>
  Higher-order quotients are defined over partial equivalence
  relations (PERs) instead of total ones.  We provide axiomatic type
  classes \<open>equiv < partial_equiv\<close> and a type constructor
  \<open>'a quot\<close> with basic operations.  This development is based
  on:

  Oscar Slotosch: \emph{Higher Order Quotients and their
  Implementation in Isabelle HOL.}  Elsa L. Gunter and Amy Felty,
  editors, Theorem Proving in Higher Order Logics: TPHOLs '97,
  Springer LNCS 1275, 1997.
\<close>

subsection \<open>Partial equivalence\<close>

text \<open>
  Type class \<open>partial_equiv\<close> models partial equivalence
  relations (PERs) using the polymorphic \<open>\<sim> :: 'a \<Rightarrow> 'a \<Rightarrow>
  bool\<close> relation, which is required to be symmetric and transitive,
  but not necessarily reflexive.
\<close>

class partial_equiv =
  fixes eqv :: "'a \<Rightarrow> 'a \<Rightarrow> bool"    (infixl "\<sim>" 50)
  assumes partial_equiv_sym [elim?]: "x \<sim> y \<Longrightarrow> y \<sim> x"
  assumes partial_equiv_trans [trans]: "x \<sim> y \<Longrightarrow> y \<sim> z \<Longrightarrow> x \<sim> z"

text \<open>
  \medskip The domain of a partial equivalence relation is the set of
  reflexive elements.  Due to symmetry and transitivity this
  characterizes exactly those elements that are connected with
  \emph{any} other one.
\<close>

definition
  "domain" :: "'a::partial_equiv set" where
  "domain = {x. x \<sim> x}"

lemma domainI [intro]: "x \<sim> x \<Longrightarrow> x \<in> domain"
  unfolding domain_def by blast

lemma domainD [dest]: "x \<in> domain \<Longrightarrow> x \<sim> x"
  unfolding domain_def by blast

theorem domainI' [elim?]: "x \<sim> y \<Longrightarrow> x \<in> domain"
proof
  assume xy: "x \<sim> y"
  also from xy have "y \<sim> x" ..
  finally show "x \<sim> x" .
qed

subsection \<open>Equivalence on function spaces\<close>

text \<open>
  The \<open>\<sim>\<close> relation is lifted to function spaces.  It is
  important to note that this is \emph{not} the direct product, but a
  structural one corresponding to the congruence property.
\<close>

instantiation "fun" :: (partial_equiv, partial_equiv) partial_equiv
begin

definition "f \<sim> g \<longleftrightarrow> (\<forall>x \<in> domain. \<forall>y \<in> domain. x \<sim> y \<longrightarrow> f x \<sim> g y)"

lemma partial_equiv_funI [intro?]:
    "(\<And>x y. x \<in> domain \<Longrightarrow> y \<in> domain \<Longrightarrow> x \<sim> y \<Longrightarrow> f x \<sim> g y) \<Longrightarrow> f \<sim> g"
  unfolding eqv_fun_def by blast

lemma partial_equiv_funD [dest?]:
    "f \<sim> g \<Longrightarrow> x \<in> domain \<Longrightarrow> y \<in> domain \<Longrightarrow> x \<sim> y \<Longrightarrow> f x \<sim> g y"
  unfolding eqv_fun_def by blast

text \<open>
  The class of partial equivalence relations is closed under function
  spaces (in \emph{both} argument positions).
\<close>

instance proof
  fix f g h :: "'a::partial_equiv \<Rightarrow> 'b::partial_equiv"
  assume fg: "f \<sim> g"
  show "g \<sim> f"
  proof
    fix x y :: 'a
    assume x: "x \<in> domain" and y: "y \<in> domain"
    assume "x \<sim> y" then have "y \<sim> x" ..
    with fg y x have "f y \<sim> g x" ..
    then show "g x \<sim> f y" ..
  qed
  assume gh: "g \<sim> h"
  show "f \<sim> h"
  proof
    fix x y :: 'a
    assume x: "x \<in> domain" and y: "y \<in> domain" and "x \<sim> y"
    with fg have "f x \<sim> g y" ..
    also from y have "y \<sim> y" ..
    with gh y y have "g y \<sim> h y" ..
    finally show "f x \<sim> h y" .
  qed
qed

end

subsection \<open>Total equivalence\<close>

text \<open>
  The class of total equivalence relations on top of PERs.  It
  coincides with the standard notion of equivalence, i.e.\ \<open>\<sim>
  :: 'a \<Rightarrow> 'a \<Rightarrow> bool\<close> is required to be reflexive, transitive and
  symmetric.
\<close>

class equiv =
  assumes eqv_refl [intro]: "x \<sim> x"

text \<open>
  On total equivalences all elements are reflexive, and congruence
  holds unconditionally.
\<close>

theorem equiv_domain [intro]: "(x::'a::equiv) \<in> domain"
proof
  show "x \<sim> x" ..
qed

theorem equiv_cong [dest?]: "f \<sim> g \<Longrightarrow> x \<sim> y \<Longrightarrow> f x \<sim> g (y::'a::equiv)"
proof -
  assume "f \<sim> g"
  moreover have "x \<in> domain" ..
  moreover have "y \<in> domain" ..
  moreover assume "x \<sim> y"
  ultimately show ?thesis ..
qed

subsection \<open>Quotient types\<close>

text \<open>
  The quotient type \<open>'a quot\<close> consists of all
  \emph{equivalence classes} over elements of the base type \<^typ>\<open>'a\<close>.
\<close>

definition "quot = {{x. a \<sim> x}| a::'a::partial_equiv. True}"

typedef (overloaded) 'a quot = "quot :: 'a::partial_equiv set set"
  unfolding quot_def by blast

lemma quotI [intro]: "{x. a \<sim> x} \<in> quot"
  unfolding quot_def by blast

lemma quotE [elim]: "R \<in> quot \<Longrightarrow> (\<And>a. R = {x. a \<sim> x} \<Longrightarrow> C) \<Longrightarrow> C"
  unfolding quot_def by blast

text \<open>
  \medskip Abstracted equivalence classes are the canonical
  representation of elements of a quotient type.
\<close>

definition eqv_class :: "('a::partial_equiv) \<Rightarrow> 'a quot"  ("\<lfloor>_\<rfloor>")
  where "\<lfloor>a\<rfloor> = Abs_quot {x. a \<sim> x}"

theorem quot_rep: "\<exists>a. A = \<lfloor>a\<rfloor>"
proof (cases A)
  fix R assume R: "A = Abs_quot R"
  assume "R \<in> quot" then have "\<exists>a. R = {x. a \<sim> x}" by blast
  with R have "\<exists>a. A = Abs_quot {x. a \<sim> x}" by blast
  then show ?thesis by (unfold eqv_class_def)
qed

lemma quot_cases [cases type: quot]:
  obtains (rep) a where "A = \<lfloor>a\<rfloor>"
  using quot_rep by blast

subsection \<open>Equality on quotients\<close>

text \<open>
  Equality of canonical quotient elements corresponds to the original
  relation as follows.
\<close>

theorem eqv_class_eqI [intro]: "a \<sim> b \<Longrightarrow> \<lfloor>a\<rfloor> = \<lfloor>b\<rfloor>"
proof -
  assume ab: "a \<sim> b"
  have "{x. a \<sim> x} = {x. b \<sim> x}"
  proof (rule Collect_cong)
    fix x show "a \<sim> x \<longleftrightarrow> b \<sim> x"
    proof
      from ab have "b \<sim> a" ..
      also assume "a \<sim> x"
      finally show "b \<sim> x" .
    next
      note ab
      also assume "b \<sim> x"
      finally show "a \<sim> x" .
    qed
  qed
  then show ?thesis by (simp only: eqv_class_def)
qed

theorem eqv_class_eqD' [dest?]: "\<lfloor>a\<rfloor> = \<lfloor>b\<rfloor> \<Longrightarrow> a \<in> domain \<Longrightarrow> a \<sim> b"
proof (unfold eqv_class_def)
  assume "Abs_quot {x. a \<sim> x} = Abs_quot {x. b \<sim> x}"
  then have "{x. a \<sim> x} = {x. b \<sim> x}" by (simp only: Abs_quot_inject quotI)
  moreover assume "a \<in> domain" then have "a \<sim> a" ..
  ultimately have "a \<in> {x. b \<sim> x}" by blast
  then have "b \<sim> a" by blast
  then show "a \<sim> b" ..
qed

theorem eqv_class_eqD [dest?]: "\<lfloor>a\<rfloor> = \<lfloor>b\<rfloor> \<Longrightarrow> a \<sim> (b::'a::equiv)"
proof (rule eqv_class_eqD')
  show "a \<in> domain" ..
qed

lemma eqv_class_eq' [simp]: "a \<in> domain \<Longrightarrow> \<lfloor>a\<rfloor> = \<lfloor>b\<rfloor> \<longleftrightarrow> a \<sim> b"
  using eqv_class_eqI eqv_class_eqD' by (blast del: eqv_refl)

lemma eqv_class_eq [simp]: "\<lfloor>a\<rfloor> = \<lfloor>b\<rfloor> \<longleftrightarrow> a \<sim> (b::'a::equiv)"
  using eqv_class_eqI eqv_class_eqD by blast

subsection \<open>Picking representing elements\<close>

definition pick :: "'a::partial_equiv quot \<Rightarrow> 'a"
  where "pick A = (SOME a. A = \<lfloor>a\<rfloor>)"

theorem pick_eqv' [intro?, simp]: "a \<in> domain \<Longrightarrow> pick \<lfloor>a\<rfloor> \<sim> a"
proof (unfold pick_def)
  assume a: "a \<in> domain"
  show "(SOME x. \<lfloor>a\<rfloor> = \<lfloor>x\<rfloor>) \<sim> a"
  proof (rule someI2)
    show "\<lfloor>a\<rfloor> = \<lfloor>a\<rfloor>" ..
    fix x assume "\<lfloor>a\<rfloor> = \<lfloor>x\<rfloor>"
    from this and a have "a \<sim> x" ..
    then show "x \<sim> a" ..
  qed
qed

theorem pick_eqv [intro, simp]: "pick \<lfloor>a\<rfloor> \<sim> (a::'a::equiv)"
proof (rule pick_eqv')
  show "a \<in> domain" ..
qed

theorem pick_inverse: "\<lfloor>pick A\<rfloor> = (A::'a::equiv quot)"
proof (cases A)
  fix a assume a: "A = \<lfloor>a\<rfloor>"
  then have "pick A \<sim> a" by simp
  then have "\<lfloor>pick A\<rfloor> = \<lfloor>a\<rfloor>" by simp
  with a show ?thesis by simp
qed

end


theory Basel_Sum_Approx
  imports "HOL.Transcendental" "HOL-Analysis.Interval_Integral"
begin

text \<open>Inspired by Integral_Test.sum_integral_diff_series_nonneg.\<close>
lemma riemann_approx:
  fixes f :: "real \<Rightarrow> real"
  assumes "\<And>x y. x \<ge> a \<Longrightarrow> y \<le> b \<Longrightarrow> x \<le> y \<Longrightarrow> f x \<ge> f y"
  assumes "continuous_on {a..b} f"
  assumes "a \<le> b"
  shows "(\<Sum>k=a+1..b. f (of_int k)) \<le> integral {a..b} f" (is "?L \<le> ?R")
proof -
  note int = integrable_continuous_real[OF continuous_on_subset[OF assms(2)]]
  obtain j :: nat where m_def: "b = a + int j"
    using zle_iff_zadd assms(3) by blast

  have "integral {a..a+int j} f = (\<Sum>k=a+1..a+int j. integral {k-1..k} f)" if "a + int j \<le> b" for j
    using that
  proof (induction j)
    case 0
    then show ?case by simp
  next
    case (Suc j)
    have "integral {a..a+int (Suc j)} f = integral {a..a+int j} f + integral {a+int j..a+int (Suc j)} f"
      using Suc(2) by (intro integral_combine[symmetric] int) auto
    also have "... = (\<Sum>k=a+1..a+ int j. integral {k-1..k} f) + integral {a+int j..a+int (Suc j)} f"
      using Suc(2) by (intro arg_cong2[where f="(+)"] Suc(1)) auto
    also have "... = (\<Sum>k \<in> insert (a+int (Suc j)) {a+1..a+ int j}. integral {k-1..k} f)"
      by simp
    also have "... = (\<Sum>k \<in> {a+1..a+ int (Suc j)}. integral {k-1..k} f)"
      by (intro sum.cong) auto
    finally show ?case by simp
  qed
  hence a:"integral {a..b} f = (\<Sum>k=a+1..b. integral {k-1..k} f)"
    using m_def by simp

  have "?L = (\<Sum>k=a+1..b. integral {k-1..k} (\<lambda>_. f (of_int k)))"
    by simp
  also have "... \<le> (\<Sum>k=a+1..b. integral {k-1..k} f)"
    using assms by (intro sum_mono integral_le int) auto
  also have "... = ?R"
    using a by simp
  finally show ?thesis by simp
qed

lemma basel_sum:
  assumes "k > 0"
  shows "(\<Sum>y\<in>{k+1..m}. 1 / real y^2) \<le> 1/real k" (is "?L \<le> ?R")
proof (cases "m \<ge> k")
  case True
  have "?L = (\<Sum>y\<in>int ` {k+1..m}. 1 / real_of_int y^2)"
    by (subst sum.reindex) auto
  also have "... = (\<Sum>y\<in>{int k+1..int m}. 1 / real_of_int y^2)"
    using image_int_atLeastAtMost by (intro sum.cong refl)  auto
  also have "... \<le> integral {int k..int m} (\<lambda>y. 1 / y^2)"
    using assms True by (intro riemann_approx frac_le power_mono continuous_intros) auto
  also have "... \<le> integral {real k..real m} (\<lambda>y. 1 / y^2)"
    by simp
  also have "... = (-(1/m))-(-(1/k))"
    using assms True has_real_derivative_iff_has_vector_derivative[symmetric]
    by (intro integral_unique[OF fundamental_theorem_of_calculus] of_nat_mono True)
     (auto intro!:derivative_eq_intros simp add:power2_eq_square)
  also have "... \<le> 1/k"
    by simp
  finally show ?thesis by simp
next
  case False
  thus ?thesis by simp
qed

end