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

import algebra.module.basic
import algebra.ring.equiv
import algebra.ring.prod
import algebra.order.ring.inj_surj
import algebra.group_ring_action.subobjects
import data.set.finite
import group_theory.submonoid.centralizer
import group_theory.submonoid.membership

/-!
# Bundled subsemirings

> THIS FILE IS SYNCHRONIZED WITH MATHLIB4.
> Any changes to this file require a corresponding PR to mathlib4.

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.
-/

open_locale big_operators

universes u v w

section add_submonoid_with_one_class

/-- `add_submonoid_with_one_class S R` says `S` is a type of subsets `s ≤ R` that contain `0`, `1`,
and are closed under `(+)` -/
class add_submonoid_with_one_class (S : Type*) (R : Type*)
  [add_monoid_with_one R] [set_like S R]
  extends add_submonoid_class S R, one_mem_class S R : Prop

variables {S R : Type*} [add_monoid_with_one R] [set_like S R] (s : S)

lemma nat_cast_mem [add_submonoid_with_one_class S R] (n : ℕ) : (n : R) ∈ s :=
by induction n; simp [zero_mem, add_mem, one_mem, *]

@[priority 74]
instance add_submonoid_with_one_class.to_add_monoid_with_one [add_submonoid_with_one_class S R] :
  add_monoid_with_one s :=
{ one := ⟨_, one_mem s⟩,
  nat_cast := λ n, ⟨n, nat_cast_mem s n⟩,
  nat_cast_zero := subtype.ext nat.cast_zero,
  nat_cast_succ := λ n, subtype.ext (nat.cast_succ _),
  .. add_submonoid_class.to_add_monoid s }

end add_submonoid_with_one_class

variables {R : Type u} {S : Type v} {T : Type w} [non_assoc_semiring R] (M : submonoid R)

section subsemiring_class

/-- `subsemiring_class S R` states that `S` is a type of subsets `s ⊆ R` that
are both a multiplicative and an additive submonoid. -/
class subsemiring_class (S : Type*) (R : Type u) [non_assoc_semiring R] [set_like S R]
  extends submonoid_class S R, add_submonoid_class S R : Prop

@[priority 100] -- See note [lower instance priority]
instance subsemiring_class.add_submonoid_with_one_class (S : Type*) (R : Type u)
  [non_assoc_semiring R] [set_like S R] [h : subsemiring_class S R] :
  add_submonoid_with_one_class S R :=
{ .. h }

variables [set_like S R] [hSR : subsemiring_class S R] (s : S)
include hSR

lemma coe_nat_mem (n : ℕ) : (n : R) ∈ s :=
by { rw ← nsmul_one, exact nsmul_mem (one_mem _) _ }

namespace subsemiring_class

/-- A subsemiring of a `non_assoc_semiring` inherits a `non_assoc_semiring` structure -/
@[priority 75] -- Prefer subclasses of `non_assoc_semiring` over subclasses of `subsemiring_class`.
instance to_non_assoc_semiring : non_assoc_semiring s :=
subtype.coe_injective.non_assoc_semiring coe rfl rfl (λ _ _, rfl) (λ _ _, rfl) (λ _ _, rfl)
  (λ _, rfl)

instance nontrivial [nontrivial R] : nontrivial s :=
nontrivial_of_ne 0 1 $ λ H, zero_ne_one (congr_arg subtype.val H)

instance no_zero_divisors [no_zero_divisors R] : no_zero_divisors s :=
{ eq_zero_or_eq_zero_of_mul_eq_zero := λ x y h,
  or.cases_on (eq_zero_or_eq_zero_of_mul_eq_zero $ subtype.ext_iff.mp h)
    (λ h, or.inl $ subtype.eq h) (λ h, or.inr $ subtype.eq h) }

/-- The natural ring hom from a subsemiring of semiring `R` to `R`. -/
def subtype : s →+* R :=
{ to_fun := coe, .. submonoid_class.subtype s, .. add_submonoid_class.subtype s }

@[simp] theorem coe_subtype : (subtype s : s → R) = coe := rfl

omit hSR

/-- A subsemiring of a `semiring` is a `semiring`. -/
@[priority 75] -- Prefer subclasses of `semiring` over subclasses of `subsemiring_class`.
instance to_semiring {R} [semiring R] [set_like S R] [subsemiring_class S R] : semiring s :=
subtype.coe_injective.semiring coe rfl rfl (λ _ _, rfl) (λ _ _, rfl) (λ _ _, rfl) (λ _ _, rfl)
  (λ _, rfl)

@[simp, norm_cast] lemma coe_pow {R} [semiring R] [set_like S R] [subsemiring_class S R]
  (x : s) (n : ℕ) :
  ((x^n : s) : R) = (x^n : R) :=
begin
  induction n with n ih,
  { simp, },
  { simp [pow_succ, ih], },
end

/-- A subsemiring of a `comm_semiring` is a `comm_semiring`. -/
instance to_comm_semiring {R} [comm_semiring R] [set_like S R] [subsemiring_class S R] :
  comm_semiring s :=
subtype.coe_injective.comm_semiring coe
  rfl rfl (λ _ _, rfl) (λ _ _, rfl) (λ _ _, rfl) (λ _ _, rfl) (λ _, rfl)

/-- A subsemiring of an `ordered_semiring` is an `ordered_semiring`. -/
instance to_ordered_semiring {R} [ordered_semiring R] [set_like S R] [subsemiring_class S R] :
  ordered_semiring s :=
subtype.coe_injective.ordered_semiring coe
  rfl rfl (λ _ _, rfl) (λ _ _, rfl) (λ _ _, rfl) (λ _ _, rfl) (λ _, rfl)

/-- A subsemiring of an `strict_ordered_semiring` is an `strict_ordered_semiring`. -/
instance to_strict_ordered_semiring {R} [strict_ordered_semiring R] [set_like S R]
  [subsemiring_class S R] :
  strict_ordered_semiring s :=
subtype.coe_injective.strict_ordered_semiring coe
  rfl rfl (λ _ _, rfl) (λ _ _, rfl) (λ _ _, rfl) (λ _ _, rfl) (λ _, rfl)

/-- A subsemiring of an `ordered_comm_semiring` is an `ordered_comm_semiring`. -/
instance to_ordered_comm_semiring {R} [ordered_comm_semiring R] [set_like S R]
  [subsemiring_class S R] : ordered_comm_semiring s :=
subtype.coe_injective.ordered_comm_semiring coe
  rfl rfl (λ _ _, rfl) (λ _ _, rfl) (λ _ _, rfl) (λ _ _, rfl) (λ _, rfl)

/-- A subsemiring of an `strict_ordered_comm_semiring` is an `strict_ordered_comm_semiring`. -/
instance to_strict_ordered_comm_semiring {R} [strict_ordered_comm_semiring R] [set_like S R]
  [subsemiring_class S R] :
  strict_ordered_comm_semiring s :=
subtype.coe_injective.strict_ordered_comm_semiring coe
  rfl rfl (λ _ _, rfl) (λ _ _, rfl) (λ _ _, rfl) (λ _ _, rfl) (λ _, rfl)

/-- A subsemiring of a `linear_ordered_semiring` is a `linear_ordered_semiring`. -/
instance to_linear_ordered_semiring {R} [linear_ordered_semiring R] [set_like S R]
  [subsemiring_class S R] : linear_ordered_semiring s :=
subtype.coe_injective.linear_ordered_semiring coe
  rfl rfl (λ _ _, rfl) (λ _ _, rfl) (λ _ _, rfl) (λ _ _, rfl) (λ _, rfl) (λ _ _, rfl) (λ _ _, rfl)

/-- A subsemiring of a `linear_ordered_comm_semiring` is a `linear_ordered_comm_semiring`. -/
instance to_linear_ordered_comm_semiring {R} [linear_ordered_comm_semiring R] [set_like S R]
  [subsemiring_class S R] : linear_ordered_comm_semiring s :=
subtype.coe_injective.linear_ordered_comm_semiring coe
  rfl rfl (λ _ _, rfl) (λ _ _, rfl) (λ _ _, rfl) (λ _ _, rfl) (λ _, rfl) (λ _ _, rfl) (λ _ _, rfl)

end subsemiring_class

end subsemiring_class

variables [non_assoc_semiring S] [non_assoc_semiring T]

set_option old_structure_cmd true

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

/-- Reinterpret a `subsemiring` as a `submonoid`. -/
add_decl_doc subsemiring.to_submonoid

/-- Reinterpret a `subsemiring` as an `add_submonoid`. -/
add_decl_doc subsemiring.to_add_submonoid

namespace subsemiring

instance : set_like (subsemiring R) R :=
{ coe := subsemiring.carrier,
  coe_injective' := λ p q h, by cases p; cases q; congr' }

