/-
Copyright (c) 2020 Yury Kudryashov All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Yury Kudryashov
-/
import Mathlib.PrePort
import Mathlib.Lean3Lib.init.default
import Mathlib.algebra.ring.prod
import Mathlib.group_theory.submonoid.default
import Mathlib.data.equiv.ring
import Mathlib.PostPort

universes u l u_1 u_2 v w

namespace Mathlib

/-!
# Bundled subsemirings

We define bundled subsemirings and some standard constructions: `complete_lattice` structure,
`subtype` and `inclusion` ring homomorphisms, subsemiring `map`, `comap` and range (`srange`) of
a `ring_hom` etc.
-/

/-- A subsemiring of a semiring `R` is a subset `s` that is both a multiplicative and an additive
submonoid. -/
structure subsemiring (R : Type u) [semiring R] extends add_submonoid R, submonoid R where

/-- Reinterpret a `subsemiring` as a `submonoid`. -/
/-- Reinterpret a `subsemiring` as an `add_submonoid`. -/
namespace subsemiring

protected instance set.has_coe {R : Type u} [semiring R] : has_coe (subsemiring R) (set R) :=
  has_coe.mk carrier

protected instance has_mem {R : Type u} [semiring R] : has_mem R (subsemiring R) :=
  has_mem.mk fun (m : R) (S : subsemiring R) => m ∈ ↑S

protected instance has_coe_to_sort {R : Type u} [semiring R] : has_coe_to_sort (subsemiring R) :=
  has_coe_to_sort.mk (Type u) fun (S : subsemiring R) => Subtype fun (x : R) => x ∈ S

/-- Construct a `subsemiring R` from a set `s`, a submonoid `sm`, and an additive
submonoid `sa` such that `x ∈ s ↔ x ∈ sm ↔ x ∈ sa`. -/
protected def mk' {R : Type u} [semiring R] (s : set R) (sm : submonoid R) (hm : ↑sm = s)
    (sa : add_submonoid R) (ha : ↑sa = s) : subsemiring R :=
  mk s sorry sorry sorry sorry

