(*  Title:       LList_CCPO_Topology.thy
    Author:      Johannes Hölzl, TU Munich
    Author:      Andreas Lochbihler, ETH Zurich
*)

header {* A CCPO topology on lazy lists with examples *}

theory LList_CCPO_Topology imports
  CCPO_Topology
  "../Coinductive_List_Prefix"
begin

instantiation llist :: (type) ccpo_topology
begin

definition open_llist :: "'a llist set \<Rightarrow> bool" where
  "open_llist A \<longleftrightarrow> (\<forall>C. chain C \<longrightarrow> C \<noteq> {} \<longrightarrow> Sup C \<in> A \<longrightarrow> C \<inter> A \<noteq> {})"

instance
  by intro_classes (simp add: open_llist_def)

end

subsection {* Continuity and closedness of predefined constants *}

lemma tendsto_mcont_llist: "mcont lSup lprefix lSup lprefix f \<Longrightarrow> f -- l --> f l"
  by (auto simp add: Sup_llist_def[abs_def] intro!: tendsto_mcont)

lemma tendsto_ltl[THEN tendsto_compose, tendsto_intros]: "ltl -- l --> ltl l"
  by (intro tendsto_mcont_llist mcont_ltl)

lemma tendsto_lappend2[THEN tendsto_compose, tendsto_intros]: "lappend l -- l' --> lappend l l'"
  by (intro tendsto_mcont_llist mcont_lappend2)

lemma tendsto_LCons[THEN tendsto_compose, tendsto_intros]: "LCons x -- l --> LCons x l"
  by (intro tendsto_mcont_llist mcont_LCons)

lemma tendsto_lmap[THEN tendsto_compose, tendsto_intros]: "lmap f -- l --> lmap f l"
  by (intro tendsto_mcont_llist mcont_lmap)

lemma tendsto_llength[THEN tendsto_compose, tendsto_intros]: "llength -- l --> llength l"
  by (intro tendsto_mcont) (simp add: Sup_llist_def[abs_def])

lemma tendsto_lset[THEN tendsto_compose, tendsto_intros]: "lset -- l --> lset l"
  by(rule tendsto_mcont)(simp add: Sup_llist_def[abs_def])

lemma open_lhd: "open {l. \<not> lnull l \<and> lhd l = x}"
  unfolding open_ccpo set_eq_iff
proof (simp add: imp_conjL Sup_llist_def del: lhd_lSup, intro allI impI)
  fix C assume "Complete_Partial_Order.chain lprefix C" "lhd (lSup C) = x"
  moreover assume "\<exists>c\<in>C. \<not> lnull c"
  then obtain c where "c \<in> C" "\<not> lnull c"
    by auto
  ultimately show "\<exists>c. c \<in> C \<and> \<not> lnull c \<and> lhd c = x"
    by (force simp: lhd_lSup_eq)
qed

lemma open_LCons': assumes A: "open A" shows "open (LCons x ` A)"
proof -
  have "open (ltl -` A \<inter> {l. \<not> lnull l \<and> lhd l = x})"
    by (intro open_Int open_vimageI open_lhd A tendsto_intros)
  also have "(ltl -` A \<inter> {l. \<not> lnull l \<and> lhd l = x}) = LCons x ` A"
    by force
  finally show ?thesis .
qed

lemma open_Ici: "lfinite xs \<Longrightarrow> open {xs ..}"
proof (induct xs rule: lfinite.induct)
  case lfinite_LNil then show ?case
    by (simp add: atLeast_def)