instance : subsemiring_class (subsemiring R) R :=
{ zero_mem := zero_mem',
  add_mem := add_mem',
  one_mem := one_mem',
  mul_mem := mul_mem' }

@[simp]
lemma mem_carrier {s : subsemiring R} {x : R} : x ∈ s.carrier ↔ x ∈ s := iff.rfl

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

/-- Copy of a subsemiring with a new `carrier` equal to the old one. Useful to fix definitional
equalities.-/
protected def copy (S : subsemiring R) (s : set R) (hs : s = ↑S) : subsemiring R :=
{ carrier := s,
  ..S.to_add_submonoid.copy s hs,
  ..S.to_submonoid.copy s hs }

@[simp] lemma coe_copy (S : subsemiring R) (s : set R) (hs : s = ↑S) :
  (S.copy s hs : set R) = s := rfl

lemma copy_eq (S : subsemiring R) (s : set R) (hs : s = ↑S) : S.copy s hs = S :=
set_like.coe_injective hs

lemma to_submonoid_injective : function.injective (to_submonoid : subsemiring R → submonoid R)
| r s h := ext (set_like.ext_iff.mp h : _)

@[mono] lemma to_submonoid_strict_mono : strict_mono (to_submonoid : subsemiring R → submonoid R) :=
λ _ _, id

@[mono] lemma to_submonoid_mono : monotone (to_submonoid : subsemiring R → submonoid R) :=
to_submonoid_strict_mono.monotone

lemma to_add_submonoid_injective :
  function.injective (to_add_submonoid : subsemiring R → add_submonoid R)
| r s h := ext (set_like.ext_iff.mp h : _)

@[mono] lemma to_add_submonoid_strict_mono :
  strict_mono (to_add_submonoid : subsemiring R → add_submonoid R) := λ _ _, id

@[mono]
lemma to_add_submonoid_mono : monotone (to_add_submonoid : subsemiring R → add_submonoid R) :=
to_add_submonoid_strict_mono.monotone

/-- 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' (s : set R) (sm : submonoid R) (hm : ↑sm = s)
  (sa : add_submonoid R) (ha : ↑sa = s) :
  subsemiring R :=
{ carrier := s,
  zero_mem' := ha ▸ sa.zero_mem,
  one_mem' := hm ▸ sm.one_mem,
  add_mem' := λ x y, by simpa only [← ha] using sa.add_mem,
  mul_mem' := λ x y, by simpa only [← hm] using sm.mul_mem }

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

@[simp] lemma mem_mk' {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] lemma mk'_to_submonoid {s : set R} {sm : submonoid R} (hm : ↑sm = s)
  {sa : add_submonoid R} (ha : ↑sa = s) :
  (subsemiring.mk' s sm hm sa ha).to_submonoid = sm :=
set_like.coe_injective hm.symm

@[simp] lemma mk'_to_add_submonoid {s : set R} {sm : submonoid R} (hm : ↑sm = s)
  {sa : add_submonoid R} (ha : ↑sa  =s) :
  (subsemiring.mk' s sm hm sa ha).to_add_submonoid = sa :=
set_like.coe_injective ha.symm

end subsemiring

namespace subsemiring

variables (s : subsemiring R)

/-- A subsemiring contains the semiring's 1. -/
protected theorem one_mem : (1 : R) ∈ s := one_mem s

/-- A subsemiring contains the semiring's 0. -/
protected theorem zero_mem : (0 : R) ∈ s := zero_mem s

/-- A subsemiring is closed under multiplication. -/
protected theorem mul_mem {x y : R} : x ∈ s → y ∈ s → x * y ∈ s := mul_mem

/-- A subsemiring is closed under addition. -/
protected theorem add_mem {x y : R} : x ∈ s → y ∈ s → x + y ∈ s := add_mem

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

/-- Sum of a list of elements in a `subsemiring` is in the `subsemiring`. -/
protected lemma list_sum_mem {l : list R} : (∀x ∈ l, x ∈ s) → l.sum ∈ s := list_sum_mem

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

/-- Sum of a multiset of elements in a `subsemiring` of a `semiring` is
in the `add_subsemiring`. -/
protected lemma multiset_sum_mem (m : multiset R) :
  (∀a ∈ m, a ∈ s) → m.sum ∈ s :=
multiset_sum_mem m

/-- Product of elements of a subsemiring of a `comm_semiring` indexed by a `finset` is in the
    subsemiring. -/
protected lemma prod_mem {R : Type*} [comm_semiring R] (s : subsemiring R)
  {ι : Type*} {t : finset ι} {f : ι → R} (h : ∀c ∈ t, f c ∈ s) :
  ∏ i in t, f i ∈ s :=
prod_mem h

/-- Sum of elements in an `subsemiring` of an `semiring` indexed by a `finset`
is in the `add_subsemiring`. -/
protected lemma sum_mem (s : subsemiring R)
  {ι : Type*} {t : finset ι} {f : ι → R} (h : ∀c ∈ t, f c ∈ s) :
  ∑ i in t, f i ∈ s :=
sum_mem h
/-- A subsemiring of a `non_assoc_semiring` inherits a `non_assoc_semiring` structure -/
instance to_non_assoc_semiring : non_assoc_semiring s :=
{ mul_zero := λ x, subtype.eq $ mul_zero x,
  zero_mul := λ x, subtype.eq $ zero_mul x,
  right_distrib := λ x y z, subtype.eq $ right_distrib x y z,
  left_distrib := λ x y z, subtype.eq $ left_distrib x y z,
  nat_cast := λ n, ⟨n, coe_nat_mem s n⟩,
  nat_cast_zero := by simp [nat.cast]; refl,
  nat_cast_succ := λ _, by simp [nat.cast]; refl,
  .. s.to_submonoid.to_mul_one_class, .. s.to_add_submonoid.to_add_comm_monoid }

@[simp, norm_cast] lemma coe_one : ((1 : s) : R) = (1 : R) := rfl
@[simp, norm_cast] lemma coe_zero : ((0 : s) : R) = (0 : R) := rfl
@[simp, norm_cast] lemma coe_add (x y : s) : ((x + y : s) : R) = (x + y : R) := rfl
@[simp, norm_cast] lemma coe_mul (x y : s) : ((x * y : s) : R) = (x * y : R) := rfl

instance nontrivial [nontrivial R] : nontrivial s :=
nontrivial_of_ne 0 1 $ λ H, zero_ne_one (congr_arg subtype.val H)

protected lemma pow_mem {R : Type*} [semiring R] (s : subsemiring R) {x : R} (hx : x ∈ s) (n : ℕ) :
  x^n ∈ s := pow_mem hx n

instance no_zero_divisors [no_zero_divisors R] : no_zero_divisors s :=
{ eq_zero_or_eq_zero_of_mul_eq_zero := λ x y h,
  or.cases_on (eq_zero_or_eq_zero_of_mul_eq_zero $ subtype.ext_iff.mp h)
    (λ h, or.inl $ subtype.eq h) (λ h, or.inr $ subtype.eq h) }

/-- A subsemiring of a `semiring` is a `semiring`. -/
instance to_semiring {R} [semiring R] (s : subsemiring R) : semiring s :=
{ ..s.to_non_assoc_semiring, ..s.to_submonoid.to_monoid }

@[simp, norm_cast] lemma coe_pow {R} [semiring R] (s : subsemiring R) (x : s) (n : ℕ) :
  ((x^n : s) : R) = (x^n : R) :=
begin
  induction n with n ih,
  { simp, },
  { simp [pow_succ, ih], },
end

/-- A subsemiring of a `comm_semiring` is a `comm_semiring`. -/
instance to_comm_semiring {R} [comm_semiring R] (s : subsemiring R) : comm_semiring s :=
{ mul_comm := λ _ _, subtype.eq $ mul_comm _ _, ..s.to_semiring}

/-- The natural ring hom from a subsemiring of semiring `R` to `R`. -/
def subtype : s →+* R :=
{ to_fun := coe, .. s.to_submonoid.subtype, .. s.to_add_submonoid.subtype }

@[simp] theorem coe_subtype : ⇑s.subtype = coe := rfl

/-- A subsemiring of an `ordered_semiring` is an `ordered_semiring`. -/
instance to_ordered_semiring {R} [ordered_semiring R] (s : subsemiring R) : ordered_semiring s :=
subtype.coe_injective.ordered_semiring coe
  rfl rfl (λ _ _, rfl) (λ _ _, rfl) (λ _ _, rfl) (λ _ _, rfl) (λ _, rfl)

/-- A subsemiring of a `strict_ordered_semiring` is a `strict_ordered_semiring`. -/
instance to_strict_ordered_semiring {R} [strict_ordered_semiring R] (s : subsemiring R) :
  strict_ordered_semiring s :=
subtype.coe_injective.strict_ordered_semiring coe
  rfl rfl (λ _ _, rfl) (λ _ _, rfl) (λ _ _, rfl) (λ _ _, rfl) (λ _, rfl)

/-- A subsemiring of an `ordered_comm_semiring` is an `ordered_comm_semiring`. -/
instance to_ordered_comm_semiring {R} [ordered_comm_semiring R] (s : subsemiring R) :
  ordered_comm_semiring s :=
subtype.coe_injective.ordered_comm_semiring coe
  rfl rfl (λ _ _, rfl) (λ _ _, rfl) (λ _ _, rfl) (λ _ _, rfl) (λ _, rfl)

/-- A subsemiring of a `strict_ordered_comm_semiring` is a `strict_ordered_comm_semiring`. -/
instance to_strict_ordered_comm_semiring {R} [strict_ordered_comm_semiring R] (s : subsemiring R) :
  strict_ordered_comm_semiring s :=
subtype.coe_injective.strict_ordered_comm_semiring coe
  rfl rfl (λ _ _, rfl) (λ _ _, rfl) (λ _ _, rfl) (λ _ _, rfl) (λ _, rfl)

/-- A subsemiring of a `linear_ordered_semiring` is a `linear_ordered_semiring`. -/
instance to_linear_ordered_semiring {R} [linear_ordered_semiring R] (s : subsemiring R) :
  linear_ordered_semiring s :=
subtype.coe_injective.linear_ordered_semiring coe
  rfl rfl (λ _ _, rfl) (λ _ _, rfl) (λ _ _, rfl) (λ _ _, rfl) (λ _, rfl) (λ _ _, rfl) (λ _ _, rfl)

/-- A subsemiring of a `linear_ordered_comm_semiring` is a `linear_ordered_comm_semiring`. -/
instance to_linear_ordered_comm_semiring {R} [linear_ordered_comm_semiring R] (s : subsemiring R) :
  linear_ordered_comm_semiring s :=
subtype.coe_injective.linear_ordered_comm_semiring coe
  rfl rfl (λ _ _, rfl) (λ _ _, rfl) (λ _ _, rfl) (λ _ _, rfl) (λ _, rfl) (λ _ _, rfl) (λ _ _, rfl)

protected lemma nsmul_mem {x : R} (hx : x ∈ s) (n : ℕ) :
  n • x ∈ s := nsmul_mem hx n

@[simp] lemma mem_to_submonoid {s : subsemiring R} {x : R} : x ∈ s.to_submonoid ↔ x ∈ s := iff.rfl
@[simp] lemma coe_to_submonoid (s : subsemiring R) : (s.to_submonoid : set R) = s := rfl
@[simp] lemma mem_to_add_submonoid {s : subsemiring R} {x : R} :
  x ∈ s.to_add_submonoid ↔ x ∈ s := iff.rfl
@[simp] lemma coe_to_add_submonoid (s : subsemiring R) : (s.to_add_submonoid : set R) = s := rfl

/-- The subsemiring `R` of the semiring `R`. -/
instance : has_top (subsemiring R) :=
⟨{ .. (⊤ : submonoid R), .. (⊤ : add_submonoid R) }⟩

@[simp] lemma mem_top (x : R) : x ∈ (⊤ : subsemiring R) := set.mem_univ x

@[simp] lemma coe_top : ((⊤ : subsemiring R) : set R) = set.univ := rfl

/-- The ring equiv between the top element of `subsemiring R` and `R`. -/
@[simps]
def top_equiv : (⊤ : subsemiring R) ≃+* R :=
{ to_fun := λ r, r,
  inv_fun := λ r, ⟨r, subsemiring.mem_top r⟩,
  left_inv := λ r, set_like.eta r _,
  right_inv := λ r, set_like.coe_mk r _,
  map_mul' := (⊤ : subsemiring R).coe_mul,
  map_add' := (⊤ : subsemiring R).coe_add, }

/-- The preimage of a subsemiring along a ring homomorphism is a subsemiring. -/
def comap (f : R →+* S) (s : subsemiring S) : subsemiring R :=
{ carrier := f ⁻¹' s,
  .. s.to_submonoid.comap (f : R →* S), .. s.to_add_submonoid.comap (f : R →+ S) }

@[simp]

@[simp]
lemma mem_comap {s : subsemiring S} {f : R →+* S} {x : R} : x ∈ s.comap f ↔ f x ∈ s := iff.rfl

lemma comap_comap (s : subsemiring T) (g : S →+* T) (f : R →+* S) :
  (s.comap g).comap f = s.comap (g.comp f) :=
rfl

/-- The image of a subsemiring along a ring homomorphism is a subsemiring. -/
def map (f : R →+* S) (s : subsemiring R) : subsemiring S :=
{ carrier := f '' s,
  .. s.to_submonoid.map (f : R →* S), .. s.to_add_submonoid.map (f : R →+ S) }

@[simp] lemma coe_map (f : R →+* S) (s : subsemiring R) : (s.map f : set S) = f '' s := rfl

@[simp] lemma mem_map {f : R →+* S} {s : subsemiring R} {y : S} :
  y ∈ s.map f ↔ ∃ x ∈ s, f x = y :=
set.mem_image_iff_bex

@[simp] lemma map_id : s.map (ring_hom.id R) = s :=
set_like.coe_injective $ set.image_id _

lemma map_map (g : S →+* T) (f : R →+* S) : (s.map f).map g = s.map (g.comp f) :=
set_like.coe_injective $ set.image_image _ _ _

lemma map_le_iff_le_comap {f : R →+* S} {s : subsemiring R} {t : subsemiring S} :
  s.map f ≤ t ↔ s ≤ t.comap f :=
set.image_subset_iff

lemma gc_map_comap (f : R →+* S) : galois_connection (map f) (comap f) :=
λ S T, map_le_iff_le_comap

/-- A subsemiring is isomorphic to its image under an injective function -/
noncomputable def equiv_map_of_injective
  (f : R →+* S) (hf : function.injective f) : s ≃+* s.map f :=
{ map_mul' := λ _ _, subtype.ext (f.map_mul _ _),
  map_add' := λ _ _, subtype.ext (f.map_add _ _),
  ..equiv.set.image f s hf }

@[simp] lemma coe_equiv_map_of_injective_apply
  (f : R →+* S) (hf : function.injective f) (x : s) :
  (equiv_map_of_injective s f hf x : S) = f x := rfl

end subsemiring

namespace ring_hom

variables (g : S →+* T) (f : R →+* S)

/-- The range of a ring homomorphism is a subsemiring. See Note [range copy pattern]. -/
def srange : subsemiring S :=
((⊤ : subsemiring R).map f).copy (set.range f) set.image_univ.symm

@[simp] lemma coe_srange : (f.srange : set S) = set.range f := rfl

@[simp] lemma mem_srange {f : R →+* S} {y : S} : y ∈ f.srange ↔ ∃ x, f x = y :=
iff.rfl

lemma srange_eq_map (f : R →+* S) : f.srange = (⊤ : subsemiring R).map f :=
by { ext, simp }

lemma mem_srange_self (f : R →+* S) (x : R) : f x ∈ f.srange :=
mem_srange.mpr ⟨x, rfl⟩

lemma map_srange : f.srange.map g = (g.comp f).srange :=
by simpa only [srange_eq_map] using (⊤ : subsemiring R).map_map g f

/-- The range of a morphism of semirings is a fintype, if the domain is a fintype.
Note: this instance can form a diamond with `subtype.fintype` in the
  presence of `fintype S`.-/
instance fintype_srange [fintype R] [decidable_eq S] (f : R →+* S) : fintype (srange f) :=
set.fintype_range f

end ring_hom

namespace subsemiring

instance : has_bot (subsemiring R) := ⟨(nat.cast_ring_hom R).srange⟩

instance : inhabited (subsemiring R) := ⟨⊥⟩

lemma coe_bot : ((⊥ : subsemiring R) : set R) = set.range (coe : ℕ → R) :=
(nat.cast_ring_hom R).coe_srange

lemma mem_bot {x : R} : x ∈ (⊥ : subsemiring R) ↔ ∃ n : ℕ, ↑n=x := ring_hom.mem_srange

/-- The inf of two subsemirings is their intersection. -/
instance : has_inf (subsemiring R) :=
⟨λ s t,
  { carrier := s ∩ t,
    .. s.to_submonoid ⊓ t.to_submonoid,
    .. s.to_add_submonoid ⊓ t.to_add_submonoid }⟩

@[simp] lemma coe_inf (p p' : subsemiring R) : ((p ⊓ p' : subsemiring R) : set R) = p ∩ p' := rfl

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

instance : has_Inf (subsemiring R) :=
⟨λ s, subsemiring.mk' (⋂ t ∈ s, ↑t) (⨅ t ∈ s, subsemiring.to_submonoid t) (by simp)
  (⨅ t ∈ s, subsemiring.to_add_submonoid t) (by simp)⟩

@[simp, norm_cast] lemma coe_Inf (S : set (subsemiring R)) :
  ((Inf S : subsemiring R) : set R) = ⋂ s ∈ S, ↑s := rfl

lemma mem_Inf {S : set (subsemiring R)} {x : R} : x ∈ Inf S ↔ ∀ p ∈ S, x ∈ p := set.mem_Inter₂

@[simp] lemma Inf_to_submonoid (s : set (subsemiring R)) :
  (Inf s).to_submonoid = ⨅ t ∈ s, subsemiring.to_submonoid t :=
mk'_to_submonoid _ _

@[simp] lemma Inf_to_add_submonoid (s : set (subsemiring R)) :
  (Inf s).to_add_submonoid = ⨅ t ∈ s, subsemiring.to_add_submonoid t :=
mk'_to_add_submonoid _ _

/-- Subsemirings of a semiring form a complete lattice. -/
instance : complete_lattice (subsemiring R) :=
{ bot := (⊥),
  bot_le := λ s x hx, let ⟨n, hn⟩ := mem_bot.1 hx in hn ▸ coe_nat_mem s n,
  top := (⊤),
  le_top := λ s x hx, trivial,
  inf := (⊓),
  inf_le_left := λ s t x, and.left,
  inf_le_right := λ s t x, and.right,
  le_inf := λ s t₁ t₂ h₁ h₂ x hx, ⟨h₁ hx, h₂ hx⟩,
  .. complete_lattice_of_Inf (subsemiring R)
    (λ s, is_glb.of_image (λ s t,
      show (s : set R) ≤ t ↔ s ≤ t, from set_like.coe_subset_coe) is_glb_binfi)}

lemma eq_top_iff' (A : subsemiring R) : A = ⊤ ↔ ∀ x : R, x ∈ A :=
eq_top_iff.trans ⟨λ h m, h $ mem_top m, λ h m _, h m⟩

section center

/-- The center of a semiring `R` is the set of elements that commute with everything in `R` -/
def center (R) [semiring R] : subsemiring R :=
{ carrier := set.center R,
  zero_mem' := set.zero_mem_center R,
  add_mem' := λ a b, set.add_mem_center,
  .. submonoid.center R }

lemma coe_center (R) [semiring R] : ↑(center R) = set.center R := rfl

@[simp]
lemma center_to_submonoid (R) [semiring R] : (center R).to_submonoid = submonoid.center R := rfl

lemma mem_center_iff {R} [semiring R] {z : R} : z ∈ center R ↔ ∀ g, g * z = z * g :=
iff.rfl

instance decidable_mem_center {R} [semiring R] [decidable_eq R] [fintype R] :
  decidable_pred (∈ center R) :=
λ _, decidable_of_iff' _ mem_center_iff

@[simp] lemma center_eq_top (R) [comm_semiring R] : center R = ⊤ :=
set_like.coe_injective (set.center_eq_univ R)

/-- The center is commutative. -/
instance {R} [semiring R] : comm_semiring (center R) :=
{ ..submonoid.center.comm_monoid,
  ..(center R).to_semiring}

end center

section centralizer

/-- The centralizer of a set as subsemiring. -/
def centralizer {R} [semiring R] (s : set R) : subsemiring R :=
{ carrier := s.centralizer,
  zero_mem' := set.zero_mem_centralizer _,
  add_mem' := λ x y hx hy, set.add_mem_centralizer hx hy,
  ..submonoid.centralizer s }

@[simp, norm_cast]
lemma coe_centralizer {R} [semiring R] (s : set R) : (centralizer s : set R) = s.centralizer := rfl

lemma centralizer_to_submonoid {R} [semiring R] (s : set R) :
  (centralizer s).to_submonoid = submonoid.centralizer s := rfl

lemma mem_centralizer_iff {R} [semiring R] {s : set R} {z : R} :
  z ∈ centralizer s ↔ ∀ g ∈ s, g * z = z * g :=
iff.rfl

lemma centralizer_le {R} [semiring R] (s t : set R) (h : s ⊆ t) :
  centralizer t ≤ centralizer s :=
set.centralizer_subset h

@[simp]
lemma centralizer_univ {R} [semiring R] : centralizer set.univ = center R :=
set_like.ext' (set.centralizer_univ R)

end centralizer

/-- The `subsemiring` generated by a set. -/
def closure (s : set R) : subsemiring R := Inf {S | s ⊆ S}

lemma mem_closure {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] lemma subset_closure {s : set R} : s ⊆ closure s := λ x hx, mem_closure.2 $ λ S hS, hS hx

lemma not_mem_of_not_mem_closure {s : set R} {P : R} (hP : P ∉ closure s) : P ∉ s :=
λ h, hP (subset_closure h)

/-- A subsemiring `S` includes `closure s` if and only if it includes `s`. -/
@[simp]
lemma closure_le {s : set R} {t : subsemiring R} : closure s ≤ t ↔ s ⊆ t :=
⟨set.subset.trans subset_closure, λ h, Inf_le h⟩

/-- Subsemiring closure of a set is monotone in its argument: if `s ⊆ t`,
then `closure s ≤ closure t`. -/
lemma closure_mono ⦃s t : set R⦄ (h : s ⊆ t) : closure s ≤ closure t :=
closure_le.2 $ set.subset.trans h subset_closure

lemma closure_eq_of_le {s : set R} {t : subsemiring R} (h₁ : s ⊆ t) (h₂ : t ≤ closure s) :
  closure s = t :=
le_antisymm (closure_le.2 h₁) h₂

lemma mem_map_equiv {f : R ≃+* S} {K : subsemiring R} {x : S} :
  x ∈ K.map (f : R →+* S) ↔ f.symm x ∈ K :=
@set.mem_image_equiv _ _ ↑K f.to_equiv x

lemma map_equiv_eq_comap_symm (f : R ≃+* S) (K : subsemiring R) :
  K.map (f : R →+* S) = K.comap f.symm :=
set_like.coe_injective (f.to_equiv.image_eq_preimage K)

lemma comap_equiv_eq_map_symm (f : R ≃+* S) (K : subsemiring S) :
  K.comap (f : R →+* S) = K.map f.symm :=
(map_equiv_eq_comap_symm f.symm K).symm

end subsemiring

namespace submonoid

/-- The additive closure of a submonoid is a subsemiring. -/
def subsemiring_closure (M : submonoid R) : subsemiring R :=
{ one_mem' := add_submonoid.mem_closure.mpr (λ y hy, hy M.one_mem),
  mul_mem' := λ x y, mul_mem_class.mul_mem_add_closure,
  ..add_submonoid.closure (M : set R)}

lemma subsemiring_closure_coe :
  (M.subsemiring_closure : set R) = add_submonoid.closure (M : set R) := rfl

lemma subsemiring_closure_to_add_submonoid :
  M.subsemiring_closure.to_add_submonoid = add_submonoid.closure (M : set R) := rfl

/-- The `subsemiring` generated by a multiplicative submonoid coincides with the
`subsemiring.closure` of the submonoid itself . -/
lemma subsemiring_closure_eq_closure : M.subsemiring_closure = subsemiring.closure (M : set R) :=
begin
  ext,
  refine ⟨λ hx, _, λ hx, (subsemiring.mem_closure.mp hx) M.subsemiring_closure (λ s sM, _)⟩;
  rintros - ⟨H1, rfl⟩;
  rintros - ⟨H2, rfl⟩,
  { exact add_submonoid.mem_closure.mp hx H1.to_add_submonoid H2 },
  { exact H2 sM }
end

end submonoid

namespace subsemiring

@[simp]
lemma closure_submonoid_closure (s : set R) : closure ↑(submonoid.closure s) = closure s :=
le_antisymm
  (closure_le.mpr (λ y hy, (submonoid.mem_closure.mp hy) (closure s).to_submonoid subset_closure))
  (closure_mono (submonoid.subset_closure))

/-- The elements of the subsemiring closure of `M` are exactly the elements of the additive closure
of a multiplicative submonoid `M`. -/
lemma coe_closure_eq (s : set R) :
  (closure s : set R) = add_submonoid.closure (submonoid.closure s : set R) :=
by simp [← submonoid.subsemiring_closure_to_add_submonoid, submonoid.subsemiring_closure_eq_closure]

lemma mem_closure_iff {s : set R} {x} :
  x ∈ closure s ↔ x ∈ add_submonoid.closure (submonoid.closure s : set R) :=
set.ext_iff.mp (coe_closure_eq s) x

@[simp]
lemma closure_add_submonoid_closure {s : set R} : closure ↑(add_submonoid.closure s) = closure s :=
begin
  ext x,
  refine ⟨λ hx, _, λ hx, closure_mono add_submonoid.subset_closure hx⟩,
  rintros - ⟨H, rfl⟩,
  rintros - ⟨J, rfl⟩,
  refine (add_submonoid.mem_closure.mp (mem_closure_iff.mp hx)) H.to_add_submonoid (λ y hy, _),
  refine (submonoid.mem_closure.mp hy) H.to_submonoid (λ z hz, _),
  exact (add_submonoid.mem_closure.mp hz) H.to_add_submonoid (λ w hw, J hw),
end

/-- 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`. -/
@[elab_as_eliminator]
lemma closure_induction {s : set R} {p : R → Prop} {x} (h : x ∈ closure s)
  (Hs : ∀ x ∈ s, p x) (H0 : p 0) (H1 : p 1)
  (Hadd : ∀ x y, p x → p y → p (x + y)) (Hmul : ∀ x y, p x → p y → p (x * y)) : p x :=
(@closure_le _ _ _ ⟨p, Hmul, H1, Hadd, H0⟩).2 Hs h

/-- An induction principle for closure membership for predicates with two arguments. -/
@[elab_as_eliminator]
lemma closure_induction₂ {s : set R} {p : R → R → Prop} {x} {y : R} (hx : x ∈ closure s)
  (hy : y ∈ closure s)
  (Hs : ∀ (x ∈ s) (y ∈ s), p x y)
  (H0_left : ∀ x, p 0 x)
  (H0_right : ∀ x, p x 0)
  (H1_left : ∀ x, p 1 x)
  (H1_right : ∀ x, p x 1)
  (Hadd_left : ∀ x₁ x₂ y, p x₁ y → p x₂ y → p (x₁ + x₂) y)
  (Hadd_right : ∀ x y₁ y₂, p x y₁ → p x y₂ → p x (y₁ + y₂))
  (Hmul_left : ∀ x₁ x₂ y, p x₁ y → p x₂ y → p (x₁ * x₂) y)
  (Hmul_right : ∀ x y₁ y₂, p x y₁ → p x y₂ → p x (y₁ * y₂))
  : p x y :=
closure_induction hx
  (λ x₁ x₁s, closure_induction hy (Hs x₁ x₁s) (H0_right x₁) (H1_right x₁) (Hadd_right x₁)
                                                                                (Hmul_right x₁))
  (H0_left y) (H1_left y) (λ z z', Hadd_left z z' y) (λ z z', Hmul_left z z' y)

lemma mem_closure_iff_exists_list {R} [semiring R] {s : set R} {x} : x ∈ closure s ↔
  ∃ L : list (list R), (∀ t ∈ L, ∀ y ∈ t, y ∈ s) ∧ (L.map list.prod).sum = x :=
⟨λ hx, add_submonoid.closure_induction (mem_closure_iff.1 hx)
  (λ x hx, suffices ∃ t : list R, (∀ y ∈ t, y ∈ s) ∧ t.prod = x,
    from let ⟨t, ht1, ht2⟩ := this in ⟨[t], list.forall_mem_singleton.2 ht1,
      by rw [list.map_singleton, list.sum_singleton, ht2]⟩,
    submonoid.closure_induction hx
      (λ x hx, ⟨[x], list.forall_mem_singleton.2 hx, one_mul x⟩)
      ⟨[], list.forall_mem_nil _, rfl⟩
      (λ x y ⟨t, ht1, ht2⟩ ⟨u, hu1, hu2⟩, ⟨t ++ u, list.forall_mem_append.2 ⟨ht1, hu1⟩,
        by rw [list.prod_append, ht2, hu2]⟩))
  ⟨[], list.forall_mem_nil _, rfl⟩
  (λ x y ⟨L, HL1, HL2⟩ ⟨M, HM1, HM2⟩, ⟨L ++ M, list.forall_mem_append.2 ⟨HL1, HM1⟩,
    by rw [list.map_append, list.sum_append, HL2, HM2]⟩),
λ ⟨L, HL1, HL2⟩, HL2 ▸ list_sum_mem (λ r hr, let ⟨t, ht1, ht2⟩ := list.mem_map.1 hr in
  ht2 ▸ list_prod_mem _ (λ y hy, subset_closure $ HL1 t ht1 y hy))⟩

variable (R)

/-- `closure` forms a Galois insertion with the coercion to set. -/
protected def gi : galois_insertion (@closure R _) coe :=
{ choice := λ s _, closure s,
  gc := λ s t, closure_le,
  le_l_u := λ s, subset_closure,
  choice_eq := λ s h, rfl }

variable {R}

/-- Closure of a subsemiring `S` equals `S`. -/
lemma closure_eq (s : subsemiring R) : closure (s : set R) = s := (subsemiring.gi R).l_u_eq s

@[simp] lemma closure_empty : closure (∅ : set R) = ⊥ := (subsemiring.gi R).gc.l_bot

@[simp] lemma closure_univ : closure (set.univ : set R) = ⊤ := @coe_top R _ ▸ closure_eq ⊤

lemma closure_union (s t : set R) : closure (s ∪ t) = closure s ⊔ closure t :=
(subsemiring.gi R).gc.l_sup

lemma closure_Union {ι} (s : ι → set R) : closure (⋃ i, s i) = ⨆ i, closure (s i) :=
(subsemiring.gi R).gc.l_supr

lemma closure_sUnion (s : set (set R)) : closure (⋃₀ s) = ⨆ t ∈ s, closure t :=
(subsemiring.gi R).gc.l_Sup

lemma map_sup (s t : subsemiring R) (f : R →+* S) : (s ⊔ t).map f = s.map f ⊔ t.map f :=
(gc_map_comap f).l_sup

lemma map_supr {ι : Sort*} (f : R →+* S) (s : ι → subsemiring R) :
  (supr s).map f = ⨆ i, (s i).map f :=
(gc_map_comap f).l_supr

lemma comap_inf (s t : subsemiring S) (f : R →+* S) : (s ⊓ t).comap f = s.comap f ⊓ t.comap f :=
(gc_map_comap f).u_inf

lemma comap_infi {ι : Sort*} (f : R →+* S) (s : ι → subsemiring S) :
  (infi s).comap f = ⨅ i, (s i).comap f :=
(gc_map_comap f).u_infi

@[simp] lemma map_bot (f : R →+* S) : (⊥ : subsemiring R).map f = ⊥ :=
(gc_map_comap f).l_bot

@[simp] lemma comap_top (f : R →+* S) : (⊤ : subsemiring S).comap f = ⊤ :=
(gc_map_comap f).u_top

/-- Given `subsemiring`s `s`, `t` of semirings `R`, `S` respectively, `s.prod t` is `s × t`
as a subsemiring of `R × S`. -/
def prod (s : subsemiring R) (t : subsemiring S) : subsemiring (R × S) :=
{ carrier := s ×ˢ t,
  .. s.to_submonoid.prod t.to_submonoid, .. s.to_add_submonoid.prod t.to_add_submonoid}

@[norm_cast]
lemma coe_prod (s : subsemiring R) (t : subsemiring S) : (s.prod t : set (R × S)) = s ×ˢ t :=
rfl

lemma mem_prod {s : subsemiring R} {t : subsemiring S} {p : R × S} :
  p ∈ s.prod t ↔ p.1 ∈ s ∧ p.2 ∈ t := iff.rfl

@[mono] lemma prod_mono ⦃s₁ s₂ : subsemiring R⦄ (hs : s₁ ≤ s₂) ⦃t₁ t₂ : subsemiring S⦄
  (ht : t₁ ≤ t₂) : s₁.prod t₁ ≤ s₂.prod t₂ :=
set.prod_mono hs ht

lemma prod_mono_right (s : subsemiring R) : monotone (λ t : subsemiring S, s.prod t) :=
prod_mono (le_refl s)

lemma prod_mono_left (t : subsemiring S) : monotone (λ s : subsemiring R, s.prod t) :=
λ s₁ s₂ hs, prod_mono hs (le_refl t)

lemma prod_top (s : subsemiring R) :
  s.prod (⊤ : subsemiring S) = s.comap (ring_hom.fst R S) :=
ext $ λ x, by simp [mem_prod, monoid_hom.coe_fst]

lemma top_prod (s : subsemiring S) :
  (⊤ : subsemiring R).prod s = s.comap (ring_hom.snd R S) :=
ext $ λ x, by simp [mem_prod, monoid_hom.coe_snd]

@[simp]
lemma top_prod_top : (⊤ : subsemiring R).prod (⊤ : subsemiring S) = ⊤ :=
(top_prod _).trans $ comap_top _

/-- Product of subsemirings is isomorphic to their product as monoids. -/
def prod_equiv (s : subsemiring R) (t : subsemiring S) : s.prod t ≃+* s × t :=
{ map_mul' := λ x y, rfl, map_add' := λ x y, rfl, .. equiv.set.prod ↑s ↑t }

lemma mem_supr_of_directed {ι} [hι : nonempty ι] {S : ι → subsemiring R} (hS : directed (≤) S)
  {x : R} :
  x ∈ (⨆ i, S i) ↔ ∃ i, x ∈ S i :=
begin
  refine ⟨_, λ ⟨i, hi⟩, (set_like.le_def.1 $ le_supr S i) hi⟩,
  let U : subsemiring R := subsemiring.mk' (⋃ i, (S i : set R))
    (⨆ i, (S i).to_submonoid) (submonoid.coe_supr_of_directed $ hS.mono_comp _ (λ _ _, id))
    (⨆ i, (S i).to_add_submonoid) (add_submonoid.coe_supr_of_directed $ hS.mono_comp _ (λ _ _, id)),
  suffices : (⨆ i, S i) ≤ U, by simpa using @this x,
  exact supr_le (λ i x hx, set.mem_Union.2 ⟨i, hx⟩),
end

lemma coe_supr_of_directed {ι} [hι : nonempty ι] {S : ι → subsemiring R} (hS : directed (≤) S) :
  ((⨆ i, S i : subsemiring R) : set R) = ⋃ i, ↑(S i) :=
set.ext $ λ x, by simp [mem_supr_of_directed hS]

lemma mem_Sup_of_directed_on {S : set (subsemiring R)} (Sne : S.nonempty)
  (hS : directed_on (≤) S) {x : R} :
  x ∈ Sup S ↔ ∃ s ∈ S, x ∈ s :=
begin
  haveI : nonempty S := Sne.to_subtype,
  simp only [Sup_eq_supr', mem_supr_of_directed hS.directed_coe, set_coe.exists, subtype.coe_mk]
end

lemma coe_Sup_of_directed_on {S : set (subsemiring R)} (Sne : S.nonempty) (hS : directed_on (≤) S) :
  (↑(Sup S) : set R) = ⋃ s ∈ S, ↑s :=
set.ext $ λ x, by simp [mem_Sup_of_directed_on Sne hS]

end subsemiring

namespace ring_hom

variables [non_assoc_semiring T] {s : subsemiring R}
variables {σR σS : Type*}
variables [set_like σR R] [set_like σS S] [subsemiring_class σR R] [subsemiring_class σS S]

open subsemiring

/-- Restriction of a ring homomorphism to a subsemiring of the domain. -/
def dom_restrict (f : R →+* S) (s : σR) : s →+* S := f.comp $ subsemiring_class.subtype s

@[simp] lemma restrict_apply (f : R →+* S) {s : σR} (x : s) : f.dom_restrict s x = f x := rfl

/-- Restriction of a ring homomorphism to a subsemiring of the codomain. -/
def cod_restrict (f : R →+* S) (s : σS) (h : ∀ x, f x ∈ s) : R →+* s :=
{ to_fun := λ n, ⟨f n, h n⟩,
  .. (f : R →* S).cod_restrict s h,
  .. (f : R →+ S).cod_restrict s h }

/-- The ring homomorphism from the preimage of `s` to `s`. -/
def restrict (f : R →+* S) (s' : σR) (s : σS) (h : ∀ x ∈ s', f x ∈ s) :
  s' →+* s := (f.dom_restrict s').cod_restrict s (λ x, h x x.2)

@[simp] lemma coe_restrict_apply (f : R →+* S) (s' : σR) (s : σS) (h : ∀ x ∈ s', f x ∈ s) (x : s') :
  (f.restrict s' s h x : S) = f x := rfl

@[simp] lemma comp_restrict (f : R →+* S) (s' : σR) (s : σS) (h : ∀ x ∈ s', f x ∈ s) :
  (subsemiring_class.subtype s).comp (f.restrict s' s h) = f.comp (subsemiring_class.subtype s') :=
rfl

/-- Restriction of a ring homomorphism to its range interpreted as a subsemiring.

This is the bundled version of `set.range_factorization`. -/
def srange_restrict (f : R →+* S) : R →+* f.srange :=
f.cod_restrict f.srange f.mem_srange_self

@[simp] lemma coe_srange_restrict (f : R →+* S) (x : R) :
  (f.srange_restrict x : S) = f x :=
rfl

lemma srange_restrict_surjective (f : R →+* S) : function.surjective f.srange_restrict :=
λ ⟨y, hy⟩, let ⟨x, hx⟩ := mem_srange.mp hy in ⟨x, subtype.ext hx⟩

lemma srange_top_iff_surjective {f : R →+* S} :
  f.srange = (⊤ : subsemiring S) ↔ function.surjective f :=
set_like.ext'_iff.trans $ iff.trans (by rw [coe_srange, coe_top]) set.range_iff_surjective

/-- The range of a surjective ring homomorphism is the whole of the codomain. -/
lemma srange_top_of_surjective (f : R →+* S) (hf : function.surjective f) :
  f.srange = (⊤ : subsemiring S) :=
srange_top_iff_surjective.2 hf

/-- The subsemiring of elements `x : R` such that `f x = g x` -/
def eq_slocus (f g : R →+* S) : subsemiring R :=
{ carrier := {x | f x = g x}, .. (f : R →* S).eq_mlocus g, .. (f : R →+ S).eq_mlocus g }

@[simp] lemma eq_slocus_same (f : R →+* S) : f.eq_slocus f = ⊤ :=
set_like.ext $ λ _, eq_self_iff_true _

/-- If two ring homomorphisms are equal on a set, then they are equal on its subsemiring closure. -/
lemma eq_on_sclosure {f g : R →+* S} {s : set R} (h : set.eq_on f g s) :
  set.eq_on f g (closure s) :=
show closure s ≤ f.eq_slocus g, from closure_le.2 h

lemma eq_of_eq_on_stop {f g : R →+* S} (h : set.eq_on f g (⊤ : subsemiring R)) :
  f = g :=
ext $ λ x, h trivial

lemma eq_of_eq_on_sdense {s : set R} (hs : closure s = ⊤) {f g : R →+* S} (h : s.eq_on f g) :
  f = g :=
eq_of_eq_on_stop $ hs ▸ eq_on_sclosure h

lemma sclosure_preimage_le (f : R →+* S) (s : set S) :
  closure (f ⁻¹' s) ≤ (closure s).comap f :=
closure_le.2 $ λ x hx, set_like.mem_coe.2 $ mem_comap.2 $ 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. -/
lemma map_sclosure (f : R →+* S) (s : set R) :
  (closure s).map f = closure (f '' s) :=
le_antisymm
  (map_le_iff_le_comap.2 $ le_trans (closure_mono $ set.subset_preimage_image _ _)
    (sclosure_preimage_le _ _))
  (closure_le.2 $ set.image_subset _ subset_closure)

end ring_hom

namespace subsemiring

open ring_hom

/-- The ring homomorphism associated to an inclusion of subsemirings. -/
def inclusion {S T : subsemiring R} (h : S ≤ T) : S →+* T :=
S.subtype.cod_restrict _ (λ x, h x.2)

@[simp] lemma srange_subtype (s : subsemiring R) : s.subtype.srange = s :=
set_like.coe_injective $ (coe_srange _).trans subtype.range_coe

@[simp]
lemma range_fst : (fst R S).srange = ⊤ :=
(fst R S).srange_top_of_surjective $ prod.fst_surjective

@[simp]
lemma range_snd : (snd R S).srange = ⊤ :=
(snd R S).srange_top_of_surjective $ prod.snd_surjective

@[simp]
lemma prod_bot_sup_bot_prod (s : subsemiring R) (t : subsemiring S) :
  (s.prod ⊥) ⊔ (prod ⊥ t) = s.prod t :=
le_antisymm (sup_le (prod_mono_right s bot_le) (prod_mono_left t bot_le)) $
assume p hp, prod.fst_mul_snd p ▸ mul_mem
  ((le_sup_left : s.prod ⊥ ≤ s.prod ⊥ ⊔ prod ⊥ t) ⟨hp.1, set_like.mem_coe.2 $ one_mem ⊥⟩)
  ((le_sup_right : prod ⊥ t ≤ s.prod ⊥ ⊔ prod ⊥ t) ⟨set_like.mem_coe.2 $ one_mem ⊥, hp.2⟩)

end subsemiring

namespace ring_equiv

variables {s t : subsemiring R}

/-- Makes the identity isomorphism from a proof two subsemirings of a multiplicative
    monoid are equal. -/
def subsemiring_congr (h : s = t) : s ≃+* t :=
{ map_mul' :=  λ _ _, rfl, map_add' := λ _ _, rfl, ..equiv.set_congr $ congr_arg _ h }

/-- Restrict a ring homomorphism with a left inverse to a ring isomorphism to its
`ring_hom.srange`. -/
def sof_left_inverse {g : S → R} {f : R →+* S} (h : function.left_inverse g f) :
  R ≃+* f.srange :=
{ to_fun := λ x, f.srange_restrict x,
  inv_fun := λ x, (g ∘ f.srange.subtype) x,
  left_inv := h,
  right_inv := λ x, subtype.ext $
    let ⟨x', hx'⟩ := ring_hom.mem_srange.mp x.prop in
    show f (g x) = x, by rw [←hx', h x'],
  ..f.srange_restrict }

@[simp] lemma sof_left_inverse_apply
  {g : S → R} {f : R →+* S} (h : function.left_inverse g f) (x : R) :
  ↑(sof_left_inverse h x) = f x := rfl

@[simp] lemma sof_left_inverse_symm_apply
  {g : S → R} {f : R →+* S} (h : function.left_inverse g f) (x : f.srange) :
  (sof_left_inverse h).symm x = g x := rfl

/-- Given an equivalence `e : R ≃+* S` of semirings and a subsemiring `s` of `R`,
`subsemiring_map e s` is the induced equivalence between `s` and `s.map e` -/
@[simps] def subsemiring_map (e : R ≃+* S) (s : subsemiring R) :
  s ≃+* s.map e.to_ring_hom :=
{ ..e.to_add_equiv.add_submonoid_map s.to_add_submonoid,
  ..e.to_mul_equiv.submonoid_map s.to_submonoid }

end ring_equiv

/-! ### Actions by `subsemiring`s

These are just copies of the definitions about `submonoid` starting from `submonoid.mul_action`.
The only new result is `subsemiring.module`.

When `R` is commutative, `algebra.of_subsemiring` provides a stronger result than those found in
this file, which uses the same scalar action.
-/
section actions

namespace subsemiring

variables {R' α β : Type*}

section non_assoc_semiring
variables [non_assoc_semiring R']

/-- The action by a subsemiring is the action by the underlying semiring. -/
instance [has_smul R' α] (S : subsemiring R') : has_smul S α := S.to_submonoid.has_smul

lemma smul_def [has_smul R' α] {S : subsemiring R'} (g : S) (m : α) : g • m = (g : R') • m := rfl

instance smul_comm_class_left
  [has_smul R' β] [has_smul α β] [smul_comm_class R' α β] (S : subsemiring R') :
  smul_comm_class S α β :=
S.to_submonoid.smul_comm_class_left

instance smul_comm_class_right
  [has_smul α β] [has_smul R' β] [smul_comm_class α R' β] (S : subsemiring R') :
  smul_comm_class α S β :=
S.to_submonoid.smul_comm_class_right

/-- Note that this provides `is_scalar_tower S R R` which is needed by `smul_mul_assoc`. -/
instance [has_smul α β] [has_smul R' α] [has_smul R' β] [is_scalar_tower R' α β]
  (S : subsemiring R') :
  is_scalar_tower S α β :=
S.to_submonoid.is_scalar_tower

instance [has_smul R' α] [has_faithful_smul R' α] (S : subsemiring R') :
  has_faithful_smul S α :=
S.to_submonoid.has_faithful_smul

/-- The action by a subsemiring is the action by the underlying semiring. -/
instance [has_zero α] [smul_with_zero R' α] (S : subsemiring R') : smul_with_zero S α :=
smul_with_zero.comp_hom _ S.subtype.to_monoid_with_zero_hom.to_zero_hom

end non_assoc_semiring

variables [semiring R']

/-- The action by a subsemiring is the action by the underlying semiring. -/
instance [mul_action R' α] (S : subsemiring R') : mul_action S α :=
S.to_submonoid.mul_action

/-- The action by a subsemiring is the action by the underlying semiring. -/
instance [add_monoid α] [distrib_mul_action R' α] (S : subsemiring R') : distrib_mul_action S α :=
S.to_submonoid.distrib_mul_action

/-- The action by a subsemiring is the action by the underlying semiring. -/
instance [monoid α] [mul_distrib_mul_action R' α] (S : subsemiring R') :
  mul_distrib_mul_action S α :=
S.to_submonoid.mul_distrib_mul_action

/-- The action by a subsemiring is the action by the underlying semiring. -/
instance [has_zero α] [mul_action_with_zero R' α] (S : subsemiring R') : mul_action_with_zero S α :=
mul_action_with_zero.comp_hom _ S.subtype.to_monoid_with_zero_hom

/-- The action by a subsemiring is the action by the underlying semiring. -/
instance [add_comm_monoid α] [module R' α] (S : subsemiring R') : module S α :=
{ smul := (•), .. module.comp_hom _ S.subtype }

/-- The action by a subsemiring is the action by the underlying semiring. -/
instance [semiring α] [mul_semiring_action R' α] (S : subsemiring R') : mul_semiring_action S α :=
S.to_submonoid.mul_semiring_action

/-- The center of a semiring acts commutatively on that semiring. -/
instance center.smul_comm_class_left : smul_comm_class (center R') R' R' :=
submonoid.center.smul_comm_class_left

/-- The center of a semiring acts commutatively on that semiring. -/
instance center.smul_comm_class_right : smul_comm_class R' (center R') R' :=
submonoid.center.smul_comm_class_right

/-- If all the elements of a set `s` commute, then `closure s` is a commutative monoid. -/
def closure_comm_semiring_of_comm {s : set R'} (hcomm : ∀ (a ∈ s) (b ∈ s), a * b = b * a) :
  comm_semiring (closure s) :=
{ mul_comm := λ x y,
  begin
    ext,
    simp only [subsemiring.coe_mul],
    refine closure_induction₂ x.prop y.prop hcomm
    (λ x, by simp only [zero_mul, mul_zero])
    (λ x, by simp only [zero_mul, mul_zero])
    (λ x, by simp only [one_mul, mul_one])
    (λ x, by simp only [one_mul, mul_one])
    (λ x y z h₁ h₂, by simp only [add_mul, mul_add, h₁, h₂])
    (λ x y z h₁ h₂, by simp only [add_mul, mul_add, h₁, h₂])
    (λ x y z h₁ h₂, by rw [mul_assoc, h₂, ←mul_assoc, h₁, mul_assoc])
    (λ x y z h₁ h₂, by rw [←mul_assoc, h₁, mul_assoc, h₂, ←mul_assoc])
  end,
  ..(closure s).to_semiring }

end subsemiring

end actions

-- While this definition is not about `subsemiring`s, this is the earliest we have
-- both `strict_ordered_semiring` and `submonoid` available.

/-- Submonoid of positive elements of an ordered semiring. -/
def pos_submonoid (R : Type*) [strict_ordered_semiring R] : submonoid R :=
{ carrier := {x | 0 < x},
  one_mem' := show (0 : R) < 1, from zero_lt_one,
  mul_mem' := λ x y (hx : 0 < x) (hy : 0 < y), mul_pos hx hy }

@[simp] lemma mem_pos_monoid {R : Type*} [strict_ordered_semiring R] (u : Rˣ) :
  ↑u ∈ pos_submonoid R ↔ (0 : R) < u := iff.rfl


import tactic
import data.nat.parity
import data.sym.sym2
import data.multiset.basic
import algebra.big_operators.basic
import aux_walk

open finset
open function
open sym2
open list
open aux_walk

open_locale big_operators

structure graph :=
(V : Type)
(E : Type)
(edge : E → (sym2 V))

structure finite_graph extends graph :=
(dec_V : decidable_eq V)
(dec_E : decidable_eq E)
(fin_V : fintype V)
(fin_E : fintype E)

section graph

variables {G : graph}

def graph.simple (G : graph) : Prop :=
  injective G.edge ∧ ∀ e : G.E, ¬ is_diag (G.edge e)

def graph.simple_graph_from_edgeset {W : Type} (S : set (sym2 W)) : graph :=
{
  V := W,
  E := S,
  edge := λe,↑e
}

def graph.incid (G : graph) (v w : G.V) : Prop := ∃ e : G.E, G.edge e = ⟦(v,w)⟧

theorem graph.exists_unique_edge_simple_graph (G : graph) {h : G.simple} {v w : G.V} :
G.incid v w → ∃! (e:G.E), G.edge e = ⟦(v,w)⟧ :=
begin
  intro hvw,
  unfold exists_unique,
  cases hvw with e he,
  use e,
  split,
  exact he,
  intros e' he',
  apply h.1,
  exact (rfl.congr (eq.symm he)).mp he',
end

def graph.isolated_vertex (G : graph) (v : G.V) : Prop := ∀ e : G.E, v ∉ G.edge e

theorem graph.isolated_def (G : graph) (v : G.V) : G.isolated_vertex v ↔ ∀ e : G.E, v ∉ G.edge e := by refl

section finite_graph

variable {F : finite_graph}

instance : fintype F.V := begin
  exact F.fin_V,
end
instance : fintype F.E := begin
  exact F.fin_E,
end
instance : decidable_eq F.V := begin
  exact F.dec_V,
end
instance : decidable_eq F.E := begin
  exact F.dec_E,
end

instance finite_graph.get_graph : has_coe (finite_graph) (graph) := begin
  fconstructor,
  exact finite_graph.to_graph,
end

def finite_graph.simple (F : finite_graph) : Prop := F.to_graph.simple

instance {V : Type} [fintype V] [decidable_eq V] : fintype (sym2 V) :=
begin
  exact quotient.fintype (sym2.rel.setoid V),
end

def finite_graph.degree (F : finite_graph) (v : F.V) : ℕ :=
card (filter (λe:F.E,v ∈ F.edge e) univ) + card (filter (λe:F.E,F.edge e = ⟦(v,v)⟧) univ)

lemma finite_graph.degree_def (F : finite_graph) : ∀ v : F.V,
F.degree v = card (filter (λe:F.E,v ∈ F.edge e) univ) +
card (filter (λe:F.E,F.edge e = ⟦(v,v)⟧) univ) := by finish

lemma finite_graph.degree_separate (F : finite_graph) : (λv,F.degree v) =  λv:F.V,
card (filter (λe:F.E,v ∈ F.edge e ∧ F.edge e ≠ ⟦(v,v)⟧) univ) +
2*card (filter (λe:F.E,F.edge e = ⟦(v,v)⟧) univ) :=
begin
  funext,
  rw two_mul,
  rw F.degree_def v,
  simp, rw ← add_assoc,
  congr' 1,
  rw ← card_disjoint_union,swap,
  {
    rw disjoint_filter,
    simp,
  },
  {
    rw ← filter_or,
    congr,
    funext,
    simp,
    split,
    intros hv,
    finish,
    intros hv,
    finish,
  }
end

instance : decidable_pred (odd ∘ F.degree) :=
begin
  intro v,
  apply nat.decidable_pred_odd,
end

theorem finite_graph.even_sum_of_degrees (F : finite_graph) : even (∑ v : F.V, F.degree v) :=
begin
  rw F.degree_separate,
  norm_num,
  rw sum_add_distrib,
  apply nat.even.add_even,swap,
  {
    apply finset.sum_induction,
    intros a b ha hb, exact nat.even.add_even ha hb, exact nat.even_zero,
    simp, intros v, rw even_iff_two_dvd, simp,
  },
  {
    have hn : ∑ (x : F.V), (filter (λ (e : F.E), x ∈ F.edge e ∧ ¬F.edge e = ⟦(x, x)⟧) univ).card =
    (∑ (x : F.V), ∑ (e : F.E), ite (x ∈ F.edge e ∧ ¬F.edge e = ⟦(x,x)⟧) 1 0),
    {
      congr,
      funext v,
      finish,
    },
    rw hn,
    rw sum_comm,
    apply finset.sum_induction,
    intros a b ha hb, exact nat.even.add_even ha hb, exact nat.even_zero,
    intros e he, clear he,
    have he_rep := quotient.exists_rep (F.edge e),
    rcases he_rep with ⟨⟨v,w⟩,hvw⟩,
    rw ← hvw,
    simp [-quotient.eq],
    have hf : filter (λ (x : F.V), (x = v ∨ x = w) ∧ ¬⟦(v, w)⟧ = ⟦(x, x)⟧) univ = ite (v = w) ∅ {v,w},
    {
      ext u,
      simp [-quotient.eq],
      split,
      rintros ⟨h1|h1,h2⟩,
      rw h1 at h2 ⊢,
      split_ifs,exfalso,rw ← h at h2, contradiction,
      simp [-quotient.eq],
      split_ifs,
      exfalso,
      rw [h,h1] at h2, contradiction,
      rw h1, simp [-quotient.eq],
      intro hu, split_ifs at hu,
      exfalso, finish,
      simp [-quotient.eq] at hu,
      split;
      cases hu with huv huw,
      left, assumption,
      right, assumption,
      rw huv, intro hs, apply h,
      rw eq_iff at hs,
      simp at hs, symmetry, assumption,
      rw eq_iff,
      simp,
      intro hvu, finish,
    },
    rw hf,
    split_ifs,
    simp,
    rw card_insert_of_not_mem,
    rw finset.card_singleton, ring_nf, exact even_bit0 1,
    simp, exact h,
  }
end

lemma finite_graph.parity_sum_of_odd_terms {S : Type} [decidable_eq S] {A : finset S} (f : S → ℕ) :
 (∀ a ∈ A, odd (f a)) →
(even (∑ a in A, f a) ↔ even A.card) :=
begin
  apply finset.induction_on A,
  {
    intros he,
    split,
    intros he',
    simp,
    intros he',
    simp,
  },
  {
    intros a S haS hS hA,
    have hS' : even (∑ a in S, f a) ↔ even S.card,
    {
      apply hS,
      intros a ha,
      apply hA,
      finish,
    },
    rw card_insert_of_not_mem haS,
    rw sum_insert haS,
    repeat {rw nat.even_add'},
    specialize hA a (by simp),
    simp [hA],
    rwa hS',
  }

end

theorem finite_graph.even_number_of_odd_degrees (F : finite_graph) : even (card (filter (odd ∘ F.degree) univ)) :=
begin
  have h : even (∑ v in filter (odd ∘ F.degree) univ, F.degree v),
  {
    have heo := sum_filter_add_sum_filter_not univ (odd ∘ F.degree) F.degree,
    have hcc := F.even_sum_of_degrees,
    rw ← heo at hcc,
    rw nat.even_add at hcc,
    rw hcc,
    apply finset.sum_induction,
    intros a b, exact nat.even.add_even,
    exact nat.even_zero,
    intros v hv,
    finish,
  },
  rw  finite_graph.parity_sum_of_odd_terms at h,
  exact h,
  simp,
end

def finite_graph.isolated_vertex (F : finite_graph) (v : F.V) : Prop := ∀ e : F.E, v ∉ F.edge e

theorem finite_graph.isolated_def (F : finite_graph) (v : F.V) :
F.isolated_vertex v ↔ ∀ e : F.E, v ∉ F.edge e := by refl

theorem finite_graph.isolated_degree_zero (F : finite_graph) (v : F.V) :
F.isolated_vertex v ↔ F.degree v = 0 :=
begin
  rw F.isolated_def,
  split,
  {
    intro h,
    rw F.degree_def,
    norm_num,
    split,
    apply filter_false_of_mem,
    simp, exact h,
    apply filter_false_of_mem,
    simp, intros e hne, specialize h e, finish,
  },
  {
    intros hv e hn,
    rw F.degree_def at hv, norm_num at hv,
    cases hv with hv1 hv2,
    rw ← not_nonempty_iff_eq_empty at hv1,
    apply hv1,
    use e,
    rw finset.mem_filter,
    exact ⟨mem_univ e,hn⟩,
  }
end

def finite_graph.null_graph (F : finite_graph) : Prop := ∀ v : F.V, F.isolated_vertex v

theorem finite_graph.null_def (F : finite_graph) : F.null_graph ↔ ∀ v : F.V, F.isolated_vertex v:= by refl

theorem finite_graph.null_only_isolated_vertices (F : finite_graph) : F.null_graph → is_empty F.E :=
begin
  intro p,
  rw is_empty_iff,
  intro e,
  rw F.null_def at p,
  have he : ∃ v w : F.V, F.edge e = ⟦(v,w)⟧,
  {
    induction F.edge e,
    use [a.fst,a.snd],
    simp,
    refl,
    refl,
  },
  rcases he with ⟨v,w,hvw⟩,
  specialize p v e,
  finish,
end

end finite_graph

section morphism

variables {F : finite_graph} {K : finite_graph} {H : finite_graph}

structure finite_graph.morphism (F : finite_graph) (G : finite_graph) :=
(aᵥ : F.V → G.V)
(aₑ : F.E → G.E)
(commute : G.edge ∘ aₑ = map (aᵥ) ∘ F.edge)

def finite_graph.id (F : finite_graph) : F.morphism F :=
{
  aᵥ := id,
  aₑ := id,
  commute := by rw [sym2.map_id, comp.right_id,comp.left_id],
}

def finite_graph.comp (g : K.morphism H) (f : F.morphism K)  : F.morphism H :=
{
  aᵥ := g.aᵥ ∘ f.aᵥ,
  aₑ:= g.aₑ ∘ f.aₑ
,
  commute :=
  begin
    rw ← comp.assoc,
    rw g.commute,
    rw comp.assoc,
    rw f.commute,
    rw ← comp.assoc,
    rw ← map_comp,
  end
}

infixr ` ∘ `: 90  := finite_graph.comp

structure finite_graph.equiv (F : finite_graph) (H : finite_graph) :=
(to_fun : F.morphism H)
(inv_fun : H.morphism F)
(left_inv : to_fun ∘ inv_fun = H.id)
(right_inv : inv_fun ∘ to_fun = F.id)

infixr ` ≃ `: 50  := finite_graph.equiv

theorem finite_graph.isom_graphs_same_number_of_vertices (bij : F ≃ H) :
fintype.card F.V = fintype.card H.V :=
begin
  rw fintype.card_eq,
  constructor,
  constructor,
  have hn := bij.right_inv,
  unfold finite_graph.comp finite_graph.id at hn,
  injections_and_clear,
  swap 3,
  apply bij.to_fun.aᵥ,
  swap 3,
  apply bij.inv_fun.aᵥ,
  intro x,
  rw ← comp_app bij.inv_fun.aᵥ,
  rw h_1,exact id.def x,
  have hn := bij.left_inv,
  unfold finite_graph.comp finite_graph.id at hn,
  injections_and_clear,
  intro x,
  rw ← comp_app bij.to_fun.aᵥ,
  rw h_1,exact id.def x,
end

theorem finite_graph.isom_graphs_same_number_of_edges (bij : F ≃ H) :
fintype.card F.E = fintype.card H.E :=
begin
  rw fintype.card_eq,
  constructor,
  constructor,
  have hn := bij.right_inv,
  unfold finite_graph.comp finite_graph.id at hn,
  injections_and_clear,
  swap 3,
  apply bij.to_fun.aₑ,
  swap 3,
  apply bij.inv_fun.aₑ,
  intro x,
  rw ← comp_app bij.inv_fun.aₑ,
  rw h_2,exact id.def x,
  have hn := bij.left_inv,
  unfold finite_graph.comp finite_graph.id at hn,
  injections_and_clear,
  intro x,
  rw ← comp_app bij.to_fun.aₑ,
  rw h_2,exact id.def x,
end
end morphism
section subgraph

variables {F : finite_graph}

structure finite_graph.subgraph (F : finite_graph) :=
(sub_vertices : finset F.V)
(sub_edges : finset F.E)
(same_vertices : ∀ e ∈ sub_edges, ∀ v ∈ F.edge e, v ∈ sub_vertices)

instance lift_sym2 {H : finite_graph} {h : H.subgraph} : has_lift (sym2 h.sub_vertices) (sym2 H.V) :=
begin
  constructor,
  intro pa,
  induction pa with p p1 p2 hp,
  apply quot.mk,
  exact ⟨p.fst,p.snd⟩,
  simp,
  apply quot.sound,
  cases p2 with a2 b2, cases p1 with a1 b1,
  simp,
  cases hp,
  constructor,
  constructor,
end

instance finite_graph.sb_to_graph : has_lift (F.subgraph) (finite_graph) :=
begin
  constructor,
  intro H,
  split, swap 5,
  {
    split, swap,
    exact H.sub_vertices, swap,
    exact H.sub_edges,
    intro e,
    apply fintype.choose (λp : sym2 (H.sub_vertices),↑p = F.edge e),
    have he := H.same_vertices e.1 e.2,
    revert he,
    induction (F.edge ↑e) with pv pv1 pv2 hpv,
    induction pv with v1 v2,
    swap,
    refine congr_fun rfl,
    intros v1 v2 h,
    have h1 := h v1 (mk_has_mem v1 v2),
    have h2 := h v2 (mk_has_mem_right v1 v2),
    apply exists_unique.intro,
    swap 3,
    exact ⟦(⟨v1,h1⟩,⟨v2,h2⟩)⟧,
    solve_by_elim,
    clear e h,
    intros p hp,
    induction p with pr,
    induction pr with a b,
    apply eq_iff.2,
    have hpp := eq_iff.1 hp,
    simp at hpp,
    finish,
    exact rfl,
  },
  all_goals {simp},
  any_goals {apply subtype.fintype},
  any_goals {apply subtype.decidable_eq},
end

def finite_graph.top_subgraph (F : finite_graph) : F.subgraph :=
{
  sub_vertices := univ,
  sub_edges := univ,
  same_vertices :=
  begin
    intros e he v hve,
    exact mem_univ v,
  end
}
end subgraph

section walk
variables {F : finite_graph}

def finite_graph.incid (F : finite_graph) (v w : F.V) : Prop := ∃ e : F.E, F.edge e = ⟦(v,w)⟧

theorem finite_graph.incid_def (F : finite_graph) (v w : F.V) :
F.incid v w ↔ ∃ e : F.E, F.edge e = ⟦(v,w)⟧ := by refl

def finite_graph.get_edge_from_incid (F : finite_graph) {v w : F.V} {hf : F.simple} :
(F.incid v w) → F.E :=
begin
  intro h,
  rw F.incid_def at h,
  apply fintype.choose (λ e,F.to_graph.edge e = ⟦(v,w)⟧),
  simp,
  apply F.to_graph.exists_unique_edge_simple_graph,
  exact h,
  exact hf,
end

def inc_prop {V E : Type} (P : V → V → E → Prop) : list V → list E → Prop
  | [] := λ le, false
  | (a :: []) := λ le,le.empty
  | (a :: b :: lv) := λ le, match le with
                            | [] := false
                            | e::es := P a b e ∧ (inc_prop (b::lv) es) end

lemma inc_prop_empty_lv {V E : Type} (P : V → V → E → Prop) : ∀ le : list E,
inc_prop P [] le = false :=
begin
  intro le,
  induction le with x xs hxs,
  unfold inc_prop,
  unfold inc_prop,
end

lemma inc_prop_empty_le {V E : Type} (P : V → V → E → Prop) : ∀ lv : list V,
inc_prop P lv [] = (lv.length = 1) :=
begin
  intro lv,
  induction lv with x xs hxs,
  simp,
  unfold inc_prop,
  tauto,
  induction xs with y ys hys,
  {
    unfold inc_prop,
    simp,
  },
  {
    unfold inc_prop,
    simp,
  }
end

structure finite_graph.walk (F : finite_graph) :=
(lᵥ : list F.V)
(lₑ : list F.E)
(is_adj : inc_prop (λ v w e, F.edge e = ⟦(v,w)⟧) lᵥ lₑ)

theorem finite_graph.walk.nempty_lᵥ (w : F.walk) : ¬ (w.lᵥ = []) :=
begin
  intro h,
  have h' := w.is_adj,
  rw h at h',
  convert h',
end

lemma inc_prop_diff_one {V E : Type} {P : V → V → E → Prop} : ∀ lv : list V, ∀ le : list E,
inc_prop P lv le → lv.length = le.length + 1 :=
begin
  intros lv,
  induction lv with v tv hv,
  {
    intros le hve,
    exfalso,
    convert hve,
  },
  {
    induction tv with w tvv hvv,
    {
      intros le hve,
      induction le with e te he,
      refl,
      exfalso,
      convert hve, symmetry,
      tauto,
    },
    {
      intros le' hve',
      induction le' with e te he,
      tauto,
      rw list.length_cons,
      congr' 1,
      apply hv,
      exact hve'.right,
    }
  }
end

theorem finite_graph.walk.lengths_diff_one (w : F.walk) : w.lᵥ.length = w.lₑ.length + 1 :=
inc_prop_diff_one w.lᵥ w.lₑ (w.is_adj)

def finite_graph.walk.start (w : F.walk) : F.V := begin
  haveI : inhabited F.V,
  {
    constructor,
    apply list.choose (λv:F.V,true) w.lᵥ,
    simp,
    have h := w.nempty_lᵥ,
    revert h,
    induction w.lᵥ,
    case list.nil
    { simp, },
    case list.cons : hd tl ih
    { intro h,
      use hd,
      finish, },
  },
  exact w.lᵥ.head,
end

def finite_graph.walk.end (w : F.walk) : F.V := begin
  haveI : inhabited F.V,
  {
    constructor,
    apply list.choose (λv:F.V,true) w.lᵥ,
    simp,
    have h := w.nempty_lᵥ,
    revert h,
    induction w.lᵥ,
    case list.nil
    { simp, },
    case list.cons : hd tl ih
    { intro h,
      use hd,
      finish, },
  },
  exact w.lᵥ.ilast,
end

def finite_graph.walk.closed (w : F.walk) : Prop := w.start = w.end ∧ w.lᵥ.length > 1

def finite_graph.list_gives_walk (F : finite_graph) : list F.V → Prop
  | [] := false
  | (v::[]) := true
  | (v::v'::lv) := F.incid v v' ∧ finite_graph.list_gives_walk (v'::lv)

lemma finite_graph.list_gives_walk_sublist (F : finite_graph) [inhabited F.V] :
∀ v : F.V,∀ l : list F.V,
l ≠ nil → ((F.list_gives_walk (v::l)) ↔ (F.incid v l.head ∧ F.list_gives_walk l)):=
begin
  intros v l,
  induction l with x xs hxs,
  {
    intro h,
    exfalso,
    exact h rfl,
  },
  {
    intros h,
    split,
    {
      intro h',
      unfold finite_graph.list_gives_walk at h',
      exact h',
    },
    {
      rintro ⟨h1,h2⟩,
      unfold finite_graph.list_gives_walk,
      split,
      exact h1,
      exact h2,
    }
  }
end

lemma finite_graph.list_gives_walk_infix (F : finite_graph) {l : list F.V} {h : F.list_gives_walk l} :
∀ l' : list F.V, l' <:+: l → l' ≠ nil → F.list_gives_walk l' :=
begin
  intros l' hl',
  induction l' with x xs hxs,
  {
    intro h,
    contradiction,
  },
  {
    intro h,clear h,
    by_cases hs : xs = nil,
    {
      rw hs,
      unfold finite_graph.list_gives_walk,
    },
    haveI : inhabited F.V := ⟨x⟩,
    rw F.list_gives_walk_sublist,
    swap,
    exact hs,
    split,swap,
    {
      apply hxs,
      apply is_infix.trans,
      swap 3,
      exact (x::xs),
      apply infix_cons,
      refl,
      exact hl',
      exact hs,
    },
    {
      induction l with y ys hys,
      rw eq_nil_iff_infix_nil at hl',
      contradiction,
      induction ys with z zs hzs,
      {
        replace hl' := length_le_of_infix hl',
        simp at hl',
        replace hs := length_pos_iff_ne_nil.2 hs,
        linarith,
      },
      {
        unfold finite_graph.list_gives_walk at h,
        by_cases hxy : x = y ∧ xs.head = z,
        {
          cases hxy with hxy1 hxy2,
          rw [hxy1,hxy2],
          exact h.1,
        },
        {
          apply hys,
          {
            intros h1 h2,
            clear h2,
            apply hxs,
            {
              transitivity x::xs,
              apply infix_cons,
              refl,
              exact hl',
            },
            exact hs,
          },
          {
            rw infix_iff_prefix_suffix at hl' ⊢,
            rcases hl' with ⟨t,ht,ht'⟩,
            use t,
            split,
            exact ht,
            rw suffix_cons_iff at ht',
            cases ht' with ht' ht',
            swap,
            exact ht',
            rw ht' at ht,
            rw cons_prefix_iff at ht,
            simp at hxy,
            specialize hxy ht.1,
            rw ht.1 at *,
            replace ht := ht.2,
            exfalso,
            apply hxy,
            clear hys hzs hxs,
            induction xs with u us hus,
            contradiction,
            simp,
            rw cons_prefix_iff at ht,
            exact ht.1,
          },
          exact h.2,
        }
      }
    }
  }
end

lemma finite_graph.list_gives_walk_from_walk (F : finite_graph) :
∀ w : F.walk,  F.list_gives_walk w.lᵥ :=
begin
  intro w,
  have hw := w.is_adj,
  obtain ⟨lv,hv⟩ : {lv : list F.V // w.lᵥ = lv} := ⟨_, rfl⟩,
  obtain ⟨le,he⟩ : {le : list F.E // w.lₑ = le} := ⟨_, rfl⟩,
  rw hv at hw ⊢,
  rw he at hw,
  clear hv he w,
  revert le,
  induction lv with v lv hlv,
  {
    unfold inc_prop,
    tauto,
  },
  {
    induction lv with v' lv' hlv',
    {
      unfold inc_prop,
      tauto,
    },
    {
      intro le,
      induction le with e le hle,
      {
        unfold inc_prop,
        tauto,
      },
      {
        intro h,
        unfold inc_prop at h,
        clear hle hlv',
        unfold finite_graph.list_gives_walk,
        split,
        {
          use e,
          exact h.1,
        },
        {
          apply hlv,
          exact h.2,
        }
      }
    }
  }
end

def finite_graph.get_list_edges (F : finite_graph) (hs : F.simple) :
 Π l : list F.V, (F.list_gives_walk l → list F.E)
 | [] := λp, []
 | [v] := λp, []
 | (v::v'::lv) := λp, ((@finite_graph.get_edge_from_incid) F v v' hs (and.left p))::
 ((finite_graph.get_list_edges (v'::lv)) p.right)

lemma finite_graph.inc_prop_from_list_vertices (l : list F.V) (h : F.list_gives_walk l) (hs : F.simple) :
∃ p : inc_prop (λ v w e, F.edge e = ⟦(v,w)⟧) l ((F.get_list_edges hs l) h),true :=
begin
  induction l with v lv hlv,
  {
    solve_by_elim,
  },
  {
    induction lv with w lw hlw,
    {
      constructor,
      unfold inc_prop,
      solve_by_elim,
      exact trivial,
    },
    {
      constructor,
      unfold finite_graph.get_list_edges,
      unfold inc_prop,
      split,
      {
        unfold finite_graph.get_edge_from_incid,
        apply fintype.choose_spec (λe:F.E,F.edge e = ⟦(v,w)⟧)
        (F.to_graph.exists_unique_edge_simple_graph _),
        exact hs,
        unfold finite_graph.list_gives_walk at h,
        apply h.left,
      },
      {
        unfold finite_graph.list_gives_walk at h,
        specialize hlv h.right,
        cases hlv with p hp,
        exact p,
      },
      exact trivial,
    }
  }
end

structure finite_graph.path (F : finite_graph) extends finite_graph.walk F :=
(vertex_unicity : lᵥ.nodup)
(is_open : ¬ to_walk.closed)

def finite_graph.path.length (p : F.path) : ℕ := p.lₑ.length

structure finite_graph.circuit (F : finite_graph) extends finite_graph.walk F :=
(vertex_unicity : (lᵥ.tail).nodup)
(is_closed : to_walk.closed)

def finite_graph.path.start (p : F.path) : F.V := p.to_walk.start

def finite_graph.path.end (p : F.path) : F.V := p.to_walk.end

def finite_graph.are_connected (F : finite_graph) (v v' : F.V) : Prop :=
 ∃ w : F.walk, w.start = v ∧ w.end = v'

theorem finite_graph.are_connected_def (v v' : F.V) :
F.are_connected v v' ↔ ∃ w : F.walk, w.start = v ∧ w.end = v' := by refl

lemma finite_graph.rmv_unt_aux_gives_walk (F : finite_graph) : ∀ v : F.V, ∀ l : list F.V,
F.list_gives_walk l →  (F.list_gives_walk (rmv_unt_aux v l) ∨ (rmv_unt_aux v l) = nil) :=
begin
  intros v l hl,
  induction l with x xs hxs,
  {
    unfold rmv_unt_aux,
    right, refl,
  },
  {
    unfold rmv_unt_aux,
    split_ifs, swap,
    {
      left,
      exact hl,
    },
    {
      induction xs with y ys hys,
      {
        unfold rmv_unt_aux,
        right, refl,
      },
      {
        unfold finite_graph.list_gives_walk at hl,
        cases hxs hl.2 with h' h',
        left,
        exact h',
        right,
        exact h',
      }
    }
  }
end

lemma finite_graph.rmv_unt_aux_gives_walk' (F : finite_graph) [inhabited F.V] :
∀ v : F.V, ∀ l : list F.V,
F.list_gives_walk l → F.incid v l.head
→  (F.list_gives_walk (v::rmv_unt_aux v l)) :=
begin
  intros v l,
  induction l with x xs hxs,
  {
    intros h h',
    unfold rmv_unt_aux,
  },
  {
    intros h h',
    unfold rmv_unt_aux,
    split_ifs, swap,
    {
      unfold finite_graph.list_gives_walk,
      split, swap, exact h,
      apply h',
    },
    {
      by_cases hs : rmv_unt_aux v xs = nil,
      rw hs,
      unfold finite_graph.list_gives_walk,
      have hn := rmv_aux_suffix v xs,
      cases hn with hn hn,
      swap,
      {
        apply finite_graph.list_gives_walk_infix,
        swap 4,
        exact xs,
        swap,
        apply infix_of_suffix hn,
        swap,
        simp,
        rw F.list_gives_walk_sublist at h,
        exact h.2,
        intro hc,
        apply hs,
        rw hc,
        unfold rmv_unt_aux,
      },
      rw hn,
      suffices : v = x,
      rw this,
      exact h,
      rw mem_cons_iff at h_1,
      cases h_1 with hx hx,
      exact hx,
      rw rmv_aux_eq at hn,
      contradiction,
    }
  }
end

lemma finite_graph.rmv_unt_gives_walk (F : finite_graph) [inhabited F.to_graph.V] :
∀ l : list F.V, F.list_gives_walk l →  F.list_gives_walk (rmv_unt l) :=
begin
  intros l hl,
  obtain ⟨n, hn⟩ : {n : ℕ // l.length = n} := ⟨_, rfl⟩,
  revert l,
  apply nat.strong_induction_on n,
  intros m hm l hl,
  induction l with x xs hxs,
  {
    intro h,
    unfold rmv_unt,
    exact hl,
  },
  {
    intro h,
    unfold rmv_unt,
    by_cases hs : xs = nil,
    {
      rw hs at *,
      unfold rmv_unt_aux,
      unfold rmv_unt,
    },
    {
      clear hxs,
      by_cases hss : rmv_unt (rmv_unt_aux x xs) = nil,
      {
        rw hss,
        unfold finite_graph.list_gives_walk,
      },
      {
        rw finite_graph.list_gives_walk_sublist at hl ⊢,
        swap 3,
        exact hs,
        swap,
        exact hss,
        split,
        swap,
        {
          apply hm,
          swap 4,
          exact (rmv_unt_aux x xs).length,
          have hns := rmv_aux_smaller x xs,
          simp at h,
          linarith,
          swap,
          refl,
          cases (F.rmv_unt_aux_gives_walk x xs) hl.2 with h1 h2,
          exact h1,
          rw h2 at hss,
          rw rmv_unt at hss,
          contradiction,
        },
        {
          have hu : (rmv_unt_aux x xs) ≠ nil,
          {
            intro hu,
            rw hu at hss,
            unfold rmv_unt at hss,
            contradiction,
          },
          have ha : (rmv_unt (rmv_unt_aux x xs)).head = (rmv_unt_aux x xs).head,
          {
            revert hu,
            induction (rmv_unt_aux x xs) with y ys hys,
            intro hp,
            contradiction,
            intro hp, clear hp,
            unfold rmv_unt,
            simp,
          },
          rw ha,
          have hb := (F.rmv_unt_aux_gives_walk' x xs) hl.2 hl.1,
          revert hb hu,
          induction (rmv_unt_aux x xs) with y ys hys,
          intros h1 h2,
          contradiction,
          simp,
          unfold finite_graph.list_gives_walk,
          tauto,
        }
      }
    }
  }
end

set_option trace.check true
theorem finite_graph.are_connected_path (v v' : F.V) (hs : F.simple) :
F.are_connected v v' ↔ ∃ p : F.path, p.start = v ∧ p.end = v' :=
begin
  split,swap,
  {
    rintro ⟨p,hp⟩,
    use p.to_walk,
    exact hp,
  },
  {
    intro h,
    cases h with w hw,
    haveI : inhabited F.V := ⟨v⟩,
    have hwl := F.list_gives_walk_from_walk w,
    have hwn := w.nempty_lᵥ,
    have hs1 := rmv_head w.lᵥ hwn,
    unfold finite_graph.walk.start finite_graph.walk.end at hw,
    cases hw with hw1 hw2,
    rw [← hw1,←  hw2],
    clear hw1 hw2 v v',
    constructor,
    swap,
    {
      exact { lᵥ := rmv_unt w.lᵥ,
      lₑ := F.get_list_edges hs (rmv_unt w.lᵥ) (F.rmv_unt_gives_walk w.lᵥ hwl),
      is_adj :=
      begin
        have hu := finite_graph.inc_prop_from_list_vertices (rmv_unt w.lᵥ)
        (F.rmv_unt_gives_walk w.lᵥ hwl) hs,
        cases hu with p hp,
        exact p,
      end,
      vertex_unicity := rmv_nodup w.lᵥ,
      is_open :=
      begin
        unfold finite_graph.walk.closed finite_graph.path.start finite_graph.path.end,
        unfold finite_graph.walk.start finite_graph.walk.end,
        push_neg,
        apply nodup_head_eq_tail_length_1,
        exact rmv_nodup w.lᵥ,
      end },
    },
    split,
    {
      cases hs,
      dsimp at *,
      unfold finite_graph.path.start finite_graph.walk.start,
      simp,
      rw ← rmv_head,
      refl,
    }

  }
end

end walk

end graph


import algebra.associated

lemma primes_associated_of_dvd {α} [comm_cancel_monoid_with_zero α] {p q: α}
  (p_prime: prime p) (q_prime: prime q) (dvd: p ∣ q): associated p q :=
begin
  cases dvd with c hc,
  cases ((q_prime.irreducible).is_unit_or_is_unit hc)
    .resolve_left p_prime.not_unit with u hu,
  exact ⟨ u, by rw [hu, hc] ⟩,
end


/-
Copyright (c) 2015 Microsoft Corporation. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Author: Leonardo de Moura

Complete lattices

TODO: define dual complete lattice and simplify proof of dual theorems.
-/
import algebra.lattice data.set.basic algebra.monotone
open set

variable {A : Type}

structure complete_lattice [class] (A : Type) extends lattice A :=
(Inf : set A → A)
(Sup : set A → A)
(Inf_le : ∀ {a : A} {s : set A}, a ∈ s → le (Inf s) a)
(le_Inf : ∀ {b : A} {s : set A}, (∀ (a : A), a ∈ s → le b a) → le b (Inf s))
(le_Sup : ∀ {a : A} {s : set A}, a ∈ s → le a (Sup s))
(Sup_le : ∀ {b : A} {s : set A} (h : ∀ (a : A), a ∈ s → le a b), le (Sup s) b)

section
  variable [complete_lattice A]

  definition Inf (S : set A) : A := complete_lattice.Inf S
  prefix `⨅ `:70 := Inf

  definition Sup (S : set A) : A := complete_lattice.Sup S
  prefix `⨆ `:65 := Sup

  theorem Inf_le {a : A} {s : set A} (H : a ∈ s) : (Inf s) ≤ a := complete_lattice.Inf_le H

  theorem le_Inf {b : A} {s : set A} (H : ∀ (a : A), a ∈ s → b ≤ a) : b ≤ Inf s :=
    complete_lattice.le_Inf H

  theorem le_Sup {a : A} {s : set A} (H : a ∈ s) : a ≤ Sup s := complete_lattice.le_Sup H

  theorem Sup_le {b : A} {s : set A} (H : ∀ (a : A), a ∈ s → a ≤ b) : Sup s ≤ b :=
    complete_lattice.Sup_le H
end

-- Minimal complete_lattice definition based just on Inf.
-- We later show that complete_lattice_Inf is a complete_lattice.
structure complete_lattice_Inf [class] (A : Type) extends weak_order A :=
(Inf : set A → A)
(Inf_le : ∀ {a : A} {s : set A}, a ∈ s → le (Inf s) a)
(le_Inf : ∀ {b : A} {s : set A}, (∀ (a : A), a ∈ s → le b a) → le b (Inf s))

-- Minimal complete_lattice definition based just on Sup.
-- We later show that complete_lattice_Sup is a complete_lattice.
structure complete_lattice_Sup [class] (A : Type) extends weak_order A :=
(Sup : set A → A)
(le_Sup : ∀ {a : A} {s : set A}, a ∈ s → le a (Sup s))
(Sup_le : ∀ {b : A} {s : set A} (h : ∀ (a : A), a ∈ s → le a b), le (Sup s) b)

namespace complete_lattice_Inf
variable [C : complete_lattice_Inf A]
include C
definition Sup (s : set A) : A :=
Inf {b | ∀ a, a ∈ s → a ≤ b}

local prefix `⨅`:70 := Inf
local prefix `⨆`:65 := Sup

lemma le_Sup {a : A} {s : set A} : a ∈ s → a ≤ ⨆ s :=
suppose a ∈ s, le_Inf
  (show ∀ (b : A), (∀ (a : A), a ∈ s → a ≤ b) → a ≤ b, from
   take b, assume h, h a `a ∈ s`)

lemma Sup_le {b : A} {s : set A} (h : ∀ (a : A), a ∈ s → a ≤ b) : ⨆ s ≤ b :=
Inf_le h

definition inf (a b : A) := ⨅ '{a, b}
definition sup (a b : A) := ⨆ '{a, b}

local infix `⊓` := inf
local infix `⊔` := sup

lemma inf_le_left (a b : A) : a ⊓ b ≤ a :=
Inf_le !mem_insert

lemma inf_le_right (a b : A) : a ⊓ b ≤ b :=
Inf_le (!mem_insert_of_mem !mem_insert)

lemma le_inf {a b c : A} : c ≤ a → c ≤ b → c ≤ a ⊓ b :=
assume h₁ h₂,
le_Inf (take x, suppose x ∈ '{a, b},
  or.elim (eq_or_mem_of_mem_insert this)
    (suppose x = a, begin subst x, exact h₁ end)
    (suppose x ∈ '{b},
      have x = b, from !eq_of_mem_singleton this,
      begin subst x, exact h₂ end))

lemma le_sup_left (a b : A) : a ≤ a ⊔ b :=
le_Sup !mem_insert

lemma le_sup_right (a b : A) : b ≤ a ⊔ b :=
le_Sup (!mem_insert_of_mem !mem_insert)

lemma sup_le {a b c : A} : a ≤ c → b ≤ c → a ⊔ b ≤ c :=
assume h₁ h₂,
Sup_le (take x, suppose x ∈ '{a, b},
  or.elim (eq_or_mem_of_mem_insert this)
    (suppose x = a, by subst x; assumption)
    (suppose x ∈ '{b},
      have x = b, from !eq_of_mem_singleton this,
      by subst x; assumption))
end complete_lattice_Inf

-- Every complete_lattice_Inf is a complete_lattice_Sup
definition complete_lattice_Inf_to_complete_lattice_Sup [C : complete_lattice_Inf A] :
  complete_lattice_Sup A :=
⦃ complete_lattice_Sup, C ⦄

-- Every complete_lattice_Inf is a complete_lattice
definition complete_lattice_Inf_to_complete_lattice [trans_instance] [C : complete_lattice_Inf A] :
  complete_lattice A :=
⦃ complete_lattice, C ⦄

namespace complete_lattice_Sup
variable [C : complete_lattice_Sup A]
include C
definition Inf (s : set A) : A :=
Sup {b | ∀ a, a ∈ s → b ≤ a}

lemma Inf_le {a : A} {s : set A} : a ∈ s → Inf s ≤ a :=
suppose a ∈ s, Sup_le
  (show ∀ (b : A), (∀ (a : A), a ∈ s → b ≤ a) → b ≤ a, from
   take b, assume h, h a `a ∈ s`)

lemma le_Inf {b : A} {s : set A} (h : ∀ (a : A), a ∈ s → b ≤ a) : b ≤ Inf s :=
le_Sup h

local prefix `⨅`:70 := Inf
local prefix `⨆`:65 := Sup

definition inf (a b : A) := ⨅ '{a, b}
definition sup (a b : A) := ⨆ '{a, b}

local infix `⊓` := inf
local infix `⊔` := sup

lemma inf_le_left (a b : A) : a ⊓ b ≤ a :=
Inf_le !mem_insert

lemma inf_le_right (a b : A) : a ⊓ b ≤ b :=
Inf_le (!mem_insert_of_mem !mem_insert)

lemma le_inf {a b c : A} : c ≤ a → c ≤ b → c ≤ a ⊓ b :=
assume h₁ h₂,
le_Inf (take x, suppose x ∈ '{a, b},
  or.elim (eq_or_mem_of_mem_insert this)
    (suppose x = a, begin subst x, exact h₁ end)
    (suppose x ∈ '{b},
      have x = b, from !eq_of_mem_singleton this,
      begin subst x, exact h₂ end))

lemma le_sup_left (a b : A) : a ≤ a ⊔ b :=
le_Sup !mem_insert

lemma le_sup_right (a b : A) : b ≤ a ⊔ b :=
le_Sup (!mem_insert_of_mem !mem_insert)

lemma sup_le {a b c : A} : a ≤ c → b ≤ c → a ⊔ b ≤ c :=
assume h₁ h₂,
Sup_le (take x, suppose x ∈ '{a, b},
  or.elim (eq_or_mem_of_mem_insert this)
    (assume H : x = a, by subst x; exact h₁)
    (suppose x ∈ '{b},
      have x = b, from !eq_of_mem_singleton this,
      by subst x; exact h₂))

end complete_lattice_Sup

-- Every complete_lattice_Sup is a complete_lattice_Inf
definition complete_lattice_Sup_to_complete_lattice_Inf [C : complete_lattice_Sup A] :
  complete_lattice_Inf A :=
⦃ complete_lattice_Inf, C ⦄

-- Every complete_lattice_Sup is a complete_lattice
section
definition complete_lattice_Sup_to_complete_lattice [trans_instance] [C : complete_lattice_Sup A] :
  complete_lattice A :=
⦃ complete_lattice, C ⦄
end

section complete_lattice
variable [C : complete_lattice A]
include C

variable {f : A → A}
premise  (mono : nondecreasing f)

theorem knaster_tarski : ∃ a, f a = a ∧ ∀ b, f b = b → a ≤ b :=
let a := ⨅ {u | f u ≤ u} in
have h₁ : f a = a, from
  have ge : f a ≤ a, from
    have ∀ b, b ∈ {u | f u ≤ u} → f a ≤ b, from
      take b, suppose f b ≤ b,
      have a ≤ b,     from Inf_le this,
      have f a ≤ f b, from mono this,
      le.trans `f a ≤ f b` `f b ≤ b`,
    le_Inf this,
  have le : a ≤ f a, from
    have f (f a) ≤ f a,  from !mono ge,
    have f a ∈ {u | f u ≤ u}, from this,
    Inf_le this,
  le.antisymm ge le,
have h₂ : ∀ b, f b = b → a ≤ b, from
  take b,
  suppose f b = b,
  have b ∈ {u | f u ≤ u}, from
    show f b ≤ b, by rewrite this,
  Inf_le this,
exists.intro a (and.intro h₁ h₂)

theorem knaster_tarski_dual : ∃ a, f a = a ∧ ∀ b, f b = b → b ≤ a :=
let a := ⨆ {u | u ≤ f u} in
have h₁ : f a = a, from
  have le : a ≤ f a, from
    have ∀ b, b ∈ {u | u ≤ f u} → b ≤ f a, from
      take b, suppose b ≤ f b,
      have b ≤ a,     from le_Sup this,
      have f b ≤ f a, from mono this,
      le.trans `b ≤ f b` `f b ≤ f a`,
    Sup_le this,
  have ge : f a ≤ a, from
    have f a ≤ f (f a),  from !mono le,
    have f a ∈ {u | u ≤ f u}, from this,
    le_Sup this,
  le.antisymm ge le,
have h₂ : ∀ b, f b = b → b ≤ a, from
  take b,
  suppose f b = b,
  have b ≤ f b, by rewrite this,
  le_Sup this,
exists.intro a (and.intro h₁ h₂)

/- top and bot -/

definition bot : A := ⨅ univ
definition top : A := ⨆ univ
notation `⊥` := bot
notation `⊤` := top

lemma bot_le (a : A) : ⊥ ≤ a :=
Inf_le !mem_univ

lemma eq_bot {a : A} : (∀ b, a ≤ b) → a = ⊥ :=
assume h,
have a ≤ ⊥, from le_Inf (take b bin, h b),
le.antisymm this !bot_le

lemma le_top (a : A) : a ≤ ⊤ :=
le_Sup !mem_univ

lemma eq_top {a : A} : (∀ b, b ≤ a) → a = ⊤ :=
assume h,
have ⊤ ≤ a, from Sup_le (take b bin, h b),
le.antisymm !le_top this

/- general facts about complete lattices -/

lemma Inf_singleton {a : A} : ⨅'{a} = a :=
have ⨅'{a} ≤ a, from
  Inf_le !mem_insert,
have a ≤ ⨅'{a}, from
  le_Inf (take b, suppose b ∈ '{a}, have b = a, from eq_of_mem_singleton this, by rewrite this),
le.antisymm `⨅'{a} ≤ a` `a ≤ ⨅'{a}`

lemma Sup_singleton {a : A} : ⨆'{a} = a :=
have ⨆'{a} ≤ a, from
  Sup_le (take b, suppose b ∈ '{a}, have b = a, from eq_of_mem_singleton this, by rewrite this),
have a ≤ ⨆'{a}, from
  le_Sup !mem_insert,
le.antisymm `⨆'{a} ≤ a` `a ≤ ⨆'{a}`

lemma Inf_antimono {s₁ s₂ : set A} : s₁ ⊆ s₂ → ⨅ s₂ ≤ ⨅ s₁ :=
suppose s₁ ⊆ s₂, le_Inf (take a : A, suppose a ∈ s₁, Inf_le (mem_of_subset_of_mem `s₁ ⊆ s₂` `a ∈ s₁`))

lemma Sup_mono {s₁ s₂ : set A} : s₁ ⊆ s₂ → ⨆ s₁ ≤ ⨆ s₂ :=
suppose s₁ ⊆ s₂, Sup_le (take a : A, suppose a ∈ s₁, le_Sup (mem_of_subset_of_mem `s₁ ⊆ s₂` `a ∈ s₁`))

lemma Inf_union (s₁ s₂ : set A) : ⨅ (s₁ ∪ s₂) = (⨅s₁) ⊓ (⨅s₂) :=
have le₁ : ⨅ (s₁ ∪ s₂) ≤ (⨅s₁) ⊓ (⨅s₂), from
 !le_inf
     (le_Inf (take a : A, suppose a ∈ s₁, Inf_le (mem_unionl `a ∈ s₁`)))
     (le_Inf (take a : A, suppose a ∈ s₂, Inf_le (mem_unionr `a ∈ s₂`))),
have le₂ : (⨅s₁) ⊓ (⨅s₂) ≤ ⨅ (s₁ ∪ s₂), from
  le_Inf (take a : A, suppose a ∈ s₁ ∪ s₂,
    or.elim this
      (suppose a ∈ s₁,
        have (⨅s₁) ⊓ (⨅s₂) ≤ ⨅s₁, from !inf_le_left,
        have ⨅s₁ ≤ a, from Inf_le `a ∈ s₁`,
        le.trans `(⨅s₁) ⊓ (⨅s₂) ≤ ⨅s₁` `⨅s₁ ≤ a`)
      (suppose a ∈ s₂,
        have (⨅s₁) ⊓ (⨅s₂) ≤ ⨅s₂, from !inf_le_right,
        have ⨅s₂ ≤ a, from Inf_le `a ∈ s₂`,
        le.trans `(⨅s₁) ⊓ (⨅s₂) ≤ ⨅s₂` `⨅s₂ ≤ a`)),
le.antisymm le₁ le₂

lemma Sup_union (s₁ s₂ : set A) : ⨆ (s₁ ∪ s₂) = (⨆s₁) ⊔ (⨆s₂) :=
have le₁ : ⨆ (s₁ ∪ s₂) ≤ (⨆s₁) ⊔ (⨆s₂), from
  Sup_le (take a : A, suppose a ∈ s₁ ∪ s₂,
    or.elim this
      (suppose a ∈ s₁,
        have a ≤ ⨆s₁, from le_Sup `a ∈ s₁`,
        have ⨆s₁ ≤ (⨆s₁) ⊔ (⨆s₂), from !le_sup_left,
        le.trans `a ≤ ⨆s₁` `⨆s₁ ≤ (⨆s₁) ⊔ (⨆s₂)`)
      (suppose a ∈ s₂,
        have a ≤ ⨆s₂, from le_Sup `a ∈ s₂`,
        have ⨆s₂ ≤ (⨆s₁) ⊔ (⨆s₂), from !le_sup_right,
        le.trans `a ≤ ⨆s₂` `⨆s₂ ≤ (⨆s₁) ⊔ (⨆s₂)`)),
have le₂ : (⨆s₁) ⊔ (⨆s₂) ≤ ⨆ (s₁ ∪ s₂), from
  !sup_le
    (Sup_le (take a : A, suppose a ∈ s₁, le_Sup (mem_unionl `a ∈ s₁`)))
    (Sup_le (take a : A, suppose a ∈ s₂, le_Sup (mem_unionr `a ∈ s₂`))),
le.antisymm le₁ le₂

lemma Inf_empty_eq_Sup_univ : ⨅ (∅ : set A) = ⨆ univ :=
have le₁ : ⨅ (∅ : set A) ≤ ⨆ univ, from
  le_Sup !mem_univ,
have le₂ : ⨆ univ ≤ ⨅ ∅, from
  le_Inf (take a : A, suppose a ∈ ∅, absurd this !not_mem_empty),
le.antisymm le₁ le₂

lemma Sup_empty_eq_Inf_univ : ⨆ (∅ : set A) = ⨅ univ :=
have le₁ : ⨆ (∅ : set A) ≤ ⨅ univ, from
  Sup_le (take a, suppose a ∈ ∅, absurd this !not_mem_empty),
have le₂ : ⨅ univ ≤ ⨆ (∅ : set A), from
  Inf_le !mem_univ,
le.antisymm le₁ le₂

lemma Sup_pair (a b : A) : Sup '{a, b} = sup a b :=
by rewrite [insert_eq, Sup_union, *Sup_singleton]

lemma Inf_pair (a b : A) : Inf '{a, b} = inf a b :=
by rewrite [insert_eq, Inf_union, *Inf_singleton]

end complete_lattice

/- complete lattice instances  -/

section
open eq.ops complete_lattice

definition complete_lattice_fun [instance] (A B : Type) [complete_lattice B] :
    complete_lattice (A → B) :=
⦃ complete_lattice, lattice_fun A B,
  Inf := λS x, Inf ((λf, f x) ' S),
  le_Inf := take f S H x,
    le_Inf (take y Hy, obtain g `g ∈ S` `g x = y`, from Hy, `g x = y` ▸ H g `g ∈ S` x),
  Inf_le := take f S `f ∈ S` x,
    Inf_le (exists.intro f (and.intro `f ∈ S` rfl)),
  Sup := λS x, Sup ((λf, f x) ' S),
  le_Sup := take f S `f ∈ S` x,
    le_Sup (exists.intro f (and.intro `f ∈ S` rfl)),
  Sup_le := take f S H x,
    Sup_le (take y Hy, obtain g `g ∈ S` `g x = y`, from Hy, `g x = y` ▸ H g `g ∈ S` x)
⦄

section
open classical -- Prop and set are only in the classical setting a complete lattice

definition complete_lattice_Prop [instance] : complete_lattice Prop :=
⦃ complete_lattice, lattice_Prop,
  Inf := λS, false ∉ S,
  le_Inf := take x S H Hx Hf,
    H _ Hf Hx,
  Inf_le := take x S Hx Hf,
    (classical.cases_on x (take x, true.intro) Hf) Hx,
  Sup := λS, true ∈ S,
  le_Sup := take x S Hx H,
    iff_subst (iff.intro (take H, true.intro) (take H', H)) Hx,
  Sup_le := take x S H Ht,
    H _ Ht true.intro
⦄

lemma sInter_eq_Inf_fun {A : Type} (S : set (set A)) : ⋂₀ S = @Inf (A → Prop) _ S :=
funext (take x,
  calc
    (⋂₀ S) x = ∀₀ P ∈ S, P x : rfl
    ... = ¬ (∃₀ P ∈ S, P x = false) :
    begin
      rewrite not_bounded_exists,
      apply bounded_forall_congr,
      intros,
      rewrite eq_false,
      rewrite not_not_iff
    end
    ... = @Inf (A → Prop) _ S x : rfl)

lemma sUnion_eq_Sup_fun {A : Type} (S : set (set A)) : ⋃₀ S = @Sup (A → Prop) _ S :=
funext (take x,
  calc
    (⋃₀ S) x = ∃₀ P ∈ S, P x : rfl
    ... = (∃₀ P ∈ S, P x = true) :
    begin
      apply bounded_exists_congr,
      intros,
      rewrite eq_true
    end
    ... = @Sup (A → Prop) _ S x : rfl)

definition complete_lattice_set [instance] (A : Type) : complete_lattice (set A) :=
⦃ complete_lattice,
  le := subset,
  le_refl := @le_refl (A → Prop) _,
  le_trans := @le_trans (A → Prop) _,
  le_antisymm := @le_antisymm (A → Prop) _,
  inf := inter,
  sup := union,
  inf_le_left := @inf_le_left (A → Prop) _,
  inf_le_right := @inf_le_right (A → Prop) _,
  le_inf := @le_inf (A → Prop) _,
  le_sup_left := @le_sup_left (A → Prop) _,
  le_sup_right := @le_sup_right (A → Prop) _,
  sup_le := @sup_le (A → Prop) _,
  Inf := sInter,
  Sup := sUnion,
  le_Inf := begin intros X S H, rewrite sInter_eq_Inf_fun, apply (@le_Inf (A → Prop) _), exact H end,
  Inf_le := begin intros X S H, rewrite sInter_eq_Inf_fun, apply (@Inf_le (A → Prop) _), exact H end,
  le_Sup := begin intros X S H, rewrite sUnion_eq_Sup_fun, apply (@le_Sup (A → Prop) _), exact H end,
  Sup_le := begin intros X S H, rewrite sUnion_eq_Sup_fun, apply (@Sup_le (A → Prop) _), exact H end
⦄

end

end