@[simp] theorem coe_mk' {R : Type u} [semiring R] {s : set R} {sm : submonoid R} (hm : ↑sm = s)
    {sa : add_submonoid R} (ha : ↑sa = s) : ↑(subsemiring.mk' s sm hm sa ha) = s :=
  rfl

@[simp] theorem mem_mk' {R : Type u} [semiring R] {s : set R} {sm : submonoid R} (hm : ↑sm = s)
    {sa : add_submonoid R} (ha : ↑sa = s) {x : R} : x ∈ subsemiring.mk' s sm hm sa ha ↔ x ∈ s :=
  iff.rfl

@[simp] theorem mk'_to_submonoid {R : Type u} [semiring R] {s : set R} {sm : submonoid R}
    (hm : ↑sm = s) {sa : add_submonoid R} (ha : ↑sa = s) :
    to_submonoid (subsemiring.mk' s sm hm sa ha) = sm :=
  submonoid.ext' (Eq.symm hm)

@[simp] theorem mk'_to_add_submonoid {R : Type u} [semiring R] {s : set R} {sm : submonoid R}
    (hm : ↑sm = s) {sa : add_submonoid R} (ha : ↑sa = s) :
    to_add_submonoid (subsemiring.mk' s sm hm sa ha) = sa :=
  add_submonoid.ext' (Eq.symm ha)

end subsemiring

protected theorem subsemiring.exists {R : Type u} [semiring R] {s : subsemiring R} {p : ↥s → Prop} :
    (∃ (x : ↥s), p x) ↔ ∃ (x : R), ∃ (H : x ∈ s), p { val := x, property := H } :=
  set_coe.exists

protected theorem subsemiring.forall {R : Type u} [semiring R] {s : subsemiring R} {p : ↥s → Prop} :
    (∀ (x : ↥s), p x) ↔ ∀ (x : R) (H : x ∈ s), p { val := x, property := H } :=
  set_coe.forall

namespace subsemiring

/-- Two subsemirings are equal if the underlying subsets are equal. -/
theorem ext' {R : Type u} [semiring R] {s : subsemiring R} {t : subsemiring R} (h : ↑s = ↑t) :
    s = t :=
  sorry

/-- Two subsemirings are equal if and only if the underlying subsets are equal. -/
protected theorem ext'_iff {R : Type u} [semiring R] {s : subsemiring R} {t : subsemiring R} :
    s = t ↔ ↑s = ↑t :=
  { mp := fun (h : s = t) => h ▸ rfl, mpr := fun (h : ↑s = ↑t) => ext' h }

/-- Two subsemirings are equal if they have the same elements. -/
theorem ext {R : Type u} [semiring R] {S : subsemiring R} {T : subsemiring R}
    (h : ∀ (x : R), x ∈ S ↔ x ∈ T) : S = T :=
  ext' (set.ext h)

/-- A subsemiring contains the semiring's 1. -/
theorem one_mem {R : Type u} [semiring R] (s : subsemiring R) : 1 ∈ s := one_mem' s

/-- A subsemiring contains the semiring's 0. -/
theorem zero_mem {R : Type u} [semiring R] (s : subsemiring R) : 0 ∈ s := zero_mem' s

/-- A subsemiring is closed under multiplication. -/
theorem mul_mem {R : Type u} [semiring R] (s : subsemiring R) {x : R} {y : R} :
    x ∈ s → y ∈ s → x * y ∈ s :=
  mul_mem' s

/-- A subsemiring is closed under addition. -/
theorem add_mem {R : Type u} [semiring R] (s : subsemiring R) {x : R} {y : R} :
    x ∈ s → y ∈ s → x + y ∈ s :=
  add_mem' s

/-- Product of a list of elements in a `subsemiring` is in the `subsemiring`. -/
theorem list_prod_mem {R : Type u} [semiring R] (s : subsemiring R) {l : List R} :
    (∀ (x : R), x ∈ l → x ∈ s) → list.prod l ∈ s :=
  submonoid.list_prod_mem (to_submonoid s)

/-- Sum of a list of elements in a `subsemiring` is in the `subsemiring`. -/
theorem list_sum_mem {R : Type u} [semiring R] (s : subsemiring R) {l : List R} :
    (∀ (x : R), x ∈ l → x ∈ s) → list.sum l ∈ s :=
  add_submonoid.list_sum_mem (to_add_submonoid s)

/-- Product of a multiset of elements in a `subsemiring` of a `comm_semiring`
    is in the `subsemiring`. -/
theorem multiset_prod_mem {R : Type u_1} [comm_semiring R] (s : subsemiring R) (m : multiset R) :
    (∀ (a : R), a ∈ m → a ∈ s) → multiset.prod m ∈ s :=
  submonoid.multiset_prod_mem (to_submonoid s) m

/-- Sum of a multiset of elements in a `subsemiring` of a `semiring` is
in the `add_subsemiring`. -/
theorem multiset_sum_mem {R : Type u_1} [semiring R] (s : subsemiring R) (m : multiset R) :
    (∀ (a : R), a ∈ m → a ∈ s) → multiset.sum m ∈ s :=
  add_submonoid.multiset_sum_mem (to_add_submonoid s) m

/-- Product of elements of a subsemiring of a `comm_semiring` indexed by a `finset` is in the
    subsemiring. -/
theorem prod_mem {R : Type u_1} [comm_semiring R] (s : subsemiring R) {ι : Type u_2} {t : finset ι}
    {f : ι → R} (h : ∀ (c : ι), c ∈ t → f c ∈ s) : (finset.prod t fun (i : ι) => f i) ∈ s :=
  submonoid.prod_mem (to_submonoid s) h

/-- Sum of elements in an `subsemiring` of an `semiring` indexed by a `finset`
is in the `add_subsemiring`. -/
theorem sum_mem {R : Type u_1} [semiring R] (s : subsemiring R) {ι : Type u_2} {t : finset ι}
    {f : ι → R} (h : ∀ (c : ι), c ∈ t → f c ∈ s) : (finset.sum t fun (i : ι) => f i) ∈ s :=
  add_submonoid.sum_mem (to_add_submonoid s) h

theorem pow_mem {R : Type u} [semiring R] (s : subsemiring R) {x : R} (hx : x ∈ s) (n : ℕ) :
    x ^ n ∈ s :=
  submonoid.pow_mem (to_submonoid s) hx n

theorem nsmul_mem {R : Type u} [semiring R] (s : subsemiring R) {x : R} (hx : x ∈ s) (n : ℕ) :
    n •ℕ x ∈ s :=
  add_submonoid.nsmul_mem (to_add_submonoid s) hx n

theorem coe_nat_mem {R : Type u} [semiring R] (s : subsemiring R) (n : ℕ) : ↑n ∈ s := sorry

/-- A subsemiring of a semiring inherits a semiring structure -/
protected instance to_semiring {R : Type u} [semiring R] (s : subsemiring R) : semiring ↥s :=
  semiring.mk add_comm_monoid.add sorry add_comm_monoid.zero sorry sorry sorry monoid.mul sorry
    monoid.one sorry sorry sorry sorry sorry sorry

protected instance nontrivial {R : Type u} [semiring R] (s : subsemiring R) [nontrivial R] :
    nontrivial ↥s :=
  nontrivial_of_ne 0 1 fun (H : 0 = 1) => zero_ne_one (congr_arg subtype.val H)

protected instance no_zero_divisors {R : Type u} [semiring R] (s : subsemiring R)
    [no_zero_divisors R] : no_zero_divisors ↥s :=
  no_zero_divisors.mk
    fun (x y : ↥s) (h : x * y = 0) =>
      or.cases_on (eq_zero_or_eq_zero_of_mul_eq_zero (iff.mp subtype.ext_iff h))
        (fun (h : subtype.val x = 0) => Or.inl (subtype.eq h))
        fun (h : subtype.val y = 0) => Or.inr (subtype.eq h)

@[simp] theorem coe_mul {R : Type u} [semiring R] (s : subsemiring R) (x : ↥s) (y : ↥s) :
    ↑(x * y) = ↑x * ↑y :=
  rfl

@[simp] theorem coe_one {R : Type u} [semiring R] (s : subsemiring R) : ↑1 = 1 := rfl

/-- A subsemiring of a `comm_semiring` is a `comm_semiring`. -/
protected instance to_comm_semiring {R : Type u_1} [comm_semiring R] (s : subsemiring R) :
    comm_semiring ↥s :=
  comm_semiring.mk semiring.add sorry semiring.zero sorry sorry sorry semiring.mul sorry
    semiring.one sorry sorry sorry sorry sorry sorry sorry

/-- The natural ring hom from a subsemiring of semiring `R` to `R`. -/
def subtype {R : Type u} [semiring R] (s : subsemiring R) : ↥s →+* R :=
  ring_hom.mk coe sorry sorry sorry sorry

@[simp] theorem coe_subtype {R : Type u} [semiring R] (s : subsemiring R) : ⇑(subtype s) = coe :=
  rfl

protected instance partial_order {R : Type u} [semiring R] : partial_order (subsemiring R) :=
  partial_order.mk (fun (s t : subsemiring R) => ∀ {x : R}, x ∈ s → x ∈ t) partial_order.lt sorry
    sorry sorry

theorem le_def {R : Type u} [semiring R] {s : subsemiring R} {t : subsemiring R} :
    s ≤ t ↔ ∀ {x : R}, x ∈ s → x ∈ t :=
  iff.rfl

@[simp] theorem coe_subset_coe {R : Type u} [semiring R] {s : subsemiring R} {t : subsemiring R} :
    ↑s ⊆ ↑t ↔ s ≤ t :=
  iff.rfl

@[simp] theorem coe_ssubset_coe {R : Type u} [semiring R] {s : subsemiring R} {t : subsemiring R} :
    ↑s ⊂ ↑t ↔ s < t :=
  iff.rfl

@[simp] theorem mem_coe {R : Type u} [semiring R] {S : subsemiring R} {m : R} : m ∈ ↑S ↔ m ∈ S :=
  iff.rfl

@[simp] theorem coe_coe {R : Type u} [semiring R] (s : subsemiring R) : ↥↑s = ↥s := rfl

@[simp] theorem mem_to_submonoid {R : Type u} [semiring R] {s : subsemiring R} {x : R} :
    x ∈ to_submonoid s ↔ x ∈ s :=
  iff.rfl

@[simp] theorem coe_to_submonoid {R : Type u} [semiring R] (s : subsemiring R) :
    ↑(to_submonoid s) = ↑s :=
  rfl

@[simp] theorem mem_to_add_submonoid {R : Type u} [semiring R] {s : subsemiring R} {x : R} :
    x ∈ to_add_submonoid s ↔ x ∈ s :=
  iff.rfl

@[simp] theorem coe_to_add_submonoid {R : Type u} [semiring R] (s : subsemiring R) :
    ↑(to_add_submonoid s) = ↑s :=
  rfl

/-- The subsemiring `R` of the semiring `R`. -/
protected instance has_top {R : Type u} [semiring R] : has_top (subsemiring R) :=
  has_top.mk (mk (submonoid.carrier ⊤) sorry sorry sorry sorry)

@[simp] theorem mem_top {R : Type u} [semiring R] (x : R) : x ∈ ⊤ := set.mem_univ x

@[simp] theorem coe_top {R : Type u} [semiring R] : ↑⊤ = set.univ := rfl

/-- The preimage of a subsemiring along a ring homomorphism is a subsemiring. -/
def comap {R : Type u} {S : Type v} [semiring R] [semiring S] (f : R →+* S) (s : subsemiring S) :
    subsemiring R :=
  mk (⇑f ⁻¹' ↑s) sorry sorry sorry sorry

@[simp] theorem coe_comap {R : Type u} {S : Type v} [semiring R] [semiring S] (s : subsemiring S)
    (f : R →+* S) : ↑(comap f s) = ⇑f ⁻¹' ↑s :=
  rfl

@[simp] theorem mem_comap {R : Type u} {S : Type v} [semiring R] [semiring S] {s : subsemiring S}
    {f : R →+* S} {x : R} : x ∈ comap f s ↔ coe_fn f x ∈ s :=
  iff.rfl

theorem comap_comap {R : Type u} {S : Type v} {T : Type w} [semiring R] [semiring S] [semiring T]
    (s : subsemiring T) (g : S →+* T) (f : R →+* S) :
    comap f (comap g s) = comap (ring_hom.comp g f) s :=
  rfl

/-- The image of a subsemiring along a ring homomorphism is a subsemiring. -/
def map {R : Type u} {S : Type v} [semiring R] [semiring S] (f : R →+* S) (s : subsemiring R) :
    subsemiring S :=
  mk (⇑f '' ↑s) sorry sorry sorry sorry

@[simp] theorem coe_map {R : Type u} {S : Type v} [semiring R] [semiring S] (f : R →+* S)
    (s : subsemiring R) : ↑(map f s) = ⇑f '' ↑s :=
  rfl

@[simp] theorem mem_map {R : Type u} {S : Type v} [semiring R] [semiring S] {f : R →+* S}
    {s : subsemiring R} {y : S} : y ∈ map f s ↔ ∃ (x : R), ∃ (H : x ∈ s), coe_fn f x = y :=
  set.mem_image_iff_bex

theorem map_map {R : Type u} {S : Type v} {T : Type w} [semiring R] [semiring S] [semiring T]
    (s : subsemiring R) (g : S →+* T) (f : R →+* S) : map g (map f s) = map (ring_hom.comp g f) s :=
  ext' (set.image_image (fun (a : S) => coe_fn g a) (fun (a : R) => coe_fn f a) ↑s)

theorem map_le_iff_le_comap {R : Type u} {S : Type v} [semiring R] [semiring S] {f : R →+* S}
    {s : subsemiring R} {t : subsemiring S} : map f s ≤ t ↔ s ≤ comap f t :=
  set.image_subset_iff

theorem gc_map_comap {R : Type u} {S : Type v} [semiring R] [semiring S] (f : R →+* S) :
    galois_connection (map f) (comap f) :=
  fun (S_1 : subsemiring R) (T : subsemiring S) => map_le_iff_le_comap

end subsemiring

namespace ring_hom

/-- The range of a ring homomorphism is a subsemiring. -/
def srange {R : Type u} {S : Type v} [semiring R] [semiring S] (f : R →+* S) : subsemiring S :=
  subsemiring.map f ⊤

@[simp] theorem coe_srange {R : Type u} {S : Type v} [semiring R] [semiring S] (f : R →+* S) :
    ↑(srange f) = set.range ⇑f :=
  set.image_univ

@[simp] theorem mem_srange {R : Type u} {S : Type v} [semiring R] [semiring S] {f : R →+* S}
    {y : S} : y ∈ srange f ↔ ∃ (x : R), coe_fn f x = y :=
  sorry

theorem map_srange {R : Type u} {S : Type v} {T : Type w} [semiring R] [semiring S] [semiring T]
    (g : S →+* T) (f : R →+* S) : subsemiring.map g (srange f) = srange (comp g f) :=
  subsemiring.map_map ⊤ g f

end ring_hom

namespace subsemiring

protected instance has_bot {R : Type u} [semiring R] : has_bot (subsemiring R) :=
  has_bot.mk (ring_hom.srange (nat.cast_ring_hom R))

protected instance inhabited {R : Type u} [semiring R] : Inhabited (subsemiring R) :=
  { default := ⊥ }

theorem coe_bot {R : Type u} [semiring R] : ↑⊥ = set.range coe :=
  ring_hom.coe_srange (nat.cast_ring_hom R)

theorem mem_bot {R : Type u} [semiring R] {x : R} : x ∈ ⊥ ↔ ∃ (n : ℕ), ↑n = x := ring_hom.mem_srange

/-- The inf of two subsemirings is their intersection. -/
protected instance has_inf {R : Type u} [semiring R] : has_inf (subsemiring R) :=
  has_inf.mk fun (s t : subsemiring R) => mk (↑s ∩ ↑t) sorry sorry sorry sorry

@[simp] theorem coe_inf {R : Type u} [semiring R] (p : subsemiring R) (p' : subsemiring R) :
    ↑(p ⊓ p') = ↑p ∩ ↑p' :=
  rfl

@[simp] theorem mem_inf {R : Type u} [semiring R] {p : subsemiring R} {p' : subsemiring R} {x : R} :
    x ∈ p ⊓ p' ↔ x ∈ p ∧ x ∈ p' :=
  iff.rfl

protected instance has_Inf {R : Type u} [semiring R] : has_Inf (subsemiring R) :=
  has_Inf.mk
    fun (s : set (subsemiring R)) =>
      subsemiring.mk' (set.Inter fun (t : subsemiring R) => set.Inter fun (H : t ∈ s) => ↑t)
        (infi fun (t : subsemiring R) => infi fun (H : t ∈ s) => to_submonoid t) sorry
        (infi fun (t : subsemiring R) => infi fun (H : t ∈ s) => to_add_submonoid t) sorry

@[simp] theorem coe_Inf {R : Type u} [semiring R] (S : set (subsemiring R)) :
    ↑(Inf S) = set.Inter fun (s : subsemiring R) => set.Inter fun (H : s ∈ S) => ↑s :=
  rfl

theorem mem_Inf {R : Type u} [semiring R] {S : set (subsemiring R)} {x : R} :
    x ∈ Inf S ↔ ∀ (p : subsemiring R), p ∈ S → x ∈ p :=
  set.mem_bInter_iff

@[simp] theorem Inf_to_submonoid {R : Type u} [semiring R] (s : set (subsemiring R)) :
    to_submonoid (Inf s) = infi fun (t : subsemiring R) => infi fun (H : t ∈ s) => to_submonoid t :=
  mk'_to_submonoid (has_Inf._proof_1 s) (has_Inf._proof_2 s)

@[simp] theorem Inf_to_add_submonoid {R : Type u} [semiring R] (s : set (subsemiring R)) :
    to_add_submonoid (Inf s) =
        infi fun (t : subsemiring R) => infi fun (H : t ∈ s) => to_add_submonoid t :=
  mk'_to_add_submonoid (has_Inf._proof_1 s) (has_Inf._proof_2 s)

/-- Subsemirings of a semiring form a complete lattice. -/
protected instance complete_lattice {R : Type u} [semiring R] : complete_lattice (subsemiring R) :=
  complete_lattice.mk complete_lattice.sup complete_lattice.le complete_lattice.lt sorry sorry sorry
    sorry sorry sorry has_inf.inf sorry sorry sorry ⊤ sorry ⊥ sorry complete_lattice.Sup
    complete_lattice.Inf sorry sorry sorry sorry

/-- The `subsemiring` generated by a set. -/
def closure {R : Type u} [semiring R] (s : set R) : subsemiring R :=
  Inf (set_of fun (S : subsemiring R) => s ⊆ ↑S)

theorem mem_closure {R : Type u} [semiring R] {x : R} {s : set R} :
    x ∈ closure s ↔ ∀ (S : subsemiring R), s ⊆ ↑S → x ∈ S :=
  mem_Inf

/-- The subsemiring generated by a set includes the set. -/
@[simp] theorem subset_closure {R : Type u} [semiring R] {s : set R} : s ⊆ ↑(closure s) :=
  fun (x : R) (hx : x ∈ s) => iff.mpr mem_closure fun (S : subsemiring R) (hS : s ⊆ ↑S) => hS hx

/-- A subsemiring `S` includes `closure s` if and only if it includes `s`. -/
@[simp] theorem closure_le {R : Type u} [semiring R] {s : set R} {t : subsemiring R} :
    closure s ≤ t ↔ s ⊆ ↑t :=
  { mp := set.subset.trans subset_closure, mpr := fun (h : s ⊆ ↑t) => Inf_le h }

/-- Subsemiring closure of a set is monotone in its argument: if `s ⊆ t`,
then `closure s ≤ closure t`. -/
theorem closure_mono {R : Type u} [semiring R] {s : set R} {t : set R} (h : s ⊆ t) :
    closure s ≤ closure t :=
  iff.mpr closure_le (set.subset.trans h subset_closure)

theorem closure_eq_of_le {R : Type u} [semiring R] {s : set R} {t : subsemiring R} (h₁ : s ⊆ ↑t)
    (h₂ : t ≤ closure s) : closure s = t :=
  le_antisymm (iff.mpr closure_le h₁) h₂

/-- An induction principle for closure membership. If `p` holds for `0`, `1`, and all elements
of `s`, and is preserved under addition and multiplication, then `p` holds for all elements
of the closure of `s`. -/
theorem closure_induction {R : Type u} [semiring R] {s : set R} {p : R → Prop} {x : R}
    (h : x ∈ closure s) (Hs : ∀ (x : R), x ∈ s → p x) (H0 : p 0) (H1 : p 1)
    (Hadd : ∀ (x y : R), p x → p y → p (x + y)) (Hmul : ∀ (x y : R), p x → p y → p (x * y)) : p x :=
  iff.mpr closure_le Hs x h

theorem mem_closure_iff {R : Type u} [semiring R] {s : set R} {x : R} :
    x ∈ closure s ↔ x ∈ add_submonoid.closure ↑(submonoid.closure s) :=
  sorry

theorem mem_closure_iff_exists_list {R : Type u} [semiring R] {s : set R} {x : R} :
    x ∈ closure s ↔
        ∃ (L : List (List R)),
          (∀ (t : List R), t ∈ L → ∀ (y : R), y ∈ t → y ∈ s) ∧
            list.sum (list.map list.prod L) = x :=
  sorry

/-- `closure` forms a Galois insertion with the coercion to set. -/
protected def gi (R : Type u) [semiring R] : galois_insertion closure coe :=
  galois_insertion.mk (fun (s : set R) (_x : ↑(closure s) ≤ s) => closure s) sorry sorry sorry

/-- Closure of a subsemiring `S` equals `S`. -/
theorem closure_eq {R : Type u} [semiring R] (s : subsemiring R) : closure ↑s = s :=
  galois_insertion.l_u_eq (subsemiring.gi R) s

@[simp] theorem closure_empty {R : Type u} [semiring R] : closure ∅ = ⊥ :=
  galois_connection.l_bot (galois_insertion.gc (subsemiring.gi R))

@[simp] theorem closure_univ {R : Type u} [semiring R] : closure set.univ = ⊤ :=
  coe_top ▸ closure_eq ⊤

theorem closure_union {R : Type u} [semiring R] (s : set R) (t : set R) :
    closure (s ∪ t) = closure s ⊔ closure t :=
  galois_connection.l_sup (galois_insertion.gc (subsemiring.gi R))

theorem closure_Union {R : Type u} [semiring R] {ι : Sort u_1} (s : ι → set R) :
    closure (set.Union fun (i : ι) => s i) = supr fun (i : ι) => closure (s i) :=
  galois_connection.l_supr (galois_insertion.gc (subsemiring.gi R))

theorem closure_sUnion {R : Type u} [semiring R] (s : set (set R)) :
    closure (⋃₀s) = supr fun (t : set R) => supr fun (H : t ∈ s) => closure t :=
  galois_connection.l_Sup (galois_insertion.gc (subsemiring.gi R))

theorem map_sup {R : Type u} {S : Type v} [semiring R] [semiring S] (s : subsemiring R)
    (t : subsemiring R) (f : R →+* S) : map f (s ⊔ t) = map f s ⊔ map f t :=
  galois_connection.l_sup (gc_map_comap f)

theorem map_supr {R : Type u} {S : Type v} [semiring R] [semiring S] {ι : Sort u_1} (f : R →+* S)
    (s : ι → subsemiring R) : map f (supr s) = supr fun (i : ι) => map f (s i) :=
  galois_connection.l_supr (gc_map_comap f)

theorem comap_inf {R : Type u} {S : Type v} [semiring R] [semiring S] (s : subsemiring S)
    (t : subsemiring S) (f : R →+* S) : comap f (s ⊓ t) = comap f s ⊓ comap f t :=
  galois_connection.u_inf (gc_map_comap f)

theorem comap_infi {R : Type u} {S : Type v} [semiring R] [semiring S] {ι : Sort u_1} (f : R →+* S)
    (s : ι → subsemiring S) : comap f (infi s) = infi fun (i : ι) => comap f (s i) :=
  galois_connection.u_infi (gc_map_comap f)

@[simp] theorem map_bot {R : Type u} {S : Type v} [semiring R] [semiring S] (f : R →+* S) :
    map f ⊥ = ⊥ :=
  galois_connection.l_bot (gc_map_comap f)

@[simp] theorem comap_top {R : Type u} {S : Type v} [semiring R] [semiring S] (f : R →+* S) :
    comap f ⊤ = ⊤ :=
  galois_connection.u_top (gc_map_comap f)

/-- Given `subsemiring`s `s`, `t` of semirings `R`, `S` respectively, `s.prod t` is `s × t`
as a subsemiring of `R × S`. -/
def prod {R : Type u} {S : Type v} [semiring R] [semiring S] (s : subsemiring R)
    (t : subsemiring S) : subsemiring (R × S) :=
  mk (set.prod ↑s ↑t) sorry sorry sorry sorry

theorem coe_prod {R : Type u} {S : Type v} [semiring R] [semiring S] (s : subsemiring R)
    (t : subsemiring S) : ↑(prod s t) = set.prod ↑s ↑t :=
  rfl

theorem mem_prod {R : Type u} {S : Type v} [semiring R] [semiring S] {s : subsemiring R}
    {t : subsemiring S} {p : R × S} : p ∈ prod s t ↔ prod.fst p ∈ s ∧ prod.snd p ∈ t :=
  iff.rfl

theorem prod_mono {R : Type u} {S : Type v} [semiring R] [semiring S] {s₁ : subsemiring R}
    {s₂ : subsemiring R} (hs : s₁ ≤ s₂) {t₁ : subsemiring S} {t₂ : subsemiring S} (ht : t₁ ≤ t₂) :
    prod s₁ t₁ ≤ prod s₂ t₂ :=
  set.prod_mono hs ht

theorem prod_mono_right {R : Type u} {S : Type v} [semiring R] [semiring S] (s : subsemiring R) :
    monotone fun (t : subsemiring S) => prod s t :=
  prod_mono (le_refl s)

theorem prod_mono_left {R : Type u} {S : Type v} [semiring R] [semiring S] (t : subsemiring S) :
    monotone fun (s : subsemiring R) => prod s t :=
  fun (s₁ s₂ : subsemiring R) (hs : s₁ ≤ s₂) => prod_mono hs (le_refl t)

theorem prod_top {R : Type u} {S : Type v} [semiring R] [semiring S] (s : subsemiring R) :
    prod s ⊤ = comap (ring_hom.fst R S) s :=
  sorry

theorem top_prod {R : Type u} {S : Type v} [semiring R] [semiring S] (s : subsemiring S) :
    prod ⊤ s = comap (ring_hom.snd R S) s :=
  sorry

@[simp] theorem top_prod_top {R : Type u} {S : Type v} [semiring R] [semiring S] : prod ⊤ ⊤ = ⊤ :=
  Eq.trans (top_prod ⊤) (comap_top (ring_hom.snd R S))

/-- Product of subsemirings is isomorphic to their product as monoids. -/
def prod_equiv {R : Type u} {S : Type v} [semiring R] [semiring S] (s : subsemiring R)
    (t : subsemiring S) : ↥(prod s t) ≃+* ↥s × ↥t :=
  ring_equiv.mk (equiv.to_fun (equiv.set.prod ↑s ↑t)) (equiv.inv_fun (equiv.set.prod ↑s ↑t)) sorry
    sorry sorry sorry

theorem mem_supr_of_directed {R : Type u} [semiring R] {ι : Sort u_1} [hι : Nonempty ι]
    {S : ι → subsemiring R} (hS : directed LessEq S) {x : R} :
    (x ∈ supr fun (i : ι) => S i) ↔ ∃ (i : ι), x ∈ S i :=
  sorry

theorem coe_supr_of_directed {R : Type u} [semiring R] {ι : Sort u_1} [hι : Nonempty ι]
    {S : ι → subsemiring R} (hS : directed LessEq S) :
    ↑(supr fun (i : ι) => S i) = set.Union fun (i : ι) => ↑(S i) :=
  sorry

theorem mem_Sup_of_directed_on {R : Type u} [semiring R] {S : set (subsemiring R)}
    (Sne : set.nonempty S) (hS : directed_on LessEq S) {x : R} :
    x ∈ Sup S ↔ ∃ (s : subsemiring R), ∃ (H : s ∈ S), x ∈ s :=
  sorry

theorem coe_Sup_of_directed_on {R : Type u} [semiring R] {S : set (subsemiring R)}
    (Sne : set.nonempty S) (hS : directed_on LessEq S) :
    ↑(Sup S) = set.Union fun (s : subsemiring R) => set.Union fun (H : s ∈ S) => ↑s :=
  sorry

end subsemiring

namespace ring_hom

/-- Restriction of a ring homomorphism to a subsemiring of the domain. -/
def srestrict {R : Type u} {S : Type v} [semiring R] [semiring S] (f : R →+* S)
    (s : subsemiring R) : ↥s →+* S :=
  comp f (subsemiring.subtype s)

@[simp] theorem srestrict_apply {R : Type u} {S : Type v} [semiring R] [semiring S]
    {s : subsemiring R} (f : R →+* S) (x : ↥s) : coe_fn (srestrict f s) x = coe_fn f ↑x :=
  rfl

/-- Restriction of a ring homomorphism to a subsemiring of the codomain. -/
def cod_srestrict {R : Type u} {S : Type v} [semiring R] [semiring S] (f : R →+* S)
    (s : subsemiring S) (h : ∀ (x : R), coe_fn f x ∈ s) : R →+* ↥s :=
  mk (fun (n : R) => { val := coe_fn f n, property := h n }) sorry sorry sorry sorry

/-- Restriction of a ring homomorphism to its range iterpreted as a subsemiring. -/
def srange_restrict {R : Type u} {S : Type v} [semiring R] [semiring S] (f : R →+* S) :
    R →+* ↥(srange f) :=
  cod_srestrict f (srange f) sorry

@[simp] theorem coe_srange_restrict {R : Type u} {S : Type v} [semiring R] [semiring S]
    (f : R →+* S) (x : R) : ↑(coe_fn (srange_restrict f) x) = coe_fn f x :=
  rfl

theorem srange_top_iff_surjective {R : Type u} {S : Type v} [semiring R] [semiring S]
    {f : R →+* S} : srange f = ⊤ ↔ function.surjective ⇑f :=
  sorry

/-- The range of a surjective ring homomorphism is the whole of the codomain. -/
theorem srange_top_of_surjective {R : Type u} {S : Type v} [semiring R] [semiring S] (f : R →+* S)
    (hf : function.surjective ⇑f) : srange f = ⊤ :=
  iff.mpr srange_top_iff_surjective hf

/-- The subsemiring of elements `x : R` such that `f x = g x` -/
def eq_slocus {R : Type u} {S : Type v} [semiring R] [semiring S] (f : R →+* S) (g : R →+* S) :
    subsemiring R :=
  subsemiring.mk (set_of fun (x : R) => coe_fn f x = coe_fn g x) sorry sorry sorry sorry

/-- If two ring homomorphisms are equal on a set, then they are equal on its subsemiring closure. -/
theorem eq_on_sclosure {R : Type u} {S : Type v} [semiring R] [semiring S] {f : R →+* S}
    {g : R →+* S} {s : set R} (h : set.eq_on (⇑f) (⇑g) s) :
    set.eq_on ⇑f ⇑g ↑(subsemiring.closure s) :=
  (fun (this : subsemiring.closure s ≤ eq_slocus f g) => this) (iff.mpr subsemiring.closure_le h)

theorem eq_of_eq_on_stop {R : Type u} {S : Type v} [semiring R] [semiring S] {f : R →+* S}
    {g : R →+* S} (h : set.eq_on ⇑f ⇑g ↑⊤) : f = g :=
  ext fun (x : R) => h trivial

theorem eq_of_eq_on_sdense {R : Type u} {S : Type v} [semiring R] [semiring S] {s : set R}
    (hs : subsemiring.closure s = ⊤) {f : R →+* S} {g : R →+* S} (h : set.eq_on (⇑f) (⇑g) s) :
    f = g :=
  eq_of_eq_on_stop (hs ▸ eq_on_sclosure h)

theorem sclosure_preimage_le {R : Type u} {S : Type v} [semiring R] [semiring S] (f : R →+* S)
    (s : set S) : subsemiring.closure (⇑f ⁻¹' s) ≤ subsemiring.comap f (subsemiring.closure s) :=
  iff.mpr subsemiring.closure_le
    fun (x : R) (hx : x ∈ ⇑f ⁻¹' s) =>
      iff.mpr subsemiring.mem_coe (iff.mpr subsemiring.mem_comap (subsemiring.subset_closure hx))

/-- The image under a ring homomorphism of the subsemiring generated by a set equals
the subsemiring generated by the image of the set. -/
theorem map_sclosure {R : Type u} {S : Type v} [semiring R] [semiring S] (f : R →+* S) (s : set R) :
    subsemiring.map f (subsemiring.closure s) = subsemiring.closure (⇑f '' s) :=
  sorry

end ring_hom

namespace subsemiring

/-- The ring homomorphism associated to an inclusion of subsemirings. -/
def inclusion {R : Type u} [semiring R] {S : subsemiring R} {T : subsemiring R} (h : S ≤ T) :
    ↥S →* ↥T :=
  ↑(ring_hom.cod_srestrict (subtype S) T sorry)

@[simp] theorem srange_subtype {R : Type u} [semiring R] (s : subsemiring R) :
    ring_hom.srange (subtype s) = s :=
  ext' (Eq.trans (ring_hom.coe_srange (subtype s)) subtype.range_coe)

@[simp] theorem range_fst {R : Type u} {S : Type v} [semiring R] [semiring S] :
    ring_hom.srange (ring_hom.fst R S) = ⊤ :=
  ring_hom.srange_top_of_surjective (ring_hom.fst R S) prod.fst_surjective

@[simp] theorem range_snd {R : Type u} {S : Type v} [semiring R] [semiring S] :
    ring_hom.srange (ring_hom.snd R S) = ⊤ :=
  ring_hom.srange_top_of_surjective (ring_hom.snd R S) prod.snd_surjective

@[simp] theorem prod_bot_sup_bot_prod {R : Type u} {S : Type v} [semiring R] [semiring S]
    (s : subsemiring R) (t : subsemiring S) : prod s ⊥ ⊔ prod ⊥ t = prod s t :=
  sorry

end subsemiring

namespace ring_equiv

/-- Makes the identity isomorphism from a proof two subsemirings of a multiplicative
    monoid are equal. -/
def subsemiring_congr {R : Type u} [semiring R] {s : subsemiring R} {t : subsemiring R}
    (h : s = t) : ↥s ≃+* ↥t :=
  mk (equiv.to_fun (equiv.set_congr sorry)) (equiv.inv_fun (equiv.set_congr sorry)) sorry sorry
    sorry sorry

end Mathlib


/-
Copyright (c) 2020 Floris van Doorn. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Floris van Doorn, Yaël Dillies
-/
import topology.sets.opens

/-!
# Closed sets

We define a few types of closed sets in a topological space.

## Main Definitions

For a topological space `α`,
* `closeds α`: The type of closed sets.
* `clopens α`: The type of clopen sets.
-/

open set

variables {α β : Type*} [topological_space α] [topological_space β]

namespace topological_space

/-! ### Closed sets -/

/-- The type of closed subsets of a topological space. -/
structure closeds (α : Type*) [topological_space α] :=
(carrier : set α)
(closed' : is_closed carrier)

namespace closeds
variables {α}

instance : set_like (closeds α) α :=
{ coe := closeds.carrier,
  coe_injective' := λ s t h, by { cases s, cases t, congr' } }

lemma closed (s : closeds α) : is_closed (s : set α) := s.closed'

@[ext] protected lemma ext {s t : closeds α} (h : (s : set α) = t) : s = t := set_like.ext' h

@[simp]

instance : has_sup (closeds α) := ⟨λ s t, ⟨s ∪ t, s.closed.union t.closed⟩⟩
instance : has_inf (closeds α) := ⟨λ s t, ⟨s ∩ t, s.closed.inter t.closed⟩⟩
instance : has_top (closeds α) := ⟨⟨univ, is_closed_univ⟩⟩
instance : has_bot (closeds α) := ⟨⟨∅, is_closed_empty⟩⟩

instance : distrib_lattice (closeds α) :=
set_like.coe_injective.distrib_lattice _ (λ _ _, rfl) (λ _ _, rfl)
instance : bounded_order (closeds α) := bounded_order.lift (coe : _ → set α) (λ _ _, id) rfl rfl

/-- The type of closed sets is inhabited, with default element the empty set. -/
instance : inhabited (closeds α) := ⟨⊥⟩

@[simp] lemma coe_sup (s t : closeds α) : (↑(s ⊔ t) : set α) = s ∪ t := rfl
@[simp] lemma coe_inf (s t : closeds α) : (↑(s ⊓ t) : set α) = s ∩ t := rfl
@[simp] lemma coe_top : (↑(⊤ : closeds α) : set α) = univ := rfl
@[simp] lemma coe_bot : (↑(⊥ : closeds α) : set α) = ∅ := rfl

end closeds

/-! ### Clopen sets -/

/-- The type of clopen sets of a topological space. -/
structure clopens (α : Type*) [topological_space α] :=
(carrier : set α)
(clopen' : is_clopen carrier)

namespace clopens

instance : set_like (clopens α) α :=
{ coe := λ s, s.carrier,
  coe_injective' := λ s t h, by { cases s, cases t, congr' } }

lemma clopen (s : clopens α) : is_clopen (s : set α) := s.clopen'

/-- Reinterpret a compact open as an open. -/
@[simps] def to_opens (s : clopens α) : opens α := ⟨s, s.clopen.is_open⟩

@[ext] protected lemma ext {s t : clopens α} (h : (s : set α) = t) : s = t := set_like.ext' h

@[simp] lemma coe_mk (s : set α) (h) : (mk s h : set α) = s := rfl

instance : has_sup (clopens α) := ⟨λ s t, ⟨s ∪ t, s.clopen.union t.clopen⟩⟩
instance : has_inf (clopens α) := ⟨λ s t, ⟨s ∩ t, s.clopen.inter t.clopen⟩⟩
instance : has_top (clopens α) := ⟨⟨⊤, is_clopen_univ⟩⟩
instance : has_bot (clopens α) := ⟨⟨⊥, is_clopen_empty⟩⟩
instance : has_sdiff (clopens α) := ⟨λ s t, ⟨s \ t, s.clopen.diff t.clopen⟩⟩
instance : has_compl (clopens α) := ⟨λ s, ⟨sᶜ, s.clopen.compl⟩⟩

instance : boolean_algebra (clopens α) :=
set_like.coe_injective.boolean_algebra _ (λ _ _, rfl) (λ _ _, rfl) rfl rfl (λ _, rfl) (λ _ _, rfl)

@[simp] lemma coe_sup (s t : clopens α) : (↑(s ⊔ t) : set α) = s ∪ t := rfl
@[simp] lemma coe_inf (s t : clopens α) : (↑(s ⊓ t) : set α) = s ∩ t := rfl
@[simp] lemma coe_top : (↑(⊤ : clopens α) : set α) = univ := rfl
@[simp] lemma coe_bot : (↑(⊥ : clopens α) : set α) = ∅ := rfl
@[simp] lemma coe_sdiff (s t : clopens α) : (↑(s \ t) : set α) = s \ t := rfl
@[simp] lemma coe_compl (s : clopens α) : (↑sᶜ : set α) = sᶜ := rfl

instance : inhabited (clopens α) := ⟨⊥⟩

end clopens
end topological_space


import data.fintype.basic

structure dfa (S : Type) [fintype S] :=
  (Q : Type) -- states
  [Qfin : fintype Q]
  (start : Q) -- starting state
  (term : set Q) -- terminal states
  (next : Q → S → Q) -- transitions

variables {S : Type} [fintype S] (d : dfa S)

namespace dfa

open_locale classical
noncomputable theory

instance : fintype d.Q := d.Qfin

def go {d : dfa S} : d.Q → list S → d.Q
| q []             := q
| q (head :: tail) := go (d.next q head) tail

@[simp] lemma go_nil (a : d.Q) : go a [] = a := rfl
@[simp] lemma go_cons (a : d.Q) (head : S) (tail : list S) : go a (head :: tail) = go (d.next a head) tail := rfl

@[simp] lemma go_append (q : d.Q) (u v : list S) :
  go q (u ++ v) = go (go q u) v :=
begin
  induction u with hd tl ih generalizing q, {
    simp,
  }, {
    specialize ih (d.next q hd),
    simpa using ih,
  }
end

def state_equiv (d : dfa S) (u v : d.Q) := ∀ (w : list S), go u w ∈ d.term ↔ go v w ∈ d.term

@[simp] lemma state_equiv_def (u v : d.Q) : state_equiv d u v = ∀ w, go u w ∈ d.term ↔ go v w ∈ d.term := rfl

lemma state_equiv_reflexive : reflexive (state_equiv d) := λ v, by simp

lemma state_equiv_symmetric : symmetric (state_equiv d) := λ u v h w, by simp only [h w]

lemma state_equiv_transitive : transitive (state_equiv d) := λ a b c hab hbc w, by simp only [hab w, hbc w]

lemma state_equiv_equivalence: equivalence (state_equiv d) :=
  ⟨state_equiv_reflexive d, state_equiv_symmetric d, state_equiv_transitive d⟩

instance setoid : setoid d.Q := ⟨state_equiv d, state_equiv_equivalence d⟩

def Q' (d : dfa S) := quotient d.setoid

@[simp] lemma state_equiv_equiv (a b : d.Q) : a ≈ b ↔ ∀ w, go a w ∈ d.term ↔ go b w ∈ d.term := by refl

def term' (d : dfa S) : set d.Q' := quotient.lift (d.term)
begin
  rintro a b hab,
  specialize hab [],
  simpa using hab,
end

def next' (d : dfa S) (c : S) : d.Q' → d.Q' := quotient.lift (λ q, ⟦d.next q c⟧)
begin
  rintro a b hab,
  dsimp only,
  rw [quotient.eq, state_equiv_equiv],
  intro w,
  specialize hab (c :: w),
  simpa using hab,
end

def min_dfa (d : dfa S) : dfa S :=
  { Q := Q' d,
    Qfin := quotient.fintype _,
    start := ⟦d.start⟧,
    term  := term' d,
    next  := λ q c, next' d c q}

@[simp] lemma min_dfa_Q {d : dfa S} : (min_dfa d).Q = quotient (d.setoid) := rfl
@[simp] lemma min_dfa_start {d : dfa S} : (min_dfa d).start = ⟦d.start⟧ := rfl
@[simp] lemma min_dfa_term {d : dfa S} {q} : ⟦q⟧ ∈ (min_dfa d).term ↔ q ∈ d.term := by refl
@[simp] lemma min_dfa_next {d : dfa S} {q} {c : S}: (min_dfa d).next ⟦q⟧ c = ⟦d.next q c⟧ := by refl
@[simp] theorem min_dfa_go (d : dfa S) {a} {w}: @go _ _ (min_dfa d) ⟦a⟧ w = ⟦go a w⟧ :=
begin
  induction w with head tail ih generalizing a, {
    simp only [state_equiv_equiv, forall_const, state_equiv_def, iff_self, go_nil],
  }, {
    specialize @ih (d.next a head),
    rw [go, go],
    exact ih,
  },
end

def language (d : dfa S) := {w | go d.start w ∈ d.term}

@[simp] lemma mem_dfa_language_iff {w : list S} {d : dfa S} :
  w ∈ d.language ↔ go d.start w ∈ d.term := iff.rfl

theorem min_dfa_lang_eq_dfa_lang (d : dfa S) : d.language = (min_dfa d).language :=
begin
  ext,
  simp,
end

theorem min_dfa_card_le (d : dfa S) : fintype.card (min_dfa d).Q ≤ fintype.card d.Q :=
begin
  simp,
  exact fintype.card_quotient_le (dfa.setoid d),
end

def all_reachable (d : dfa S) := ∀ q : d.Q, ∃ w, go d.start w = q

end dfa

namespace right_ctx

variable {L : set (list S)}

def r (L : set (list S)) (u v : list S) := ∀ w, (u ++ w) ∈ L ↔ (v ++ w) ∈ L

@[simp] lemma r_def {u v} : (r L) u v ↔ ∀ w, (u ++ w) ∈ L ↔ (v ++ w) ∈ L := iff.rfl

def r_refl : reflexive (r L) := λ a, by simp

def r_symm : symmetric (r L) := λ a b hab w, by simp [hab w]

def r_trans : transitive (r L) := λ a b c hab hbc w, by simp [hab w, hbc w]

instance setoid : setoid (list S) := ⟨r L, r_refl, r_symm, r_trans⟩

def right_ctx (L : set (list S)) := quotient (@right_ctx.setoid S _ L)

-- @[simp] lemma right_ctx_equiv (u v : list S) :
--   u ≈ v ↔ ∀ w, (u ++ w) ∈ L ↔ (v ++ w) ∈ L := iff.rfl

end right_ctx

namespace myhill_nerode

open dfa right_ctx

def myhill_nerode_equiv {d : dfa S} (hd : d.all_reachable): (min_dfa d).Q ≃ (right_ctx d.language) :=
begin
  letI := @right_ctx.setoid S _ d.language,
  exact {
    to_fun := quotient.map (λ q, classical.some (hd q))
    begin
      rintro a b rab,
      simp at rab,
      simp [has_equiv.equiv, setoid.r, r],
      have ha := classical.some_spec (hd a),
      have hb := classical.some_spec (hd b),
      simpa [ha, hb] using rab,
    end,
    inv_fun := quotient.map (λ w, go d.start w)
    begin
      rintro u v ruv,
      simpa [has_equiv.equiv, setoid.r] using ruv,
    end,
    left_inv := λ q,
    begin
      apply quotient.induction_on q, clear q, intro q,
      have hq := classical.some_spec (hd q),
      simp [hq],
    end,
    right_inv := λ w,
    begin
      apply quotient.induction_on w, clear w, intro w,
      have hw := classical.some_spec (hd (go d.start w)),
      simp [has_equiv.equiv, setoid.r, hw],
    end
  },
end

theorem min_dfas_equiv {d d' : dfa S} (hd : d.all_reachable) (hd' : d'.all_reachable) (hl : d.language = d'.language) : (min_dfa d).Q ≃ (min_dfa d').Q :=
begin
  have e1 := myhill_nerode_equiv hd,
  have e2 := (myhill_nerode_equiv hd').symm,
  rw hl at e1,
  exact equiv.trans e1 e2,
end

end myhill_nerode


/-
Copyright (c) 2018 Johannes Hölzl. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Johannes Hölzl
-/
import algebra.algebra.basic
import algebra.field.basic
import algebra.group.type_tags
import logic.equiv.basic
import ring_theory.ideal.local_ring

/-!
# Transfer algebraic structures across `equiv`s

In this file we prove theorems of the following form: if `β` has a
group structure and `α ≃ β` then `α` has a group structure, and
similarly for monoids, semigroups, rings, integral domains, fields and
so on.

Note that most of these constructions can also be obtained using the `transport` tactic.

## Tags

equiv, group, ring, field, module, algebra
-/

universes u v
variables {α : Type u} {β : Type v}

namespace equiv

section instances

variables (e : α ≃ β)

/-- Transfer `has_one` across an `equiv` -/
@[to_additive "Transfer `has_zero` across an `equiv`"]
protected def has_one [has_one β] : has_one α := ⟨e.symm 1⟩
@[to_additive]
lemma one_def [has_one β] : @has_one.one _ (equiv.has_one e) = e.symm 1 := rfl

/-- Transfer `has_mul` across an `equiv` -/
@[to_additive "Transfer `has_add` across an `equiv`"]
protected def has_mul [has_mul β] : has_mul α := ⟨λ x y, e.symm (e x * e y)⟩
@[to_additive]
lemma mul_def [has_mul β] (x y : α) :
  @has_mul.mul _ (equiv.has_mul e) x y = e.symm (e x * e y) := rfl

/-- Transfer `has_div` across an `equiv` -/
@[to_additive "Transfer `has_sub` across an `equiv`"]
protected def has_div [has_div β] : has_div α := ⟨λ x y, e.symm (e x / e y)⟩
@[to_additive]
lemma div_def [has_div β] (x y : α) :
@has_div.div _ (equiv.has_div e) x y = e.symm (e x / e y) := rfl

/-- Transfer `has_inv` across an `equiv` -/
@[to_additive "Transfer `has_neg` across an `equiv`"]
protected def has_inv [has_inv β] : has_inv α := ⟨λ x, e.symm (e x)⁻¹⟩
@[to_additive]
lemma inv_def [has_inv β] (x : α) : @has_inv.inv _ (equiv.has_inv e) x = e.symm (e x)⁻¹ := rfl

/-- Transfer `has_scalar` across an `equiv` -/
protected def has_scalar (R : Type*) [has_scalar R β] : has_scalar R α  :=
⟨λ r x, e.symm (r • (e x))⟩
lemma smul_def {R : Type*} [has_scalar R β] (r : R) (x : α) :
  @has_scalar.smul _ _ (e.has_scalar R) r x = e.symm (r • (e x)) := rfl

/-- Transfer `has_pow` across an `equiv` -/
@[to_additive has_scalar]
protected def has_pow (N : Type*) [has_pow β N] : has_pow α N  :=
⟨λ x n, e.symm (e x ^ n)⟩
lemma pow_def {N : Type*} [has_pow β N] (n : N) (x : α) :
  @has_pow.pow _ _ (e.has_pow N) x n = e.symm (e x ^ n) := rfl

/--
An equivalence `e : α ≃ β` gives a multiplicative equivalence `α ≃* β`
where the multiplicative structure on `α` is
the one obtained by transporting a multiplicative structure on `β` back along `e`.
-/
@[to_additive
"An equivalence `e : α ≃ β` gives a additive equivalence `α ≃+ β`
where the additive structure on `α` is
the one obtained by transporting an additive structure on `β` back along `e`."]
def mul_equiv (e : α ≃ β) [has_mul β] :
  by { letI := equiv.has_mul e, exact α ≃* β } :=
begin
  introsI,
  exact
  { map_mul' := λ x y, by { apply e.symm.injective, simp, refl, },
    ..e }
end

@[simp, to_additive] lemma mul_equiv_apply (e : α ≃ β) [has_mul β] (a : α) :
  (mul_equiv e) a = e a := rfl

@[to_additive] lemma mul_equiv_symm_apply (e : α ≃ β) [has_mul β] (b : β) :
  by { letI := equiv.has_mul e, exact (mul_equiv e).symm b = e.symm b } :=
begin
  intros, refl,
end

/--
An equivalence `e : α ≃ β` gives a ring equivalence `α ≃+* β`
where the ring structure on `α` is
the one obtained by transporting a ring structure on `β` back along `e`.
-/
def ring_equiv (e : α ≃ β) [has_add β] [has_mul β] :
  by { letI := equiv.has_add e, letI := equiv.has_mul e, exact α ≃+* β } :=
begin
  introsI,
  exact
  { map_add' := λ x y, by { apply e.symm.injective, simp, refl, },
    map_mul' := λ x y, by { apply e.symm.injective, simp, refl, },
    ..e }
end

@[simp] lemma ring_equiv_apply (e : α ≃ β) [has_add β] [has_mul β] (a : α) :
  (ring_equiv e) a = e a := rfl

lemma ring_equiv_symm_apply (e : α ≃ β) [has_add β] [has_mul β] (b : β) :
  by { letI := equiv.has_add e, letI := equiv.has_mul e, exact (ring_equiv e).symm b = e.symm b } :=
begin
  intros, refl,
end

/-- Transfer `semigroup` across an `equiv` -/
@[to_additive "Transfer `add_semigroup` across an `equiv`"]
protected def semigroup [semigroup β] : semigroup α :=
let mul := e.has_mul in
by resetI; apply e.injective.semigroup _; intros; exact e.apply_symm_apply _

/-- Transfer `semigroup_with_zero` across an `equiv` -/
protected def semigroup_with_zero [semigroup_with_zero β] : semigroup_with_zero α :=
let mul := e.has_mul, zero := e.has_zero in
by resetI; apply e.injective.semigroup_with_zero _; intros; exact e.apply_symm_apply _

/-- Transfer `comm_semigroup` across an `equiv` -/
@[to_additive "Transfer `add_comm_semigroup` across an `equiv`"]
protected def comm_semigroup [comm_semigroup β] : comm_semigroup α :=
let mul := e.has_mul in
by resetI; apply e.injective.comm_semigroup _; intros; exact e.apply_symm_apply _

/-- Transfer `mul_zero_class` across an `equiv` -/
protected def mul_zero_class [mul_zero_class β] : mul_zero_class α :=
let zero := e.has_zero, mul := e.has_mul in
by resetI; apply e.injective.mul_zero_class _; intros; exact e.apply_symm_apply _

/-- Transfer `mul_one_class` across an `equiv` -/
@[to_additive "Transfer `add_zero_class` across an `equiv`"]
protected def mul_one_class [mul_one_class β] : mul_one_class α :=
let one := e.has_one, mul := e.has_mul in
by resetI; apply e.injective.mul_one_class _; intros; exact e.apply_symm_apply _

/-- Transfer `mul_zero_one_class` across an `equiv` -/
protected def mul_zero_one_class [mul_zero_one_class β] : mul_zero_one_class α :=
let zero := e.has_zero, one := e.has_one,mul := e.has_mul in
by resetI; apply e.injective.mul_zero_one_class _; intros; exact e.apply_symm_apply _

/-- Transfer `monoid` across an `equiv` -/
@[to_additive "Transfer `add_monoid` across an `equiv`"]
protected def monoid [monoid β] : monoid α :=
let one := e.has_one, mul := e.has_mul, pow := e.has_pow ℕ in
by resetI; apply e.injective.monoid _; intros; exact e.apply_symm_apply _

/-- Transfer `comm_monoid` across an `equiv` -/
@[to_additive "Transfer `add_comm_monoid` across an `equiv`"]
protected def comm_monoid [comm_monoid β] : comm_monoid α :=
let one := e.has_one, mul := e.has_mul, pow := e.has_pow ℕ in
by resetI; apply e.injective.comm_monoid _; intros; exact e.apply_symm_apply _

/-- Transfer `group` across an `equiv` -/
@[to_additive "Transfer `add_group` across an `equiv`"]
protected def group [group β] : group α :=
let one := e.has_one, mul := e.has_mul, inv := e.has_inv, div := e.has_div,
  npow := e.has_pow ℕ, zpow := e.has_pow ℤ in
by resetI; apply e.injective.group _; intros; exact e.apply_symm_apply _

/-- Transfer `comm_group` across an `equiv` -/
@[to_additive "Transfer `add_comm_group` across an `equiv`"]
protected def comm_group [comm_group β] : comm_group α :=
let one := e.has_one, mul := e.has_mul, inv := e.has_inv, div := e.has_div,
  npow := e.has_pow ℕ, zpow := e.has_pow ℤ in
by resetI; apply e.injective.comm_group _; intros; exact e.apply_symm_apply _

/-- Transfer `non_unital_non_assoc_semiring` across an `equiv` -/
protected def non_unital_non_assoc_semiring [non_unital_non_assoc_semiring β] :
  non_unital_non_assoc_semiring α :=
let zero := e.has_zero, add := e.has_add, mul := e.has_mul, nsmul := e.has_scalar ℕ in
by resetI; apply e.injective.non_unital_non_assoc_semiring _; intros; exact e.apply_symm_apply _

/-- Transfer `non_unital_semiring` across an `equiv` -/
protected def non_unital_semiring [non_unital_semiring β] :  non_unital_semiring α :=
let zero := e.has_zero, add := e.has_add, mul := e.has_mul, nsmul := e.has_scalar ℕ in
by resetI; apply e.injective.non_unital_semiring _; intros; exact e.apply_symm_apply _

/-- Transfer `non_assoc_semiring` across an `equiv` -/
protected def non_assoc_semiring [non_assoc_semiring β] : non_assoc_semiring α :=
let zero := e.has_zero, add := e.has_add, one := e.has_one, mul := e.has_mul,
  nsmul := e.has_scalar ℕ in
by resetI; apply e.injective.non_assoc_semiring _; intros; exact e.apply_symm_apply _

/-- Transfer `semiring` across an `equiv` -/
protected def semiring [semiring β] : semiring α :=
let zero := e.has_zero, add := e.has_add, one := e.has_one, mul := e.has_mul,
  nsmul := e.has_scalar ℕ, npow := e.has_pow ℕ in
by resetI; apply e.injective.semiring _; intros; exact e.apply_symm_apply _

/-- Transfer `comm_semiring` across an `equiv` -/
protected def comm_semiring [comm_semiring β] : comm_semiring α :=
let zero := e.has_zero, add := e.has_add, one := e.has_one, mul := e.has_mul,
  nsmul := e.has_scalar ℕ, npow := e.has_pow ℕ in
by resetI; apply e.injective.comm_semiring _; intros; exact e.apply_symm_apply _

/-- Transfer `non_unital_non_assoc_ring` across an `equiv` -/
protected def non_unital_non_assoc_ring [non_unital_non_assoc_ring β] :
  non_unital_non_assoc_ring α :=
let zero := e.has_zero, add := e.has_add, mul := e.has_mul, neg := e.has_neg, sub := e.has_sub,
  nsmul := e.has_scalar ℕ, zsmul := e.has_scalar ℤ in
by resetI; apply e.injective.non_unital_non_assoc_ring _; intros; exact e.apply_symm_apply _

/-- Transfer `non_unital_ring` across an `equiv` -/
protected def non_unital_ring [non_unital_ring β] :
  non_unital_ring α :=
let zero := e.has_zero, add := e.has_add, mul := e.has_mul, neg := e.has_neg, sub := e.has_sub,
  nsmul := e.has_scalar ℕ, zsmul := e.has_scalar ℤ in
by resetI; apply e.injective.non_unital_ring _; intros; exact e.apply_symm_apply _

/-- Transfer `non_assoc_ring` across an `equiv` -/
protected def non_assoc_ring [non_assoc_ring β] :
  non_assoc_ring α :=
let zero := e.has_zero, add := e.has_add, one := e.has_one, mul := e.has_mul, neg := e.has_neg,
  sub := e.has_sub, nsmul := e.has_scalar ℕ, zsmul := e.has_scalar ℤ in
by resetI; apply e.injective.non_assoc_ring _; intros; exact e.apply_symm_apply _

/-- Transfer `ring` across an `equiv` -/
protected def ring [ring β] : ring α :=
let zero := e.has_zero, add := e.has_add, one := e.has_one, mul := e.has_mul, neg := e.has_neg,
  sub := e.has_sub, nsmul := e.has_scalar ℕ, zsmul := e.has_scalar ℤ, npow := e.has_pow ℕ in
by resetI; apply e.injective.ring _; intros; exact e.apply_symm_apply _

/-- Transfer `comm_ring` across an `equiv` -/
protected def comm_ring [comm_ring β] : comm_ring α :=
let zero := e.has_zero, add := e.has_add, one := e.has_one, mul := e.has_mul, neg := e.has_neg,
  sub := e.has_sub, nsmul := e.has_scalar ℕ, zsmul := e.has_scalar ℤ, npow := e.has_pow ℕ in
by resetI; apply e.injective.comm_ring _; intros; exact e.apply_symm_apply _

/-- Transfer `nontrivial` across an `equiv` -/
protected theorem nontrivial [nontrivial β] : nontrivial α :=
e.surjective.nontrivial

/-- Transfer `is_domain` across an `equiv` -/
protected theorem is_domain [ring α] [ring β] [is_domain β] (e : α ≃+* β) : is_domain α :=
function.injective.is_domain e.to_ring_hom e.injective

/-- Transfer `division_ring` across an `equiv` -/
protected def division_ring [division_ring β] : division_ring α :=
let zero := e.has_zero, add := e.has_add, one := e.has_one, mul := e.has_mul, neg := e.has_neg,
  sub := e.has_sub, inv := e.has_inv, div := e.has_div,
  nsmul := e.has_scalar ℕ, zsmul := e.has_scalar ℤ, npow := e.has_pow ℕ, zpow := e.has_pow ℤ in
by resetI; apply e.injective.division_ring _; intros; exact e.apply_symm_apply _

/-- Transfer `field` across an `equiv` -/
protected def field [field β] : field α :=
let zero := e.has_zero, add := e.has_add, one := e.has_one, mul := e.has_mul, neg := e.has_neg,
  sub := e.has_sub, inv := e.has_inv, div := e.has_div,
  nsmul := e.has_scalar ℕ, zsmul := e.has_scalar ℤ, npow := e.has_pow ℕ, zpow := e.has_pow ℤ in
by resetI; apply e.injective.field _; intros; exact e.apply_symm_apply _

section R
variables (R : Type*)
include R

section
variables [monoid R]

/-- Transfer `mul_action` across an `equiv` -/
protected def mul_action (e : α ≃ β) [mul_action R β] : mul_action R α :=
{ one_smul := by simp [smul_def],
  mul_smul := by simp [smul_def, mul_smul],
  ..e.has_scalar R }

/-- Transfer `distrib_mul_action` across an `equiv` -/
protected def distrib_mul_action (e : α ≃ β) [add_comm_monoid β] :
  begin
    letI := equiv.add_comm_monoid e,
    exact Π [distrib_mul_action R β], distrib_mul_action R α
  end :=
begin
  intros,
  letI := equiv.add_comm_monoid e,
  exact (
  { smul_zero := by simp [zero_def, smul_def],
    smul_add := by simp [add_def, smul_def, smul_add],
    ..equiv.mul_action R e } : distrib_mul_action R α)
end

end

section
variables [semiring R]

/-- Transfer `module` across an `equiv` -/
protected def module (e : α ≃ β) [add_comm_monoid β] :
  begin
    letI := equiv.add_comm_monoid e,
    exact Π [module R β], module R α
  end :=
begin
  introsI,
  exact (
  { zero_smul := by simp [zero_def, smul_def],
    add_smul := by simp [add_def, smul_def, add_smul],
    ..equiv.distrib_mul_action R e } : module R α)
end

/--
An equivalence `e : α ≃ β` gives a linear equivalence `α ≃ₗ[R] β`
where the `R`-module structure on `α` is
the one obtained by transporting an `R`-module structure on `β` back along `e`.
-/
def linear_equiv (e : α ≃ β) [add_comm_monoid β] [module R β] :
  begin
    letI := equiv.add_comm_monoid e,
    letI := equiv.module R e,
    exact α ≃ₗ[R] β
  end :=
begin
  introsI,
  exact
  { map_smul' := λ r x, by { apply e.symm.injective, simp, refl, },
    ..equiv.add_equiv e }
end

end

section
variables [comm_semiring R]

/-- Transfer `algebra` across an `equiv` -/
protected def algebra (e : α ≃ β) [semiring β] :
  begin
    letI := equiv.semiring e,
    exact Π [algebra R β], algebra R α
  end :=
begin
  introsI,
  fapply ring_hom.to_algebra',
  { exact ((ring_equiv e).symm : β →+* α).comp (algebra_map R β), },
  { intros r x,
    simp only [function.comp_app, ring_hom.coe_comp],
    have p := ring_equiv_symm_apply e,
    dsimp at p,
    erw p, clear p,
    apply (ring_equiv e).injective,
    simp only [(ring_equiv e).map_mul],
    simp [algebra.commutes], }
end

/--
An equivalence `e : α ≃ β` gives an algebra equivalence `α ≃ₐ[R] β`
where the `R`-algebra structure on `α` is
the one obtained by transporting an `R`-algebra structure on `β` back along `e`.
-/
def alg_equiv (e : α ≃ β) [semiring β] [algebra R β] :
  begin
    letI := equiv.semiring e,
    letI := equiv.algebra R e,
    exact α ≃ₐ[R] β
  end :=
begin
  introsI,
  exact
  { commutes' := λ r, by { apply e.symm.injective, simp, refl, },
    ..equiv.ring_equiv e }
end

end
end R

end instances
end equiv

namespace ring_equiv

protected lemma local_ring {A B : Type*} [comm_ring A] [local_ring A] [comm_ring B] (e : A ≃+* B) :
  local_ring B :=
begin
  haveI := e.symm.to_equiv.nontrivial,
  refine @local_of_surjective A B _ _ _ _ e e.to_equiv.surjective,
end

end ring_equiv


/-
Copyright (c) 2022 Aaron Anderson. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Aaron Anderson
-/
import data.fintype.basic
import model_theory.substructures

/-!
# Elementary Maps Between First-Order Structures

## Main Definitions
* A `first_order.language.elementary_embedding` is an embedding that commutes with the
  realizations of formulas.
* A `first_order.language.elementary_substructure` is a substructure where the realization of each
  formula agrees with the realization in the larger model.
* The `first_order.language.elementary_diagram` of a structure is the set of all sentences with
  parameters that the structure satisfies.
* `first_order.language.elementary_embedding.of_models_elementary_diagram` is the canonical
elementary embedding of any structure into a model of its elementary diagram.

## Main Results
* The Tarski-Vaught Test for embeddings: `first_order.language.embedding.is_elementary_of_exists`
gives a simple criterion for an embedding to be elementary.
* The Tarski-Vaught Test for substructures: `first_order.language.embedding.is_elementary_of_exists`
gives a simple criterion for a substructure to be elementary.
 -/

open_locale first_order
namespace first_order
namespace language
open Structure

variables (L : language) (M : Type*) (N : Type*) {P : Type*} {Q : Type*}
variables [L.Structure M] [L.Structure N] [L.Structure P] [L.Structure Q]

/-- An elementary embedding of first-order structures is an embedding that commutes with the
  realizations of formulas. -/
structure elementary_embedding :=
(to_fun : M → N)
(map_formula' : ∀{n} (φ : L.formula (fin n)) (x : fin n → M),
  φ.realize (to_fun ∘ x) ↔ φ.realize x . obviously)

localized "notation A ` ↪ₑ[`:25 L `] ` B := first_order.language.elementary_embedding L A B"
  in first_order

variables {L} {M} {N}

namespace elementary_embedding

instance fun_like : fun_like (M ↪ₑ[L] N) M (λ _, N) :=
{ coe := λ f, f.to_fun,
  coe_injective' := λ f g h, begin
    cases f,
    cases g,
    simp only,
    ext x,
    exact function.funext_iff.1 h x end }

instance : has_coe_to_fun (M ↪ₑ[L] N) (λ _, M → N) := fun_like.has_coe_to_fun

@[simp] lemma map_bounded_formula (f : M ↪ₑ[L] N) {α : Type} {n : ℕ}
  (φ : L.bounded_formula α n) (v : α → M) (xs : fin n → M) :
  φ.realize (f ∘ v) (f ∘ xs) ↔ φ.realize v xs :=
begin
  classical,
  rw [← bounded_formula.realize_restrict_free_var set.subset.rfl, set.inclusion_eq_id, iff_eq_eq],
  swap, { apply_instance },
  have h := f.map_formula' ((φ.restrict_free_var id).to_formula.relabel (fintype.equiv_fin _))
    ((sum.elim (v ∘ coe) xs) ∘ (fintype.equiv_fin _).symm),
  simp only [formula.realize_relabel, bounded_formula.realize_to_formula, iff_eq_eq] at h,
  rw [← function.comp.assoc _ _ ((fintype.equiv_fin _).symm),
    function.comp.assoc _ ((fintype.equiv_fin _).symm) (fintype.equiv_fin _),
    equiv.symm_comp_self, function.comp.right_id, function.comp.assoc, sum.elim_comp_inl,
    function.comp.assoc _ _ sum.inr, sum.elim_comp_inr,
    ← function.comp.assoc] at h,
  refine h.trans _,
  rw [function.comp.assoc _ _ (fintype.equiv_fin _), equiv.symm_comp_self,
    function.comp.right_id, sum.elim_comp_inl, sum.elim_comp_inr, ← set.inclusion_eq_id,
    bounded_formula.realize_restrict_free_var set.subset.rfl],
end

@[simp] lemma map_formula (f : M ↪ₑ[L] N) {α : Type} (φ : L.formula α) (x : α → M) :
  φ.realize (f ∘ x) ↔ φ.realize x :=
by rw [formula.realize, formula.realize, ← f.map_bounded_formula, unique.eq_default (f ∘ default)]

lemma map_sentence (f : M ↪ₑ[L] N) (φ : L.sentence) :
  M ⊨ φ ↔ N ⊨ φ :=
by rw [sentence.realize, sentence.realize, ← f.map_formula, unique.eq_default (f ∘ default)]

lemma Theory_model_iff (f : M ↪ₑ[L] N) (T : L.Theory) :
  M ⊨ T ↔ N ⊨ T :=
by simp only [Theory.model_iff, f.map_sentence]

lemma elementarily_equivalent (f : M ↪ₑ[L] N) : M ≅[L] N :=
elementarily_equivalent_iff.2 f.map_sentence

@[simp] lemma injective (φ : M ↪ₑ[L] N) :
  function.injective φ :=
begin
  intros x y,
  have h := φ.map_formula ((var 0).equal (var 1) : L.formula (fin 2)) (λ i, if i = 0 then x else y),
  rw [formula.realize_equal, formula.realize_equal] at h,
  simp only [nat.one_ne_zero, term.realize, fin.one_eq_zero_iff, if_true, eq_self_iff_true,
    function.comp_app, if_false] at h,
  exact h.1,
end

instance embedding_like : embedding_like (M ↪ₑ[L] N) M N :=
{ injective' := injective }

@[simp] lemma map_fun (φ : M ↪ₑ[L] N) {n : ℕ} (f : L.functions n) (x : fin n → M) :
  φ (fun_map f x) = fun_map f (φ ∘ x) :=
begin
  have h := φ.map_formula (formula.graph f) (fin.cons (fun_map f x) x),
  rw [formula.realize_graph, fin.comp_cons, formula.realize_graph] at h,
  rw [eq_comm, h]
end

@[simp] lemma map_rel (φ : M ↪ₑ[L] N) {n : ℕ} (r : L.relations n) (x : fin n → M) :
  rel_map r (φ ∘ x) ↔ rel_map r x :=
begin
  have h := φ.map_formula (r.formula var) x,
  exact h
end

instance strong_hom_class : strong_hom_class L (M ↪ₑ[L] N) M N :=
{ map_fun := map_fun,
  map_rel := map_rel }

@[simp] lemma map_constants (φ : M ↪ₑ[L] N) (c : L.constants) : φ c = c :=
hom_class.map_constants φ c

/-- An elementary embedding is also a first-order embedding. -/
def to_embedding (f : M ↪ₑ[L] N) : M ↪[L] N :=
{ to_fun := f,
  inj' := f.injective, }

/-- An elementary embedding is also a first-order homomorphism. -/
def to_hom (f : M ↪ₑ[L] N) : M →[L] N :=
{ to_fun := f }

@[simp] lemma to_embedding_to_hom (f : M ↪ₑ[L] N) : f.to_embedding.to_hom = f.to_hom := rfl

@[simp]
lemma coe_to_hom {f : M ↪ₑ[L] N} : (f.to_hom : M → N) = (f : M → N) := rfl

@[simp] lemma coe_to_embedding (f : M ↪ₑ[L] N) : (f.to_embedding : M → N) = (f : M → N) := rfl

lemma coe_injective : @function.injective (M ↪ₑ[L] N) (M → N) coe_fn :=
fun_like.coe_injective

@[ext]
lemma ext ⦃f g : M ↪ₑ[L] N⦄ (h : ∀ x, f x = g x) : f = g :=
fun_like.ext f g h

lemma ext_iff {f g : M ↪ₑ[L] N} : f = g ↔ ∀ x, f x = g x :=
fun_like.ext_iff

variables (L) (M)
/-- The identity elementary embedding from a structure to itself -/
@[refl] def refl : M ↪ₑ[L] M :=
{ to_fun := id }

variables {L} {M}

instance : inhabited (M ↪ₑ[L] M) := ⟨refl L M⟩

@[simp] lemma refl_apply (x : M) :
  refl L M x = x := rfl

/-- Composition of elementary embeddings -/
@[trans] def comp (hnp : N ↪ₑ[L] P) (hmn : M ↪ₑ[L] N) : M ↪ₑ[L] P :=
{ to_fun := hnp ∘ hmn }

@[simp] lemma comp_apply (g : N ↪ₑ[L] P) (f : M ↪ₑ[L] N) (x : M) :
  g.comp f x = g (f x) := rfl

/-- Composition of elementary embeddings is associative. -/
lemma comp_assoc (f : M ↪ₑ[L] N) (g : N ↪ₑ[L] P) (h : P ↪ₑ[L] Q) :
  (h.comp g).comp f = h.comp (g.comp f) := rfl

end elementary_embedding

variables (L) (M)

/-- The elementary diagram of an `L`-structure is the set of all sentences with parameters it
  satisfies. -/
abbreviation elementary_diagram : L[[M]].Theory := L[[M]].complete_theory M

/-- The canonical elementary embedding of an `L`-structure into any model of its elementary diagram
-/
@[simps] def elementary_embedding.of_models_elementary_diagram
  (N : Type*) [L.Structure N] [L[[M]].Structure N]
  [(Lhom_with_constants L M).is_expansion_on N] [N ⊨ L.elementary_diagram M] :
  M ↪ₑ[L] N :=
⟨(coe : L[[M]].constants → N) ∘ sum.inr, λ n φ x, begin
  refine trans _ ((realize_iff_of_model_complete_theory M N (((L.Lhom_with_constants
    M).on_bounded_formula φ).subst (constants.term ∘ sum.inr ∘ x)).alls).trans _),
  { simp_rw [sentence.realize, bounded_formula.realize_alls, bounded_formula.realize_subst,
      Lhom.realize_on_bounded_formula, formula.realize, unique.forall_iff, realize_constants] },
  { simp_rw [sentence.realize, bounded_formula.realize_alls, bounded_formula.realize_subst,
    Lhom.realize_on_bounded_formula, formula.realize, unique.forall_iff],
    refl }
end⟩

variables {L M}

namespace embedding

/-- The Tarski-Vaught test for elementarity of an embedding. -/
theorem is_elementary_of_exists (f : M ↪[L] N)
  (htv : ∀ (n : ℕ) (φ : L.bounded_formula empty (n + 1)) (x : fin n → M) (a : N),
    φ.realize default (fin.snoc (f ∘ x) a : _ → N) →
    ∃ b : M, φ.realize default (fin.snoc (f ∘ x) (f b) : _ → N)) :
  ∀{n} (φ : L.formula (fin n)) (x : fin n → M), φ.realize (f ∘ x) ↔ φ.realize x :=
begin
  suffices h : ∀ (n : ℕ) (φ : L.bounded_formula empty n) (xs : fin n → M),
    φ.realize (f ∘ default) (f ∘ xs) ↔ φ.realize default xs,
  { intros n φ x,
    refine φ.realize_relabel_sum_inr.symm.trans (trans (h n _ _) φ.realize_relabel_sum_inr), },
  refine λ n φ, φ.rec_on _ _ _ _ _,
  { exact λ _ _, iff.rfl },
  { intros,
    simp [bounded_formula.realize, ← sum.comp_elim, embedding.realize_term] },
  { intros,
    simp [bounded_formula.realize, ← sum.comp_elim, embedding.realize_term] },
  { intros _ _ _ ih1 ih2 _,
    simp [ih1, ih2] },
  { intros n φ ih xs,
    simp only [bounded_formula.realize_all],
    refine ⟨λ h a, _, _⟩,
    { rw [← ih, fin.comp_snoc],
      exact h (f a) },
    { contrapose!,
      rintro ⟨a, ha⟩,
      obtain ⟨b, hb⟩ := htv n φ.not xs a _,
      { refine ⟨b, λ h, hb (eq.mp _ ((ih _).2 h))⟩,
        rw [unique.eq_default (f ∘ default), fin.comp_snoc], },
      { rw [bounded_formula.realize_not, ← unique.eq_default (f ∘ default)],
        exact ha } } },
end

/-- Bundles an embedding satisfying the Tarski-Vaught test as an elementary embedding. -/
@[simps] def to_elementary_embedding (f : M ↪[L] N)
  (htv : ∀ (n : ℕ) (φ : L.bounded_formula empty (n + 1)) (x : fin n → M) (a : N),
    φ.realize default (fin.snoc (f ∘ x) a : _ → N) →
    ∃ b : M, φ.realize default (fin.snoc (f ∘ x) (f b) : _ → N)) :
  M ↪ₑ[L] N :=
⟨f, λ _, f.is_elementary_of_exists htv⟩

end embedding

namespace equiv

/-- A first-order equivalence is also an elementary embedding. -/
def to_elementary_embedding (f : M ≃[L] N) : M ↪ₑ[L] N :=
{ to_fun := f }

@[simp] lemma to_elementary_embedding_to_embedding (f : M ≃[L] N) :
  f.to_elementary_embedding.to_embedding = f.to_embedding := rfl

@[simp] lemma coe_to_elementary_embedding (f : M ≃[L] N) :
  (f.to_elementary_embedding : M → N) = (f : M → N) := rfl

end equiv

@[simp] lemma realize_term_substructure {α : Type*} {S : L.substructure M} (v : α → S)
  (t : L.term α) :
  t.realize (coe ∘ v) = (↑(t.realize v) : M) :=
S.subtype.realize_term t

namespace substructure

@[simp]

@[simp] lemma realize_formula_top {α : Type*} {φ : L.formula α} {v : α → (⊤ : L.substructure M)} :
  φ.realize v ↔ φ.realize ((coe : (⊤ : L.substructure M) → M) ∘ v) :=
begin
  rw ← substructure.top_equiv.realize_formula φ,
  simp,
end

/-- A substructure is elementary when every formula applied to a tuple in the subtructure
  agrees with its value in the overall structure. -/
def is_elementary (S : L.substructure M) : Prop :=
∀{n} (φ : L.formula (fin n)) (x : fin n → S), φ.realize ((coe : _ → M) ∘ x) ↔ φ.realize x

end substructure

variables (L) (M)
/-- An elementary substructure is one in which every formula applied to a tuple in the subtructure
  agrees with its value in the overall structure. -/
structure elementary_substructure :=
(to_substructure : L.substructure M)
(is_elementary' : to_substructure.is_elementary)

variables {L} {M}

namespace elementary_substructure

instance : has_coe (L.elementary_substructure M) (L.substructure M) :=
⟨elementary_substructure.to_substructure⟩

instance : set_like (L.elementary_substructure M) M :=
⟨λ x, x.to_substructure.carrier, λ ⟨⟨s, hs1⟩, hs2⟩ ⟨⟨t, ht1⟩, ht2⟩ h, begin
  congr,
  exact h,
end⟩

@[simp] lemma is_elementary (S : L.elementary_substructure M) :
  (S : L.substructure M).is_elementary := S.is_elementary'

/-- The natural embedding of an `L.substructure` of `M` into `M`. -/
def subtype (S : L.elementary_substructure M) : S ↪ₑ[L] M :=
{ to_fun := coe,
  map_formula' := λ n, S.is_elementary }

@[simp] theorem coe_subtype {S : L.elementary_substructure M} : ⇑S.subtype = coe := rfl

/-- The substructure `M` of the structure `M` is elementary. -/
instance : has_top (L.elementary_substructure M) :=
⟨⟨⊤, λ n φ x, substructure.realize_formula_top.symm⟩⟩

instance : inhabited (L.elementary_substructure M) := ⟨⊤⟩

@[simp] lemma mem_top (x : M) : x ∈ (⊤ : L.elementary_substructure M) := set.mem_univ x

@[simp] lemma coe_top : ((⊤ : L.elementary_substructure M) : set M) = set.univ := rfl

@[simp] lemma realize_sentence (S : L.elementary_substructure M) (φ : L.sentence)  :
  S ⊨ φ ↔ M ⊨ φ :=
S.subtype.map_sentence φ

@[simp] lemma Theory_model_iff (S : L.elementary_substructure M) (T : L.Theory) :
  S ⊨ T ↔ M ⊨ T :=
by simp only [Theory.model_iff, realize_sentence]

instance Theory_model {T : L.Theory} [h : M ⊨ T] {S : L.elementary_substructure M} : S ⊨ T :=
(Theory_model_iff S T).2 h

instance [h : nonempty M] {S : L.elementary_substructure M} : nonempty S :=
(model_nonempty_theory_iff L).1 infer_instance

lemma elementarily_equivalent (S : L.elementary_substructure M) : S ≅[L] M :=
S.subtype.elementarily_equivalent

end elementary_substructure

namespace substructure

/-- The Tarski-Vaught test for elementarity of a substructure. -/
theorem is_elementary_of_exists (S : L.substructure M)
  (htv : ∀ (n : ℕ) (φ : L.bounded_formula empty (n + 1)) (x : fin n → S) (a : M),
    φ.realize default (fin.snoc (coe ∘ x) a : _ → M) →
    ∃ b : S, φ.realize default (fin.snoc (coe ∘ x) b : _ → M)) :
  S.is_elementary :=
λ n, S.subtype.is_elementary_of_exists htv

/-- Bundles a substructure satisfying the Tarski-Vaught test as an elementary substructure. -/
@[simps] def to_elementary_substructure (S : L.substructure M)
  (htv : ∀ (n : ℕ) (φ : L.bounded_formula empty (n + 1)) (x : fin n → S) (a : M),
    φ.realize default (fin.snoc (coe ∘ x) a : _ → M) →
    ∃ b : S, φ.realize default (fin.snoc (coe ∘ x) b : _ → M)) :
  L.elementary_substructure M :=
⟨S, λ _, S.is_elementary_of_exists htv⟩

end substructure

end language
end first_order


/-
Copyright (c) 2020 Kenny Lau. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Kenny Lau
-/

import linear_algebra.smodeq
import ring_theory.ideal.operations

/-!
# Completion of a module with respect to an ideal.

In this file we define the notions of Hausdorff, precomplete, and complete for an `R`-module `M`
with respect to an ideal `I`:

## Main definitions

- `is_Hausdorff I M`: this says that the intersection of `I^n M` is `0`.
- `is_precomplete I M`: this says that every Cauchy sequence converges.
- `is_adic_complete I M`: this says that `M` is Hausdorff and precomplete.
- `Hausdorffification I M`: this is the universal Hausdorff module with a map from `M`.
- `completion I M`: if `I` is finitely generated, then this is the universal complete module (TODO)
  with a map from `M`. This map is injective iff `M` is Hausdorff and surjective iff `M` is
  precomplete.

-/

open submodule

variables {R : Type*} [comm_ring R] (I : ideal R)
variables (M : Type*) [add_comm_group M] [module R M]
variables {N : Type*} [add_comm_group N] [module R N]

/-- A module `M` is Hausdorff with respect to an ideal `I` if `⋂ I^n M = 0`. -/
class is_Hausdorff : Prop :=
(haus' : ∀ x : M, (∀ n : ℕ, x ≡ 0 [SMOD (I ^ n • ⊤ : submodule R M)]) → x = 0)

/-- A module `M` is precomplete with respect to an ideal `I` if every Cauchy sequence converges. -/
class is_precomplete : Prop :=
(prec' : ∀ f : ℕ → M,
  (∀ {m n}, m ≤ n → f m ≡ f n [SMOD (I ^ m • ⊤ : submodule R M)]) →
  ∃ L : M, ∀ n, f n ≡ L [SMOD (I ^ n • ⊤ : submodule R M)])

/-- A module `M` is `I`-adically complete if it is Hausdorff and precomplete. -/
class is_adic_complete extends is_Hausdorff I M, is_precomplete I M : Prop

variables {I M}

theorem is_Hausdorff.haus (h : is_Hausdorff I M) :
  ∀ x : M, (∀ n : ℕ, x ≡ 0 [SMOD (I ^ n • ⊤ : submodule R M)]) → x = 0 := is_Hausdorff.haus'

theorem is_Hausdorff_iff : is_Hausdorff I M ↔
  ∀ x : M, (∀ n : ℕ, x ≡ 0 [SMOD (I ^ n • ⊤ : submodule R M)]) → x = 0 :=
⟨is_Hausdorff.haus, λ h, ⟨h⟩⟩

theorem is_precomplete.prec (h : is_precomplete I M) {f : ℕ → M} :
  (∀ {m n}, m ≤ n → f m ≡ f n [SMOD (I ^ m • ⊤ : submodule R M)]) →
  ∃ L : M, ∀ n, f n ≡ L [SMOD (I ^ n • ⊤ : submodule R M)] := is_precomplete.prec' _

theorem is_precomplete_iff : is_precomplete I M ↔ ∀ f : ℕ → M,
  (∀ {m n}, m ≤ n → f m ≡ f n [SMOD (I ^ m • ⊤ : submodule R M)]) →
  ∃ L : M, ∀ n, f n ≡ L [SMOD (I ^ n • ⊤ : submodule R M)] :=
⟨λ h, h.1, λ h, ⟨h⟩⟩

variables (I M)

/-- The Hausdorffification of a module with respect to an ideal. -/
@[reducible] def Hausdorffification : Type* :=
(⨅ n : ℕ, I ^ n • ⊤ : submodule R M).quotient

/-- The completion of a module with respect to an ideal. This is not necessarily Hausdorff.
In fact, this is only complete if the ideal is finitely generated. -/
def adic_completion : submodule R (Π n : ℕ, (I ^ n • ⊤ : submodule R M).quotient) :=
{ carrier := { f | ∀ {m n} (h : m ≤ n), liftq _ (mkq _)
    (by { rw ker_mkq, exact smul_mono (ideal.pow_le_pow h) (le_refl _) }) (f n) = f m },
  zero_mem' := λ m n hmn, by rw [pi.zero_apply, pi.zero_apply, linear_map.map_zero],
  add_mem' := λ f g hf hg m n hmn, by rw [pi.add_apply, pi.add_apply,
    linear_map.map_add, hf hmn, hg hmn],
  smul_mem' := λ c f hf m n hmn, by rw [pi.smul_apply, pi.smul_apply, linear_map.map_smul, hf hmn] }

namespace is_Hausdorff

instance bot : is_Hausdorff (⊥ : ideal R) M :=
⟨λ x hx, by simpa only [pow_one ⊥, bot_smul, smodeq.bot] using hx 1⟩

variables {M}
protected theorem subsingleton (h : is_Hausdorff (⊤ : ideal R) M) : subsingleton M :=
⟨λ x y, eq_of_sub_eq_zero $ h.haus (x - y) $ λ n,
  by { rw [ideal.top_pow, top_smul], exact smodeq.top }⟩
variables (M)

@[priority 100] instance of_subsingleton [subsingleton M] : is_Hausdorff I M :=
⟨λ x _, subsingleton.elim _ _⟩

variables {I M}
theorem infi_pow_smul (h : is_Hausdorff I M) :
  (⨅ n : ℕ, I ^ n • ⊤ : submodule R M) = ⊥ :=
eq_bot_iff.2 $ λ x hx, (mem_bot _).2 $ h.haus x $ λ n, smodeq.zero.2 $
(mem_infi $ λ n : ℕ, I ^ n • ⊤).1 hx n

end is_Hausdorff

namespace Hausdorffification

/-- The canonical linear map to the Hausdorffification. -/
def of : M →ₗ[R] Hausdorffification I M := mkq _

variables {I M}
@[elab_as_eliminator]
lemma induction_on {C : Hausdorffification I M → Prop} (x : Hausdorffification I M)
  (ih : ∀ x, C (of I M x)) : C x :=
quotient.induction_on' x ih
variables (I M)

instance : is_Hausdorff I (Hausdorffification I M) :=
⟨λ x, quotient.induction_on' x $ λ x hx, (quotient.mk_eq_zero _).2 $ (mem_infi _).2 $ λ n, begin
  have := comap_map_mkq (⨅ n : ℕ, I ^ n • ⊤ : submodule R M) (I ^ n • ⊤),
  simp only [sup_of_le_right (infi_le (λ n, (I ^ n • ⊤ : submodule R M)) n)] at this,
  rw [← this, map_smul'', mem_comap, map_top, range_mkq, ← smodeq.zero], exact hx n
end⟩

variables {M} [h : is_Hausdorff I N]
include h

/-- universal property of Hausdorffification: any linear map to a Hausdorff module extends to a
unique map from the Hausdorffification. -/
def lift (f : M →ₗ[R] N) : Hausdorffification I M →ₗ[R] N :=
liftq _ f $ map_le_iff_le_comap.1 $ h.infi_pow_smul ▸ le_infi (λ n,
le_trans (map_mono $ infi_le _ n) $ by { rw map_smul'', exact smul_mono (le_refl _) le_top })

theorem lift_of (f : M →ₗ[R] N) (x : M) : lift I f (of I M x) = f x := rfl

theorem lift_comp_of (f : M →ₗ[R] N) : (lift I f).comp (of I M) = f :=
linear_map.ext $ λ _, rfl

/-- Uniqueness of lift. -/
theorem lift_eq (f : M →ₗ[R] N) (g : Hausdorffification I M →ₗ[R] N) (hg : g.comp (of I M) = f) :
  g = lift I f :=
linear_map.ext $ λ x, induction_on x $ λ x, by rw [lift_of, ← hg, linear_map.comp_apply]

end Hausdorffification

namespace is_precomplete

instance bot : is_precomplete (⊥ : ideal R) M :=
begin
  refine ⟨λ f hf, ⟨f 1, λ n, _⟩⟩, cases n,
  { rw [pow_zero, ideal.one_eq_top, top_smul], exact smodeq.top },
  specialize hf (nat.le_add_left 1 n),
  rw [pow_one, bot_smul, smodeq.bot] at hf, rw hf
end

instance top : is_precomplete (⊤ : ideal R) M :=
⟨λ f hf, ⟨0, λ n, by { rw [ideal.top_pow, top_smul], exact smodeq.top }⟩⟩

@[priority 100] instance of_subsingleton [subsingleton M] : is_precomplete I M :=
⟨λ f hf, ⟨0, λ n, by rw subsingleton.elim (f n) 0⟩⟩

end is_precomplete

namespace adic_completion

/-- The canonical linear map to the completion. -/
def of : M →ₗ[R] adic_completion I M :=
{ to_fun    := λ x, ⟨λ n, mkq _ x, λ m n hmn, rfl⟩,
  map_add'  := λ x y, rfl,
  map_smul' := λ c x, rfl }

@[simp] lemma of_apply (x : M) (n : ℕ) : (of I M x).1 n = mkq _ x := rfl

/-- Linearly evaluating a sequence in the completion at a given input. -/
def eval (n : ℕ) : adic_completion I M →ₗ[R] (I ^ n • ⊤ : submodule R M).quotient :=
{ to_fun    := λ f, f.1 n,
  map_add'  := λ f g, rfl,
  map_smul' := λ c f, rfl }

@[simp] lemma coe_eval (n : ℕ) :
  (eval I M n : adic_completion I M → (I ^ n • ⊤ : submodule R M).quotient) = λ f, f.1 n := rfl

lemma eval_apply (n : ℕ) (f : adic_completion I M) : eval I M n f = f.1 n := rfl

lemma eval_of (n : ℕ) (x : M) : eval I M n (of I M x) = mkq _ x := rfl

@[simp] lemma eval_comp_of (n : ℕ) : (eval I M n).comp (of I M) = mkq _ := rfl

@[simp] lemma range_eval (n : ℕ) : (eval I M n).range = ⊤ :=
linear_map.range_eq_top.2 $ λ x, quotient.induction_on' x $ λ x, ⟨of I M x, rfl⟩

variables {I M}
@[ext] lemma ext {x y : adic_completion I M} (h : ∀ n, eval I M n x = eval I M n y) : x = y :=
subtype.eq $ funext h
variables (I M)

instance : is_Hausdorff I (adic_completion I M) :=
⟨λ x hx, ext $ λ n, smul_induction_on (smodeq.zero.1 $ hx n)
  (λ r hr x _, ((eval I M n).map_smul r x).symm ▸ quotient.induction_on' (eval I M n x)
    (λ x, smodeq.zero.2 $ smul_mem_smul hr mem_top))
  rfl
  (λ _ _ ih1 ih2, by rw [linear_map.map_add, ih1, ih2, linear_map.map_zero, add_zero])
  (λ c _ ih, by rw [linear_map.map_smul, ih, linear_map.map_zero, smul_zero])⟩

end adic_completion

namespace is_adic_complete

instance bot : is_adic_complete (⊥ : ideal R) M := {}

protected theorem subsingleton (h : is_adic_complete (⊤ : ideal R) M) : subsingleton M :=
h.1.subsingleton

@[priority 100] instance of_subsingleton [subsingleton M] : is_adic_complete I M := {}

end is_adic_complete


/-
Copyright (c) 2017 Mario Carneiro. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Mario Carneiro
-/
import order.basic algebra.order algebra.ordered_group algebra.ring

universe u
variable {α : Type u}

-- TODO: this is necessary additionally to mul_nonneg otherwise the simplifier can not match
lemma zero_le_mul [ordered_semiring α] {a b : α} : 0 ≤ a → 0 ≤ b → 0 ≤ a * b :=
mul_nonneg

section linear_ordered_semiring
variable [linear_ordered_semiring α]

@[simp] lemma mul_le_mul_left {a b c : α} (h : 0 < c) : c * a ≤ c * b ↔ a ≤ b :=
⟨λ h', le_of_mul_le_mul_left h' h, λ h', mul_le_mul_of_nonneg_left h' (le_of_lt h)⟩

@[simp] lemma mul_le_mul_right {a b c : α} (h : 0 < c) : a * c ≤ b * c ↔ a ≤ b :=
⟨λ h', le_of_mul_le_mul_right h' h, λ h', mul_le_mul_of_nonneg_right h' (le_of_lt h)⟩

@[simp] lemma mul_lt_mul_left {a b c : α} (h : 0 < c) : c * a < c * b ↔ a < b :=
⟨λ h', lt_of_mul_lt_mul_left h' (le_of_lt h), λ h', mul_lt_mul_of_pos_left h' h⟩

@[simp] lemma mul_lt_mul_right {a b c : α} (h : 0 < c) : a * c < b * c ↔ a < b :=
⟨λ h', lt_of_mul_lt_mul_right h' (le_of_lt h), λ h', mul_lt_mul_of_pos_right h' h⟩

lemma mul_lt_mul'' {a b c d : α} (h1 : a < c) (h2 : b < d) (h3 : 0 ≤ a) (h4 : 0 ≤ b) :
       a * b < c * d :=
(lt_or_eq_of_le h4).elim
  (λ b0, mul_lt_mul h1 (le_of_lt h2) b0 (le_trans h3 (le_of_lt h1)))
  (λ b0, by rw [← b0, mul_zero]; exact
    mul_pos (lt_of_le_of_lt h3 h1) (lt_of_le_of_lt h4 h2))

lemma le_mul_iff_one_le_left {a b : α} (hb : b > 0) : b ≤ a * b ↔ 1 ≤ a :=
suffices 1 * b ≤ a * b ↔ 1 ≤ a, by rwa one_mul at this,
mul_le_mul_right hb

lemma lt_mul_iff_one_lt_left {a b : α} (hb : b > 0) : b < a * b ↔ 1 < a :=
suffices 1 * b < a * b ↔ 1 < a, by rwa one_mul at this,
mul_lt_mul_right hb

lemma le_mul_iff_one_le_right {a b : α} (hb : b > 0) : b ≤ b * a ↔ 1 ≤ a :=
suffices b * 1 ≤ b * a ↔ 1 ≤ a, by rwa mul_one at this,
mul_le_mul_left hb

lemma lt_mul_iff_one_lt_right {a b : α} (hb : b > 0) : b < b * a ↔ 1 < a :=
suffices b * 1 < b * a ↔ 1 < a, by rwa mul_one at this,
mul_lt_mul_left hb

lemma lt_mul_of_gt_one_right' {a b : α} (hb : b > 0) : a > 1 → b < b * a :=
(lt_mul_iff_one_lt_right hb).2

lemma le_mul_of_ge_one_right' {a b : α} (hb : b ≥ 0) (h : a ≥ 1) : b ≤ b * a :=
suffices b * 1 ≤ b * a, by rwa mul_one at this,
mul_le_mul_of_nonneg_left h hb

lemma le_mul_of_ge_one_left' {a b : α} (hb : b ≥ 0) (h : a ≥ 1) : b ≤ a * b :=
suffices 1 * b ≤ a * b, by rwa one_mul at this,
mul_le_mul_of_nonneg_right h hb

theorem mul_nonneg_iff_right_nonneg_of_pos {a b : α} (h : 0 < a) : 0 ≤ b * a ↔ 0 ≤ b :=
⟨assume : 0 ≤ b * a, nonneg_of_mul_nonneg_right this h, assume : 0 ≤ b, mul_nonneg this $ le_of_lt h⟩

lemma bit1_pos {a : α} (h : 0 ≤ a) : 0 < bit1 a :=
lt_add_of_le_of_pos (add_nonneg h h) zero_lt_one

lemma bit1_pos' {a : α} (h : 0 < a) : 0 < bit1 a :=
bit1_pos (le_of_lt h)

lemma lt_add_one (a : α) : a < a + 1 :=
lt_add_of_le_of_pos (le_refl _) zero_lt_one

lemma one_lt_two : 1 < (2 : α) := lt_add_one _

lemma mul_le_one {a b : α} (ha : a ≤ 1) (hb' : 0 ≤ b) (hb : b ≤ 1) : a * b ≤ 1 :=
begin rw ← one_mul (1 : α), apply mul_le_mul; {assumption <|> apply zero_le_one} end

end linear_ordered_semiring

instance linear_ordered_semiring.to_no_top_order {α : Type*} [linear_ordered_semiring α] :
  no_top_order α :=
⟨assume a, ⟨a + 1, lt_add_of_pos_right _ zero_lt_one⟩⟩

instance linear_ordered_semiring.to_no_bot_order {α : Type*} [linear_ordered_ring α] :
  no_bot_order α :=
⟨assume a, ⟨a - 1, sub_lt_iff_lt_add.mpr $ lt_add_of_pos_right _ zero_lt_one⟩⟩

instance to_domain [s : linear_ordered_ring α] : domain α :=
{ eq_zero_or_eq_zero_of_mul_eq_zero := @linear_ordered_ring.eq_zero_or_eq_zero_of_mul_eq_zero α s,
  ..s }

section linear_ordered_ring
variable [linear_ordered_ring α]

@[simp] lemma mul_le_mul_left_of_neg {a b c : α} (h : c < 0) : c * a ≤ c * b ↔ b ≤ a :=
⟨le_imp_le_iff_lt_imp_lt.2 $ λ h', mul_lt_mul_of_neg_left h' h,
  λ h', mul_le_mul_of_nonpos_left h' (le_of_lt h)⟩

@[simp] lemma mul_le_mul_right_of_neg {a b c : α} (h : c < 0) : a * c ≤ b * c ↔ b ≤ a :=
⟨le_imp_le_iff_lt_imp_lt.2 $ λ h', mul_lt_mul_of_neg_right h' h,
  λ h', mul_le_mul_of_nonpos_right h' (le_of_lt h)⟩

@[simp] lemma mul_lt_mul_left_of_neg {a b c : α} (h : c < 0) : c * a < c * b ↔ b < a :=
le_iff_le_iff_lt_iff_lt.1 (mul_le_mul_left_of_neg h)

@[simp] lemma mul_lt_mul_right_of_neg {a b c : α} (h : c < 0) : a * c < b * c ↔ b < a :=
le_iff_le_iff_lt_iff_lt.1 (mul_le_mul_right_of_neg h)

lemma sub_one_lt (a : α) : a - 1 < a :=
sub_lt_iff_lt_add.2 (lt_add_one a)

lemma mul_self_pos {a : α} (ha : a ≠ 0) : 0 < a * a :=
by rcases lt_trichotomy a 0 with h|h|h;
   [exact mul_pos_of_neg_of_neg h h, exact (ha h).elim, exact mul_pos h h]

end linear_ordered_ring

set_option old_structure_cmd true
/-- Extend `nonneg_comm_group` to support ordered rings
  specified by their nonnegative elements -/
class nonneg_ring (α : Type*)
  extends ring α, zero_ne_one_class α, nonneg_comm_group α :=
(mul_nonneg : ∀ {a b}, nonneg a → nonneg b → nonneg (a * b))
(mul_pos : ∀ {a b}, pos a → pos b → pos (a * b))

/-- Extend `nonneg_comm_group` to support linearly ordered rings
  specified by their nonnegative elements -/
class linear_nonneg_ring (α : Type*) extends domain α, nonneg_comm_group α :=
(mul_nonneg : ∀ {a b}, nonneg a → nonneg b → nonneg (a * b))
(nonneg_total : ∀ a, nonneg a ∨ nonneg (-a))

namespace nonneg_ring
open nonneg_comm_group
variable [s : nonneg_ring α]

instance to_ordered_ring : ordered_ring α :=
{ le := (≤),
  lt := (<),
  lt_iff_le_not_le := @lt_iff_le_not_le _ _,
  le_refl := @le_refl _ _,
  le_trans := @le_trans _ _,
  le_antisymm := @le_antisymm _ _,
  add_lt_add_left := @add_lt_add_left _ _,
  add_le_add_left := @add_le_add_left _ _,
  mul_nonneg := λ a b, by simp [nonneg_def.symm]; exact mul_nonneg,
  mul_pos := λ a b, by simp [pos_def.symm]; exact mul_pos,
  ..s }

def nonneg_ring.to_linear_nonneg_ring
  (nonneg_total : ∀ a : α, nonneg a ∨ nonneg (-a))
  : linear_nonneg_ring α :=
{ nonneg_total := nonneg_total,
  eq_zero_or_eq_zero_of_mul_eq_zero :=
    suffices ∀ {a} b : α, nonneg a → a * b = 0 → a = 0 ∨ b = 0,
    from λ a b, (nonneg_total a).elim (this b)
      (λ na, by simpa using this b na),
    suffices ∀ {a b : α}, nonneg a → nonneg b → a * b = 0 → a = 0 ∨ b = 0,
    from λ a b na, (nonneg_total b).elim (this na)
      (λ nb, by simpa using this na nb),
    λ a b na nb z, classical.by_cases
      (λ nna : nonneg (-a), or.inl (nonneg_antisymm na nna))
      (λ pa, classical.by_cases
        (λ nnb : nonneg (-b), or.inr (nonneg_antisymm nb nnb))
        (λ pb, absurd z $ ne_of_gt $ pos_def.1 $ mul_pos
          ((pos_iff _ _).2 ⟨na, pa⟩)
          ((pos_iff _ _).2 ⟨nb, pb⟩))),
  ..s }

end nonneg_ring

namespace linear_nonneg_ring
open nonneg_comm_group
variable [s : linear_nonneg_ring α]

instance to_nonneg_ring : nonneg_ring α :=
{ mul_pos := λ a b pa pb,
  let ⟨a1, a2⟩ := (pos_iff α a).1 pa,
      ⟨b1, b2⟩ := (pos_iff α b).1 pb in
  have ab : nonneg (a * b), from mul_nonneg a1 b1,
  (pos_iff α _).2 ⟨ab, λ hn,
    have a * b = 0, from nonneg_antisymm ab hn,
    (eq_zero_or_eq_zero_of_mul_eq_zero _ _ this).elim
      (ne_of_gt (pos_def.1 pa))
      (ne_of_gt (pos_def.1 pb))⟩,
  ..s }

instance to_linear_order : linear_order α :=
{ le := (≤),
  lt := (<),
  lt_iff_le_not_le := @lt_iff_le_not_le _ _,
  le_refl := @le_refl _ _,
  le_trans := @le_trans _ _,
  le_antisymm := @le_antisymm _ _,
  le_total := nonneg_total_iff.1 nonneg_total,
  ..s }

instance to_linear_ordered_ring : linear_ordered_ring α :=
{ le := (≤),
  lt := (<),
  lt_iff_le_not_le := @lt_iff_le_not_le _ _,
  le_refl := @le_refl _ _,
  le_trans := @le_trans _ _,
  le_antisymm := @le_antisymm _ _,
  le_total := @le_total _ _,
  add_lt_add_left := @add_lt_add_left _ _,
  add_le_add_left := @add_le_add_left _ _,
  mul_nonneg := by simp [nonneg_def.symm]; exact @mul_nonneg _ _,
  mul_pos := by simp [pos_def.symm]; exact @nonneg_ring.mul_pos _ _,
  zero_lt_one := lt_of_not_ge $ λ (h : nonneg (0 - 1)), begin
    rw [zero_sub] at h,
    have := mul_nonneg h h, simp at this,
    exact zero_ne_one _ (nonneg_antisymm this h).symm
  end, ..s }

instance to_decidable_linear_ordered_comm_ring
  [decidable_pred (@nonneg α _)]
  [comm : @is_commutative α (*)]
  : decidable_linear_ordered_comm_ring α :=
{ decidable_le := by apply_instance,
  decidable_eq := by apply_instance,
  decidable_lt := by apply_instance,
  mul_comm := is_commutative.comm (*),
  ..@linear_nonneg_ring.to_linear_ordered_ring _ s }

end linear_nonneg_ring

class canonically_ordered_comm_semiring (α : Type*) extends
  canonically_ordered_monoid α, comm_semiring α, zero_ne_one_class α :=
(mul_eq_zero_iff (a b : α) : a * b = 0 ↔ a = 0 ∨ b = 0)

namespace canonically_ordered_semiring
open canonically_ordered_monoid

lemma mul_le_mul [canonically_ordered_comm_semiring α] {a b c d : α} (hab : a ≤ b) (hcd : c ≤ d) :
  a * c ≤ b * d :=
begin
  rcases (le_iff_exists_add _ _).1 hab with ⟨b, rfl⟩,
  rcases (le_iff_exists_add _ _).1 hcd with ⟨d, rfl⟩,
  suffices : a * c ≤ a * c + (a * d + b * c + b * d), by simpa [mul_add, add_mul],
  exact (le_iff_exists_add _ _).2 ⟨_, rfl⟩
end

end canonically_ordered_semiring

instance : canonically_ordered_comm_semiring ℕ :=
{ le_iff_exists_add := assume a b,
  ⟨assume h, let ⟨c, hc⟩ := nat.le.dest h in ⟨c, hc.symm⟩,
    assume ⟨c, hc⟩, hc.symm ▸ nat.le_add_right _ _⟩,
  zero_ne_one       := ne_of_lt zero_lt_one,
  mul_eq_zero_iff   := assume a b,
    iff.intro nat.eq_zero_of_mul_eq_zero (by simp [or_imp_distrib] {contextual := tt}),
  .. (infer_instance : ordered_comm_monoid ℕ),
  .. (infer_instance : linear_ordered_semiring ℕ),
  .. (infer_instance : comm_semiring ℕ) }

namespace with_top
variables [canonically_ordered_comm_semiring α] [decidable_eq α]

instance : mul_zero_class (with_top α) :=
{ zero := 0,
  mul := λm n, if m = 0 ∨ n = 0 then 0 else m.bind (λa, n.bind $ λb, ↑(a * b)),
  zero_mul := assume a, if_pos $ or.inl rfl,
  mul_zero := assume a, if_pos $ or.inr rfl }

instance : has_one (with_top α) := ⟨↑(1:α)⟩

lemma mul_def {a b : with_top α} :
  a * b = if a = 0 ∨ b = 0 then 0 else a.bind (λa, b.bind $ λb, ↑(a * b)) := rfl

@[simp] theorem top_ne_zero [partial_order α] : ⊤ ≠ (0 : with_top α) .
@[simp] theorem zero_ne_top [partial_order α] : (0 : with_top α) ≠ ⊤ .

@[simp] theorem coe_eq_zero [partial_order α] {a : α} : (a : with_top α) = 0 ↔ a = 0 :=
iff.intro
  (assume h, match a, h with _, rfl := rfl end)
  (assume h, h.symm ▸ rfl)

@[simp] theorem zero_eq_coe [partial_order α] {a : α} : 0 = (a : with_top α) ↔ a = 0 :=
by rw [eq_comm, coe_eq_zero]

@[simp] theorem coe_zero [partial_order α] : ↑(0 : α) = (0 : with_top α) := rfl

@[simp] lemma mul_top {a : with_top α} (h : a ≠ 0) : a * ⊤ = ⊤ :=
by cases a; simp [mul_def, h]; refl

@[simp] lemma top_mul {a : with_top α} (h : a ≠ 0) : ⊤ * a = ⊤ :=
by cases a; simp [mul_def, h]; refl

@[simp] lemma top_mul_top : (⊤ * ⊤ : with_top α) = ⊤ :=
top_mul top_ne_zero

lemma coe_mul {a b : α} : (↑(a * b) : with_top α) = a * b :=
decidable.by_cases (assume : a = 0, by simp [this]) $ assume ha,
decidable.by_cases (assume : b = 0, by simp [this]) $ assume hb,
by simp [*, mul_def]; refl

lemma mul_coe {b : α} (hb : b ≠ 0) : ∀{a : with_top α}, a * b = a.bind (λa:α, ↑(a * b))
| none     := show (if (⊤:with_top α) = 0 ∨ (b:with_top α) = 0 then 0 else ⊤ : with_top α) = ⊤,
    by simp [hb]
| (some a) := show ↑a * ↑b = ↑(a * b), from coe_mul.symm

private lemma comm (a b : with_top α) : a * b = b * a :=
begin
  by_cases ha : a = 0, { simp [ha] },
  by_cases hb : b = 0, { simp [hb] },
  simp [ha, hb, mul_def, option.bind_comm a b, mul_comm]
end

private lemma distrib' (a b c : with_top α) : (a + b) * c = a * c + b * c :=
begin
  cases c,
  { show (a + b) * ⊤ = a * ⊤ + b * ⊤,
    by_cases ha : a = 0; simp [ha] },
  { show (a + b) * c = a * c + b * c,
    by_cases hc : c = 0, { simp [hc] },
    simp [mul_coe hc], cases a; cases b,
    repeat { refl <|> exact congr_arg some (add_mul _ _ _) } }
end

private lemma mul_eq_zero (a b : with_top α) : a * b = 0 ↔ a = 0 ∨ b = 0 :=
by cases a; cases b; dsimp [mul_def]; split_ifs;
  simp [*, none_eq_top, some_eq_coe, canonically_ordered_comm_semiring.mul_eq_zero_iff] at *

private lemma assoc (a b c : with_top α) : (a * b) * c = a * (b * c) :=
begin
  cases a,
  { by_cases hb : b = 0; by_cases hc : c = 0;
      simp [*, none_eq_top, mul_eq_zero b c] },
  cases b,
  { by_cases ha : a = 0; by_cases hc : c = 0;
      simp [*, none_eq_top, some_eq_coe, mul_eq_zero ↑a c] },
  cases c,
  { by_cases ha : a = 0; by_cases hb : b = 0;
      simp [*, none_eq_top, some_eq_coe, mul_eq_zero ↑a ↑b] },
  simp [some_eq_coe, coe_mul.symm, mul_assoc]
end

private lemma one_mul' : ∀a : with_top α, 1 * a = a
| none     := show ((1:α) : with_top α) * ⊤ = ⊤, by simp
| (some a) := show ((1:α) : with_top α) * a = a, by simp [coe_mul.symm]

instance [canonically_ordered_comm_semiring α] [decidable_eq α] :
  canonically_ordered_comm_semiring (with_top α) :=
{ one             := (1 : α),
  right_distrib   := distrib',
  left_distrib    := assume a b c, by rw [comm, distrib', comm b, comm c]; refl,
  mul_assoc       := assoc,
  mul_comm        := comm,
  mul_eq_zero_iff := mul_eq_zero,
  one_mul         := one_mul',
  mul_one         := assume a, by rw [comm, one_mul'],
  zero_ne_one     := assume h, @zero_ne_one α _ $ option.some.inj h,
  .. with_top.add_comm_monoid, .. with_top.mul_zero_class, .. with_top.canonically_ordered_monoid }

end with_top