next
  case (lfinite_LConsI xs x)
  moreover have "{LCons x xs ..} = LCons x ` {xs ..}"
    by (auto simp: LCons_lprefix_conv)
  ultimately show ?case
    by (auto intro: open_LCons')
qed

lemma open_lfinite[simp]: "lfinite x \<Longrightarrow> open {x}"
proof (induct rule: lfinite.induct)
  show "open {LNil}"
    using open_ccpo_Iic[of LNil] by (simp add: atMost_def lnull_def)
qed (auto dest: open_LCons')

lemma open_singleton_iff_lfinite: "open {x} \<longleftrightarrow> lfinite x"
proof
  assume "lfinite x" then show "open {x}"
    unfolding compact_eq_lfinite[symmetric] Sup_llist_def[abs_def, symmetric] less_eq_llist_def[abs_def, symmetric]
    by (rule open_singletonI_compact)
next
  assume "open {x}"
  show "lfinite x"
  proof (rule ccontr)
    let ?C = "{ys. lprefix ys x \<and> ys \<noteq> x}"
    assume inf: "\<not> lfinite x"
    note lSup_strict_prefixes[OF this] `open {x}`
    moreover have "chain ?C"
      using lprefixes_chain[of x] by (auto dest: chain_compr)
    moreover have "?C \<noteq> {}"
      using inf by (cases x) auto
    ultimately show False
      by (auto simp: open_ccpo Sup_llist_def)
  qed
qed

lemma closure_eq_lfinite:
  assumes closed_Q: "closed {xs. Q xs}"
  assumes downwards_Q: "\<And>xs ys. Q xs \<Longrightarrow> lprefix ys xs \<Longrightarrow> Q ys"
  shows "{xs. Q xs} = closure {xs. lfinite xs \<and> Q xs}"
proof (rule closure_unique[symmetric])
  fix T assume T: "{xs. lfinite xs \<and> Q xs} \<subseteq> T" and "closed T"

  show "{xs. Q xs} \<subseteq> T"
  proof clarify
    fix xs :: "'a llist"
    let ?F = "{ys. lprefix ys xs \<and> lfinite ys}"
    assume "Q xs"
    with T downwards_Q have "?F \<subseteq> T"
      by auto
    moreover have "chain ?F" "?F \<noteq> {}"
      by (auto intro: lprefixes_chain chain_subset)
    moreover have "lSup ?F = xs"
      by (rule lSup_finite_prefixes)
    ultimately show "xs \<in> T"
      using `closed T` by (auto simp: closed_ccpo Sup_llist_def)
  qed
qed (auto simp: closed_Q)

lemma closure_lfinite: "closure {xs. lfinite xs} = UNIV"
  using closure_eq_lfinite[of "\<lambda>_. True"] by auto

lemma closed_ldistinct: "closed {xs. ldistinct xs}"
  unfolding closed_ccpo by (auto simp: ldistinct_lSup Sup_llist_def subset_eq)

lemma ldistinct_closure: "{xs. ldistinct xs} = closure {xs. lfinite xs \<and> ldistinct xs}"
  by (rule closure_eq_lfinite[OF closed_ldistinct ldistinct_lprefix])

lemma closed_ldistinct': "(\<And>x. isCont f x) \<Longrightarrow> closed {xs. ldistinct (f xs)}"
  using continuous_closed_preimage_univ[of f, OF _ closed_ldistinct] by auto

lemma closed_lsorted: "closed {xs. lsorted xs}"
  unfolding closed_ccpo by (auto simp: lsorted_lSup Sup_llist_def subset_eq)

lemma lsorted_closure: "{xs. lsorted xs} = closure {xs. lfinite xs \<and> lsorted xs}"
  by (rule closure_eq_lfinite[OF closed_lsorted lsorted_lprefixD])

lemma closed_lsorted': "(\<And>x. isCont f x) \<Longrightarrow> closed {xs. lsorted (f xs)}"
  using continuous_closed_preimage_univ[of f, OF _ closed_lsorted] by auto

lemma closed_in_lset: "closed {l. x \<in> lset l}"
  unfolding closed_ccpo by (auto simp add: subset_eq lset_lSup Sup_llist_def)

lemma closed_llist_all2:
  "closed {(x, y). llist_all2 R x y}"
proof -
  { fix a b assume *: "\<And>A B. open A \<Longrightarrow> open B \<Longrightarrow> a \<in> A \<Longrightarrow> b \<in> B \<Longrightarrow> (\<exists>x\<in>A. \<exists>y\<in>B. llist_all2 R x y)"
    then have "llist_all2 R a b"
    proof (coinduction arbitrary: a b)
      case LNil
      from LNil[rule_format, of "{LNil}" "- {LNil}"] LNil[rule_format, of "- {LNil}" "{LNil}"]
      show ?case
        by (auto simp: closed_def[symmetric] lnull_def)
    next
      case LCons
      show ?case
      proof
        show ?lhd
          using LCons(1)[rule_format, OF open_lhd open_lhd, of "lhd a" "lhd b"] LCons(2,3)
          by (auto dest: llist_all2_lhdD)
        show ?ltl
        proof (rule, simp, safe)
          fix A B assume "open A" "open B" "ltl a \<in> A" "ltl b \<in> B"
          with LCons(1)[rule_format, OF open_LCons' open_LCons', of A B "lhd a" "lhd b"] LCons(2,3)
          show "\<exists>a'\<in>A. \<exists>b'\<in>B. llist_all2 R a' b'"
            by (auto simp: not_lnull_conv)
        qed
      qed
    qed }
  then show ?thesis
    unfolding closed_def open_prod_def
    by (auto simp: subset_eq)
qed

lemma closed_list_all2:
  fixes f g :: "'b::t2_space \<Rightarrow> 'a llist"
  assumes f: "\<And>x. isCont f x" and g: "\<And>x. isCont g x"
  shows "closed {x. llist_all2 R (f x) (g x)}"
  using  isCont_closed_vimage[OF isCont_Pair[OF f g] closed_llist_all2, of R]
  by simp

lemma at_botI_lfinite[simp]: "lfinite l \<Longrightarrow> at l = bot"
  by (simp add: at_eq_bot_iff)

lemma at_eq_lfinite: "at l = (if lfinite l then bot else at' l)"
  by (auto simp: at'_def open_singleton_iff_lfinite)

lemma eventually_lfinite: "eventually lfinite (at' x)"
  apply (simp add: at'_def open_singleton_iff_lfinite eventually_principal eventually_at_topological)
  apply (intro exI[of _ "{.. x}"] impI conjI open_ccpo_Iic)
  apply (auto simp: lstrict_prefix_def intro!: lstrict_prefix_lfinite1)
  done

lemma eventually_nhds_llist:
  "eventually P (nhds l) \<longleftrightarrow> (\<exists>xs\<le>l. lfinite xs \<and> (\<forall>ys\<ge>xs. ys \<le> l \<longrightarrow> P ys))"
  unfolding eventually_nhds
proof safe
  let ?F = "{l'. lprefix l' l \<and> lfinite l'}"
  fix A assume "open A" "l \<in> A" "\<forall>l\<in>A. P l"
  moreover have "chain ?F" "?F \<noteq> {}"
    by (auto simp: chain_def dest: lprefix_down_linear)
  moreover have "Sup ?F = l"
    unfolding Sup_llist_def by (rule lSup_finite_prefixes)
  ultimately have "\<exists>xs. xs \<in> ?F \<and> (\<forall>ys\<ge>xs. ys \<in> ?F \<longrightarrow> P ys)"
    using open_ccpoD[of A ?F] by auto
  then show "\<exists>xs\<le>l. lfinite xs \<and> (\<forall>ys\<ge>xs. ys \<le> l \<longrightarrow> P ys)"
    by (metis (lifting) `l \<in> A` `\<forall>l\<in>A. P l` le_llist_conv_lprefix mem_Collect_eq not_lfinite_lprefix_conv_eq)
next
  fix xs assume "xs \<le> l" "lfinite xs" "\<forall>ys\<ge>xs. ys \<le> l \<longrightarrow> P ys"
  then show "\<exists>S. open S \<and> l \<in> S \<and> Ball S P"
    by (intro exI[of _ "{xs ..} \<inter> {.. l}"] conjI open_Int open_Ici open_ccpo_Iic) auto
qed

lemma nhds_lfinite: "lfinite l \<Longrightarrow> nhds l = principal {l}"
  unfolding filter_eq_iff eventually_principal eventually_nhds_llist
  by (auto simp del: le_llist_conv_lprefix)

lemma eventually_at'_llist:
  "eventually P (at' l) \<longleftrightarrow> (\<exists>xs\<le>l. lfinite xs \<and> (\<forall>ys\<ge>xs. lfinite ys \<longrightarrow> ys \<le> l \<longrightarrow> P ys))"
proof cases
  assume "lfinite l"
  then show ?thesis
    by (auto simp add: eventually_filtermap at'_def open_singleton_iff_lfinite
                       eventually_principal lfinite_eq_range_llist_of)
next
  assume "\<not> lfinite l"
  then show ?thesis
    by (auto simp: eventually_filtermap at'_def open_singleton_iff_lfinite
                   eventually_at_filter eventually_nhds_llist)
       (metis not_lfinite_lprefix_conv_eq)
qed

lemma eventually_at'_llistI: "(\<And>xs. lfinite xs \<Longrightarrow> xs \<le> l \<Longrightarrow> P xs) \<Longrightarrow> eventually P (at' l)"
  by (auto simp: eventually_at'_llist)

lemma Lim_at'_lfinite: "lfinite xs \<Longrightarrow> Lim (at' xs) f = f xs"
  by (rule tendsto_Lim[OF at'_bot]) (auto simp add: at'_def topological_tendstoI eventually_principal)

lemma filterlim_at'_list:
  "(f ---> y) (at' (x::'a llist)) \<Longrightarrow> f -- x --> y"
  unfolding at'_def by (auto split: split_if_asm simp: open_singleton_iff_lfinite)

lemma tendsto_mcont_llist': "mcont lSup lprefix lSup lprefix f \<Longrightarrow> (f ---> f x) (at' (x :: 'a llist))"
by(auto simp add: at'_def nhds_lfinite[symmetric] open_singleton_iff_lfinite tendsto_at_iff_tendsto_nhds[symmetric] intro: tendsto_mcont_llist)

lemma tendsto_closed:
  assumes eq: "closed {x. P x}"
  assumes ev: "\<And>ys. lfinite ys \<Longrightarrow> ys \<le> x \<Longrightarrow> P ys"
  shows "P x"
proof -
  have "x \<in> {x. P x}"
  proof (rule Lim_in_closed_set)
    show "eventually (\<lambda>x. x \<in> {x. P x}) (at' x)"
      unfolding eq using ev
      by (force intro!: eventually_at'_llistI)
  qed (rule assms tendsto_id_at' at'_bot)+
  then show ?thesis
    by simp
qed

lemma tendsto_Sup_at':
  fixes f :: "'a llist \<Rightarrow> 'b::ccpo_topology"
  assumes f: "\<And>x y. x \<le> y \<Longrightarrow> lfinite x \<Longrightarrow> lfinite y \<Longrightarrow> f x \<le> f y"
  shows "(f ---> (Sup (f`{xs. lfinite xs \<and> xs \<le> l}))) (at' l)"
proof (rule topological_tendstoI)
  let ?F = "{xs. lfinite xs \<and> xs \<le> l}"

  have ch_F: "chain (f`?F)" "f`?F \<noteq> {}"
    by (rule chain_imageI[OF chain_subset, OF lprefixes_chain]) (auto simp: f)

  fix A assume A: "open A" "Sup (f`?F) \<in> A" then show "eventually (\<lambda>x. f x \<in> A) (at' l)"
    using open_ccpoD[OF _ ch_F, OF A] by (auto simp: eventually_at'_llist f simp del: le_llist_conv_lprefix)
qed

lemma tendsto_Lim_at':
  fixes f :: "'a llist \<Rightarrow> 'b::ccpo_topology"
  assumes f: "\<And>l. f l = Lim (at' l) f'"
  assumes mono: "\<And>x y. x \<le> y \<Longrightarrow> lfinite x \<Longrightarrow> lfinite y \<Longrightarrow> f' x \<le> f' y"
  shows "(f ---> f l) (at' l)"
  unfolding f[abs_def]
  apply (subst filterlim_cong[OF refl refl eventually_elim1[OF eventually_lfinite Lim_at'_lfinite]])
  apply assumption
  apply (rule tendsto_LimI[OF tendsto_Sup_at'[OF mono]])
  apply assumption+
  done

lemma isCont_lmap[THEN isCont_o2[rotated]]: "isCont (lmap f) l"
  by (simp add: isCont_def tendsto_lmap tendsto_ident_at)

lemma isCont_lappend[THEN isCont_o2[rotated]]: "isCont (lappend xs) ys"
  by (simp add: isCont_def tendsto_lappend2 tendsto_ident_at)

lemma isCont_lset[THEN isCont_o2[rotated]]: "isCont lset xs"
  by(simp add: isCont_def tendsto_lset tendsto_ident_at)

subsection {* Define @{term lfilter} as continuous extension *}

definition "lfilter' P l = Lim (at' l) (\<lambda>xs. llist_of (filter P (list_of xs)))"

lemma tendsto_lfilter: "(lfilter' P ---> lfilter' P xs) (at' xs)"
  by (rule tendsto_Lim_at'[OF lfilter'_def]) (auto simp add: lfinite_eq_range_llist_of less_eq_list_def prefixeq_def)

lemma isCont_lfilter[THEN isCont_o2[rotated]]: "isCont (lfilter' P) l"
  by (simp add: isCont_def filterlim_at'_list tendsto_lfilter)

lemma lfilter'_lfinite[simp]: "lfinite xs \<Longrightarrow> lfilter' P xs = llist_of (filter P (list_of xs))"
  by (simp add: lfilter'_def Lim_at'_lfinite)

lemma lfilter'_LCons [simp]: "lfilter' P (LCons a xs) = (if P a then LCons a (lfilter' P xs) else lfilter' P xs)"
  by (rule tendsto_closed[where x=xs, OF closed_Collect_eq])
     (auto intro!: isCont_lfilter isCont_LCons isCont_ident isCont_If)

lemma ldistinct_lfilter': "ldistinct l \<Longrightarrow> ldistinct (lfilter' P l)"
  by (rule tendsto_closed[OF closed_ldistinct', OF isCont_lfilter])
     (auto intro!: distinct_filter dest: ldistinct_lprefix simp: lfinite_eq_range_llist_of)

lemma lfilter'_lmap: "lfilter' P (lmap f xs) = lmap f (lfilter' (P \<circ> f) xs)"
  by (rule tendsto_closed[where x=xs, OF closed_Collect_eq])
     (auto simp add: filter_map comp_def intro!: isCont_lmap isCont_lfilter)

lemma lfilter'_lfilter': "lfilter' P (lfilter' Q xs) = lfilter' (\<lambda>x. Q x \<and> P x) xs"
  by (rule tendsto_closed[where x=xs, OF closed_Collect_eq]) (auto intro!: isCont_lfilter)

lemma lset_lfilter': "lset (lfilter' P xs) = lset xs \<inter> {x. P x}"
  by(rule tendsto_closed[OF closed_Collect_eq])
    (auto 4 3 intro: isCont_lset isCont_lfilter isCont_inf2)

lemma lfilter'_eq_LNil_iff: "lfilter' P xs = LNil \<longleftrightarrow> (\<forall>x\<in>lset xs. \<not> P x)"
  using lset_lfilter'[of P xs] by auto

lemma lfilter'_eq_lfilter: "lfilter' P xs = lfilter P xs"
using isCont_lfilter
proof(rule tendsto_closed[where x=xs, OF closed_Collect_eq])
  fix ys :: "'a llist"
  assume "lfinite ys"
  thus "lfilter' P ys = lfilter P ys" by induction simp_all
qed(simp_all add: isCont_def tendsto_mcont_llist mcont_lfilter)

subsection {* Define @{term lconcat} as continuous extension*}

definition "lconcat' xs = Lim (at' xs) (\<lambda>xs. foldr lappend (list_of xs) LNil)"

lemma tendsto_lconcat': "(lconcat' ---> lconcat' xss) (at' xss)"
  apply (rule tendsto_Lim_at'[OF lconcat'_def])
  apply (auto simp add: lfinite_eq_range_llist_of less_eq_list_def prefixeq_def)
  apply (induct_tac xa)
  apply simp_all
  done

lemma isCont_lconcat'[THEN isCont_o2[rotated]]: "isCont lconcat' l"
  by (simp add: isCont_def filterlim_at'_list tendsto_lconcat')

lemma lconcat'_lfinite[simp]: "lfinite xs \<Longrightarrow> lconcat' xs = foldr lappend (list_of xs) LNil"
  by (simp add: lconcat'_def Lim_at'_lfinite)

lemma lconcat'_LNil: "lconcat' LNil = LNil"
  by simp

lemma lconcat'_LCons [simp]: "lconcat' (LCons l xs) = lappend l (lconcat' xs)"
  by (rule tendsto_closed[where x=xs, OF closed_Collect_eq])
     (auto intro!: isCont_lconcat' isCont_lappend isCont_LCons isCont_ident)

lemma lmap_lconcat: "lmap f (lconcat' xss) = lconcat' (lmap (lmap f) (xss::'a llist llist))"
proof (rule tendsto_closed[where x=xss, OF closed_Collect_eq])
  fix xs :: "'a llist llist" assume "lfinite xs" then show "lmap f (lconcat' xs) = lconcat' (lmap (lmap f) xs)"
    by (induct xs rule: lfinite.induct) (auto simp: lmap_lappend_distrib)
qed (intro isCont_lconcat' isCont_lappend isCont_LCons isCont_ident isCont_lmap)+

lemmas tendsto_Sup[THEN tendsto_compose, tendsto_intros] =
  mcont_SUP[OF mcont_id' mcont_const, THEN tendsto_mcont]

lemma
  assumes fin: "\<forall>xs\<in>lset xss. lfinite xs"
  shows "lset (lconcat' xss) = (\<Union>xs\<in>lset xss. lset xs)" (is "?lhs = ?rhs")
proof(rule tendsto_unique_eventually[OF at'_bot])
  show "eventually (\<lambda>x. lset (lconcat' x) = (\<Union>y\<in>lset x. lset y)) (at' xss)"
  proof(rule eventually_at'_llistI)
    fix xss'
    assume "lfinite xss'" "xss' \<le> xss"
    hence "\<forall>xs\<in>lset xss'. lfinite xs" using fin by (auto dest!: lprefix_lsetD)
    with `lfinite xss'` show "lset (lconcat' xss') = (\<Union>xs\<in>lset xss'. lset xs)"
      by (induct xss') auto
  qed
qed (rule tendsto_intros tendsto_lconcat' tendsto_id_at')+

subsection {* Define @{term ldropWhile} as continuous extension *}

definition "ldropWhile' P xs = Lim (at' xs) (\<lambda>xs. llist_of (dropWhile P (list_of xs)))"

lemma tendsto_ldropWhile':
  "(ldropWhile' P ---> ldropWhile' P xs) (at' xs)"
  by (rule tendsto_Lim_at'[OF ldropWhile'_def])
     (auto simp add: lfinite_eq_range_llist_of less_eq_list_def prefixeq_def dropWhile_append dropWhile_False)

lemma isCont_ldropWhile'[THEN isCont_o2[rotated]]: "isCont (ldropWhile' P) l"
  by (simp add: isCont_def filterlim_at'_list tendsto_ldropWhile')

lemma ldropWhile'_lfinite[simp]: "lfinite xs \<Longrightarrow> ldropWhile' P xs = llist_of (dropWhile P (list_of xs))"
  by (simp add: ldropWhile'_def Lim_at'_lfinite)

lemma ldropWhile'_LNil: "ldropWhile' P LNil = LNil"
  by simp

lemma ldropWhile'_LCons [simp]: "ldropWhile' P (LCons l xs) = (if P l then ldropWhile' P xs else LCons l xs)"
  by (rule tendsto_closed[where x=xs, OF closed_Collect_eq])
     (auto intro!: isCont_ldropWhile' isCont_If isCont_LCons isCont_ident)

lemma "ldropWhile' P (lmap f xs) = lmap f (ldropWhile' (P \<circ> f) xs)"
  by (rule tendsto_closed[where x=xs, OF closed_Collect_eq])
     (auto simp add: dropWhile_map comp_def intro!: isCont_lmap isCont_ldropWhile')

lemma ldropWhile'_LNil_I[simp]: "\<forall>x \<in> lset xs. P x \<Longrightarrow> ldropWhile' P xs = LNil"
  by (rule tendsto_closed[where x=xs, OF closed_Collect_eq])
     (auto simp add: llist_of_eq_LNil_conv intro!: isCont_lmap isCont_ldropWhile' dest!: lprefix_lsetD)

lemma lnull_ldropWhile': "lnull (ldropWhile' P xs) \<longleftrightarrow> (\<forall>x \<in> lset xs. P x)" (is "?lhs \<longleftrightarrow> _")
proof (intro iffI ballI)
  fix x assume "x \<in> lset xs" ?lhs then show "P x" by induct (simp_all split: split_if_asm)
qed simp

lemma lhd_lfilter': "lhd (lfilter' P xs) = lhd (ldropWhile' (Not \<circ> P) xs)"
proof cases
  assume "\<exists>x\<in>lset xs. P x"
  then obtain x where "x \<in> lset xs" and "P x" by blast
  from `x \<in> lset xs` show ?thesis by induct (simp_all add: `P x`)
qed simp

subsection {* Define @{text ldrop} as continuous extension *}

primrec edrop where
  "edrop n [] = []"
| "edrop n (x # xs) = (case n of eSuc n \<Rightarrow> edrop n xs | 0 \<Rightarrow> x # xs)"

lemma mono_edrop: "edrop n xs \<le> edrop n (xs @ ys)"
  by (induct xs arbitrary: n) (auto split: enat_cosplit)

lemma edrop_mono: "xs \<le> ys \<Longrightarrow> edrop n xs \<le> edrop n ys"
  using mono_edrop[of n xs] by (auto simp add: less_eq_list_def prefixeq_def)

definition "ldrop' n xs = Lim (at' xs) (llist_of \<circ> edrop n \<circ> list_of)"

lemma ldrop'_lfinite[simp]: "lfinite xs \<Longrightarrow> ldrop' n xs = llist_of (edrop n (list_of xs))"
  by (simp add: ldrop'_def Lim_at'_lfinite)

lemma tendsto_ldrop': "(ldrop' n ---> ldrop' n l) (at' l)"
  by (rule tendsto_Lim_at'[OF ldrop'_def]) (auto simp add: lfinite_eq_range_llist_of intro!: edrop_mono)

lemma isCont_ldrop'[THEN isCont_o2[rotated]]: "isCont (ldrop' n) l"
  by (simp add: isCont_def filterlim_at'_list tendsto_ldrop')

lemma "ldrop' n LNil = LNil"
  by simp

lemma "ldrop' n (LCons x xs) = (case n of 0 \<Rightarrow> LCons x xs | eSuc n \<Rightarrow> ldrop' n xs)"
  by (rule tendsto_closed[where x=xs, OF closed_Collect_eq])
     (auto intro!: isCont_ldrop' isCont_enat_case isCont_LCons isCont_ident split: enat_cosplit)

primrec up :: "'a :: order \<Rightarrow> 'a list \<Rightarrow> 'a list" where
  "up a [] = []"
| "up a (x # xs) = (if a < x then x # up x xs else up a xs)"

lemma set_upD: "x \<in> set (up y xs) \<Longrightarrow> x \<in> set xs \<and> y < x"
  by (induct xs arbitrary: y) (auto split: split_if_asm intro: less_trans)

lemma prefixeq_up: "prefixeq (up a xs) (up a (xs @  ys))"
  by (induction xs arbitrary: a) auto

lemma mono_up: "xs \<le> ys \<Longrightarrow> up a xs \<le> up a ys"
  unfolding less_eq_list_def by (subst (asm) prefixeq_def) (auto intro!: prefixeq_up)

lemma sorted_up: "sorted (up a xs)"
  by (induction xs arbitrary: a) (auto dest: set_upD intro: less_imp_le sorted.Cons)

subsection {* Define more functions on lazy lists as continuous extensions *}

definition "lup a xs = Lim (at' xs) (\<lambda>xs. llist_of (up a (list_of xs)))"

lemma tendsto_lup: "(lup a ---> lup a xs) (at' xs)"
  by (rule tendsto_Lim_at'[OF lup_def]) (auto simp: lfinite_eq_range_llist_of mono_up)

lemma isCont_lup[THEN isCont_o2[rotated]]: "isCont (lup a) l"
  by (simp add: isCont_def filterlim_at'_list tendsto_lup)

lemma lup_lfinite[simp]: "lfinite xs \<Longrightarrow> lup a xs = llist_of (up a (list_of xs))"
  by (simp add: lup_def Lim_at'_lfinite)

lemma lup_LNil: "lup a LNil = LNil"
  by simp

lemma lup_LCons [simp]: "lup a (LCons x xs) = (if a < x then LCons x (lup x xs) else lup a xs)"
  by (rule tendsto_closed[where x=xs, OF closed_Collect_eq])
     (auto intro!: isCont_lup isCont_If isCont_LCons isCont_ident)

lemma lset_lup: "lset (lup x xs) \<subseteq> lset xs \<inter> {y. x < y}"
  by (rule tendsto_le_ccpo[where g="\<lambda>xs. lset (lup x xs)" and f="\<lambda>xs. lset xs \<inter> {y. x < y}" and F="at' xs"])
     (auto dest!: lprefix_lsetD set_upD intro!:  tendsto_intros at'_bot tendsto_lup eventually_at'_llistI)

lemma lsorted_lup: "lsorted (lup (a::'a::linorder) l)"
  by (rule tendsto_closed[OF closed_lsorted', OF isCont_lup])
     (auto intro!: sorted_up simp: lprefix_conv_lappend)

partial_function (llist) lup' :: "'a :: ord \<Rightarrow> 'a llist \<Rightarrow> 'a llist" where
  "lup' a xs = (case xs of LNil \<Rightarrow> LNil | LCons x xs \<Rightarrow> if a < x then LCons x (lup' x xs) else lup' a xs)"

declare lup'.mono[cont_intro]

lemma monotone_lup': "monotone (rel_prod op = lprefix) lprefix (\<lambda>(a, xs). lup' a xs)"
by(rule llist.fixp_preserves_mono2[OF lup'.mono lup'_def]) simp

lemma mono2mono_lup'2[THEN llist.mono2mono, simp, cont_intro]:
  shows monotone_lup'2: "monotone lprefix lprefix (lup' a)"
using monotone_lup' by auto

lemma mcont_lup': "mcont (prod_lub the_Sup lSup) (rel_prod op = lprefix) lSup lprefix (\<lambda>(a, xs). lup' a xs)"
by(rule llist.fixp_preserves_mcont2[OF lup'.mono lup'_def]) simp

lemma mcont2mcont_lup'2[THEN llist.mcont2mcont, simp, cont_intro]:
  shows mcont_lup'2: "mcont lSup lprefix lSup lprefix (lup' a)"
using mcont_lup' by auto

simps_of_case lup'_simps [simp]: lup'.simps

lemma lset_lup'_subset:
  fixes x :: "_ :: preorder"
  shows "lset (lup' x xs) \<subseteq> lset xs \<inter> {y. x < y}"
by(induction xs arbitrary: x)(auto intro: less_trans)

lemma in_lset_lup'D:
  fixes x :: "_ :: preorder"
  assumes "y \<in> lset (lup' x xs)"
  shows "y \<in> lset xs \<and> x < y"
using lset_lup'_subset[of x xs] assms by auto

lemma lsorted_lup':
  fixes x :: "_ :: preorder"
  shows "lsorted (lup' x xs)"
by(induction xs arbitrary: x)(auto simp add: lsorted_LCons dest: in_lset_lup'D intro: less_imp_le)

lemma ldistinct_lup':
  fixes x :: "_ :: preorder"
  shows "ldistinct (lup' x xs)"
by(induction xs arbitrary: x)(auto dest: in_lset_lup'D)

context fixes f :: "'a \<Rightarrow> 'a" begin

partial_function (llist) iterate :: "'a \<Rightarrow> 'a llist"
where "iterate x = LCons x (iterate (f x))"

lemma lmap_iterate: "lmap f (iterate x) = iterate (f x)"
by(induction arbitrary: x rule: iterate.fixp_induct) simp_all

end

fun extup extdown  :: "int \<Rightarrow> int list \<Rightarrow> int list" where
  "extup i [] = []"
| "extup i (x # xs) = (if i \<le> x then extup x xs else i # extdown x xs)"
| "extdown i [] = []"
| "extdown i (x # xs) = (if i \<ge> x then extdown x xs else i # extup x xs)"

lemma prefixeq_ext:
  "prefixeq (extup a xs) (extup a (xs @  ys))"
  "prefixeq (extdown a xs) (extdown a (xs @  ys))"
  by (induction xs arbitrary: a) auto

lemma mono_ext: assumes "xs \<le> ys" shows "extup a xs \<le> extup a ys" "extdown a xs \<le> extdown a ys"
  using assms[unfolded less_eq_list_def prefixeq_def] by (auto simp: less_eq_list_def prefixeq_ext)

lemma set_ext: "set (extup a xs) \<subseteq> {a} \<union> set xs" "set (extdown a xs) \<subseteq> {a} \<union> set xs"
  using assms by (induction xs arbitrary: a) auto

definition "lextup i l = Lim (at' l) (llist_of \<circ> extup i \<circ> list_of)"
definition "lextdown i l = Lim (at' l) (llist_of \<circ> extdown i \<circ> list_of)"

lemma tendsto_lextup[tendsto_intros]: "(lextup i ---> lextup i xs) (at' xs)"
  by (rule tendsto_Lim_at'[OF lextup_def]) (auto simp: lfinite_eq_range_llist_of mono_ext)

lemma tendsto_lextdown[tendsto_intros]: "(lextdown i ---> lextdown i xs) (at' xs)"
  by (rule tendsto_Lim_at'[OF lextdown_def]) (auto simp: lfinite_eq_range_llist_of mono_ext)

lemma isCont_lextup[THEN isCont_o2[rotated]]: "isCont (lextup a) l"
  by (simp add: isCont_def filterlim_at'_list tendsto_lextup)

lemma isCont_lextdown[THEN isCont_o2[rotated]]: "isCont (lextdown a) l"
  by (simp add: isCont_def filterlim_at'_list tendsto_lextdown)

lemma lextup_lfinite[simp]: "lfinite xs \<Longrightarrow> lextup i xs = llist_of (extup i (list_of xs))"
  by (simp add: lextup_def Lim_at'_lfinite)

lemma lextdown_lfinite[simp]: "lfinite xs \<Longrightarrow> lextdown i xs = llist_of (extdown i (list_of xs))"
  by (simp add: lextdown_def Lim_at'_lfinite)

lemma "lextup i LNil = LNil" "lextdown i LNil = LNil"
  by simp_all

lemma "lextup i (LCons x xs) = (if i \<le> x then lextup x xs else LCons i (lextdown x xs))"
  by (rule tendsto_closed[where x=xs, OF closed_Collect_eq])
     (auto intro!: isCont_lextdown isCont_lextup isCont_If isCont_LCons isCont_ident)

lemma "lextdown i (LCons x xs) = (if x \<le> i then lextdown x xs else LCons i (lextup x xs))"
  by (rule tendsto_closed[where x=xs, OF closed_Collect_eq])
     (auto intro!: isCont_lextdown isCont_lextup isCont_If isCont_LCons isCont_ident)

lemma "lset (lextup a xs) \<subseteq> {a} \<union> lset xs"
  apply (rule tendsto_le_ccpo[where g="\<lambda>xs. lset (lextup a xs)" and f="\<lambda>xs. {a} \<union> lset xs" and F="at' xs"])
  apply (rule tendsto_intros at'_bot tendsto_lup eventually_at'_llistI tendsto_id_at')+
  apply (auto dest!: lprefix_lsetD set_ext[THEN set_mp])
  done

lemma "lset (lextdown a xs) \<subseteq> {a} \<union> lset xs"
  apply (rule tendsto_le_ccpo[where g="\<lambda>xs. lset (lextdown a xs)" and f="\<lambda>xs. {a} \<union> lset xs" and F="at' xs"])
  apply (rule tendsto_intros at'_bot tendsto_lup eventually_at'_llistI tendsto_id_at')+
  apply (auto dest!: lprefix_lsetD set_ext[THEN set_mp])
  done

lemma distinct_ext:
  assumes "distinct xs" "a \<notin> set xs"
  shows "distinct (extup a xs)" "distinct (extdown a xs)"
  using assms set_ext
  apply (induction xs arbitrary: a)
  apply auto
  apply (metis eq_iff insert_iff subset_iff)+
  done

lemma "ldistinct xs \<Longrightarrow> a \<notin> lset xs \<Longrightarrow> ldistinct (lextup a xs)"
  by (rule_tac tendsto_closed[OF closed_ldistinct', OF isCont_lextup])
     (force simp: lfinite_eq_range_llist_of intro!: distinct_ext dest: ldistinct_lprefix dest: lprefix_lsetD)+

definition elistsum :: "ereal llist \<Rightarrow> ereal" where
  "elistsum xs = Lim (at' xs) (listsum \<circ> list_of)"

lemma elistsum_lfinite[simp]: "lfinite xs \<Longrightarrow> elistsum xs = listsum (list_of xs)"
  by (simp add: elistsum_def Lim_at'_lfinite)

lemma elistsum_LNil: "elistsum LNil = 0"
  by simp

context
  fixes xs :: "ereal llist"
  assumes xs: "\<And>x. x \<in> lset xs \<Longrightarrow> 0 \<le> x"
begin

lemma elistsum_tendsto_SUP:
  "((listsum\<circ>list_of) ---> (SUP ys : {ys. lfinite ys \<and> ys \<le> xs}. elistsum ys)) (at' xs)"
    (is "(_ ---> ?y) _")
proof (rule order_tendstoI)
  fix a assume "a < ?y"
  then obtain ys where "llist_of ys \<le> xs" "a < listsum ys"
    by (auto simp: less_SUP_iff lfinite_eq_range_llist_of)
  moreover
  { fix zs assume "ys \<le> zs" "llist_of zs \<le> xs"
    then obtain ys' where zs: "zs = ys @ ys'"
      by (auto simp: prefixeq_def less_eq_list_def)
    with `llist_of zs \<le> xs` have nonneg: "0 \<le> listsum ys'"
      using xs by (auto simp: lprefix_conv_lappend listsum_setsum_nth setsum_nonneg)
    note `a < listsum ys`
    also have "listsum ys \<le> listsum zs"
      using zs ereal_add_mono[OF order_refl nonneg] by auto
    finally have "a < listsum zs" . }
  ultimately show "eventually (\<lambda>x. a < (listsum\<circ>list_of) x) (at' xs)"
    unfolding eventually_at'_llist by (auto simp: lfinite_eq_range_llist_of)
next
  fix a assume "?y < a" then show "eventually (\<lambda>x. (listsum\<circ>list_of) x < a) (at' xs)"
    by (auto intro!: eventually_at'_llistI dest: SUP_lessD)
qed

lemma tendsto_elistsum: "(elistsum ---> elistsum xs) (at' xs)"
  apply (rule filterlim_cong[where g="listsum \<circ> list_of", THEN iffD2, OF refl refl])
  apply (rule eventually_elim1[OF eventually_lfinite])
  apply simp
  unfolding elistsum_def
  apply (rule tendsto_LimI)
  apply (rule elistsum_tendsto_SUP)
  done

lemma isCont_elistsum: "isCont elistsum xs"
  by (simp add: isCont_def filterlim_at'_list tendsto_elistsum)

end

lemma elistsum_nonneg:
  "(\<And>x. x \<in> lset xs \<Longrightarrow> 0 \<le> x) \<Longrightarrow> 0 \<le> elistsum xs"
  by (rule tendsto_le[OF at'_bot tendsto_elistsum tendsto_const])
     (auto intro!: eventually_at'_llistI
           simp: lprefix_conv_lappend listsum_setsum_nth setsum_nonneg lfinite_eq_range_llist_of)

lemma elistsum_LCons:
  assumes x: "0 \<le> x" "\<And>x. x \<in> lset xs \<Longrightarrow> 0 \<le> x" shows "elistsum (LCons x xs) = x + elistsum xs"
proof (rule tendsto_unique_eventually[OF at'_bot])
  from x show "((\<lambda>xs. elistsum (LCons x xs)) ---> elistsum (LCons x xs)) (at' xs)"
    by (intro tendsto_compose[OF filterlim_at'_list[OF tendsto_elistsum] tendsto_LCons]) auto
  show "eventually (\<lambda>xa. elistsum (LCons x xa) = x + elistsum xa) (at' xs)"
    using eventually_lfinite by eventually_elim simp
  from x show "((\<lambda>xa. x + elistsum xa) ---> x + elistsum xs) (at' xs)"
    by (intro elistsum_nonneg tendsto_elistsum tendsto_add_ereal) auto
qed

lemma elistsum_lfilter':
  assumes nn: "\<And>x. x \<in> lset xs \<Longrightarrow> 0 \<le> x" shows "elistsum (lfilter' (\<lambda>x. x \<noteq> 0) xs) = elistsum xs"
proof (rule tendsto_unique_eventually[OF at'_bot])
  show "(elistsum ---> elistsum xs) (at' xs)"
    using nn by (rule tendsto_elistsum)
  from nn show "((\<lambda>xs. elistsum (lfilter' (\<lambda>x. x \<noteq> 0) xs)) ---> elistsum (lfilter' (\<lambda>x. x \<noteq> 0) xs)) (at' xs)"
    by (intro tendsto_compose[OF filterlim_at'_list[OF tendsto_elistsum] tendsto_lfilter]) (auto simp: lset_lfilter')
  show "eventually (\<lambda>xs. elistsum (lfilter' (\<lambda>x. x \<noteq> 0) xs) = elistsum xs) (at' xs)"
    using eventually_lfinite
    by eventually_elim (simp add: listsum_map_filter[where f = "\<lambda>x. x" and P="\<lambda>x. x \<noteq> 0", simplified])
qed

function f:: "nat list \<Rightarrow> nat list" where
  "f [] = []"
| "f (x#xs) = (x * 2) # f (f xs)"
  by auto pat_completeness

termination f
proof (relation "inv_image natLess length")
  fix x xs assume "f_dom xs" then show "(f xs, x # xs) \<in> inv_image natLess length"
    by induct (auto simp: f.psimps natLess_def)
qed (auto intro: wf_less simp add: natLess_def)

lemma length_f[simp]: "length (f xs) = length xs"
  by (induct rule: f.induct) simp_all

lemma f_mono': "\<exists>ys'. f (xs @ ys) = f xs @ ys'"
proof (induct "length xs" arbitrary: xs ys rule: less_induct)
  case less then show ?case
    apply (cases xs)
    apply auto
    apply (metis length_f lessI)
    done
qed

lemma f_mono: "xs \<le> ys \<Longrightarrow> f xs \<le> f ys"
  by (auto simp: less_eq_list_def prefixeq_def f_mono')

definition "f' l = Lim (at' l) (\<lambda>l. llist_of (f (list_of l)))"

lemma f'_lfinite[simp]: "lfinite xs \<Longrightarrow> f' xs = llist_of (f (list_of xs))"
  by (simp add: f'_def Lim_at'_lfinite)

lemma tendsto_f': "(f' ---> f' l) (at' l)"
  by (rule tendsto_Lim_at'[OF f'_def]) (auto simp add: lfinite_eq_range_llist_of intro!: f_mono)

lemma isCont_f'[THEN isCont_o2[rotated]]: "isCont f' l"
  by (simp add: isCont_def filterlim_at'_list tendsto_f')

lemma "f' LNil = LNil"
  by simp

lemma "f' (LCons x xs) = LCons (x * 2) (f' (f' xs))"
  by (rule tendsto_closed[where x=xs, OF closed_Collect_eq])
     (auto intro!: isCont_f' isCont_LCons isCont_ident)

end


(*  Title:      HOL/Algebra/AbelCoset.thy
    Author:     Stephan Hohe, TU Muenchen
*)

theory AbelCoset
imports Coset Ring
begin

subsection \<open>More Lifting from Groups to Abelian Groups\<close>

subsubsection \<open>Definitions\<close>

text \<open>Hiding \<open><+>\<close> from @{theory HOL.Sum_Type} until I come
  up with better syntax here\<close>

no_notation Sum_Type.Plus (infixr "<+>" 65)

definition
  a_r_coset    :: "[_, 'a set, 'a] \<Rightarrow> 'a set"    (infixl "+>\<index>" 60)
  where "a_r_coset G = r_coset (add_monoid G)"

definition
  a_l_coset    :: "[_, 'a, 'a set] \<Rightarrow> 'a set"    (infixl "<+\<index>" 60)
  where "a_l_coset G = l_coset (add_monoid G)"

definition
  A_RCOSETS  :: "[_, 'a set] \<Rightarrow> ('a set)set"   ("a'_rcosets\<index> _" [81] 80)
  where "A_RCOSETS G H = RCOSETS (add_monoid G) H"

definition
  set_add  :: "[_, 'a set ,'a set] \<Rightarrow> 'a set" (infixl "<+>\<index>" 60)
  where "set_add G = set_mult (add_monoid G)"

definition
  A_SET_INV :: "[_,'a set] \<Rightarrow> 'a set"  ("a'_set'_inv\<index> _" [81] 80)
  where "A_SET_INV G H = SET_INV (add_monoid G) H"

definition
  a_r_congruent :: "[('a,'b)ring_scheme, 'a set] \<Rightarrow> ('a*'a)set"  ("racong\<index>")
  where "a_r_congruent G = r_congruent (add_monoid G)"

definition
  A_FactGroup :: "[('a,'b) ring_scheme, 'a set] \<Rightarrow> ('a set) monoid" (infixl "A'_Mod" 65)
    \<comment> \<open>Actually defined for groups rather than monoids\<close>
  where "A_FactGroup G H = FactGroup (add_monoid G) H"

definition
  a_kernel :: "('a, 'm) ring_scheme \<Rightarrow> ('b, 'n) ring_scheme \<Rightarrow>  ('a \<Rightarrow> 'b) \<Rightarrow> 'a set"
    \<comment> \<open>the kernel of a homomorphism (additive)\<close>
  where "a_kernel G H h = kernel (add_monoid G) (add_monoid H) h"

locale abelian_group_hom = G?: abelian_group G + H?: abelian_group H
    for G (structure) and H (structure) +
  fixes h
  assumes a_group_hom: "group_hom (add_monoid G) (add_monoid H) h"

lemmas a_r_coset_defs =
  a_r_coset_def r_coset_def

lemma a_r_coset_def':
  fixes G (structure)
  shows "H +> a \<equiv> \<Union>h\<in>H. {h \<oplus> a}"
  unfolding a_r_coset_defs by simp

lemmas a_l_coset_defs =
  a_l_coset_def l_coset_def

lemma a_l_coset_def':
  fixes G (structure)
  shows "a <+ H \<equiv> \<Union>h\<in>H. {a \<oplus> h}"
  unfolding a_l_coset_defs by simp

lemmas A_RCOSETS_defs =
  A_RCOSETS_def RCOSETS_def

lemma A_RCOSETS_def':
  fixes G (structure)
  shows "a_rcosets H \<equiv> \<Union>a\<in>carrier G. {H +> a}"
  unfolding A_RCOSETS_defs by (fold a_r_coset_def, simp)

lemmas set_add_defs =
  set_add_def set_mult_def

lemma set_add_def':
  fixes G (structure)
  shows "H <+> K \<equiv> \<Union>h\<in>H. \<Union>k\<in>K. {h \<oplus> k}"
  unfolding set_add_defs by simp

lemmas A_SET_INV_defs =
  A_SET_INV_def SET_INV_def

lemma A_SET_INV_def':
  fixes G (structure)
  shows "a_set_inv H \<equiv> \<Union>h\<in>H. {\<ominus> h}"
  unfolding A_SET_INV_defs by (fold a_inv_def)

subsubsection \<open>Cosets\<close>

sublocale abelian_group <
        add: group "(add_monoid G)"
  rewrites "carrier (add_monoid G) =   carrier G"
       and "   mult (add_monoid G) =       add G"
       and "    one (add_monoid G) =      zero G"
       and "  m_inv (add_monoid G) =     a_inv G"
       and "finprod (add_monoid G) =    finsum G"
       and "r_coset (add_monoid G) = a_r_coset G"
       and "l_coset (add_monoid G) = a_l_coset G"
       and "(\<lambda>a k. pow (add_monoid G) a k) = (\<lambda>a k. add_pow G k a)"
  by (rule a_group)
     (auto simp: m_inv_def a_inv_def finsum_def a_r_coset_def a_l_coset_def add_pow_def)

context abelian_group
begin

thm add.coset_mult_assoc
lemmas a_repr_independence' = add.repr_independence

(*
lemmas a_coset_add_assoc = add.coset_mult_assoc
lemmas a_coset_add_zero [simp] = add.coset_mult_one
lemmas a_coset_add_inv1 = add.coset_mult_inv1
lemmas a_coset_add_inv2 = add.coset_mult_inv2
lemmas a_coset_join1 = add.coset_join1
lemmas a_coset_join2 = add.coset_join2
lemmas a_solve_equation = add.solve_equation
lemmas a_repr_independence = add.repr_independence
lemmas a_rcosI = add.rcosI
lemmas a_rcosetsI = add.rcosetsI
*)

end

lemma (in abelian_group) a_coset_add_assoc:
     "[| M \<subseteq> carrier G; g \<in> carrier G; h \<in> carrier G |]
      ==> (M +> g) +> h = M +> (g \<oplus> h)"
by (rule group.coset_mult_assoc [OF a_group,
    folded a_r_coset_def, simplified monoid_record_simps])

thm abelian_group.a_coset_add_assoc

lemma (in abelian_group) a_coset_add_zero [simp]:
  "M \<subseteq> carrier G ==> M +> \<zero> = M"
by (rule group.coset_mult_one [OF a_group,
    folded a_r_coset_def, simplified monoid_record_simps])

lemma (in abelian_group) a_coset_add_inv1:
     "[| M +> (x \<oplus> (\<ominus> y)) = M;  x \<in> carrier G ; y \<in> carrier G;
         M \<subseteq> carrier G |] ==> M +> x = M +> y"
by (rule group.coset_mult_inv1 [OF a_group,
    folded a_r_coset_def a_inv_def, simplified monoid_record_simps])

lemma (in abelian_group) a_coset_add_inv2:
     "[| M +> x = M +> y;  x \<in> carrier G;  y \<in> carrier G;  M \<subseteq> carrier G |]
      ==> M +> (x \<oplus> (\<ominus> y)) = M"
by (rule group.coset_mult_inv2 [OF a_group,
    folded a_r_coset_def a_inv_def, simplified monoid_record_simps])

lemma (in abelian_group) a_coset_join1:
     "[| H +> x = H;  x \<in> carrier G;  subgroup H (add_monoid G) |] ==> x \<in> H"
by (rule group.coset_join1 [OF a_group,
    folded a_r_coset_def, simplified monoid_record_simps])

lemma (in abelian_group) a_solve_equation:
    "\<lbrakk>subgroup H (add_monoid G); x \<in> H; y \<in> H\<rbrakk> \<Longrightarrow> \<exists>h\<in>H. y = h \<oplus> x"
by (rule group.solve_equation [OF a_group,
    folded a_r_coset_def, simplified monoid_record_simps])

lemma (in abelian_group) a_repr_independence:
  "\<lbrakk> y \<in> H +> x; x \<in> carrier G; subgroup H (add_monoid G) \<rbrakk> \<Longrightarrow>
     H +> x = H +> y"
  using a_repr_independence' by (simp add: a_r_coset_def)

lemma (in abelian_group) a_coset_join2:
     "\<lbrakk>x \<in> carrier G;  subgroup H (add_monoid G); x\<in>H\<rbrakk> \<Longrightarrow> H +> x = H"
by (rule group.coset_join2 [OF a_group,
    folded a_r_coset_def, simplified monoid_record_simps])

lemma (in abelian_monoid) a_r_coset_subset_G:
     "[| H \<subseteq> carrier G; x \<in> carrier G |] ==> H +> x \<subseteq> carrier G"
by (rule monoid.r_coset_subset_G [OF a_monoid,
    folded a_r_coset_def, simplified monoid_record_simps])

lemma (in abelian_group) a_rcosI:
     "[| h \<in> H; H \<subseteq> carrier G; x \<in> carrier G|] ==> h \<oplus> x \<in> H +> x"
by (rule group.rcosI [OF a_group,
    folded a_r_coset_def, simplified monoid_record_simps])

lemma (in abelian_group) a_rcosetsI:
     "\<lbrakk>H \<subseteq> carrier G; x \<in> carrier G\<rbrakk> \<Longrightarrow> H +> x \<in> a_rcosets H"
by (rule group.rcosetsI [OF a_group,
    folded a_r_coset_def A_RCOSETS_def, simplified monoid_record_simps])

text\<open>Really needed?\<close>
lemma (in abelian_group) a_transpose_inv:
     "[| x \<oplus> y = z;  x \<in> carrier G;  y \<in> carrier G;  z \<in> carrier G |]
      ==> (\<ominus> x) \<oplus> z = y"
  using r_neg1 by blast

subsubsection \<open>Subgroups\<close>

locale additive_subgroup =
  fixes H and G (structure)
  assumes a_subgroup: "subgroup H (add_monoid G)"

lemma (in additive_subgroup) is_additive_subgroup:
  shows "additive_subgroup H G"
by (rule additive_subgroup_axioms)

lemma additive_subgroupI:
  fixes G (structure)
  assumes a_subgroup: "subgroup H (add_monoid G)"
  shows "additive_subgroup H G"
by (rule additive_subgroup.intro) (rule a_subgroup)

lemma (in additive_subgroup) a_subset:
     "H \<subseteq> carrier G"
by (rule subgroup.subset[OF a_subgroup,
    simplified monoid_record_simps])

lemma (in additive_subgroup) a_closed [intro, simp]:
     "\<lbrakk>x \<in> H; y \<in> H\<rbrakk> \<Longrightarrow> x \<oplus> y \<in> H"
by (rule subgroup.m_closed[OF a_subgroup,
    simplified monoid_record_simps])

lemma (in additive_subgroup) zero_closed [simp]:
     "\<zero> \<in> H"
by (rule subgroup.one_closed[OF a_subgroup,
    simplified monoid_record_simps])

lemma (in additive_subgroup) a_inv_closed [intro,simp]:
     "x \<in> H \<Longrightarrow> \<ominus> x \<in> H"
by (rule subgroup.m_inv_closed[OF a_subgroup,
    folded a_inv_def, simplified monoid_record_simps])

subsubsection \<open>Additive subgroups are normal\<close>

text \<open>Every subgroup of an \<open>abelian_group\<close> is normal\<close>

locale abelian_subgroup = additive_subgroup + abelian_group G +
  assumes a_normal: "normal H (add_monoid G)"

lemma (in abelian_subgroup) is_abelian_subgroup:
  shows "abelian_subgroup H G"
by (rule abelian_subgroup_axioms)

lemma abelian_subgroupI:
  assumes a_normal: "normal H (add_monoid G)"
      and a_comm: "!!x y. [| x \<in> carrier G; y \<in> carrier G |] ==> x \<oplus>\<^bsub>G\<^esub> y = y \<oplus>\<^bsub>G\<^esub> x"
  shows "abelian_subgroup H G"
proof -
  interpret normal "H" "(add_monoid G)"
    by (rule a_normal)

  show "abelian_subgroup H G"
    by standard (simp add: a_comm)
qed

lemma abelian_subgroupI2:
  fixes G (structure)
  assumes a_comm_group: "comm_group (add_monoid G)"
      and a_subgroup: "subgroup H (add_monoid G)"
  shows "abelian_subgroup H G"
proof -
  interpret comm_group "(add_monoid G)"
    by (rule a_comm_group)
  interpret subgroup "H" "(add_monoid G)"
    by (rule a_subgroup)

  show "abelian_subgroup H G"
    apply unfold_locales
  proof (simp add: r_coset_def l_coset_def, clarsimp)
    fix x
    assume xcarr: "x \<in> carrier G"
    from a_subgroup have Hcarr: "H \<subseteq> carrier G"
      unfolding subgroup_def by simp
    from xcarr Hcarr show "(\<Union>h\<in>H. {h \<oplus>\<^bsub>G\<^esub> x}) = (\<Union>h\<in>H. {x \<oplus>\<^bsub>G\<^esub> h})"
      using m_comm [simplified] by fastforce
  qed
qed

lemma abelian_subgroupI3:
  fixes G (structure)
  assumes "additive_subgroup H G"
    and "abelian_group G"
  shows "abelian_subgroup H G"
  using assms abelian_subgroupI2 abelian_group.a_comm_group additive_subgroup_def by blast

lemma (in abelian_subgroup) a_coset_eq:
     "(\<forall>x \<in> carrier G. H +> x = x <+ H)"
by (rule normal.coset_eq[OF a_normal,
    folded a_r_coset_def a_l_coset_def, simplified monoid_record_simps])

lemma (in abelian_subgroup) a_inv_op_closed1:
  shows "\<lbrakk>x \<in> carrier G; h \<in> H\<rbrakk> \<Longrightarrow> (\<ominus> x) \<oplus> h \<oplus> x \<in> H"
by (rule normal.inv_op_closed1 [OF a_normal,
    folded a_inv_def, simplified monoid_record_simps])

lemma (in abelian_subgroup) a_inv_op_closed2:
  shows "\<lbrakk>x \<in> carrier G; h \<in> H\<rbrakk> \<Longrightarrow> x \<oplus> h \<oplus> (\<ominus> x) \<in> H"
by (rule normal.inv_op_closed2 [OF a_normal,
    folded a_inv_def, simplified monoid_record_simps])

text\<open>Alternative characterization of normal subgroups\<close>
lemma (in abelian_group) a_normal_inv_iff:
     "(N \<lhd> (add_monoid G)) =
      (subgroup N (add_monoid G) & (\<forall>x \<in> carrier G. \<forall>h \<in> N. x \<oplus> h \<oplus> (\<ominus> x) \<in> N))"
      (is "_ = ?rhs")
by (rule group.normal_inv_iff [OF a_group,
    folded a_inv_def, simplified monoid_record_simps])

lemma (in abelian_group) a_lcos_m_assoc:
  "\<lbrakk> M \<subseteq> carrier G; g \<in> carrier G; h \<in> carrier G \<rbrakk> \<Longrightarrow> g <+ (h <+ M) = (g \<oplus> h) <+ M"
by (rule group.lcos_m_assoc [OF a_group,
    folded a_l_coset_def, simplified monoid_record_simps])

lemma (in abelian_group) a_lcos_mult_one:
     "M \<subseteq> carrier G ==> \<zero> <+ M = M"
by (rule group.lcos_mult_one [OF a_group,
    folded a_l_coset_def, simplified monoid_record_simps])

lemma (in abelian_group) a_l_coset_subset_G:
  "\<lbrakk> H \<subseteq> carrier G; x \<in> carrier G \<rbrakk> \<Longrightarrow> x <+ H \<subseteq> carrier G"
by (rule group.l_coset_subset_G [OF a_group,
    folded a_l_coset_def, simplified monoid_record_simps])

lemma (in abelian_group) a_l_coset_swap:
     "\<lbrakk>y \<in> x <+ H;  x \<in> carrier G;  subgroup H (add_monoid G)\<rbrakk> \<Longrightarrow> x \<in> y <+ H"
by (rule group.l_coset_swap [OF a_group,
    folded a_l_coset_def, simplified monoid_record_simps])

lemma (in abelian_group) a_l_coset_carrier:
     "[| y \<in> x <+ H;  x \<in> carrier G;  subgroup H (add_monoid G) |] ==> y \<in> carrier G"
by (rule group.l_coset_carrier [OF a_group,
    folded a_l_coset_def, simplified monoid_record_simps])

lemma (in abelian_group) a_l_repr_imp_subset:
  assumes "y \<in> x <+ H" "x \<in> carrier G" "subgroup H (add_monoid G)"
  shows "y <+ H \<subseteq> x <+ H"
  by (metis (full_types) a_l_coset_defs(1) add.l_repr_independence assms set_eq_subset)

lemma (in abelian_group) a_l_repr_independence:
  assumes y: "y \<in> x <+ H" and x: "x \<in> carrier G" and sb: "subgroup H (add_monoid G)"
  shows "x <+ H = y <+ H"
apply (rule group.l_repr_independence [OF a_group,
    folded a_l_coset_def, simplified monoid_record_simps])
apply (rule y)
apply (rule x)
apply (rule sb)
done

lemma (in abelian_group) setadd_subset_G:
     "\<lbrakk>H \<subseteq> carrier G; K \<subseteq> carrier G\<rbrakk> \<Longrightarrow> H <+> K \<subseteq> carrier G"
by (rule group.setmult_subset_G [OF a_group,
    folded set_add_def, simplified monoid_record_simps])

lemma (in abelian_group) subgroup_add_id: "subgroup H (add_monoid G) \<Longrightarrow> H <+> H = H"
by (rule group.subgroup_mult_id [OF a_group,
    folded set_add_def, simplified monoid_record_simps])

lemma (in abelian_subgroup) a_rcos_inv:
  assumes x:     "x \<in> carrier G"
  shows "a_set_inv (H +> x) = H +> (\<ominus> x)"
by (rule normal.rcos_inv [OF a_normal,
  folded a_r_coset_def a_inv_def A_SET_INV_def, simplified monoid_record_simps]) (rule x)

lemma (in abelian_group) a_setmult_rcos_assoc:
     "\<lbrakk>H \<subseteq> carrier G; K \<subseteq> carrier G; x \<in> carrier G\<rbrakk>
      \<Longrightarrow> H <+> (K +> x) = (H <+> K) +> x"
by (rule group.setmult_rcos_assoc [OF a_group,
    folded set_add_def a_r_coset_def, simplified monoid_record_simps])

lemma (in abelian_group) a_rcos_assoc_lcos:
     "\<lbrakk>H \<subseteq> carrier G; K \<subseteq> carrier G; x \<in> carrier G\<rbrakk>
      \<Longrightarrow> (H +> x) <+> K = H <+> (x <+ K)"
by (rule group.rcos_assoc_lcos [OF a_group,
     folded set_add_def a_r_coset_def a_l_coset_def, simplified monoid_record_simps])

lemma (in abelian_subgroup) a_rcos_sum:
     "\<lbrakk>x \<in> carrier G; y \<in> carrier G\<rbrakk>
      \<Longrightarrow> (H +> x) <+> (H +> y) = H +> (x \<oplus> y)"
by (rule normal.rcos_sum [OF a_normal,
    folded set_add_def a_r_coset_def, simplified monoid_record_simps])

lemma (in abelian_subgroup) rcosets_add_eq:
  "M \<in> a_rcosets H \<Longrightarrow> H <+> M = M"
  \<comment> \<open>generalizes \<open>subgroup_mult_id\<close>\<close>
by (rule normal.rcosets_mult_eq [OF a_normal,
    folded set_add_def A_RCOSETS_def, simplified monoid_record_simps])

subsubsection \<open>Congruence Relation\<close>

lemma (in abelian_subgroup) a_equiv_rcong:
   shows "equiv (carrier G) (racong H)"
by (rule subgroup.equiv_rcong [OF a_subgroup a_group,
    folded a_r_congruent_def, simplified monoid_record_simps])

lemma (in abelian_subgroup) a_l_coset_eq_rcong:
  assumes a: "a \<in> carrier G"
  shows "a <+ H = racong H `` {a}"
by (rule subgroup.l_coset_eq_rcong [OF a_subgroup a_group,
    folded a_r_congruent_def a_l_coset_def, simplified monoid_record_simps]) (rule a)

lemma (in abelian_subgroup) a_rcos_equation:
  shows
     "\<lbrakk>ha \<oplus> a = h \<oplus> b; a \<in> carrier G;  b \<in> carrier G;
        h \<in> H;  ha \<in> H;  hb \<in> H\<rbrakk>
      \<Longrightarrow> hb \<oplus> a \<in> (\<Union>h\<in>H. {h \<oplus> b})"
by (rule group.rcos_equation [OF a_group a_subgroup,
    folded a_r_congruent_def a_l_coset_def, simplified monoid_record_simps])

lemma (in abelian_subgroup) a_rcos_disjoint:
  shows "\<lbrakk>a \<in> a_rcosets H; b \<in> a_rcosets H; a\<noteq>b\<rbrakk> \<Longrightarrow> a \<inter> b = {}"
by (rule group.rcos_disjoint [OF a_group a_subgroup,
    folded A_RCOSETS_def, simplified monoid_record_simps])

lemma (in abelian_subgroup) a_rcos_self:
  shows "x \<in> carrier G \<Longrightarrow> x \<in> H +> x"
by (rule group.rcos_self [OF a_group _ a_subgroup,
    folded a_r_coset_def, simplified monoid_record_simps])

lemma (in abelian_subgroup) a_rcosets_part_G:
  shows "\<Union>(a_rcosets H) = carrier G"
by (rule group.rcosets_part_G [OF a_group a_subgroup,
    folded A_RCOSETS_def, simplified monoid_record_simps])

lemma (in abelian_subgroup) a_cosets_finite:
     "\<lbrakk>c \<in> a_rcosets H;  H \<subseteq> carrier G;  finite (carrier G)\<rbrakk> \<Longrightarrow> finite c"
by (rule group.cosets_finite [OF a_group,
    folded A_RCOSETS_def, simplified monoid_record_simps])

lemma (in abelian_group) a_card_cosets_equal:
     "\<lbrakk>c \<in> a_rcosets H;  H \<subseteq> carrier G; finite(carrier G)\<rbrakk>
      \<Longrightarrow> card c = card H"
  by (simp add: A_RCOSETS_defs(1) add.card_rcosets_equal)

lemma (in abelian_group) rcosets_subset_PowG:
     "additive_subgroup H G  \<Longrightarrow> a_rcosets H \<subseteq> Pow(carrier G)"
by (rule group.rcosets_subset_PowG [OF a_group,
    folded A_RCOSETS_def, simplified monoid_record_simps],
    rule additive_subgroup.a_subgroup)

theorem (in abelian_group) a_lagrange:
     "\<lbrakk>finite(carrier G); additive_subgroup H G\<rbrakk>
      \<Longrightarrow> card(a_rcosets H) * card(H) = order(G)"
by (rule group.lagrange [OF a_group,
    folded A_RCOSETS_def, simplified monoid_record_simps order_def, folded order_def])
    (fast intro!: additive_subgroup.a_subgroup)+

subsubsection \<open>Factorization\<close>

lemmas A_FactGroup_defs = A_FactGroup_def FactGroup_def

lemma A_FactGroup_def':
  fixes G (structure)
  shows "G A_Mod H \<equiv> \<lparr>carrier = a_rcosets\<^bsub>G\<^esub> H, mult = set_add G, one = H\<rparr>"
unfolding A_FactGroup_defs
by (fold A_RCOSETS_def set_add_def)

lemma (in abelian_subgroup) a_setmult_closed:
     "\<lbrakk>K1 \<in> a_rcosets H; K2 \<in> a_rcosets H\<rbrakk> \<Longrightarrow> K1 <+> K2 \<in> a_rcosets H"
by (rule normal.setmult_closed [OF a_normal,
    folded A_RCOSETS_def set_add_def, simplified monoid_record_simps])

lemma (in abelian_subgroup) a_setinv_closed:
     "K \<in> a_rcosets H \<Longrightarrow> a_set_inv K \<in> a_rcosets H"
by (rule normal.setinv_closed [OF a_normal,
    folded A_RCOSETS_def A_SET_INV_def, simplified monoid_record_simps])

lemma (in abelian_subgroup) a_rcosets_assoc:
     "\<lbrakk>M1 \<in> a_rcosets H; M2 \<in> a_rcosets H; M3 \<in> a_rcosets H\<rbrakk>
      \<Longrightarrow> M1 <+> M2 <+> M3 = M1 <+> (M2 <+> M3)"
by (rule normal.rcosets_assoc [OF a_normal,
    folded A_RCOSETS_def set_add_def, simplified monoid_record_simps])

lemma (in abelian_subgroup) a_subgroup_in_rcosets:
     "H \<in> a_rcosets H"
by (rule subgroup.subgroup_in_rcosets [OF a_subgroup a_group,
    folded A_RCOSETS_def, simplified monoid_record_simps])

lemma (in abelian_subgroup) a_rcosets_inv_mult_group_eq:
     "M \<in> a_rcosets H \<Longrightarrow> a_set_inv M <+> M = H"
by (rule normal.rcosets_inv_mult_group_eq [OF a_normal,
    folded A_RCOSETS_def A_SET_INV_def set_add_def, simplified monoid_record_simps])

theorem (in abelian_subgroup) a_factorgroup_is_group:
  "group (G A_Mod H)"
by (rule normal.factorgroup_is_group [OF a_normal,
    folded A_FactGroup_def, simplified monoid_record_simps])

text \<open>Since the Factorization is based on an \emph{abelian} subgroup, is results in
        a commutative group\<close>
theorem (in abelian_subgroup) a_factorgroup_is_comm_group:
  "comm_group (G A_Mod H)"
apply (intro comm_group.intro comm_monoid.intro) prefer 3
  apply (rule a_factorgroup_is_group)
 apply (rule group.axioms[OF a_factorgroup_is_group])
apply (rule comm_monoid_axioms.intro)
apply (unfold A_FactGroup_def FactGroup_def RCOSETS_def, fold set_add_def a_r_coset_def, clarsimp)
apply (simp add: a_rcos_sum a_comm)
done

lemma add_A_FactGroup [simp]: "X \<otimes>\<^bsub>(G A_Mod H)\<^esub> X' = X <+>\<^bsub>G\<^esub> X'"
by (simp add: A_FactGroup_def set_add_def)

lemma (in abelian_subgroup) a_inv_FactGroup:
     "X \<in> carrier (G A_Mod H) \<Longrightarrow> inv\<^bsub>G A_Mod H\<^esub> X = a_set_inv X"
by (rule normal.inv_FactGroup [OF a_normal,
    folded A_FactGroup_def A_SET_INV_def, simplified monoid_record_simps])

text\<open>The coset map is a homomorphism from @{term G} to the quotient group
  @{term "G Mod H"}\<close>
lemma (in abelian_subgroup) a_r_coset_hom_A_Mod:
  "(\<lambda>a. H +> a) \<in> hom (add_monoid G) (G A_Mod H)"
by (rule normal.r_coset_hom_Mod [OF a_normal,
    folded A_FactGroup_def a_r_coset_def, simplified monoid_record_simps])

text \<open>The isomorphism theorems have been omitted from lifting, at
  least for now\<close>

subsubsection\<open>The First Isomorphism Theorem\<close>

text\<open>The quotient by the kernel of a homomorphism is isomorphic to the
  range of that homomorphism.\<close>

lemmas a_kernel_defs =
  a_kernel_def kernel_def

lemma a_kernel_def':
  "a_kernel R S h = {x \<in> carrier R. h x = \<zero>\<^bsub>S\<^esub>}"
by (rule a_kernel_def[unfolded kernel_def, simplified ring_record_simps])

subsubsection \<open>Homomorphisms\<close>

lemma abelian_group_homI:
  assumes "abelian_group G"
  assumes "abelian_group H"
  assumes a_group_hom: "group_hom (add_monoid G)
                                  (add_monoid H) h"
  shows "abelian_group_hom G H h"
proof -
  interpret G: abelian_group G by fact
  interpret H: abelian_group H by fact
  show ?thesis
    apply (intro abelian_group_hom.intro abelian_group_hom_axioms.intro)
      apply fact
     apply fact
    apply (rule a_group_hom)
    done
qed

lemma (in abelian_group_hom) is_abelian_group_hom:
  "abelian_group_hom G H h"
  ..

lemma (in abelian_group_hom) hom_add [simp]:
  "[| x \<in> carrier G; y \<in> carrier G |]
        ==> h (x \<oplus>\<^bsub>G\<^esub> y) = h x \<oplus>\<^bsub>H\<^esub> h y"
by (rule group_hom.hom_mult[OF a_group_hom,
    simplified ring_record_simps])

lemma (in abelian_group_hom) hom_closed [simp]:
  "x \<in> carrier G \<Longrightarrow> h x \<in> carrier H"
by (rule group_hom.hom_closed[OF a_group_hom,
    simplified ring_record_simps])

lemma (in abelian_group_hom) zero_closed [simp]:
  "h \<zero> \<in> carrier H"
by (rule group_hom.one_closed[OF a_group_hom,
    simplified ring_record_simps])

lemma (in abelian_group_hom) hom_zero [simp]:
  "h \<zero> = \<zero>\<^bsub>H\<^esub>"
by (rule group_hom.hom_one[OF a_group_hom,
    simplified ring_record_simps])

lemma (in abelian_group_hom) a_inv_closed [simp]:
  "x \<in> carrier G ==> h (\<ominus>x) \<in> carrier H"
by (rule group_hom.inv_closed[OF a_group_hom,
    folded a_inv_def, simplified ring_record_simps])

lemma (in abelian_group_hom) hom_a_inv [simp]:
  "x \<in> carrier G ==> h (\<ominus>x) = \<ominus>\<^bsub>H\<^esub> (h x)"
by (rule group_hom.hom_inv[OF a_group_hom,
    folded a_inv_def, simplified ring_record_simps])

lemma (in abelian_group_hom) additive_subgroup_a_kernel:
  "additive_subgroup (a_kernel G H h) G"
apply (rule additive_subgroup.intro)
apply (rule group_hom.subgroup_kernel[OF a_group_hom,
       folded a_kernel_def, simplified ring_record_simps])
done

text\<open>The kernel of a homomorphism is an abelian subgroup\<close>
lemma (in abelian_group_hom) abelian_subgroup_a_kernel:
  "abelian_subgroup (a_kernel G H h) G"
apply (rule abelian_subgroupI)
apply (rule group_hom.normal_kernel[OF a_group_hom,
       folded a_kernel_def, simplified ring_record_simps])
apply (simp add: G.a_comm)
done

lemma (in abelian_group_hom) A_FactGroup_nonempty:
  assumes X: "X \<in> carrier (G A_Mod a_kernel G H h)"
  shows "X \<noteq> {}"
by (rule group_hom.FactGroup_nonempty[OF a_group_hom,
    folded a_kernel_def A_FactGroup_def, simplified ring_record_simps]) (rule X)

lemma (in abelian_group_hom) FactGroup_the_elem_mem:
  assumes X: "X \<in> carrier (G A_Mod (a_kernel G H h))"
  shows "the_elem (h`X) \<in> carrier H"
by (rule group_hom.FactGroup_the_elem_mem[OF a_group_hom,
    folded a_kernel_def A_FactGroup_def, simplified ring_record_simps]) (rule X)

lemma (in abelian_group_hom) A_FactGroup_hom:
     "(\<lambda>X. the_elem (h`X)) \<in> hom (G A_Mod (a_kernel G H h))
          (add_monoid H)"
by (rule group_hom.FactGroup_hom[OF a_group_hom,
    folded a_kernel_def A_FactGroup_def, simplified ring_record_simps])

lemma (in abelian_group_hom) A_FactGroup_inj_on:
     "inj_on (\<lambda>X. the_elem (h ` X)) (carrier (G A_Mod a_kernel G H h))"
by (rule group_hom.FactGroup_inj_on[OF a_group_hom,
    folded a_kernel_def A_FactGroup_def, simplified ring_record_simps])

text\<open>If the homomorphism @{term h} is onto @{term H}, then so is the
homomorphism from the quotient group\<close>
lemma (in abelian_group_hom) A_FactGroup_onto:
  assumes h: "h ` carrier G = carrier H"
  shows "(\<lambda>X. the_elem (h ` X)) ` carrier (G A_Mod a_kernel G H h) = carrier H"
by (rule group_hom.FactGroup_onto[OF a_group_hom,
    folded a_kernel_def A_FactGroup_def, simplified ring_record_simps]) (rule h)

text\<open>If @{term h} is a homomorphism from @{term G} onto @{term H}, then the
 quotient group @{term "G Mod (kernel G H h)"} is isomorphic to @{term H}.\<close>
theorem (in abelian_group_hom) A_FactGroup_iso_set:
  "h ` carrier G = carrier H
   \<Longrightarrow> (\<lambda>X. the_elem (h`X)) \<in> iso (G A_Mod (a_kernel G H h)) (add_monoid H)"
by (rule group_hom.FactGroup_iso_set[OF a_group_hom,
    folded a_kernel_def A_FactGroup_def, simplified ring_record_simps])

corollary (in abelian_group_hom) A_FactGroup_iso :
  "h ` carrier G = carrier H
   \<Longrightarrow>  (G A_Mod (a_kernel G H h)) \<cong>  (add_monoid H)"
  using A_FactGroup_iso_set unfolding is_iso_def by auto

subsubsection \<open>Cosets\<close>

text \<open>Not eveything from \texttt{CosetExt.thy} is lifted here.\<close>

lemma (in additive_subgroup) a_Hcarr [simp]:
  assumes hH: "h \<in> H"
  shows "h \<in> carrier G"
by (rule subgroup.mem_carrier [OF a_subgroup,
    simplified monoid_record_simps]) (rule hH)

lemma (in abelian_subgroup) a_elemrcos_carrier:
  assumes acarr: "a \<in> carrier G"
      and a': "a' \<in> H +> a"
  shows "a' \<in> carrier G"
by (rule subgroup.elemrcos_carrier [OF a_subgroup a_group,
    folded a_r_coset_def, simplified monoid_record_simps]) (rule acarr, rule a')

lemma (in abelian_subgroup) a_rcos_const:
  assumes hH: "h \<in> H"
  shows "H +> h = H"
by (rule subgroup.rcos_const [OF a_subgroup a_group,
    folded a_r_coset_def, simplified monoid_record_simps]) (rule hH)

lemma (in abelian_subgroup) a_rcos_module_imp:
  assumes xcarr: "x \<in> carrier G"
      and x'cos: "x' \<in> H +> x"
  shows "(x' \<oplus> \<ominus>x) \<in> H"
by (rule subgroup.rcos_module_imp [OF a_subgroup a_group,
    folded a_r_coset_def a_inv_def, simplified monoid_record_simps]) (rule xcarr, rule x'cos)

lemma (in abelian_subgroup) a_rcos_module_rev:
  assumes "x \<in> carrier G" "x' \<in> carrier G"
      and "(x' \<oplus> \<ominus>x) \<in> H"
  shows "x' \<in> H +> x"
using assms
by (rule subgroup.rcos_module_rev [OF a_subgroup a_group,
    folded a_r_coset_def a_inv_def, simplified monoid_record_simps])

lemma (in abelian_subgroup) a_rcos_module:
  assumes "x \<in> carrier G" "x' \<in> carrier G"
  shows "(x' \<in> H +> x) = (x' \<oplus> \<ominus>x \<in> H)"
using assms
by (rule subgroup.rcos_module [OF a_subgroup a_group,
    folded a_r_coset_def a_inv_def, simplified monoid_record_simps])

\<comment> \<open>variant\<close>
lemma (in abelian_subgroup) a_rcos_module_minus:
  assumes "ring G"
  assumes carr: "x \<in> carrier G" "x' \<in> carrier G"
  shows "(x' \<in> H +> x) = (x' \<ominus> x \<in> H)"
proof -
  interpret G: ring G by fact
  from carr
  have "(x' \<in> H +> x) = (x' \<oplus> \<ominus>x \<in> H)" by (rule a_rcos_module)
  with carr
  show "(x' \<in> H +> x) = (x' \<ominus> x \<in> H)"
    by (simp add: minus_eq)
qed

lemma (in abelian_subgroup) a_repr_independence':
  assumes y: "y \<in> H +> x"
      and xcarr: "x \<in> carrier G"
  shows "H +> x = H +> y"
  apply (rule a_repr_independence)
    apply (rule y)
   apply (rule xcarr)
  apply (rule a_subgroup)
  done

lemma (in abelian_subgroup) a_repr_independenceD:
  assumes ycarr: "y \<in> carrier G"
      and repr:  "H +> x = H +> y"
  shows "y \<in> H +> x"
by (rule group.repr_independenceD [OF a_group a_subgroup,
    folded a_r_coset_def, simplified monoid_record_simps]) (rule ycarr, rule repr)

lemma (in abelian_subgroup) a_rcosets_carrier:
  "X \<in> a_rcosets H \<Longrightarrow> X \<subseteq> carrier G"
by (rule subgroup.rcosets_carrier [OF a_subgroup a_group,
    folded A_RCOSETS_def, simplified monoid_record_simps])

subsubsection \<open>Addition of Subgroups\<close>

lemma (in abelian_monoid) set_add_closed:
  assumes Acarr: "A \<subseteq> carrier G"
      and Bcarr: "B \<subseteq> carrier G"
  shows "A <+> B \<subseteq> carrier G"
by (rule monoid.set_mult_closed [OF a_monoid,
    folded set_add_def, simplified monoid_record_simps]) (rule Acarr, rule Bcarr)

lemma (in abelian_group) add_additive_subgroups:
  assumes subH: "additive_subgroup H G"
      and subK: "additive_subgroup K G"
  shows "additive_subgroup (H <+> K) G"
apply (rule additive_subgroup.intro)
apply (unfold set_add_def)
apply (intro comm_group.mult_subgroups)
  apply (rule a_comm_group)
 apply (rule additive_subgroup.a_subgroup[OF subH])
apply (rule additive_subgroup.a_subgroup[OF subK])
done

end


subsection \<open>Binary masking is Diophantine\<close>

theory Binary_Masking
  imports Binary_Orthogonal
begin

lemma lm0243_masks_binom_equiv: "(b \<preceq> c) \<longleftrightarrow> odd (c choose b)" (is "?P \<longleftrightarrow> ?Q")
proof-
  consider (lt) "b < c" | (eq) "b = c" | (gt) "b > c" using nat_neq_iff by blast
  then show ?thesis
  proof(cases)
    case lt
    hence "\<exists>a. c = a + b" using less_imp_add_positive semiring_normalization_rules(24) by blast
    then obtain a where a_def:"c = a + b" ..
    have "a \<bottom> b \<longleftrightarrow> b \<preceq> a + b" (is "?P \<longleftrightarrow> ?Q")
    proof
      assume ?P
      then show ?Q
        using ortho_mult_equiv no_carry_mult_equiv masks_leq_equiv[of b "a+b"]
              sum_digit_formula nth_bit_bounded
        by auto (metis add.commute add.right_neutral lessI less_one mod_less
                        nat_less_le one_add_one plus_1_eq_Suc zero_le)
    next
      assume ?Q
      have "?Q \<Longrightarrow> \<forall>k. a \<exclamdown> k + b \<exclamdown> k \<le> 1"
      proof(rule ccontr)
        assume "\<not>(\<forall>k. a \<exclamdown> k + b \<exclamdown> k \<le> 1) "
        then obtain k where k1:"\<not>(a \<exclamdown> k + b \<exclamdown> k \<le> 1)" and k2:"\<forall>r<k. a \<exclamdown> r + b \<exclamdown> r \<le> 1"
          by (auto dest: obtain_smallest)
        have c1: "bin_carry a b k = 1"
          using `?Q` masks_leq_equiv sum_digit_formula carry_bounded nth_bit_bounded k1
          by (metis add.commute add.left_neutral add_self_mod_2 less_one nat_less_le not_le)
        then show False using carry_digit_impl[of a b k] k2 by auto
      qed
      then show ?P
        using `?Q` ortho_mult_equiv no_carry_mult_equiv masks_leq_equiv[of b "a+b"]
              sum_digit_formula nth_bit_bounded
        by auto (metis add_le_same_cancel2 le_0_eq le_SucE)
    qed
    then show ?thesis using lm0241_ortho_binom_equiv a_def by auto
  next
    case eq
    hence "odd (c choose b)" by simp
    moreover have "b \<preceq> c" using digit_wise_equiv masks_leq_equiv eq by blast
    ultimately show ?thesis by simp
  next
    case gt
    hence "\<not> odd (c choose b)" by (simp add: binomial_eq_0)
    moreover have "\<not> (b \<preceq> c)" using masks_leq_equiv masks_leq gt not_le by blast
    ultimately show ?thesis by simp
  qed
qed

definition masking ("_ [\<preceq>] _" 60)
  where "P [\<preceq>] Q \<equiv> (BINARY (\<lambda>a b. a \<preceq> b) P Q)"

lemma masking_dioph[dioph]:
  fixes P Q
  defines "DR \<equiv> (P [\<preceq>] Q)"
  shows "is_dioph_rel DR"
proof -
  define P' Q' where pushed_def: "P' \<equiv> push_param P 1" "Q' \<equiv> push_param Q 1"

  define DS where "DS \<equiv> [\<exists>] [Param 0 = Q' choose P'] [\<and>] ODD Param 0"

  have "eval DS a = eval DR a" for a
    unfolding DS_def DR_def defs pushed_def masking_def
    using push_push1 by (simp add: push0 lm0243_masks_binom_equiv)

  moreover have "is_dioph_rel DS"
    unfolding DS_def by (simp add: dioph)

  ultimately show ?thesis
    by (auto simp: is_dioph_rel_def)
qed

declare masking_def[defs]

end


theory NumberWang_IPv4
imports Main
  "~~/src/HOL/Word/Word"
begin

section\<open>Helper Lemmas for Low-Level Operations on Machine Words\<close>
text\<open>Needed for IPv4 Syntax\<close>

lemma mod256: "((d::nat) + 256 * c + 65536 * b + 16777216 * a) mod 256 = d mod 256"
proof -
  from mod_mult_self2[where a="d + 256 * c + 65536 * b" and b="256" and c="65536 * a"] have
    "(d + 256 * c + 65536 * b + 256 * 65536 * a) mod 256 = (d + 256 * c + 65536 * b) mod 256"
    by simp
  also have "\<dots>  = (d + 256 * c) mod 256"
    using mod_mult_self2[where a="d + 256 * c" and b="256" and c="256 * b"] by simp
  also have "\<dots> = d mod 256" using mod_mult_self2 by blast
  finally show ?thesis by presburger
qed

lemma div65536: assumes "a < 256" "b < 256" "c < 256" "d < 256"
    shows "nat ((int d + int (256 * c) + int (65536 * b) + int (16777216 * a)) div 65536 mod 256) = b"
proof -
  from zdiv_mult_self[where a="int d + int (256 * c) + int (65536 * b)" and m=65536 and n="256 * (int a)"] have
    "(int d + int (256 * c) + int (65536 * b) + int (16777216 * a)) div 65536 =
     ((int d + int (256 * c) + int (65536 * b)) div 65536) + 256 * int a" by linarith
  also from zdiv_mult_self[where a="int d + int (256 * c)" and m="65536" and n="int b"] have
    "\<dots> = (int d + int (256 * c)) div 65536 + int b + 256 * int a" by linarith
  also from assms have "\<dots> = int b + 256 * int a" by simp
  finally have helper:
    "(int d + int (256 * c) + int (65536 * b) + int (16777216 * a)) div 65536 = int b + 256 * int a" .
  from assms show ?thesis
    unfolding helper
    apply(simp)
    apply(subst mod_pos_pos_trivial)
      apply simp_all
    done
qed

lemma div256: assumes "a < 256" "b < 256" "c < 256" "d < 256"
  shows "nat ((int d + int (256 * c) + int (65536 * b) + int (16777216 * a)) div 256 mod 256) = c"
proof -
  from zdiv_mult_self[where a="int d + int (256 * c) + int (65536 * b)" and m=256 and n="65536 * (int a)"] have
    "(int d + int (256 * c) + int (65536 * b) + int (16777216 * a)) div 256 =
     ((int d + int (256 * c) + int (65536 * b)) div 256) + 65536 * int a" by linarith
  also from zdiv_mult_self[where a="int d + int (256 * c)" and m="256" and n="256 * int b"] have
    "\<dots> = (int d + int (256 * c)) div 256 + 256 * int b + 65536 * int a" by linarith
  also from zdiv_mult_self[where a="int d" and m="256" and n="int c"] have
    "\<dots> = (int d) div 256 + int c + 256 * int b + 65536 * int a" by linarith
  also from assms have "\<dots> = int c + 256 * int b + 65536 * int a" by simp
  finally have helper1: "(int d + int (256 * c) + int (65536 * b) + int (16777216 * a)) div 256 =
                          int c + 256 * int b + 65536 * int a" .

  from mod_mult_self2[where a="int c + 256 * int b" and c="256 * int a" and b=256] have
    "(int c + 256 * int b + 65536 * int a) mod 256 = (int c + 256 * int b) mod 256" by simp
  also have "\<dots> = int c mod 256" using mod_mult_self2[where a="int c" and b=256 and c="int b"] by simp
  also have "\<dots> = int c" using assms
    apply(subst mod_pos_pos_trivial)
    by(simp_all)
  finally have helper2: "(int c + 256 * int b + 65536 * int a) mod 256 = int c" .

  from helper1 helper2 show ?thesis by simp
qed

end


(* This Isabelle theory is produced using the TIP tool offered at the following website:
     https://github.com/tip-org/tools
   This file was originally provided as part of TIP benchmark at the following website:
     https://github.com/tip-org/benchmarks
   Yutaka Nagashima at CIIRC, CTU changed the TIP output theory file slightly
   to make it compatible with Isabelle2017.*)
  theory TIP_regexp_SeqDistrPlus
imports "../../Test_Base"
begin

datatype 'a list = nil2 | cons2 "'a" "'a list"

datatype A = X | Y

datatype R
         = Nil | Eps | Atom "A" | Plus "R" "R" | Seq "R" "R" | Star "R"

fun seq :: "R => R => R" where
"seq x y =
   (case x of
      Nil => Nil
      | other =>
          (case y of
             Nil => Nil
             | other =>
                 (case x of
                    Eps => y
                    | other =>
                        (case y of
                           Eps => x
                           | other => Seq x y))))"

fun plus :: "R => R => R" where
"plus x y =
   (case x of
      Nil => y
      | other =>
          (case y of
             Nil => x
             | other => Plus x y))"

fun eqA :: "A => A => bool" where
"eqA (X) (X) = True"
| "eqA (X) (Y) = False"
| "eqA (Y) (X) = False"
| "eqA (Y) (Y) = True"

fun eps :: "R => bool" where
"eps x =
   (case x of
      Eps => True
      | Plus p q => ((eps p) | (eps q))
      | Seq r q2 => ((eps r) & (eps q2))
      | Star y => True
      | other => False)"

fun epsR :: "R => R" where
"epsR x = (if eps x then Eps else Nil)"

fun step :: "R => A => R" where
"step x y =
   (case x of
      Atom a => (if eqA a y then Eps else Nil)
      | Plus p q => plus (step p y) (step q y)
      | Seq r q2 => plus (seq (step r y) q2) (seq (epsR r) (step q2 y))
      | Star p2 => seq (step p2 y) x
      | other => Nil)"

fun recognise :: "R => A list => bool" where
"recognise x (nil2) = eps x"
| "recognise x (cons2 z xs) = recognise (step x z) xs"

theorem property0 :
  "((recognise (Seq p (Plus q r)) s) =
      (recognise (Plus (Seq p q) (Seq p r)) s))"
  oops

end


theory T118
imports Main
begin
lemma "(
(\<forall> x::nat. \<forall> y::nat. meet(x, y) = meet(y, x)) &
(\<forall> x::nat. \<forall> y::nat. join(x, y) = join(y, x)) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. meet(x, meet(y, z)) = meet(meet(x, y), z)) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. join(x, join(y, z)) = join(join(x, y), z)) &
(\<forall> x::nat. \<forall> y::nat. meet(x, join(x, y)) = x) &
(\<forall> x::nat. \<forall> y::nat. join(x, meet(x, y)) = x) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. mult(x, join(y, z)) = join(mult(x, y), mult(x, z))) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. mult(join(x, y), z) = join(mult(x, z), mult(y, z))) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. meet(x, over(join(mult(x, y), z), y)) = x) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. meet(y, undr(x, join(mult(x, y), z))) = y) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. join(mult(over(x, y), y), x) = x) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. join(mult(y, undr(y, x)), x) = x) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. mult(x, meet(y, z)) = meet(mult(x, y), mult(x, z))) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. mult(meet(x, y), z) = meet(mult(x, z), mult(y, z))) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. undr(x, join(y, z)) = join(undr(x, y), undr(x, z))) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. over(x, meet(y, z)) = join(over(x, y), over(x, z))) &
(\<forall> x::nat. \<forall> y::nat. invo(join(x, y)) = meet(invo(x), invo(y))) &
(\<forall> x::nat. \<forall> y::nat. invo(meet(x, y)) = join(invo(x), invo(y))) &
(\<forall> x::nat. invo(invo(x)) = x)
) \<longrightarrow>
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. over(join(x, y), z) = join(over(x, z), over(y, z)))
"
nitpick[card nat=4,timeout=86400]
oops
end