/-
Copyright (c) 2017 Mario Carneiro. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Mario Carneiro
-/
import logic.embedding
import order.rel_classes
import data.set.intervals.basic

open function

universes u v w
variables {α : Type*} {β : Type*} {γ : Type*}
  {r : α → α → Prop} {s : β → β → Prop} {t : γ → γ → Prop}

/-- A relation homomorphism with respect to a given pair of relations `r` and `s`
is a function `f : α → β` such that `r a b → s (f a) (f b)`. -/
@[nolint has_inhabited_instance]
structure rel_hom {α β : Type*} (r : α → α → Prop) (s : β → β → Prop) :=
(to_fun : α → β)
(map_rel' : ∀ {a b}, r a b → s (to_fun a) (to_fun b))

infix ` →r `:25 := rel_hom

namespace rel_hom

instance : has_coe_to_fun (r →r s) := ⟨λ _, α → β, λ o, o.to_fun⟩

initialize_simps_projections rel_hom (to_fun → apply)

theorem map_rel (f : r →r s) : ∀ {a b}, r a b → s (f a) (f b) := f.map_rel'

@[simp] theorem coe_fn_mk (f : α → β) (o) :
  (@rel_hom.mk _ _ r s f o : α → β) = f := rfl

@[simp] theorem coe_fn_to_fun (f : r →r s) : (f.to_fun : α → β) = f := rfl

/-- The map `coe_fn : (r →r s) → (α → β)` is injective. We can't use `function.injective`
here but mimic its signature by using `⦃e₁ e₂⦄`. -/
theorem coe_fn_inj : ∀ ⦃e₁ e₂ : r →r s⦄, (e₁ : α → β) = e₂ → e₁ = e₂
| ⟨f₁, o₁⟩ ⟨f₂, o₂⟩ h := by { congr, exact h }

@[ext] theorem ext ⦃f g : r →r s⦄ (h : ∀ x, f x = g x) : f = g :=
coe_fn_inj (funext h)

theorem ext_iff {f g : r →r s} : f = g ↔ ∀ x, f x = g x :=
⟨λ h x, h ▸ rfl, λ h, ext h⟩

/-- Identity map is a relation homomorphism. -/
@[refl, simps] protected def id (r : α → α → Prop) : r →r r :=
⟨λ x, x, λ a b x, x⟩

/-- Composition of two relation homomorphisms is a relation homomorphism. -/
@[trans, simps] protected def comp (g : s →r t) (f : r →r s) : r →r t :=
⟨λ x, g (f x), λ a b h, g.2 (f.2 h)⟩

/-- A relation homomorphism is also a relation homomorphism between dual relations. -/
protected def swap (f : r →r s) : swap r →r swap s :=
⟨f, λ a b, f.map_rel⟩

/-- A function is a relation homomorphism from the preimage relation of `s` to `s`. -/
def preimage (f : α → β) (s : β → β → Prop) : f ⁻¹'o s →r s := ⟨f, λ a b, id⟩

protected theorem is_irrefl : ∀ (f : r →r s) [is_irrefl β s], is_irrefl α r
| ⟨f, o⟩ ⟨H⟩ := ⟨λ a h, H _ (o h)⟩

protected theorem is_asymm : ∀ (f : r →r s) [is_asymm β s], is_asymm α r
| ⟨f, o⟩ ⟨H⟩ := ⟨λ a b h₁ h₂, H _ _ (o h₁) (o h₂)⟩

protected theorem acc (f : r →r s) (a : α) : acc s (f a) → acc r a :=
begin
  generalize h : f a = b, intro ac,
  induction ac with _ H IH generalizing a, subst h,
  exact ⟨_, λ a' h, IH (f a') (f.map_rel h) _ rfl⟩
end

protected theorem well_founded : ∀ (f : r →r s) (h : well_founded s), well_founded r
| f ⟨H⟩ := ⟨λ a, f.acc _ (H _)⟩

lemma map_inf {α β : Type*} [semilattice_inf α] [linear_order β]
  (a : ((<) : β → β → Prop) →r ((<) : α → α → Prop)) (m n : β) : a (m ⊓ n) = a m ⊓ a n :=
begin
  symmetry, cases le_or_lt n m with h,
  { rw [inf_eq_right.mpr h, inf_eq_right], exact strict_mono.monotone (λ x y, a.map_rel) h, },
  { rw [inf_eq_left.mpr (le_of_lt h), inf_eq_left], exact le_of_lt (a.map_rel h), },
end

lemma map_sup {α β : Type*} [semilattice_sup α] [linear_order β]
  (a : ((>) : β → β → Prop) →r ((>) : α → α → Prop)) (m n : β) : a (m ⊔ n) = a m ⊔ a n :=
begin
  symmetry, cases le_or_lt m n with h,
  { rw [sup_eq_right.mpr h, sup_eq_right], exact strict_mono.monotone (λ x y, a.swap.map_rel) h, },
  { rw [sup_eq_left.mpr (le_of_lt h), sup_eq_left], exact le_of_lt (a.map_rel h), },
end

end rel_hom

/-- An increasing function is injective -/
lemma injective_of_increasing (r : α → α → Prop) (s : β → β → Prop) [is_trichotomous α r]
  [is_irrefl β s] (f : α → β) (hf : ∀{x y}, r x y → s (f x) (f y)) : injective f :=
begin
  intros x y hxy,
  rcases trichotomous_of r x y with h | h | h,
  have := hf h, rw hxy at this, exfalso, exact irrefl_of s (f y) this,
  exact h,
  have := hf h, rw hxy at this, exfalso, exact irrefl_of s (f y) this
end

/-- An increasing function is injective -/
lemma rel_hom.injective_of_increasing [is_trichotomous α r]
  [is_irrefl β s] (f : r →r s) : injective f :=
injective_of_increasing r s f (λ x y, f.map_rel)

theorem surjective.well_founded_iff {f : α → β} (hf : surjective f)
  (o : ∀ {a b}, r a b ↔ s (f a) (f b)) : well_founded r ↔ well_founded s :=
iff.intro (begin
  apply rel_hom.well_founded,
  refine rel_hom.mk _ _,
  {exact classical.some hf.has_right_inverse},
  intros a b h, apply o.2, convert h,
  iterate 2 { apply classical.some_spec hf.has_right_inverse },
end) (rel_hom.well_founded ⟨f, λ _ _, o.1⟩)

/-- A relation embedding with respect to a given pair of relations `r` and `s`
is an embedding `f : α ↪ β` such that `r a b ↔ s (f a) (f b)`. -/
structure rel_embedding {α β : Type*} (r : α → α → Prop) (s : β → β → Prop) extends α ↪ β :=
(map_rel_iff' : ∀ {a b}, s (to_embedding a) (to_embedding b) ↔ r a b)

infix ` ↪r `:25 := rel_embedding

/-- An order embedding is an embedding `f : α ↪ β` such that `a ≤ b ↔ (f a) ≤ (f b)`.
This definition is an abbreviation of `rel_embedding (≤) (≤)`. -/
abbreviation order_embedding (α β : Type*) [has_le α] [has_le β] :=
@rel_embedding α β (≤) (≤)

infix ` ↪o `:25 := order_embedding

/-- The induced relation on a subtype is an embedding under the natural inclusion. -/
definition subtype.rel_embedding {X : Type*} (r : X → X → Prop) (p : X → Prop) :
  ((subtype.val : subtype p → X) ⁻¹'o r) ↪r r :=
⟨embedding.subtype p, λ x y, iff.rfl⟩

theorem preimage_equivalence {α β} (f : α → β) {s : β → β → Prop}
  (hs : equivalence s) : equivalence (f ⁻¹'o s) :=
⟨λ a, hs.1 _, λ a b h, hs.2.1 h, λ a b c h₁ h₂, hs.2.2 h₁ h₂⟩

namespace rel_embedding

/-- A relation embedding is also a relation homomorphism -/
def to_rel_hom (f : r ↪r s) : (r →r s) :=
{ to_fun := f.to_embedding.to_fun,
  map_rel' := λ x y, (map_rel_iff' f).mpr }

instance : has_coe (r ↪r s) (r →r s) := ⟨to_rel_hom⟩
-- see Note [function coercion]
instance : has_coe_to_fun (r ↪r s) := ⟨λ _, α → β, λ o, o.to_embedding⟩

/-- See Note [custom simps projection]. We need to specify this projection explicitly in this case,
  because it is a composition of multiple projections. -/
def simps.apply (h : r ↪r s) : α → β := h

initialize_simps_projections rel_embedding (to_embedding_to_fun → apply, -to_embedding)

@[simp] lemma to_rel_hom_eq_coe (f : r ↪r s) : f.to_rel_hom = f := rfl

@[simp] lemma coe_coe_fn (f : r ↪r s) : ((f : r →r s) : α → β) = f := rfl

theorem injective (f : r ↪r s) : injective f := f.inj'

theorem map_rel_iff (f : r ↪r s) : ∀ {a b}, s (f a) (f b) ↔ r a b := f.map_rel_iff'

@[simp] theorem coe_fn_mk (f : α ↪ β) (o) :
  (@rel_embedding.mk _ _ r s f o : α → β) = f := rfl

@[simp] theorem coe_fn_to_embedding (f : r ↪r s) : (f.to_embedding : α → β) = f := rfl

/-- The map `coe_fn : (r ↪r s) → (α → β)` is injective. We can't use `function.injective`
here but mimic its signature by using `⦃e₁ e₂⦄`. -/
theorem coe_fn_inj : ∀ ⦃e₁ e₂ : r ↪r s⦄, (e₁ : α → β) = e₂ → e₁ = e₂
| ⟨⟨f₁, h₁⟩, o₁⟩ ⟨⟨f₂, h₂⟩, o₂⟩ h := by { congr, exact h }

@[ext] theorem ext ⦃f g : r ↪r s⦄ (h : ∀ x, f x = g x) : f = g :=
coe_fn_inj (funext h)

theorem ext_iff {f g : r ↪r s} : f = g ↔ ∀ x, f x = g x :=
⟨λ h x, h ▸ rfl, λ h, ext h⟩

/-- Identity map is a relation embedding. -/
@[refl, simps] protected def refl (r : α → α → Prop) : r ↪r r :=
⟨embedding.refl _, λ a b, iff.rfl⟩

/-- Composition of two relation embeddings is a relation embedding. -/
@[trans] protected def trans (f : r ↪r s) (g : s ↪r t) : r ↪r t :=
⟨f.1.trans g.1, λ a b, by simp [f.map_rel_iff, g.map_rel_iff]⟩

instance (r : α → α → Prop) : inhabited (r ↪r r) := ⟨rel_embedding.refl _⟩

theorem trans_apply (f : r ↪r s) (g : s ↪r t) (a : α) : (f.trans g) a = g (f a) := rfl

@[simp] theorem coe_trans (f : r ↪r s) (g : s ↪r t) : ⇑(f.trans g) = g ∘ f := rfl

/-- A relation embedding is also a relation embedding between dual relations. -/
protected def swap (f : r ↪r s) : swap r ↪r swap s :=
⟨f.to_embedding, λ a b, f.map_rel_iff⟩

/-- If `f` is injective, then it is a relation embedding from the
  preimage relation of `s` to `s`. -/
def preimage (f : α ↪ β) (s : β → β → Prop) : f ⁻¹'o s ↪r s := ⟨f, λ a b, iff.rfl⟩

theorem eq_preimage (f : r ↪r s) : r = f ⁻¹'o s :=
by { ext a b, exact f.map_rel_iff.symm }

protected theorem is_irrefl (f : r ↪r s) [is_irrefl β s] : is_irrefl α r :=
⟨λ a, mt f.map_rel_iff.2 (irrefl (f a))⟩

protected theorem is_refl (f : r ↪r s) [is_refl β s] : is_refl α r :=
⟨λ a, f.map_rel_iff.1 $ refl _⟩

protected theorem is_symm (f : r ↪r s) [is_symm β s] : is_symm α r :=
⟨λ a b, imp_imp_imp f.map_rel_iff.2 f.map_rel_iff.1 symm⟩

protected theorem is_asymm (f : r ↪r s) [is_asymm β s] : is_asymm α r :=
⟨λ a b h₁ h₂, asymm (f.map_rel_iff.2 h₁) (f.map_rel_iff.2 h₂)⟩

protected theorem is_antisymm : ∀ (f : r ↪r s) [is_antisymm β s], is_antisymm α r
| ⟨f, o⟩ ⟨H⟩ := ⟨λ a b h₁ h₂, f.inj' (H _ _ (o.2 h₁) (o.2 h₂))⟩

protected theorem is_trans : ∀ (f : r ↪r s) [is_trans β s], is_trans α r
| ⟨f, o⟩ ⟨H⟩ := ⟨λ a b c h₁ h₂, o.1 (H _ _ _ (o.2 h₁) (o.2 h₂))⟩

protected theorem is_total : ∀ (f : r ↪r s) [is_total β s], is_total α r
| ⟨f, o⟩ ⟨H⟩ := ⟨λ a b, (or_congr o o).1 (H _ _)⟩

protected theorem is_preorder : ∀ (f : r ↪r s) [is_preorder β s], is_preorder α r
| f H := by exactI {..f.is_refl, ..f.is_trans}

protected theorem is_partial_order : ∀ (f : r ↪r s) [is_partial_order β s], is_partial_order α r
| f H := by exactI {..f.is_preorder, ..f.is_antisymm}

protected theorem is_linear_order : ∀ (f : r ↪r s) [is_linear_order β s], is_linear_order α r
| f H := by exactI {..f.is_partial_order, ..f.is_total}

protected theorem is_strict_order : ∀ (f : r ↪r s) [is_strict_order β s], is_strict_order α r
| f H := by exactI {..f.is_irrefl, ..f.is_trans}

protected theorem is_trichotomous : ∀ (f : r ↪r s) [is_trichotomous β s], is_trichotomous α r
| ⟨f, o⟩ ⟨H⟩ := ⟨λ a b, (or_congr o (or_congr f.inj'.eq_iff o)).1 (H _ _)⟩

protected theorem is_strict_total_order' :
  ∀ (f : r ↪r s) [is_strict_total_order' β s], is_strict_total_order' α r
| f H := by exactI {..f.is_trichotomous, ..f.is_strict_order}

protected theorem acc (f : r ↪r s) (a : α) : acc s (f a) → acc r a :=
begin
  generalize h : f a = b, intro ac,
  induction ac with _ H IH generalizing a, subst h,
  exact ⟨_, λ a' h, IH (f a') (f.map_rel_iff.2 h) _ rfl⟩
end

protected theorem well_founded : ∀ (f : r ↪r s) (h : well_founded s), well_founded r
| f ⟨H⟩ := ⟨λ a, f.acc _ (H _)⟩

protected theorem is_well_order : ∀ (f : r ↪r s) [is_well_order β s], is_well_order α r
| f H := by exactI {wf := f.well_founded H.wf, ..f.is_strict_total_order'}

/--
To define an relation embedding from an antisymmetric relation `r` to a reflexive relation `s` it
suffices to give a function together with a proof that it satisfies `s (f a) (f b) ↔ r a b`.
-/
def of_map_rel_iff (f : α → β) [is_antisymm α r] [is_refl β s]
  (hf : ∀ a b, s (f a) (f b) ↔ r a b) : r ↪r s :=
{ to_fun := f,
  inj' := λ x y h, antisymm ((hf _ _).1 (h ▸ refl _)) ((hf _ _).1 (h ▸ refl _)),
  map_rel_iff' := hf }

@[simp]
lemma of_map_rel_iff_coe (f : α → β) [is_antisymm α r] [is_refl β s]
  (hf : ∀ a b, s (f a) (f b) ↔ r a b) :
  ⇑(of_map_rel_iff f hf : r ↪r s) = f :=
rfl

/-- It suffices to prove `f` is monotone between strict relations
  to show it is a relation embedding. -/
def of_monotone [is_trichotomous α r] [is_asymm β s] (f : α → β)
  (H : ∀ a b, r a b → s (f a) (f b)) : r ↪r s :=
begin
  haveI := @is_asymm.is_irrefl β s _,
  refine ⟨⟨f, λ a b e, _⟩, λ a b, ⟨λ h, _, H _ _⟩⟩,
  { refine ((@trichotomous _ r _ a b).resolve_left _).resolve_right _;
    exact λ h, @irrefl _ s _ _ (by simpa [e] using H _ _ h) },
  { refine (@trichotomous _ r _ a b).resolve_right (or.rec (λ e, _) (λ h', _)),
    { subst e, exact irrefl _ h },
    { exact asymm (H _ _ h') h } }
end

@[simp] theorem of_monotone_coe [is_trichotomous α r] [is_asymm β s] (f : α → β) (H) :
  (@of_monotone _ _ r s _ _ f H : α → β) = f := rfl

/-- Embeddings of partial orders that preserve `<` also preserve `≤`  -/
def order_embedding_of_lt_embedding [partial_order α] [partial_order β]
  (f : ((<) : α → α → Prop) ↪r ((<) : β → β → Prop)) :
  α ↪o β :=
{ map_rel_iff' := by { intros, simp [le_iff_lt_or_eq,f.map_rel_iff, f.injective.eq_iff] }, .. f }

@[simp]
lemma order_embedding_of_lt_embedding_apply [partial_order α] [partial_order β]
  {f : ((<) : α → α → Prop) ↪r ((<) : β → β → Prop)} {x : α} :
  order_embedding_of_lt_embedding f x = f x := rfl

end rel_embedding

namespace order_embedding

variables [preorder α] [preorder β] (f : α ↪o β)

/-- lt is preserved by order embeddings of preorders -/
def lt_embedding : ((<) : α → α → Prop) ↪r ((<) : β → β → Prop) :=
{ map_rel_iff' := by intros; simp [lt_iff_le_not_le, f.map_rel_iff], .. f }

@[simp] lemma lt_embedding_apply (x : α) : f.lt_embedding x = f x := rfl

@[simp] theorem le_iff_le {a b} : (f a) ≤ (f b) ↔ a ≤ b := f.map_rel_iff

@[simp] theorem lt_iff_lt {a b} : f a < f b ↔ a < b :=
f.lt_embedding.map_rel_iff

@[simp] lemma eq_iff_eq {a b} : f a = f b ↔ a = b := f.injective.eq_iff

protected theorem monotone : monotone f := λ x y, f.le_iff_le.2

protected theorem strict_mono : strict_mono f := λ x y, f.lt_iff_lt.2

protected theorem acc (a : α) : acc (<) (f a) → acc (<) a :=
f.lt_embedding.acc a

protected theorem well_founded :
  well_founded ((<) : β → β → Prop) → well_founded ((<) : α → α → Prop) :=
f.lt_embedding.well_founded

protected theorem is_well_order [is_well_order β (<)] : is_well_order α (<) :=
f.lt_embedding.is_well_order

/-- An order embedding is also an order embedding between dual orders. -/
protected def dual : order_dual α ↪o order_dual β :=
⟨f.to_embedding, λ a b, f.map_rel_iff⟩

/--
To define an order embedding from a partial order to a preorder it suffices to give a function
together with a proof that it satisfies `f a ≤ f b ↔ a ≤ b`.
-/
def of_map_rel_iff {α β} [partial_order α] [preorder β] (f : α → β)
  (hf : ∀ a b, f a ≤ f b ↔ a ≤ b) : α ↪o β :=
rel_embedding.of_map_rel_iff f hf

@[simp] lemma coe_of_map_rel_iff {α β} [partial_order α] [preorder β] {f : α → β} (h) :
  ⇑(of_map_rel_iff f h) = f := rfl

/-- A strictly monotone map from a linear order is an order embedding. --/
def of_strict_mono {α β} [linear_order α] [preorder β] (f : α → β)
  (h : strict_mono f) : α ↪o β :=
of_map_rel_iff f (λ _ _, h.le_iff_le)

@[simp] lemma coe_of_strict_mono {α β} [linear_order α] [preorder β] {f : α → β}
  (h : strict_mono f) : ⇑(of_strict_mono f h) = f := rfl

/-- Embedding of a subtype into the ambient type as an `order_embedding`. -/
@[simps {fully_applied := ff}] def subtype (p : α → Prop) : subtype p ↪o α :=
⟨embedding.subtype p, λ x y, iff.rfl⟩

end order_embedding

/-- A relation isomorphism is an equivalence that is also a relation embedding. -/
structure rel_iso {α β : Type*} (r : α → α → Prop) (s : β → β → Prop) extends α ≃ β :=
(map_rel_iff' : ∀ {a b}, s (to_equiv a) (to_equiv b) ↔ r a b)

infix ` ≃r `:25 := rel_iso

/-- An order isomorphism is an equivalence such that `a ≤ b ↔ (f a) ≤ (f b)`.
This definition is an abbreviation of `rel_iso (≤) (≤)`. -/
abbreviation order_iso (α β : Type*) [has_le α] [has_le β] := @rel_iso α β (≤) (≤)

infix ` ≃o `:25 := order_iso

namespace rel_iso

/-- Convert an `rel_iso` to an `rel_embedding`. This function is also available as a coercion
but often it is easier to write `f.to_rel_embedding` than to write explicitly `r` and `s`
in the target type. -/
def to_rel_embedding (f : r ≃r s) : r ↪r s :=
⟨f.to_equiv.to_embedding, f.map_rel_iff'⟩

instance : has_coe (r ≃r s) (r ↪r s) := ⟨to_rel_embedding⟩
-- see Note [function coercion]
instance : has_coe_to_fun (r ≃r s) := ⟨λ _, α → β, λ f, f⟩

@[simp] lemma to_rel_embedding_eq_coe (f : r ≃r s) : f.to_rel_embedding = f := rfl

@[simp] lemma coe_coe_fn (f : r ≃r s) : ((f : r ↪r s) : α → β) = f := rfl

theorem map_rel_iff (f : r ≃r s) : ∀ {a b}, s (f a) (f b) ↔ r a b := f.map_rel_iff'

@[simp] theorem coe_fn_mk (f : α ≃ β) (o : ∀ ⦃a b⦄, s (f a) (f b) ↔ r a b) :
  (rel_iso.mk f o : α → β) = f := rfl

@[simp] theorem coe_fn_to_equiv (f : r ≃r s) : (f.to_equiv : α → β) = f := rfl

theorem to_equiv_injective : injective (to_equiv : (r ≃r s) → α ≃ β)
| ⟨e₁, o₁⟩ ⟨e₂, o₂⟩ h := by { congr, exact h }

/-- The map `coe_fn : (r ≃r s) → (α → β)` is injective. Lean fails to parse
`function.injective (λ e : r ≃r s, (e : α → β))`, so we use a trick to say the same. -/
theorem coe_fn_injective : function.injective (λ (e : r ≃r s) (x : α), e x) :=
equiv.coe_fn_injective.comp to_equiv_injective

@[ext] theorem ext ⦃f g : r ≃r s⦄ (h : ∀ x, f x = g x) : f = g :=
coe_fn_injective (funext h)

theorem ext_iff {f g : r ≃r s} : f = g ↔ ∀ x, f x = g x :=
⟨λ h x, h ▸ rfl, λ h, ext h⟩

/-- Inverse map of a relation isomorphism is a relation isomorphism. -/
@[symm] protected def symm (f : r ≃r s) : s ≃r r :=
⟨f.to_equiv.symm, λ a b, by erw [← f.map_rel_iff, f.1.apply_symm_apply, f.1.apply_symm_apply]⟩

/-- See Note [custom simps projection]. We need to specify this projection explicitly in this case,
  because it is a composition of multiple projections. -/
def simps.apply (h : r ≃r s) : α → β := h
/-- See Note [custom simps projection]. -/
def simps.symm_apply (h : r ≃r s) : β → α := h.symm

initialize_simps_projections rel_iso
  (to_equiv_to_fun → apply, to_equiv_inv_fun → symm_apply, -to_equiv)

/-- Identity map is a relation isomorphism. -/
@[refl, simps apply] protected def refl (r : α → α → Prop) : r ≃r r :=
⟨equiv.refl _, λ a b, iff.rfl⟩

/-- Composition of two relation isomorphisms is a relation isomorphism. -/
@[trans, simps apply] protected def trans (f₁ : r ≃r s) (f₂ : s ≃r t) : r ≃r t :=
⟨f₁.to_equiv.trans f₂.to_equiv, λ a b, f₂.map_rel_iff.trans f₁.map_rel_iff⟩

instance (r : α → α → Prop) : inhabited (r ≃r r) := ⟨rel_iso.refl _⟩

@[simp] lemma default_def (r : α → α → Prop) : default (r ≃r r) = rel_iso.refl r := rfl

/-- a relation isomorphism is also a relation isomorphism between dual relations. -/
protected def swap (f : r ≃r s) : (swap r) ≃r (swap s) :=
⟨f.to_equiv, λ _ _, f.map_rel_iff⟩

@[simp] theorem coe_fn_symm_mk (f o) : ((@rel_iso.mk _ _ r s f o).symm : β → α) = f.symm :=
rfl

@[simp] theorem apply_symm_apply  (e : r ≃r s) (x : β) : e (e.symm x) = x :=
e.to_equiv.apply_symm_apply x

@[simp] theorem symm_apply_apply (e : r ≃r s) (x : α) : e.symm (e x) = x :=
e.to_equiv.symm_apply_apply x

theorem rel_symm_apply (e : r ≃r s) {x y} : r x (e.symm y) ↔ s (e x) y :=
by rw [← e.map_rel_iff, e.apply_symm_apply]

theorem symm_apply_rel (e : r ≃r s) {x y} : r (e.symm x) y ↔ s x (e y) :=
by rw [← e.map_rel_iff, e.apply_symm_apply]

protected lemma bijective (e : r ≃r s) : bijective e := e.to_equiv.bijective
protected lemma injective (e : r ≃r s) : injective e := e.to_equiv.injective
protected lemma surjective (e : r ≃r s) : surjective e := e.to_equiv.surjective

@[simp] lemma range_eq (e : r ≃r s) : set.range e = set.univ := e.surjective.range_eq

@[simp] lemma eq_iff_eq (f : r ≃r s) {a b} : f a = f b ↔ a = b :=
f.injective.eq_iff

/-- Any equivalence lifts to a relation isomorphism between `s` and its preimage. -/
protected def preimage (f : α ≃ β) (s : β → β → Prop) : f ⁻¹'o s ≃r s := ⟨f, λ a b, iff.rfl⟩

/-- A surjective relation embedding is a relation isomorphism. -/
@[simps apply]
noncomputable def of_surjective (f : r ↪r s) (H : surjective f) : r ≃r s :=
⟨equiv.of_bijective f ⟨f.injective, H⟩, λ a b, f.map_rel_iff⟩

/--
Given relation isomorphisms `r₁ ≃r r₂` and `s₁ ≃r s₂`, construct a relation isomorphism for the
lexicographic orders on the sum.
-/
def sum_lex_congr {α₁ α₂ β₁ β₂ r₁ r₂ s₁ s₂}
  (e₁ : @rel_iso α₁ α₂ r₁ r₂) (e₂ : @rel_iso β₁ β₂ s₁ s₂) :
  sum.lex r₁ s₁ ≃r sum.lex r₂ s₂ :=
⟨equiv.sum_congr e₁.to_equiv e₂.to_equiv, λ a b,
 by cases e₁ with f hf; cases e₂ with g hg;
    cases a; cases b; simp [hf, hg]⟩

/--
Given relation isomorphisms `r₁ ≃r r₂` and `s₁ ≃r s₂`, construct a relation isomorphism for the
lexicographic orders on the product.
-/
def prod_lex_congr {α₁ α₂ β₁ β₂ r₁ r₂ s₁ s₂}
  (e₁ : @rel_iso α₁ α₂ r₁ r₂) (e₂ : @rel_iso β₁ β₂ s₁ s₂) :
  prod.lex r₁ s₁ ≃r prod.lex r₂ s₂ :=
⟨equiv.prod_congr e₁.to_equiv e₂.to_equiv,
  λ a b, by simp [prod.lex_def, e₁.map_rel_iff, e₂.map_rel_iff]⟩

instance : group (r ≃r r) :=
{ one := rel_iso.refl r,
  mul := λ f₁ f₂, f₂.trans f₁,
  inv := rel_iso.symm,
  mul_assoc := λ f₁ f₂ f₃, rfl,
  one_mul := λ f, ext $ λ _, rfl,
  mul_one := λ f, ext $ λ _, rfl,
  mul_left_inv := λ f, ext f.symm_apply_apply }

@[simp] lemma coe_one : ⇑(1 : r ≃r r) = id := rfl

@[simp] lemma coe_mul (e₁ e₂ : r ≃r r) : ⇑(e₁ * e₂) = e₁ ∘ e₂ := rfl

lemma mul_apply (e₁ e₂ : r ≃r r) (x : α) : (e₁ * e₂) x = e₁ (e₂ x) := rfl

@[simp] lemma inv_apply_self (e : r ≃r r) (x) : e⁻¹ (e x) = x := e.symm_apply_apply x

@[simp] lemma apply_inv_self (e : r ≃r r) (x) : e (e⁻¹ x) = x := e.apply_symm_apply x

end rel_iso

namespace order_iso

section has_le

variables [has_le α] [has_le β] [has_le γ]

/-- Reinterpret an order isomorphism as an order embedding. -/
def to_order_embedding (e : α ≃o β) : α ↪o β :=
e.to_rel_embedding

@[simp] lemma coe_to_order_embedding (e : α ≃o β) :
  ⇑(e.to_order_embedding) = e := rfl

protected lemma bijective (e : α ≃o β) : bijective e := e.to_equiv.bijective
protected lemma injective (e : α ≃o β) : injective e := e.to_equiv.injective
protected lemma surjective (e : α ≃o β) : surjective e := e.to_equiv.surjective

@[simp] lemma range_eq (e : α ≃o β) : set.range e = set.univ := e.surjective.range_eq

@[simp] lemma apply_eq_iff_eq (e : α ≃o β) {x y : α} : e x = e y ↔ x = y :=
e.to_equiv.apply_eq_iff_eq

/-- Identity order isomorphism. -/
def refl (α : Type*) [has_le α] : α ≃o α := rel_iso.refl (≤)

@[simp] lemma coe_refl : ⇑(refl α) = id := rfl

lemma refl_apply (x : α) : refl α x = x := rfl

@[simp] lemma refl_to_equiv : (refl α).to_equiv = equiv.refl α := rfl

/-- Inverse of an order isomorphism. -/
def symm (e : α ≃o β) : β ≃o α := e.symm

@[simp] lemma apply_symm_apply (e : α ≃o β) (x : β) : e (e.symm x) = x :=
e.to_equiv.apply_symm_apply x

@[simp] lemma symm_apply_apply (e : α ≃o β) (x : α) : e.symm (e x) = x :=
e.to_equiv.symm_apply_apply x

@[simp] lemma symm_refl (α : Type*) [has_le α] : (refl α).symm = refl α := rfl

lemma apply_eq_iff_eq_symm_apply (e : α ≃o β) (x : α) (y : β) : e x = y ↔ x = e.symm y :=
e.to_equiv.apply_eq_iff_eq_symm_apply

theorem symm_apply_eq (e : α ≃o β) {x : α} {y : β} : e.symm y = x ↔ y = e x :=
e.to_equiv.symm_apply_eq

@[simp] lemma symm_symm (e : α ≃o β) : e.symm.symm = e := by { ext, refl }

lemma symm_injective : injective (symm : (α ≃o β) → (β ≃o α)) :=
λ e e' h, by rw [← e.symm_symm, h, e'.symm_symm]

@[simp] lemma to_equiv_symm (e : α ≃o β) : e.to_equiv.symm = e.symm.to_equiv := rfl

/-- Composition of two order isomorphisms is an order isomorphism. -/
@[trans] def trans (e : α ≃o β) (e' : β ≃o γ) : α ≃o γ := e.trans e'

@[simp] lemma coe_trans (e : α ≃o β) (e' : β ≃o γ) : ⇑(e.trans e') = e' ∘ e := rfl

lemma trans_apply (e : α ≃o β) (e' : β ≃o γ) (x : α) : e.trans e' x = e' (e x) := rfl

@[simp] lemma refl_trans (e : α ≃o β) : (refl α).trans e = e := by { ext x, refl }

@[simp] lemma trans_refl (e : α ≃o β) : e.trans (refl β) = e := by { ext x, refl }

end has_le

open set

variables [preorder α] [preorder β] [preorder γ]

protected lemma monotone (e : α ≃o β) : monotone e := e.to_order_embedding.monotone

protected lemma strict_mono (e : α ≃o β) : strict_mono e := e.to_order_embedding.strict_mono

@[simp] lemma le_iff_le (e : α ≃o β) {x y : α} : e x ≤ e y ↔ x ≤ y := e.map_rel_iff

@[simp] lemma lt_iff_lt (e : α ≃o β) {x y : α} : e x < e y ↔ x < y :=
e.to_order_embedding.lt_iff_lt

@[simp] lemma preimage_Iic (e : α ≃o β) (b : β) : e ⁻¹' (Iic b) = Iic (e.symm b) :=
by { ext x, simp [← e.le_iff_le] }

@[simp] lemma preimage_Ici (e : α ≃o β) (b : β) : e ⁻¹' (Ici b) = Ici (e.symm b) :=
by { ext x, simp [← e.le_iff_le] }

@[simp] lemma preimage_Iio (e : α ≃o β) (b : β) : e ⁻¹' (Iio b) = Iio (e.symm b) :=
by { ext x, simp [← e.lt_iff_lt] }

@[simp] lemma preimage_Ioi (e : α ≃o β) (b : β) : e ⁻¹' (Ioi b) = Ioi (e.symm b) :=
by { ext x, simp [← e.lt_iff_lt] }

@[simp] lemma preimage_Icc (e : α ≃o β) (a b : β) : e ⁻¹' (Icc a b) = Icc (e.symm a) (e.symm b) :=
by simp [← Ici_inter_Iic]

@[simp] lemma preimage_Ico (e : α ≃o β) (a b : β) : e ⁻¹' (Ico a b) = Ico (e.symm a) (e.symm b) :=
by simp [← Ici_inter_Iio]

@[simp] lemma preimage_Ioc (e : α ≃o β) (a b : β) : e ⁻¹' (Ioc a b) = Ioc (e.symm a) (e.symm b) :=
by simp [← Ioi_inter_Iic]

@[simp] lemma preimage_Ioo (e : α ≃o β) (a b : β) : e ⁻¹' (Ioo a b) = Ioo (e.symm a) (e.symm b) :=
by simp [← Ioi_inter_Iio]

/-- To show that `f : α → β`, `g : β → α` make up an order isomorphism of linear orders,
    it suffices to prove `cmp a (g b) = cmp (f a) b`. --/
def of_cmp_eq_cmp {α β} [linear_order α] [linear_order β] (f : α → β) (g : β → α)
  (h : ∀ (a : α) (b : β), cmp a (g b) = cmp (f a) b) : α ≃o β :=
have gf : ∀ (a : α), a = g (f a) := by { intro, rw [←cmp_eq_eq_iff, h, cmp_self_eq_eq] },
{ to_fun := f,
  inv_fun := g,
  left_inv := λ a, (gf a).symm,
  right_inv := by { intro, rw [←cmp_eq_eq_iff, ←h, cmp_self_eq_eq] },
  map_rel_iff' := by { intros, apply le_iff_le_of_cmp_eq_cmp, convert (h _ _).symm, apply gf } }

/-- Order isomorphism between two equal sets. -/
def set_congr (s t : set α) (h : s = t) : s ≃o t :=
{ to_equiv := equiv.set_congr h,
  map_rel_iff' := λ x y, iff.rfl }

/-- Order isomorphism between `univ : set α` and `α`. -/
def set.univ : (set.univ : set α) ≃o α :=
{ to_equiv := equiv.set.univ α,
  map_rel_iff' := λ x y, iff.rfl }

end order_iso

/-- If a function `f` is strictly monotone on a set `s`, then it defines an order isomorphism
between `s` and its image. -/
protected noncomputable def strict_mono_incr_on.order_iso {α β} [linear_order α] [preorder β]
  (f : α → β) (s : set α) (hf : strict_mono_incr_on f s) :
  s ≃o f '' s :=
{ to_equiv := hf.inj_on.bij_on_image.equiv _,
  map_rel_iff' := λ x y, hf.le_iff_le x.2 y.2 }

/-- A strictly monotone function from a linear order is an order isomorphism between its domain and
its range. -/
protected noncomputable def strict_mono.order_iso {α β} [linear_order α] [preorder β] (f : α → β)
  (h_mono : strict_mono f) : α ≃o set.range f :=
{ to_equiv := equiv.of_injective f h_mono.injective,
  map_rel_iff' := λ a b, h_mono.le_iff_le }

/-- A strictly monotone surjective function from a linear order is an order isomorphism. -/
noncomputable def strict_mono.order_iso_of_surjective {α β} [linear_order α] [preorder β]
  (f : α → β) (h_mono : strict_mono f) (h_surj : surjective f) : α ≃o β :=
(h_mono.order_iso f).trans $ (order_iso.set_congr _ _ h_surj.range_eq).trans order_iso.set.univ

/-- `subrel r p` is the inherited relation on a subset. -/
def subrel (r : α → α → Prop) (p : set α) : p → p → Prop :=
(coe : p → α) ⁻¹'o r

@[simp] theorem subrel_val (r : α → α → Prop) (p : set α)
  {a b} : subrel r p a b ↔ r a.1 b.1 := iff.rfl

namespace subrel

/-- The relation embedding from the inherited relation on a subset. -/
protected def rel_embedding (r : α → α → Prop) (p : set α) :
  subrel r p ↪r r := ⟨embedding.subtype _, λ a b, iff.rfl⟩

@[simp] theorem rel_embedding_apply (r : α → α → Prop) (p a) :
  subrel.rel_embedding r p a = a.1 := rfl

instance (r : α → α → Prop) [is_well_order α r]
  (p : set α) : is_well_order p (subrel r p) :=
rel_embedding.is_well_order (subrel.rel_embedding r p)

end subrel

/-- Restrict the codomain of a relation embedding. -/
def rel_embedding.cod_restrict (p : set β) (f : r ↪r s) (H : ∀ a, f a ∈ p) : r ↪r subrel s p :=
⟨f.to_embedding.cod_restrict p H, f.map_rel_iff'⟩

@[simp] theorem rel_embedding.cod_restrict_apply (p) (f : r ↪r s) (H a) :
  rel_embedding.cod_restrict p f H a = ⟨f a, H a⟩ := rfl

  /-- An order isomorphism is also an order isomorphism between dual orders. -/
protected def order_iso.dual [preorder α] [preorder β] (f : α ≃o β) :
  order_dual α ≃o order_dual β := ⟨f.to_equiv, λ _ _, f.map_rel_iff⟩

section lattice_isos

lemma order_iso.map_bot' [partial_order α] [partial_order β] (f : α ≃o β) {x : α} {y : β}
  (hx : ∀ x', x ≤ x') (hy : ∀ y', y ≤ y') : f x = y :=
by { refine le_antisymm _ (hy _), rw [← f.apply_symm_apply y, f.map_rel_iff], apply hx }

lemma order_iso.map_bot [order_bot α] [order_bot β] (f : α ≃o β) : f ⊥ = ⊥ :=
f.map_bot' (λ _, bot_le) (λ _, bot_le)

lemma order_iso.map_top' [partial_order α] [partial_order β] (f : α ≃o β) {x : α} {y : β}
  (hx : ∀ x', x' ≤ x) (hy : ∀ y', y' ≤ y) : f x = y :=
f.dual.map_bot' hx hy

lemma order_iso.map_top [order_top α] [order_top β] (f : α ≃o β) : f ⊤ = ⊤ :=
f.dual.map_bot

lemma order_embedding.map_inf_le [semilattice_inf α] [semilattice_inf β]
  (f : α ↪o β) (x y : α) :
  f (x ⊓ y) ≤ f x ⊓ f y :=
f.monotone.map_inf_le x y

lemma order_iso.map_inf [semilattice_inf α] [semilattice_inf β]
  (f : α ≃o β) (x y : α) :
  f (x ⊓ y) = f x ⊓ f y :=
begin
  refine (f.to_order_embedding.map_inf_le x y).antisymm _,
  simpa [← f.symm.le_iff_le] using f.symm.to_order_embedding.map_inf_le (f x) (f y)
end

lemma order_embedding.le_map_sup [semilattice_sup α] [semilattice_sup β]
  (f : α ↪o β) (x y : α) :
  f x ⊔ f y ≤ f (x ⊔ y) :=
f.monotone.le_map_sup x y

lemma order_iso.map_sup [semilattice_sup α] [semilattice_sup β]
  (f : α ≃o β) (x y : α) :
  f (x ⊔ y) = f x ⊔ f y :=
f.dual.map_inf x y

/-- Order isomorphism between `Iic (⊤ : α)` and `α` when `α` has a top element -/
def order_iso.Iic_top [order_top α] : set.Iic (⊤ : α) ≃o α :=
{ map_rel_iff' := λ x y, by refl,
  .. (@equiv.subtype_univ_equiv α (set.Iic (⊤ : α)) (λ x, le_top)), }

/-- Order isomorphism between `Ici (⊥ : α)` and `α` when `α` has a bottom element -/
def order_iso.Ici_bot [order_bot α] : set.Ici (⊥ : α) ≃o α :=
{ map_rel_iff' := λ x y, by refl,
  .. (@equiv.subtype_univ_equiv α (set.Ici (⊥ : α)) (λ x, bot_le)) }

section bounded_lattice

variables [bounded_lattice α]  [bounded_lattice β] (f : α ≃o β)
include f

lemma order_iso.is_compl {x y : α} (h : is_compl x y) : is_compl (f x) (f y) :=
⟨by { rw [← f.map_bot, ← f.map_inf, f.map_rel_iff], exact h.1 },
  by { rw [← f.map_top, ← f.map_sup, f.map_rel_iff], exact h.2 }⟩

theorem order_iso.is_compl_iff {x y : α} :
  is_compl x y ↔ is_compl (f x) (f y) :=
⟨f.is_compl, λ h, begin
  rw [← f.symm_apply_apply x, ← f.symm_apply_apply y],
  exact f.symm.is_compl h,
end⟩

lemma order_iso.is_complemented
  [is_complemented α] : is_complemented β :=
⟨λ x, begin
  obtain ⟨y, hy⟩ := exists_is_compl (f.symm x),
  rw ← f.symm_apply_apply y at hy,
  refine ⟨f y, f.symm.is_compl_iff.2 hy⟩,
end⟩

theorem order_iso.is_complemented_iff :
  is_complemented α ↔ is_complemented β :=
⟨by { introI, exact f.is_complemented }, by { introI, exact f.symm.is_complemented }⟩

end bounded_lattice
end lattice_isos


/-
Copyright (c) 2020 Anne Baanen. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors : Anne Baanen
-/
import Mathlib.PrePort
import Mathlib.Lean3Lib.init.default
import Mathlib.algebra.algebra.basic
import Mathlib.PostPort

universes u l u_1 v w

namespace Mathlib

/-!
# Subfields

Let `K` be a field. This file defines the "bundled" subfield type `subfield K`, a type
whose terms correspond to subfields of `K`. This is the preferred way to talk
about subfields in mathlib. Unbundled subfields (`s : set K` and `is_subfield s`)
are not in this file, and they will ultimately be deprecated.

We prove that subfields are a complete lattice, and that you can `map` (pushforward) and
`comap` (pull back) them along ring homomorphisms.

We define the `closure` construction from `set R` to `subfield R`, sending a subset of `R`
to the subfield it generates, and prove that it is a Galois insertion.

## Main definitions

Notation used here:

`(K : Type u) [field K] (L : Type u) [field L] (f g : K →+* L)`
`(A : subfield K) (B : subfield L) (s : set K)`

* `subfield R` : the type of subfields of a ring `R`.

* `instance : complete_lattice (subfield R)` : the complete lattice structure on the subfields.

* `subfield.closure` : subfield closure of a set, i.e., the smallest subfield that includes the set.

* `subfield.gi` : `closure : set M → subfield M` and coercion `coe : subfield M → set M`
  form a `galois_insertion`.

* `comap f B : subfield K` : the preimage of a subfield `B` along the ring homomorphism `f`

* `map f A : subfield L` : the image of a subfield `A` along the ring homomorphism `f`.

* `prod A B : subfield (K × L)` : the product of subfields

* `f.field_range : subfield B` : the range of the ring homomorphism `f`.

* `eq_locus_field f g : subfield K` : given ring homomorphisms `f g : K →+* R`,
     the subfield of `K` where `f x = g x`

## Implementation notes

A subfield is implemented as a subring which is is closed under `⁻¹`.

Lattice inclusion (e.g. `≤` and `⊓`) is used rather than set notation (`⊆` and `∩`), although
`∈` is defined as membership of a subfield's underlying set.

## Tags
subfield, subfields
-/

/-- `subfield R` is the type of subfields of `R`. A subfield of `R` is a subset `s` that is a
  multiplicative submonoid and an additive subgroup. Note in particular that it shares the
  same 0 and 1 as R. -/
structure subfield (K : Type u) [field K]
extends subring K
where
  inv_mem' : ∀ (x : K), x ∈ carrier → x⁻¹ ∈ carrier

/-- Reinterpret a `subfield` as a `subring`. -/
namespace subfield

/-- The underlying `add_subgroup` of a subfield. -/
def to_add_subgroup {K : Type u} [field K] (s : subfield K) : add_subgroup K :=
  add_subgroup.mk (add_subgroup.carrier (subring.to_add_subgroup (to_subring s))) sorry sorry sorry

/-- The underlying submonoid of a subfield. -/
def to_submonoid {K : Type u} [field K] (s : subfield K) : submonoid K :=
  submonoid.mk (submonoid.carrier (subring.to_submonoid (to_subring s))) sorry sorry

protected instance set.has_coe {K : Type u} [field K] : has_coe (subfield K) (set K) :=
  has_coe.mk carrier

@[simp] theorem coe_to_subring {K : Type u} [field K] (s : subfield K) : ↑(to_subring s) = ↑s :=
  rfl

protected instance has_coe_to_sort {K : Type u} [field K] : has_coe_to_sort (subfield K) :=
  has_coe_to_sort.mk (Type u) fun (S : subfield K) => ↥(carrier S)

protected instance has_mem {K : Type u} [field K] : has_mem K (subfield K) :=
  has_mem.mk fun (m : K) (S : subfield K) => m ∈ ↑S

@[simp] theorem mem_mk {K : Type u} [field K] (s : set K) (ho : 1 ∈ s) (hm : ∀ {a b : K}, a ∈ s → b ∈ s → a * b ∈ s) (hz : 0 ∈ s) (ha : ∀ {a b : K}, a ∈ s → b ∈ s → a + b ∈ s) (hn : ∀ {x : K}, x ∈ s → -x ∈ s) (hi : ∀ (x : K), x ∈ s → x⁻¹ ∈ s) (x : K) : x ∈ mk s ho hm hz ha hn hi ↔ x ∈ s :=
  iff.rfl

@[simp] theorem mem_to_subring {K : Type u} [field K] (s : subfield K) (x : K) : x ∈ to_subring s ↔ x ∈ s :=
  iff.rfl

end subfield

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

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

/-- A `subring` containing inverses is a `subfield`. -/
def subring.to_subfield {K : Type u} [field K] (s : subring K) (hinv : ∀ (x : K), x ∈ s → x⁻¹ ∈ s) : subfield K :=
  subfield.mk (subring.carrier s) sorry sorry sorry sorry sorry hinv

namespace subfield

/-- Two subfields are equal if the underlying subsets are equal. -/
theorem ext' {K : Type u} [field K] {s : subfield K} {t : subfield K} (h : ↑s = ↑t) : s = t := sorry

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

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

/-- A subfield contains the ring's 1. -/
theorem one_mem {K : Type u} [field K] (s : subfield K) : 1 ∈ s :=
  one_mem' s

/-- A subfield contains the ring's 0. -/
theorem zero_mem {K : Type u} [field K] (s : subfield K) : 0 ∈ s :=
  zero_mem' s

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

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

/-- A subfield is closed under negation. -/
theorem neg_mem {K : Type u} [field K] (s : subfield K) {x : K} : x ∈ s → -x ∈ s :=
  neg_mem' s

/-- A subfield is closed under subtraction. -/
theorem sub_mem {K : Type u} [field K] (s : subfield K) {x : K} {y : K} : x ∈ s → y ∈ s → x - y ∈ s :=
  subring.sub_mem (to_subring s)

/-- A subfield is closed under inverses. -/
theorem inv_mem {K : Type u} [field K] (s : subfield K) {x : K} : x ∈ s → x⁻¹ ∈ s :=
  inv_mem' s

/-- A subfield is closed under division. -/
theorem div_mem {K : Type u} [field K] (s : subfield K) {x : K} {y : K} (hx : x ∈ s) (hy : y ∈ s) : x / y ∈ s :=
  eq.mpr (id (Eq._oldrec (Eq.refl (x / y ∈ s)) (div_eq_mul_inv x y))) (mul_mem s hx (inv_mem s hy))

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

/-- Sum of a list of elements in a subfield is in the subfield. -/
theorem list_sum_mem {K : Type u} [field K] (s : subfield K) {l : List K} : (∀ (x : K), x ∈ l → x ∈ s) → list.sum l ∈ s :=
  add_subgroup.list_sum_mem (to_add_subgroup s)

/-- Product of a multiset of elements in a subfield is in the subfield. -/
theorem multiset_prod_mem {K : Type u} [field K] (s : subfield K) (m : multiset K) : (∀ (a : K), a ∈ m → a ∈ s) → multiset.prod m ∈ s :=
  submonoid.multiset_prod_mem (to_submonoid s) m

/-- Sum of a multiset of elements in a `subfield` is in the `subfield`. -/
theorem multiset_sum_mem {K : Type u} [field K] (s : subfield K) (m : multiset K) : (∀ (a : K), a ∈ m → a ∈ s) → multiset.sum m ∈ s :=
  add_subgroup.multiset_sum_mem (to_add_subgroup s) m

/-- Product of elements of a subfield indexed by a `finset` is in the subfield. -/
theorem prod_mem {K : Type u} [field K] (s : subfield K) {ι : Type u_1} {t : finset ι} {f : ι → K} (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 a `subfield` indexed by a `finset` is in the `subfield`. -/
theorem sum_mem {K : Type u} [field K] (s : subfield K) {ι : Type u_1} {t : finset ι} {f : ι → K} (h : ∀ (c : ι), c ∈ t → f c ∈ s) : (finset.sum t fun (i : ι) => f i) ∈ s :=
  add_subgroup.sum_mem (to_add_subgroup s) h

theorem pow_mem {K : Type u} [field K] (s : subfield K) {x : K} (hx : x ∈ s) (n : ℕ) : x ^ n ∈ s :=
  submonoid.pow_mem (to_submonoid s) hx n

theorem gsmul_mem {K : Type u} [field K] (s : subfield K) {x : K} (hx : x ∈ s) (n : ℤ) : n •ℤ x ∈ s :=
  add_subgroup.gsmul_mem (to_add_subgroup s) hx n

theorem coe_int_mem {K : Type u} [field K] (s : subfield K) (n : ℤ) : ↑n ∈ s := sorry

/-- A subfield inherits a field structure -/
protected instance to_field {K : Type u} [field K] (s : subfield K) : field ↥s :=
  field.mk integral_domain.add sorry integral_domain.zero sorry sorry integral_domain.neg integral_domain.sub sorry sorry
    integral_domain.mul sorry integral_domain.one sorry sorry sorry sorry sorry
    (fun (x : ↥s) => { val := ↑x⁻¹, property := sorry }) sorry sorry sorry

@[simp] theorem coe_add {K : Type u} [field K] (s : subfield K) (x : ↥s) (y : ↥s) : ↑(x + y) = ↑x + ↑y :=
  rfl

@[simp] theorem coe_neg {K : Type u} [field K] (s : subfield K) (x : ↥s) : ↑(-x) = -↑x :=
  rfl

@[simp] theorem coe_mul {K : Type u} [field K] (s : subfield K) (x : ↥s) (y : ↥s) : ↑(x * y) = ↑x * ↑y :=
  rfl

@[simp] theorem coe_inv {K : Type u} [field K] (s : subfield K) (x : ↥s) : ↑(x⁻¹) = (↑x⁻¹) :=
  rfl

@[simp] theorem coe_zero {K : Type u} [field K] (s : subfield K) : ↑0 = 0 :=
  rfl

@[simp] theorem coe_one {K : Type u} [field K] (s : subfield K) : ↑1 = 1 :=
  rfl

/-- The embedding from a subfield of the field `K` to `K`. -/
def subtype {K : Type u} [field K] (s : subfield K) : ↥s →+* K :=
  ring_hom.mk coe sorry sorry sorry sorry

protected instance to_algebra {K : Type u} [field K] (s : subfield K) : algebra (↥s) K :=
  ring_hom.to_algebra (subtype s)

@[simp] theorem coe_subtype {K : Type u} [field K] (s : subfield K) : ⇑(subtype s) = coe :=
  rfl

/-! # Partial order -/

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

theorem le_def {K : Type u} [field K] {s : subfield K} {t : subfield K} : s ≤ t ↔ ∀ {x : K}, x ∈ s → x ∈ t :=
  iff.rfl

@[simp] theorem coe_subset_coe {K : Type u} [field K] {s : subfield K} {t : subfield K} : ↑s ⊆ ↑t ↔ s ≤ t :=
  iff.rfl

@[simp] theorem coe_ssubset_coe {K : Type u} [field K] {s : subfield K} {t : subfield K} : ↑s ⊂ ↑t ↔ s < t :=
  iff.rfl

@[simp] theorem mem_coe {K : Type u} [field K] {s : subfield K} {m : K} : m ∈ ↑s ↔ m ∈ s :=
  iff.rfl

@[simp] theorem coe_coe {K : Type u} [field K] (s : subfield K) : ↥↑s = ↥s :=
  rfl

@[simp] theorem mem_to_submonoid {K : Type u} [field K] {s : subfield K} {x : K} : x ∈ to_submonoid s ↔ x ∈ s :=
  iff.rfl

@[simp] theorem coe_to_submonoid {K : Type u} [field K] (s : subfield K) : ↑(to_submonoid s) = ↑s :=
  rfl

@[simp] theorem mem_to_add_subgroup {K : Type u} [field K] {s : subfield K} {x : K} : x ∈ to_add_subgroup s ↔ x ∈ s :=
  iff.rfl

@[simp] theorem coe_to_add_subgroup {K : Type u} [field K] (s : subfield K) : ↑(to_add_subgroup s) = ↑s :=
  rfl

/-! # top -/

/-- The subfield of `K` containing all elements of `K`. -/
protected instance has_top {K : Type u} [field K] : has_top (subfield K) :=
  has_top.mk (mk (subring.carrier ⊤) sorry sorry sorry sorry sorry sorry)

protected instance inhabited {K : Type u} [field K] : Inhabited (subfield K) :=
  { default := ⊤ }

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

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

/-! # comap -/

/-- The preimage of a subfield along a ring homomorphism is a subfield. -/
def comap {K : Type u} {L : Type v} [field K] [field L] (f : K →+* L) (s : subfield L) : subfield K :=
  mk (subring.carrier (subring.comap f (to_subring s))) sorry sorry sorry sorry sorry sorry

@[simp] theorem coe_comap {K : Type u} {L : Type v} [field K] [field L] (f : K →+* L) (s : subfield L) : ↑(comap f s) = ⇑f ⁻¹' ↑s :=
  rfl

@[simp] theorem mem_comap {K : Type u} {L : Type v} [field K] [field L] {s : subfield L} {f : K →+* L} {x : K} : x ∈ comap f s ↔ coe_fn f x ∈ s :=
  iff.rfl

theorem comap_comap {K : Type u} {L : Type v} {M : Type w} [field K] [field L] [field M] (s : subfield M) (g : L →+* M) (f : K →+* L) : comap f (comap g s) = comap (ring_hom.comp g f) s :=
  rfl

/-! # map -/

/-- The image of a subfield along a ring homomorphism is a subfield. -/
def map {K : Type u} {L : Type v} [field K] [field L] (f : K →+* L) (s : subfield K) : subfield L :=
  mk (subring.carrier (subring.map f (to_subring s))) sorry sorry sorry sorry sorry sorry

@[simp] theorem coe_map {K : Type u} {L : Type v} [field K] [field L] (s : subfield K) (f : K →+* L) : ↑(map f s) = ⇑f '' ↑s :=
  rfl

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

theorem map_map {K : Type u} {L : Type v} {M : Type w} [field K] [field L] [field M] (s : subfield K) (g : L →+* M) (f : K →+* L) : map g (map f s) = map (ring_hom.comp g f) s :=
  ext' (set.image_image (fun (a : L) => coe_fn g a) (fun (a : K) => coe_fn f a) (subring.carrier (to_subring s)))

theorem map_le_iff_le_comap {K : Type u} {L : Type v} [field K] [field L] {f : K →+* L} {s : subfield K} {t : subfield L} : map f s ≤ t ↔ s ≤ comap f t :=
  set.image_subset_iff

theorem gc_map_comap {K : Type u} {L : Type v} [field K] [field L] (f : K →+* L) : galois_connection (map f) (comap f) :=
  fun (S : subfield K) (T : subfield L) => map_le_iff_le_comap

end subfield

namespace ring_hom

/-! # range -/

/-- The range of a ring homomorphism, as a subfield of the target. -/
def field_range {K : Type u} {L : Type v} [field K] [field L] (f : K →+* L) : subfield L :=
  subfield.map f ⊤

@[simp] theorem coe_field_range {K : Type u} {L : Type v} [field K] [field L] (f : K →+* L) : ↑(field_range f) = set.range ⇑f :=
  set.image_univ

@[simp] theorem mem_field_range {K : Type u} {L : Type v} [field K] [field L] {f : K →+* L} {y : L} : y ∈ range f ↔ ∃ (x : K), coe_fn f x = y := sorry

theorem map_field_range {K : Type u} {L : Type v} {M : Type w} [field K] [field L] [field M] (g : L →+* M) (f : K →+* L) : subfield.map g (field_range f) = field_range (comp g f) :=
  subfield.map_map ⊤ g f

end ring_hom

namespace subfield

/-! # inf -/

/-- The inf of two subfields is their intersection. -/
protected instance has_inf {K : Type u} [field K] : has_inf (subfield K) :=
  has_inf.mk
    fun (s t : subfield K) => mk (subring.carrier (to_subring s ⊓ to_subring t)) sorry sorry sorry sorry sorry sorry

@[simp] theorem coe_inf {K : Type u} [field K] (p : subfield K) (p' : subfield K) : ↑(p ⊓ p') = ↑p ∩ ↑p' :=
  rfl

@[simp] theorem mem_inf {K : Type u} [field K] {p : subfield K} {p' : subfield K} {x : K} : x ∈ p ⊓ p' ↔ x ∈ p ∧ x ∈ p' :=
  iff.rfl

protected instance has_Inf {K : Type u} [field K] : has_Inf (subfield K) :=
  has_Inf.mk
    fun (S : set (subfield K)) => mk (subring.carrier (Inf (to_subring '' S))) sorry sorry sorry sorry sorry sorry

@[simp] theorem coe_Inf {K : Type u} [field K] (S : set (subfield K)) : ↑(Inf S) = set.Inter fun (s : subfield K) => set.Inter fun (H : s ∈ S) => ↑s := sorry

theorem mem_Inf {K : Type u} [field K] {S : set (subfield K)} {x : K} : x ∈ Inf S ↔ ∀ (p : subfield K), p ∈ S → x ∈ p := sorry

@[simp] theorem Inf_to_subring {K : Type u} [field K] (s : set (subfield K)) : to_subring (Inf s) = infi fun (t : subfield K) => infi fun (H : t ∈ s) => to_subring t := sorry

theorem is_glb_Inf {K : Type u} [field K] (S : set (subfield K)) : is_glb S (Inf S) := sorry

/-- Subfields of a ring form a complete lattice. -/
protected instance complete_lattice {K : Type u} [field K] : complete_lattice (subfield K) :=
  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 complete_lattice.bot sorry complete_lattice.Sup complete_lattice.Inf sorry sorry
    sorry sorry

/-! # subfield closure of a subset -/

/-- The `subfield` generated by a set. -/
def closure {K : Type u} [field K] (s : set K) : subfield K :=
  mk
    (set_of
      fun (_x : K) => ∃ (x : K), ∃ (H : x ∈ subring.closure s), ∃ (y : K), ∃ (H : y ∈ subring.closure s), x / y = _x)
    sorry sorry sorry sorry sorry sorry

theorem mem_closure_iff {K : Type u} [field K] {s : set K} {x : K} : x ∈ closure s ↔ ∃ (y : K), ∃ (H : y ∈ subring.closure s), ∃ (z : K), ∃ (H : z ∈ subring.closure s), y / z = x :=
  iff.rfl

theorem subring_closure_le {K : Type u} [field K] (s : set K) : subring.closure s ≤ to_subring (closure s) :=
  fun (x : K) (hx : x ∈ subring.closure s) =>
    Exists.intro x (Exists.intro hx (Exists.intro 1 (Exists.intro (subring.one_mem (subring.closure s)) (div_one x))))

/-- The subfield generated by a set includes the set. -/
@[simp] theorem subset_closure {K : Type u} [field K] {s : set K} : s ⊆ ↑(closure s) :=
  set.subset.trans subring.subset_closure (subring_closure_le s)

theorem mem_closure {K : Type u} [field K] {x : K} {s : set K} : x ∈ closure s ↔ ∀ (S : subfield K), s ⊆ ↑S → x ∈ S := sorry

/-- A subfield `t` includes `closure s` if and only if it includes `s`. -/
@[simp] theorem closure_le {K : Type u} [field K] {s : set K} {t : subfield K} : closure s ≤ t ↔ s ⊆ ↑t :=
  { mp := set.subset.trans subset_closure,
    mpr := fun (h : s ⊆ ↑t) (x : K) (hx : x ∈ closure s) => iff.mp mem_closure hx t h }

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

theorem closure_eq_of_le {K : Type u} [field K] {s : set K} {t : subfield K} (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 `1`, and all elements
of `s`, and is preserved under addition, negation, and multiplication, then `p` holds for all elements
of the closure of `s`. -/
theorem closure_induction {K : Type u} [field K] {s : set K} {p : K → Prop} {x : K} (h : x ∈ closure s) (Hs : ∀ (x : K), x ∈ s → p x) (H1 : p 1) (Hadd : ∀ (x y : K), p x → p y → p (x + y)) (Hneg : ∀ (x : K), p x → p (-x)) (Hinv : ∀ (x : K), p x → p (x⁻¹)) (Hmul : ∀ (x y : K), p x → p y → p (x * y)) : p x :=
  iff.mpr closure_le Hs x h

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

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

@[simp] theorem closure_empty {K : Type u} [field K] : closure ∅ = ⊥ :=
  galois_connection.l_bot (galois_insertion.gc (subfield.gi K))

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

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

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

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

theorem map_sup {K : Type u} {L : Type v} [field K] [field L] (s : subfield K) (t : subfield K) (f : K →+* L) : map f (s ⊔ t) = map f s ⊔ map f t :=
  galois_connection.l_sup (gc_map_comap f)

theorem map_supr {K : Type u} {L : Type v} [field K] [field L] {ι : Sort u_1} (f : K →+* L) (s : ι → subfield K) : map f (supr s) = supr fun (i : ι) => map f (s i) :=
  galois_connection.l_supr (gc_map_comap f)

theorem comap_inf {K : Type u} {L : Type v} [field K] [field L] (s : subfield L) (t : subfield L) (f : K →+* L) : comap f (s ⊓ t) = comap f s ⊓ comap f t :=
  galois_connection.u_inf (gc_map_comap f)

theorem comap_infi {K : Type u} {L : Type v} [field K] [field L] {ι : Sort u_1} (f : K →+* L) (s : ι → subfield L) : comap f (infi s) = infi fun (i : ι) => comap f (s i) :=
  galois_connection.u_infi (gc_map_comap f)

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

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

/-- The underlying set of a non-empty directed Sup of subfields is just a union of the subfields.
  Note that this fails without the directedness assumption (the union of two subfields is
  typically not a subfield) -/
theorem mem_supr_of_directed {K : Type u} [field K] {ι : Sort u_1} [hι : Nonempty ι] {S : ι → subfield K} (hS : directed LessEq S) {x : K} : (x ∈ supr fun (i : ι) => S i) ↔ ∃ (i : ι), x ∈ S i := sorry

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

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

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

end subfield

namespace ring_hom

/-- Restrict the codomain of a ring homomorphism to a subfield that includes the range. -/
def cod_restrict_field {K : Type u} {L : Type v} [field K] [field L] (f : K →+* L) (s : subfield L) (h : ∀ (x : K), coe_fn f x ∈ s) : K →+* ↥s :=
  mk (fun (x : K) => { val := coe_fn f x, property := h x }) sorry sorry sorry sorry

/-- Restriction of a ring homomorphism to a subfield of the domain. -/
def restrict_field {K : Type u} {L : Type v} [field K] [field L] (f : K →+* L) (s : subfield K) : ↥s →+* L :=
  comp f (subfield.subtype s)

@[simp] theorem restrict_field_apply {K : Type u} {L : Type v} [field K] [field L] {s : subfield K} (f : K →+* L) (x : ↥s) : coe_fn (restrict_field f s) x = coe_fn f ↑x :=
  rfl

/-- Restriction of a ring homomorphism to its range interpreted as a subfield. -/
def range_restrict_field {K : Type u} {L : Type v} [field K] [field L] (f : K →+* L) : K →+* ↥(range f) :=
  cod_restrict' f (range f) sorry

@[simp] theorem coe_range_restrict_field {K : Type u} {L : Type v} [field K] [field L] (f : K →+* L) (x : K) : ↑(coe_fn (range_restrict_field f) x) = coe_fn f x :=
  rfl

/-- The subfield of elements `x : R` such that `f x = g x`, i.e.,
the equalizer of f and g as a subfield of R -/
def eq_locus_field {K : Type u} {L : Type v} [field K] [field L] (f : K →+* L) (g : K →+* L) : subfield K :=
  subfield.mk (set_of fun (x : K) => coe_fn f x = coe_fn g x) sorry sorry sorry sorry sorry sorry

/-- If two ring homomorphisms are equal on a set, then they are equal on its subfield closure. -/
theorem eq_on_field_closure {K : Type u} {L : Type v} [field K] [field L] {f : K →+* L} {g : K →+* L} {s : set K} (h : set.eq_on (⇑f) (⇑g) s) : set.eq_on ⇑f ⇑g ↑(subfield.closure s) :=
  (fun (this : subfield.closure s ≤ eq_locus_field f g) => this) (iff.mpr subfield.closure_le h)

theorem eq_of_eq_on_subfield_top {K : Type u} {L : Type v} [field K] [field L] {f : K →+* L} {g : K →+* L} (h : set.eq_on ⇑f ⇑g ↑⊤) : f = g :=
  ext fun (x : K) => h trivial

theorem eq_of_eq_on_of_field_closure_eq_top {K : Type u} {L : Type v} [field K] [field L] {s : set K} (hs : subfield.closure s = ⊤) {f : K →+* L} {g : K →+* L} (h : set.eq_on (⇑f) (⇑g) s) : f = g :=
  eq_of_eq_on_subfield_top (hs ▸ eq_on_field_closure h)

theorem field_closure_preimage_le {K : Type u} {L : Type v} [field K] [field L] (f : K →+* L) (s : set L) : subfield.closure (⇑f ⁻¹' s) ≤ subfield.comap f (subfield.closure s) :=
  iff.mpr subfield.closure_le
    fun (x : K) (hx : x ∈ ⇑f ⁻¹' s) => iff.mpr subfield.mem_coe (iff.mpr subfield.mem_comap (subfield.subset_closure hx))

/-- The image under a ring homomorphism of the subfield generated by a set equals
the subfield generated by the image of the set. -/
theorem map_field_closure {K : Type u} {L : Type v} [field K] [field L] (f : K →+* L) (s : set K) : subfield.map f (subfield.closure s) = subfield.closure (⇑f '' s) := sorry

end ring_hom

namespace subfield

/-- The ring homomorphism associated to an inclusion of subfields. -/
def inclusion {K : Type u} [field K] {S : subfield K} {T : subfield K} (h : S ≤ T) : ↥S →+* ↥T :=
  ring_hom.cod_restrict_field (subtype S) T sorry

@[simp] theorem field_range_subtype {K : Type u} [field K] (s : subfield K) : ring_hom.field_range (subtype s) = s :=
  ext' (Eq.trans (ring_hom.coe_srange (subtype s)) subtype.range_coe)

end subfield

namespace ring_equiv

/-- Makes the identity isomorphism from a proof two subfields of a multiplicative
    monoid are equal. -/
def subfield_congr {K : Type u} [field K] {s : subfield K} {t : subfield K} (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 ring_equiv

namespace subfield

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


import interactive
variables x y z : ℚ

example (e1 : x < 1*y) (e2 : z < 1*y) (e3 : x + z > 3*y) (e4 : x + z >0) : false :=
by polya e1 e2 e3 e4
/-exps ← monad.mapm get_local [`e1, `e2, `e3, `e4],
bb ← add_proofs_to_blackboard blackboard.mk_empty exps,
bb.trace_exprs,
(_, bb) ← return $ add_new_ineqs bb,
bb.trace,
trace $ ("contr found", bb.contr_found),
pf ← bb.contr.reconstruct,
trace pf, apply pf-/

example (e1 : x < 2*y) (e2 : z ≤ 4*y) (e3 : 1*x + 1*z > 6*y) : false :=
by polya e1 e2 e3
/-do
exps ← monad.mapm get_local [`e1, `e2, `e3],
bb ← add_proofs_to_blackboard blackboard.mk_empty exps,
bb.trace_exprs,
(_, bb) ← return $ add_new_ineqs bb,
bb.trace,
trace $ ("contr found", bb.contr_found),
pf ← bb.contr.reconstruct,
apply pf-/

def g (e1 : x = 2*y) (e2 : x > 1*y) (e3 : y < 0)  : false :=
by polya e1 e2 e3
/-by do
e1 ← get_local `e1, e2 ← get_local `e2, e3 ← get_local `e3,-- e4 ← get_local `e4,
bb ← add_proofs_to_blackboard blackboard.mk_empty [e1, e2],
bb.trace,
bb ← add_proofs_to_blackboard bb [e3],
bb.trace,
trace $ ("contr found", bb.contr_found),
pf ← bb.contr.reconstruct,
trace pf,
apply pf-/

#exit
example (e1 : 4*x+7*z = 0) (e2 : (-12)*x + (-3)*y ≤ 0) (e3 : 17*x + (-17)*y + 14*z = 0) (e4 : 9*y + (-17)*z < 0) : false :=
by polya e1 e2 e3 e4


/-
Copyright (c) 2021 Yaël Dillies. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Yaël Dillies
-/
import analysis.convex.function

/-!
# Quasiconvex and quasiconcave functions

This file defines quasiconvexity, quasiconcavity and quasilinearity of functions, which are
generalizations of unimodality and monotonicity. Convexity implies quasiconvexity, concavity implies
quasiconcavity, and monotonicity implies quasilinearity.

## Main declarations

* `quasiconvex_on 𝕜 s f`: Quasiconvexity of the function `f` on the set `s` with scalars `𝕜`. This
  means that, for all `r`, `{x ∈ s | f x ≤ r}` is `𝕜`-convex.
* `quasiconcave_on 𝕜 s f`: Quasiconcavity of the function `f` on the set `s` with scalars `𝕜`. This
  means that, for all `r`, `{x ∈ s | r ≤ f x}` is `𝕜`-convex.
* `quasilinear_on 𝕜 s f`: Quasilinearity of the function `f` on the set `s` with scalars `𝕜`. This
  means that `f` is both quasiconvex and quasiconcave.

## References

* https://en.wikipedia.org/wiki/Quasiconvex_function
-/

open function order_dual set

variables {𝕜 E F β : Type*}

section ordered_semiring
variables [ordered_semiring 𝕜]

section add_comm_monoid
variables [add_comm_monoid E] [add_comm_monoid F]

section ordered_add_comm_monoid
variables (𝕜) [ordered_add_comm_monoid β] [has_smul 𝕜 E] (s : set E) (f : E → β)

/-- A function is quasiconvex if all its sublevels are convex.
This means that, for all `r`, `{x ∈ s | f x ≤ r}` is `𝕜`-convex. -/
def quasiconvex_on : Prop :=
∀ r, convex 𝕜 {x ∈ s | f x ≤ r}

/-- A function is quasiconcave if all its superlevels are convex.
This means that, for all `r`, `{x ∈ s | r ≤ f x}` is `𝕜`-convex. -/
def quasiconcave_on : Prop :=
∀ r, convex 𝕜 {x ∈ s | r ≤ f x}

/-- A function is quasilinear if it is both quasiconvex and quasiconcave.
This means that, for all `r`,
the sets `{x ∈ s | f x ≤ r}` and `{x ∈ s | r ≤ f x}` are `𝕜`-convex. -/
def quasilinear_on : Prop :=
quasiconvex_on 𝕜 s f ∧ quasiconcave_on 𝕜 s f

variables {𝕜 s f}

lemma quasiconvex_on.dual : quasiconvex_on 𝕜 s f → quasiconcave_on 𝕜 s (to_dual ∘ f) := id
lemma quasiconcave_on.dual : quasiconcave_on 𝕜 s f → quasiconvex_on 𝕜 s (to_dual ∘ f) := id
lemma quasilinear_on.dual : quasilinear_on 𝕜 s f → quasilinear_on 𝕜 s (to_dual ∘ f) := and.swap

lemma convex.quasiconvex_on_of_convex_le (hs : convex 𝕜 s) (h : ∀ r, convex 𝕜 {x | f x ≤ r}) :
  quasiconvex_on 𝕜 s f :=
λ r, hs.inter (h r)

lemma convex.quasiconcave_on_of_convex_ge (hs : convex 𝕜 s) (h : ∀ r, convex 𝕜 {x | r ≤ f x}) :
  quasiconcave_on 𝕜 s f :=
@convex.quasiconvex_on_of_convex_le 𝕜 E βᵒᵈ _ _ _ _ _ _ hs h

lemma quasiconvex_on.convex [is_directed β (≤)] (hf : quasiconvex_on 𝕜 s f) : convex 𝕜 s :=
λ x hx y hy a b ha hb hab,
  let ⟨z, hxz, hyz⟩ := exists_ge_ge (f x) (f y) in (hf _ ⟨hx, hxz⟩ ⟨hy, hyz⟩ ha hb hab).1

lemma quasiconcave_on.convex [is_directed β (≥)] (hf : quasiconcave_on 𝕜 s f) : convex 𝕜 s :=
hf.dual.convex

end ordered_add_comm_monoid

section linear_ordered_add_comm_monoid
variables [linear_ordered_add_comm_monoid β]

section has_smul
variables [has_smul 𝕜 E] {s : set E} {f g : E → β}

lemma quasiconvex_on.sup (hf : quasiconvex_on 𝕜 s f) (hg : quasiconvex_on 𝕜 s g) :
  quasiconvex_on 𝕜 s (f ⊔ g) :=
begin
  intro r,
  simp_rw [pi.sup_def, sup_le_iff, set.sep_and],
  exact (hf r).inter (hg r),
end

lemma quasiconcave_on.inf (hf : quasiconcave_on 𝕜 s f) (hg : quasiconcave_on 𝕜 s g) :
  quasiconcave_on 𝕜 s (f ⊓ g) :=
hf.dual.sup hg

lemma quasiconvex_on_iff_le_max :
  quasiconvex_on 𝕜 s f ↔ convex 𝕜 s ∧
    ∀ ⦃x⦄, x ∈ s → ∀ ⦃y⦄, y ∈ s → ∀ ⦃a b : 𝕜⦄, 0 ≤ a → 0 ≤ b → a + b = 1 →
      f (a • x + b • y) ≤ max (f x) (f y) :=
⟨λ hf, ⟨hf.convex, λ x hx y hy a b ha hb hab,
  (hf _ ⟨hx, le_max_left _ _⟩ ⟨hy, le_max_right _ _⟩ ha hb hab).2⟩,
  λ hf r x hx y hy a b ha hb hab,
  ⟨hf.1 hx.1 hy.1 ha hb hab, (hf.2 hx.1 hy.1 ha hb hab).trans $ max_le hx.2 hy.2⟩⟩

lemma quasiconcave_on_iff_min_le :
  quasiconcave_on 𝕜 s f ↔ convex 𝕜 s ∧
    ∀ ⦃x⦄, x ∈ s → ∀ ⦃y⦄, y ∈ s → ∀ ⦃a b : 𝕜⦄, 0 ≤ a → 0 ≤ b → a + b = 1 →
      min (f x) (f y) ≤ f (a • x + b • y) :=
@quasiconvex_on_iff_le_max 𝕜 E βᵒᵈ _ _ _ _ _ _

lemma quasilinear_on_iff_mem_uIcc :
  quasilinear_on 𝕜 s f ↔ convex 𝕜 s ∧
    ∀ ⦃x⦄, x ∈ s → ∀ ⦃y⦄, y ∈ s → ∀ ⦃a b : 𝕜⦄, 0 ≤ a → 0 ≤ b → a + b = 1 →
      f (a • x + b • y) ∈ uIcc (f x) (f y) :=
begin
  rw [quasilinear_on, quasiconvex_on_iff_le_max, quasiconcave_on_iff_min_le, and_and_and_comm,
    and_self],
  apply and_congr_right',
  simp_rw [←forall_and_distrib, ←Icc_min_max, mem_Icc, and_comm],
end

lemma quasiconvex_on.convex_lt (hf : quasiconvex_on 𝕜 s f) (r : β) : convex 𝕜 {x ∈ s | f x < r} :=
begin
  refine λ x hx y hy a b ha hb hab, _,
  have h := hf _ ⟨hx.1, le_max_left _ _⟩ ⟨hy.1, le_max_right _ _⟩ ha hb hab,
  exact ⟨h.1, h.2.trans_lt $ max_lt hx.2 hy.2⟩,
end

lemma quasiconcave_on.convex_gt (hf : quasiconcave_on 𝕜 s f) (r : β) : convex 𝕜 {x ∈ s | r < f x} :=
hf.dual.convex_lt r

end has_smul

section ordered_smul
variables [has_smul 𝕜 E] [module 𝕜 β] [ordered_smul 𝕜 β] {s : set E} {f : E → β}

lemma convex_on.quasiconvex_on (hf : convex_on 𝕜 s f) : quasiconvex_on 𝕜 s f :=
hf.convex_le

lemma concave_on.quasiconcave_on (hf : concave_on 𝕜 s f) : quasiconcave_on 𝕜 s f :=
hf.convex_ge

end ordered_smul
end linear_ordered_add_comm_monoid
end add_comm_monoid

section linear_ordered_add_comm_monoid
variables [linear_ordered_add_comm_monoid E] [ordered_add_comm_monoid β] [module 𝕜 E]
  [ordered_smul 𝕜 E] {s : set E} {f : E → β}

lemma monotone_on.quasiconvex_on (hf : monotone_on f s) (hs : convex 𝕜 s) : quasiconvex_on 𝕜 s f :=
hf.convex_le hs

lemma monotone_on.quasiconcave_on (hf : monotone_on f s) (hs : convex 𝕜 s) :
  quasiconcave_on 𝕜 s f :=
hf.convex_ge hs

lemma monotone_on.quasilinear_on (hf : monotone_on f s) (hs : convex 𝕜 s) : quasilinear_on 𝕜 s f :=
⟨hf.quasiconvex_on hs, hf.quasiconcave_on hs⟩

lemma antitone_on.quasiconvex_on (hf : antitone_on f s) (hs : convex 𝕜 s) : quasiconvex_on 𝕜 s f :=
hf.convex_le hs

lemma antitone_on.quasiconcave_on (hf : antitone_on f s) (hs : convex 𝕜 s) :
  quasiconcave_on 𝕜 s f :=
hf.convex_ge hs

lemma antitone_on.quasilinear_on (hf : antitone_on f s) (hs : convex 𝕜 s) : quasilinear_on 𝕜 s f :=
⟨hf.quasiconvex_on hs, hf.quasiconcave_on hs⟩

lemma monotone.quasiconvex_on (hf : monotone f) : quasiconvex_on 𝕜 univ f :=
(hf.monotone_on _).quasiconvex_on convex_univ

lemma monotone.quasiconcave_on (hf : monotone f) : quasiconcave_on 𝕜 univ f :=
(hf.monotone_on _).quasiconcave_on convex_univ

lemma monotone.quasilinear_on (hf : monotone f) : quasilinear_on 𝕜 univ f :=
⟨hf.quasiconvex_on, hf.quasiconcave_on⟩

lemma antitone.quasiconvex_on (hf : antitone f) : quasiconvex_on 𝕜 univ f :=
(hf.antitone_on _).quasiconvex_on convex_univ

lemma antitone.quasiconcave_on (hf : antitone f) : quasiconcave_on 𝕜 univ f :=
(hf.antitone_on _).quasiconcave_on convex_univ

lemma antitone.quasilinear_on (hf : antitone f) : quasilinear_on 𝕜 univ f :=
⟨hf.quasiconvex_on, hf.quasiconcave_on⟩

end linear_ordered_add_comm_monoid
end ordered_semiring

section linear_ordered_field
variables [linear_ordered_field 𝕜] [linear_ordered_add_comm_monoid β] {s : set 𝕜} {f : 𝕜 → β}

lemma quasilinear_on.monotone_on_or_antitone_on (hf : quasilinear_on 𝕜 s f) :
  monotone_on f s ∨ antitone_on f s :=
begin
  simp_rw [monotone_on_or_antitone_on_iff_uIcc, ←segment_eq_uIcc],
  rintro a ha b hb c hc h,
  refine ⟨((hf.2 _).segment_subset _ _ h).2, ((hf.1 _).segment_subset _ _ h).2⟩; simp [*],
end

lemma quasilinear_on_iff_monotone_on_or_antitone_on (hs : convex 𝕜 s) :
  quasilinear_on 𝕜 s f ↔ monotone_on f s ∨ antitone_on f s :=
⟨λ h, h.monotone_on_or_antitone_on,
  λ h, h.elim (λ h, h.quasilinear_on hs) (λ h, h.quasilinear_on hs)⟩

end linear_ordered_field


/-
Copyright (c) 2021 Paula Neeley. All rights reserved.
Author: Paula Neeley
-/

import basicmodal.language basicmodal.syntax.syntax
import basicmodal.semantics.semantics data.set.basic basicmodal.paths
import basicmodal.semantics.definability
local attribute [instance] classical.prop_decidable

open form

---------------------- Frame Undefinability ----------------------

-- F (a class of frames) is undefinable
def undefinable (F : set (frame)) :=
  ∀ φ, ¬ defines φ F

-- The theory of x in m
def theory_at (f : frame) (v : nat → f.states → Prop) (x : f.states) :
  set (form) := { φ : form | forces f v x φ}

-- Invariance under disjoint union
variables {α β : Type}
def frame.rel.dunion (r1 : α → α → Prop) (r2 : β → β → Prop) :
  (sum α β) → (sum α β) → Prop
  | (sum.inl a1) (sum.inl a2) := r1 a1 a2
  | (sum.inr b1) (sum.inr b2) := r2 b1 b2
  | _ _                       := false

def val_dunion {f1 f2 : frame} (v1 : nat → f1.states → Prop)
  (v2 : nat → f2.states → Prop) : nat → (sum f1.states f2.states) → Prop
  | n (sum.inl x1) := v1 n x1
  | n (sum.inr x2) := v2 n x2

def frame.dunion (f1 f2 : frame) : frame :=
{
  states := sum f1.states f2.states,
  h := ⟨sum.inl f1.h.default⟩,
  rel := frame.rel.dunion (f1.rel) (f2.rel)
}

theorem invariance_dunion (f1 f2 : frame) (v1 : nat → f1.states → Prop)
  (v2 : nat → f2.states → Prop) (x1 : f1.states) :
  theory_at f1 v1 x1 = theory_at (f1.dunion f2) (val_dunion v1 v2) (sum.inl x1) :=
begin
ext φ, revert x1, induction φ,
repeat {rename φ_ih_φ ih_φ},
repeat {rename φ_ih_ψ ih_ψ},
repeat {rename φ_φ φ},
repeat {rename φ_ψ ψ},
repeat {intro x1},
repeat {split},
repeat {intro h, exact h},
{intro h, split, exact (ih_φ x1).mp h.left, exact (ih_ψ x1).mp h.right},
{intro h, split, exact (ih_φ x1).mpr h.left, exact (ih_ψ x1).mpr h.right},
{intros h h1, exact (ih_ψ x1).mp (h ((ih_φ x1).mpr h1))},
{intros h h1, exact (ih_ψ x1).mpr (h ((ih_φ x1).mp h1))},
{intros h s h1, cases s, exact (φ_ih s).mp ((h s) h1), exact false.elim h1},
{intros h s h1, exact (φ_ih s).mpr ((h (sum.inl s)) h1)}
end

-- Invariance under generated submodels
def frame.gen_subframe (f : frame) (x : f.states) : frame :=
{
  states := { y // reachable (f.rel) x y},
  h := ⟨⟨x, ref_close x (f.rel)⟩⟩,
  rel := λ x1 x2, (f.rel) x1.val x2.val
}

def val_gen_subframe (f : frame) (x : f.states)
  (v : nat → f.states → Prop) : nat → (frame.gen_subframe f x).states → Prop :=
  λ n, λ y, v n y.val

theorem invariance_gen_submodel (f : frame) (v : ℕ → f.states → Prop)
  (x : f.states) (y : (frame.gen_subframe f x).states) :
  theory_at f v y.val = theory_at (f.gen_subframe x) (val_gen_subframe f x v) y :=
begin
ext φ, revert y, induction φ,
repeat {rename φ_ih_φ ih_φ},
repeat {rename φ_ih_ψ ih_ψ},
repeat {rename φ_φ φ},
repeat {rename φ_ψ ψ},
repeat {intro y},
repeat {split},
repeat {intro h1, exact h1},
{intro h1, split, exact (ih_φ y).mp h1.left, exact (ih_ψ y).mp h1.right},
{intro h1, split, exact (ih_φ y).mpr h1.left, exact (ih_ψ y).mpr h1.right},
{intros h1 h2, exact (ih_ψ y).mp (h1 ((ih_φ y).mpr h2))},
{intros h1 h2, exact (ih_ψ y).mpr (h1 ((ih_φ y).mp h2))},
{intros h1 z h2, exact (φ_ih z).mp ((h1 z.val) h2)},
{intros h1 z h2,
have h3 := reach_right x y.1 z f.rel (and.intro y.2 h2),
exact (φ_ih ⟨z, h3⟩).mpr ((h1 ⟨z, h3⟩) h2)}
end

-- Invariance under bisimulation
def base {f1 f2 : frame} (v1 : nat → f1.states → Prop)
  (v2 : nat → f2.states → Prop) (x1 : f1.states) (x2 : f2.states) :=
  ∀ n, v1 n x1 ↔ v2 n x2

def forth {f1 f2 : frame} (bisim : f1.states → f2.states → Prop)
  (x1 : f1.states) (x2 : f2.states) :=
  ∀ y1, f1.rel x1 y1 → (∃ y2 : f2.states, f2.rel x2 y2 ∧ bisim y1 y2)

def back {f1 f2 : frame} (bisim : f1.states → f2.states → Prop)
  (x1 : f1.states) (x2 : f2.states) :=
  ∀ y2, f2.rel x2 y2 → (∃ y1 : f1.states, f1.rel x1 y1 ∧ bisim y1 y2)

-- Bisimulation between M1 = (f1,v1) and M2 = (f2,v2)
def is_bisimulation {f1 f2 : frame} (v1 : nat → f1.states → Prop)
  (v2 : nat → f2.states → Prop) (bisim : f1.states → f2.states → Prop) := ∀ x1 x2,
  bisim x1 x2 → (base v1 v2 x1 x2 ∧ forth bisim x1 x2 ∧ back bisim x1 x2)

theorem invariance_bisim {f1 f2 : frame} (v1 : nat → f1.states → Prop)
  (v2 : nat → f2.states → Prop) (bisim : f1.states → f2.states → Prop)
  (h : is_bisimulation v1 v2 bisim) (x1 : f1.states) (x2 : f2.states) :
  bisim x1 x2 → theory_at f1 v1 x1 = theory_at f2 v2 x2 :=
begin
intro h1, ext φ, revert x1 x2, induction φ,
repeat {rename φ_ih_φ ih_φ},
repeat {rename φ_ih_ψ ih_ψ},
repeat {rename φ_φ φ},
repeat {rename φ_ψ ψ},
repeat {intros x1 x2 h1},
{split, repeat {intro h2, exact h2}},
{split,
intro h2, exact ((h x1 x2 h1).left φ).mp h2,
intro h2, exact ((h x1 x2 h1).left φ).mpr h2},
{split,
intro h2, split, exact (ih_φ x1 x2 h1).mp h2.left, exact (ih_ψ x1 x2 h1).mp h2.right,
intro h2, split, exact (ih_φ x1 x2 h1).mpr h2.left, exact (ih_ψ x1 x2 h1).mpr h2.right},
{split,
intros h2 h3, exact (ih_ψ x1 x2 h1).mp (h2 ((ih_φ x1 x2 h1).mpr h3)),
intros h2 h3, exact (ih_ψ x1 x2 h1).mpr (h2 ((ih_φ x1 x2 h1).mp h3))},
{cases h x1 x2 h1 with h4 h5,
cases h5 with h5 h6, split,
{intros h2 y2 h3, cases h6 y2 h3 with y1 h6,
cases h6 with h6 h7, exact (φ_ih y1 y2 h7).mp (h2 y1 h6)},
{intros h2 y1 h3, cases h5 y1 h3 with y2 h5,
cases h5 with h5 h7, exact (φ_ih y1 y2 h7).mpr (h2 y2 h5)}}
end

-- Invariance using surjective bounded morphisms
open function

def is_bddmorphism {f1 f2 : frame} (g : f1.states → f2.states) :=
  ∀ x1 : f1.states, forth (λ x1 x2, (g x1) = x2) x1 (g x1) ∧ back (λ x1 x2, (g x1) = x2) x1 (g x1)

def is_surjbddmorphism {f1 f2 : frame} (g : f1.states → f2.states)
  := surjective g ∧ is_bddmorphism g

theorem pull_back {f1 f2 : frame} (g : f1.states → f2.states) (h : is_surjbddmorphism g) :
  ∀ φ, ¬ f_valid φ f2 → ¬ f_valid φ f1 :=
begin
intros φ h1, rw f_valid at *,
push_neg at h1, push_neg,
cases h1 with v2 h1,
cases h1 with y h1,
let v1 := (λ n x, v2 n (g x)), use v1,
cases h with hl hr, cases hl y with x hl,
existsi (x : f1.states), have h3 := invariance_bisim v1 v2 (λ x y, g x = y),
have h4 : is_bisimulation v1 v2 (λ (x : f1.states) (y : f2.states), g x = y),
{intros x1 x2 h2, split,
{intro n, split, intro h, subst h2, apply h, intro h, subst h2, apply h},
split,
have h5 : forth (λ (x1 : f1.states) (x2 : f2.states), g x1 = x2) x1 x2,
from eq.subst h2 (hr x1).left, exact h5,
have h5 : back (λ (x1 : f1.states) (x2 : f2.states), g x1 = x2) x1 x2,
from eq.subst h2 (hr x1).right, exact h5},
specialize h3 h4 x y hl, intro h2, apply h1,
rw set.subset.antisymm_iff at h3, cases h3,
rw set.subset_def at h3_left,
exact h3_left φ h2
end

lemma invariance_pull_back (F : set (frame)) {f1 f2 : frame}
  (h1 : f1 ∈ F) (h2 : f2 ∉ F) :
  (∃ g : f1.states → f2.states, is_surjbddmorphism g) → undefinable F :=
begin
intro h, cases h with g h,
intro φ, by_contradiction h3,
have h4 := h3 f1, specialize h3 f2,
rw ←not_iff_not at h3,
exact (pull_back g h φ (h3.mp h2)) (h4.mp h1)
end


/-
Copyright (c) 2018 Mario Carneiro. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Mario Carneiro

! This file was ported from Lean 3 source module set_theory.ordinal.cantor_normal_form
! leanprover-community/mathlib commit f1e061e3caef3022f0daa99d670ecf2c30e0b5c6
! Please do not edit these lines, except to modify the commit id
! if you have ported upstream changes.
-/
import Mathlib.SetTheory.Ordinal.Arithmetic
import Mathlib.SetTheory.Ordinal.Exponential

/-!
# Cantor Normal Form

The Cantor normal form of an ordinal is generally defined as its base `ω` expansion, with its
non-zero exponents in decreasing order. Here, we more generally define a base `b` expansion
`Ordinal.CNF` in this manner, which is well-behaved for any `b ≥ 2`.

# Implementation notes

We implement `Ordinal.CNF` as an association list, where keys are exponents and values are
coefficients. This is because this structure intrinsically reflects two key properties of the Cantor
normal form:

- It is ordered.
- It has finitely many entries.

# Todo

- Add API for the coefficients of the Cantor normal form.
- Prove the basic results relating the CNF to the arithmetic operations on ordinals.
-/

noncomputable section

universe u

open Order

namespace Ordinal

/-- Inducts on the base `b` expansion of an ordinal. -/
@[elab_as_elim]
noncomputable def CNFRec (b : Ordinal) {C : Ordinal → Sort _} (H0 : C 0)
    (H : ∀ o, o ≠ 0 → C (o % b ^ log b o) → C o) : ∀ o, C o := fun o ↦ by
    by_cases h : o = 0
    · rw [h]; exact H0
    · exact H o h (CNFRec _ H0 H (o % b ^ log b o))
    termination_by CNFRec b H0 H o => o
    decreasing_by exact mod_opow_log_lt_self b h
set_option linter.uppercaseLean3 false in
#align ordinal.CNF_rec Ordinal.CNFRec

@[simp]
theorem CNFRec_zero {C : Ordinal → Sort _} (b : Ordinal) (H0 : C 0)
    (H : ∀ o, o ≠ 0 → C (o % b ^ log b o) → C o) : @CNFRec b C H0 H 0 = H0 := by
  rw [CNFRec, dif_pos rfl]
  rfl
set_option linter.uppercaseLean3 false in
#align ordinal.CNF_rec_zero Ordinal.CNFRec_zero

theorem CNFRec_pos (b : Ordinal) {o : Ordinal} {C : Ordinal → Sort _} (ho : o ≠ 0) (H0 : C 0)
    (H : ∀ o, o ≠ 0 → C (o % b ^ log b o) → C o) :
    @CNFRec b C H0 H o = H o ho (@CNFRec b C H0 H _) := by rw [CNFRec, dif_neg ho]
set_option linter.uppercaseLean3 false in
#align ordinal.CNF_rec_pos Ordinal.CNFRec_pos

-- Porting note: unknown attribute @[pp_nodot]
/-- The Cantor normal form of an ordinal `o` is the list of coefficients and exponents in the
base-`b` expansion of `o`.

We special-case `CNF 0 o = CNF 1 o = [(0, o)]` for `o ≠ 0`.

`CNF b (b ^ u₁ * v₁ + b ^ u₂ * v₂) = [(u₁, v₁), (u₂, v₂)]` -/
def CNF (b o : Ordinal) : List (Ordinal × Ordinal) :=
  CNFRec b [] (fun o _ho IH ↦ (log b o, o / b ^ log b o)::IH) o
set_option linter.uppercaseLean3 false in
#align ordinal.CNF Ordinal.CNF

@[simp]
theorem CNF_zero (b : Ordinal) : CNF b 0 = [] :=
  CNFRec_zero b _ _
set_option linter.uppercaseLean3 false in
#align ordinal.CNF_zero Ordinal.CNF_zero

/-- Recursive definition for the Cantor normal form. -/
theorem CNF_ne_zero {b o : Ordinal} (ho : o ≠ 0) :
    CNF b o = (log b o, o / b ^ log b o)::CNF b (o % b ^ log b o) :=
  CNFRec_pos b ho _ _
set_option linter.uppercaseLean3 false in
#align ordinal.CNF_ne_zero Ordinal.CNF_ne_zero

theorem zero_CNF {o : Ordinal} (ho : o ≠ 0) : CNF 0 o = [⟨0, o⟩] := by simp [CNF_ne_zero ho]
set_option linter.uppercaseLean3 false in
#align ordinal.zero_CNF Ordinal.zero_CNF

theorem one_CNF {o : Ordinal} (ho : o ≠ 0) : CNF 1 o = [⟨0, o⟩] := by simp [CNF_ne_zero ho]
set_option linter.uppercaseLean3 false in
#align ordinal.one_CNF Ordinal.one_CNF

theorem CNF_of_le_one {b o : Ordinal} (hb : b ≤ 1) (ho : o ≠ 0) : CNF b o = [⟨0, o⟩] := by
  rcases le_one_iff.1 hb with (rfl | rfl)
  · exact zero_CNF ho
  · exact one_CNF ho
set_option linter.uppercaseLean3 false in
#align ordinal.CNF_of_le_one Ordinal.CNF_of_le_one

theorem CNF_of_lt {b o : Ordinal} (ho : o ≠ 0) (hb : o < b) : CNF b o = [⟨0, o⟩] := by
  simp only [CNF_ne_zero ho, log_eq_zero hb, opow_zero, div_one, mod_one, CNF_zero]
set_option linter.uppercaseLean3 false in
#align ordinal.CNF_of_lt Ordinal.CNF_of_lt

/-- Evaluating the Cantor normal form of an ordinal returns the ordinal. -/
theorem CNF_foldr (b o : Ordinal) : (CNF b o).foldr (fun p r ↦ b ^ p.1 * p.2 + r) 0 = o :=
  CNFRec b (by rw [CNF_zero]; rfl)
    (fun o ho IH ↦ by rw [CNF_ne_zero ho, List.foldr_cons, IH, div_add_mod]) o
set_option linter.uppercaseLean3 false in
#align ordinal.CNF_foldr Ordinal.CNF_foldr

/-- Every exponent in the Cantor normal form `CNF b o` is less or equal to `log b o`. -/
theorem CNF_fst_le_log {b o : Ordinal.{u}} {x : Ordinal × Ordinal} : x ∈ CNF b o → x.1 ≤ log b o :=
  by
  refine' CNFRec b _ (fun o ho H ↦ _) o
  · rw [CNF_zero]
    intro contra; contradiction
  · rw [CNF_ne_zero ho, List.mem_cons]
    rintro (rfl | h)
    · exact le_rfl
    · exact (H h).trans (log_mono_right _ (mod_opow_log_lt_self b ho).le)
set_option linter.uppercaseLean3 false in
#align ordinal.CNF_fst_le_log Ordinal.CNF_fst_le_log

/-- Every exponent in the Cantor normal form `CNF b o` is less or equal to `o`. -/
theorem CNF_fst_le {b o : Ordinal.{u}} {x : Ordinal × Ordinal} (h : x ∈ CNF b o) : x.1 ≤ o :=
  (CNF_fst_le_log h).trans <| log_le_self _ _
set_option linter.uppercaseLean3 false in
#align ordinal.CNF_fst_le Ordinal.CNF_fst_le

/-- Every coefficient in a Cantor normal form is positive. -/
theorem CNF_lt_snd {b o : Ordinal.{u}} {x : Ordinal × Ordinal} : x ∈ CNF b o → 0 < x.2 := by
  refine' CNFRec b _ (fun o ho IH ↦ _) o
  · simp only [CNF_zero, List.not_mem_nil, IsEmpty.forall_iff]
  · rcases eq_zero_or_pos b with (rfl | hb)
    · rw [zero_CNF ho, List.mem_singleton]
      rintro rfl
      exact Ordinal.pos_iff_ne_zero.2 ho
    · rw [CNF_ne_zero ho]
      intro h
      cases' (List.mem_cons.mp h) with h h
      · rw [h]; rw [div_pos]
        · exact opow_log_le_self _ ho
        · exact (opow_pos _ hb).ne'
      · exact IH h
set_option linter.uppercaseLean3 false in
#align ordinal.CNF_lt_snd Ordinal.CNF_lt_snd

/-- Every coefficient in the Cantor normal form `CNF b o` is less than `b`. -/
theorem CNF_snd_lt {b o : Ordinal.{u}} (hb : 1 < b) {x : Ordinal × Ordinal} :
    x ∈ CNF b o → x.2 < b := by
  refine' CNFRec b _ (fun o ho IH ↦ _) o
  · simp only [CNF_zero, List.not_mem_nil, IsEmpty.forall_iff]
  · rw [CNF_ne_zero ho]
    intro h
    cases' (List.mem_cons.mp h) with h h
    · rw [h]; simpa only using div_opow_log_lt o hb
    · exact IH h
set_option linter.uppercaseLean3 false in
#align ordinal.CNF_snd_lt Ordinal.CNF_snd_lt

/-- The exponents of the Cantor normal form are decreasing. -/
theorem CNF_sorted (b o : Ordinal) : ((CNF b o).map Prod.fst).Sorted (· > ·) := by
  refine' CNFRec b _ (fun o ho IH ↦ _) o
  · simp only [CNF_zero]
  · cases' le_or_lt b 1 with hb hb
    · simp only [CNF_of_le_one hb ho, List.map]
    · cases' lt_or_le o b with hob hbo
      · simp only [CNF_of_lt ho hob, List.map]
      · rw [CNF_ne_zero ho, List.map_cons, List.sorted_cons]
        refine' ⟨fun a H ↦ _, IH⟩
        rw [List.mem_map] at H
        rcases H with ⟨⟨a, a'⟩, H, rfl⟩
        exact (CNF_fst_le_log H).trans_lt (log_mod_opow_log_lt_log_self hb ho hbo)
set_option linter.uppercaseLean3 false in
#align ordinal.CNF_sorted Ordinal.CNF_sorted

end Ordinal


/-
Copyright (c) 2021 Oliver Nash. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Oliver Nash
-/
import linear_algebra.affine_space.affine_map
import topology.continuous_function.basic
import topology.algebra.module

/-!
# Continuous affine maps.

This file defines a type of bundled continuous affine maps.

Note that the definition and basic properties established here require minimal assumptions, and do
not even assume compatibility between the topological and algebraic structures. Of course it is
necessary to assume some compatibility in order to obtain a useful theory. Such a theory is
developed elsewhere for affine spaces modelled on _normed_ vector spaces, but not yet for general
topological affine spaces (since we have not defined these yet).

## Main definitions:

 * `continuous_affine_map`

## Notation:

We introduce the notation `P →A[R] Q` for `continuous_affine_map R P Q`. Note that this is parallel
to the notation `E →L[R] F` for `continuous_linear_map R E F`.
-/

/-- A continuous map of affine spaces. -/
structure continuous_affine_map (R : Type*) {V W : Type*} (P Q : Type*) [ring R]
  [add_comm_group V] [module R V] [topological_space P] [add_torsor V P]
  [add_comm_group W] [module R W] [topological_space Q] [add_torsor W Q]
  extends P →ᵃ[R] Q :=
(cont : continuous to_fun)

notation P ` →A[`:25 R `] ` Q := continuous_affine_map R P Q

namespace continuous_affine_map

variables {R V W P Q : Type*} [ring R]
variables [add_comm_group V] [module R V] [topological_space P] [add_torsor V P]
variables [add_comm_group W] [module R W] [topological_space Q] [add_torsor W Q]

include V W

/-- see Note [function coercion] -/
instance : has_coe_to_fun (P →A[R] Q) (λ _, P → Q) := ⟨λ f, f.to_affine_map.to_fun⟩

lemma to_fun_eq_coe (f : P →A[R] Q) : f.to_fun = ⇑f := rfl

lemma coe_injective :
  @function.injective (P →A[R] Q) (P → Q) coe_fn :=
begin
  rintros ⟨⟨f, ⟨f', hf₁, hf₂⟩, hf₀⟩, hf₁⟩ ⟨⟨g, ⟨g', hg₁, hg₂⟩, hg₀⟩, hg₁⟩ h,
  have : f = g ∧ f' = g', { simpa only using affine_map.coe_fn_injective h, },
  congr,
  exacts [this.1, this.2],
end

@[ext] lemma ext {f g : P →A[R] Q} (h : ∀ x, f x = g x) : f = g :=
coe_injective $ funext h

lemma ext_iff {f g : P →A[R] Q} : f = g ↔ ∀ x, f x = g x :=
⟨by { rintro rfl x, refl, }, ext⟩

lemma congr_fun {f g : P →A[R] Q} (h : f = g) (x : P) : f x = g x := h ▸ rfl

instance : has_coe (P →A[R] Q) (P →ᵃ[R] Q) :=
⟨to_affine_map⟩

/-- Forgetting its algebraic properties, a continuous affine map is a continuous map. -/
def to_continuous_map (f : P →A[R] Q) : C(P, Q) :=
⟨f, f.cont⟩

instance : has_coe (P →A[R] Q) (C(P, Q)) :=
⟨to_continuous_map⟩

@[simp] lemma to_affine_map_eq_coe (f : P →A[R] Q) :
  f.to_affine_map = ↑f :=
rfl

@[simp] lemma to_continuous_map_coe (f : P →A[R] Q) : f.to_continuous_map = ↑f :=
rfl

@[simp, norm_cast]

@[simp, norm_cast] lemma coe_to_continuous_map (f : P →A[R] Q) :
  ((f : C(P, Q)) : P → Q) = f :=
rfl

lemma to_affine_map_injective {f g : P →A[R] Q}
  (h : (f : P →ᵃ[R] Q) = (g : P →ᵃ[R] Q)) : f = g :=
by { ext a, exact affine_map.congr_fun h a, }

lemma to_continuous_map_injective {f g : P →A[R] Q}
  (h : (f : C(P, Q)) = (g : C(P, Q))) : f = g :=
by { ext a, exact continuous_map.congr_fun h a, }

@[norm_cast] lemma coe_affine_map_mk (f : P →ᵃ[R] Q) (h) :
  ((⟨f, h⟩ : P →A[R] Q) : P →ᵃ[R] Q) = f :=
rfl

@[norm_cast] lemma coe_continuous_map_mk (f : P →ᵃ[R] Q) (h) :
  ((⟨f, h⟩ : P →A[R] Q) : C(P, Q)) = ⟨f, h⟩ :=
rfl

@[simp] lemma coe_mk (f : P →ᵃ[R] Q) (h) :
  ((⟨f, h⟩ : P →A[R] Q) : P → Q) = f :=
rfl

@[simp] lemma mk_coe (f : P →A[R] Q) (h) :
  (⟨(f : P →ᵃ[R] Q), h⟩ : P →A[R] Q) = f :=
by { ext, refl, }

@[continuity]
protected lemma continuous (f : P →A[R] Q) : continuous f := f.2

variables (R P)

/-- The constant map is a continuous affine map. -/
def const (q : Q) : P →A[R] Q :=
{ to_fun := affine_map.const R P q,
  cont   := continuous_const,
  .. affine_map.const R P q, }

@[simp] lemma coe_const (q : Q) : (const R P q : P → Q) = function.const P q := rfl

noncomputable instance : inhabited (P →A[R] Q) :=
⟨const R P $ nonempty.some (by apply_instance : nonempty Q)⟩

variables {R P} {W₂ Q₂ : Type*}
variables [add_comm_group W₂] [module R W₂] [topological_space Q₂] [add_torsor W₂ Q₂]

include W₂

/-- The composition of morphisms is a morphism. -/
def comp (f : Q →A[R] Q₂) (g : P →A[R] Q) : P →A[R] Q₂ :=
{ cont := f.cont.comp g.cont,
  .. (f : Q →ᵃ[R] Q₂).comp (g : P →ᵃ[R] Q), }

@[simp, norm_cast] lemma coe_comp (f : Q →A[R] Q₂) (g : P →A[R] Q) :
  (f.comp g : P → Q₂) = (f : Q → Q₂) ∘ (g : P → Q) :=
rfl

lemma comp_apply (f : Q →A[R] Q₂) (g : P →A[R] Q) (x : P) :
  f.comp g x = f (g x) :=
rfl

omit W₂

section module_valued_maps

variables {S : Type*} [comm_ring S] [module S V] [module S W]
variables [topological_space W] [topological_space S] [has_continuous_smul S W]

instance : has_zero (P →A[R] W) := ⟨continuous_affine_map.const R P 0⟩

@[norm_cast, simp] lemma coe_zero : ((0 : P →A[R] W) : P → W) = 0 := rfl

lemma zero_apply (x : P) : (0 : P →A[R] W) x = 0 := rfl

instance : has_scalar S (P →A[S] W) :=
{ smul := λ t f, { cont := f.continuous.const_smul t, .. (t • (f : P →ᵃ[S] W)) } }

@[norm_cast, simp] lemma coe_smul (t : S) (f : P →A[S] W) : ⇑(t • f) = t • f := rfl

lemma smul_apply (t : S) (f : P →A[S] W) (x : P) : (t • f) x = t • (f x) := rfl

variables [topological_add_group W]

instance : has_add (P →A[R] W) :=
{ add := λ f g, { cont := f.continuous.add g.continuous, .. ((f : P →ᵃ[R] W) + (g : P →ᵃ[R] W)) }, }

@[norm_cast, simp] lemma coe_add (f g : P →A[R] W) : ⇑(f + g) = f + g := rfl

lemma add_apply (f g : P →A[R] W) (x : P) : (f + g) x = f x + g x := rfl

instance : has_sub (P →A[R] W) :=
{ sub := λ f g, { cont := f.continuous.sub g.continuous, .. ((f : P →ᵃ[R] W) - (g : P →ᵃ[R] W)) }, }

@[norm_cast, simp] lemma coe_sub (f g : P →A[R] W) : ⇑(f - g) = f - g := rfl

lemma sub_apply (f g : P →A[R] W) (x : P) : (f - g) x = f x - g x := rfl

instance : has_neg (P →A[R] W) :=
{ neg := λ f, { cont := f.continuous.neg, .. (-(f : P →ᵃ[R] W)) }, }

@[norm_cast, simp] lemma coe_neg (f : P →A[R] W) : ⇑(-f) = -f := rfl

lemma neg_apply (f : P →A[R] W) (x : P) : (-f) x = -(f x) := rfl

instance : add_comm_group (P →A[R] W) :=
{ add := (+),
  zero := 0,
  neg := has_neg.neg,
  sub := has_sub.sub,
  .. (coe_injective.add_comm_group _ coe_zero coe_add coe_neg coe_sub :
    add_comm_group (P →A[R] W)) }

instance : module S (P →A[S] W) :=
function.injective.module S ⟨λ f, f.to_affine_map.to_fun, rfl, coe_add⟩ coe_injective coe_smul

end module_valued_maps

end continuous_affine_map

namespace continuous_linear_map

variables {R V W : Type*} [ring R]
variables [add_comm_group V] [module R V] [topological_space V]
variables [add_comm_group W] [module R W] [topological_space W]

/-- A continuous linear map can be regarded as a continuous affine map. -/
def to_continuous_affine_map (f : V →L[R] W) : V →A[R] W :=
{ to_fun    := f,
  linear    := f,
  map_vadd' := by simp,
  cont      := f.cont, }

@[simp] lemma coe_to_continuous_affine_map (f : V →L[R] W) :
  ⇑f.to_continuous_affine_map = f :=
rfl

@[simp] lemma to_continuous_affine_map_map_zero (f : V →L[R] W) :
  f.to_continuous_affine_map 0 = 0 :=
by simp

end continuous_linear_map


import Mathlib
/-!
## Foundations

We have seen all the ingredients of the foundations of mathematics as implemented in Lean. Our goal now is to:

* Systematically review them.
* Put them in the context of what we mean by foundations of mathematics.
* Separate the foundations from the syntax parsing and elaboration which help us work efficiently with Lean.

### Foundations of foundations

The starting assumption is that we are in agreement with the meaning of syntax, including pattern matching and substitution. For example, we can understand the following definition is valid in Lean, assuming we know what `ℕ` means:

```lean
def cube : ℕ → ℕ := fun n → n * n * n
```

and that we can deduce from the above that `cube 3 = 3 * 3 * 3`.

We have __rules__ for foundations based on syntax. We also assume that the rules can be checked _mechanically_, i.e., by a computer program, and we are convinced that some such program is correct. For a flexible syntax, this is a non-trivial task. So we may want to restrict to a simpler syntax (as we will when we consider _classical foundations_).

We have to also check that we correctly represent the corresponding "real world" concept.

### Context, Rules, Terms

We assume that at any point we have a __Context__. In Lean this means that we have terms that we can refer to by name, and that these terms have a type, though this may be an _expression_.

In any context, we have __Rules__ to

* form _expressions_ from _terms_ and _expressions_, with a well-formed expression representing a term.
* make two kinds of __judgments__:
  * `e : t` means that `e` is an expression of type `t`.
  * `e = e'` means that `e` and `e'` are equal expressions.

### Generative grammars

Expressions and Rules are based on a _generative_ grammar. Thus, we do not specify whether an expression or judgement is valid or not. Instead, we specify how we can make well-formed expressions and valid judgements.

### Local Contexts

In addition to the names in the context, we can have some names that are only valid in a particular expression. These are called __local variables__.

### Initial Context

Even an empty Lean file does not have an empty context. Instead the context has [Foundational Types](http://math.iisc.ac.in/~gadgil/proofs-and-programs-2023/doc/foundational_types.html).

### Axioms

We can add axioms to the context. This means that we introduce a term and give an expression for its type. This should be done with care so that the context does not become inconsistent.

### Rules for Lean

The rules for Lean let us introduce expressions and at the same time make judgements about them.

* Function types
* Function application
* Function definitions by λ-abstraction.
* Π-types
* Dependent function definition and application
* Inductive types
* Indexed inductive types

### Propositions as Types

Remarkably, the same set of rules let us encode both objects of mathematics and statements about them. The statements (called __propositions__) are encoded as types with a proof of the proposition being a term of that type.

Logical connectives are encoded as _function types_, _Π-types_, and _inductive types_. The rules for deduction follow from the rules for Lean.

In Lean, there is an additional rule for a proposition `α : Prop`, namely if `p : α` and `q : α` then `p = q`.
-/

-- already in the context
#check ℕ -- ℕ : Type
#check Nat.succ -- Nat.succ : ℕ → ℕ

/-!
We use various rules:
* Given types `α` and `β`, we can form the type of functions from `α` to `β`, written `α → β`.
* We can form a function application `f x` from a function `f` and an argument `x`.
* We can form a function definition `fun x ↦ e` from a variable `x` and an expression `e`, where `e` is defined in the local context with the additional expression `x`.
* When defining a function using `x ↦ e`, we also introduce a rule that the function applied to `a` is the result of substituting `a` for `x` in `e`.
* In the definition below, types should match.
* Often Lean can infer some of the types.
-/

/-- Adding `2` to a natural number.
-/
def addTwo -- adding a term named `add_two`
    : ℕ → ℕ -- specified the type
      := -- specified the value
        fun (n : ℕ) ↦ -- started a λ-expression
            -- now `n : ℕ` is in the local context
            Nat.succ -- applying the function `Nat.succ` (from the context)
              (Nat.succ -- again, applying the function  `Nat.succ`
                -- `n` is in the local context
                n) -- the body of the function

/-!
A `theorem` is just like a definition, except

* The type must be a proposition, i.e. the type of the type must be `Prop`.
* The type must be fully inferred from the left-hand side.
* The value is then a proof of the proposition.
-/

/-- one plus two is three -/
theorem one_addTwo : addTwo 1 = 3 := rfl

-- the lhs does involve some type inference
set_option pp.all true in
#reduce 1 = 3 -- @Eq.{1} Nat 1 3

/-!

## Π-types

These can be viewed as:

* products of a family of types indexed by a type.
* a type corresponding to functions whose codomain _depends_ on the argument.
* these are sections of a bundle.

We consider an example
-/

def NatTuple: ℕ → Type
| 0 => Unit
| n + 1 => ℕ × (NatTuple n)

/-!
We define a dependent function associating to a natural number `n` the tuple of `n` natural numbers `(n, n-1, ..., 0)`.

* this has type `(n: ℕ) → NatTuple (n + 1)`.
-/

def descending : (n: ℕ) → NatTuple (n + 1) -- := fun n ↦
-- match n with
| 0 => (0, ())
| n + 1 => (n + 1, descending n)

#eval descending 3 -- (3, 2, 1, 0, ())

#check descending 3 -- NatTuple (3 + 1)

#eval descending 13 -- (13, 12, 11, 10, 9, 8, 7, 6, 5, 4, 3, 2, 1, 0, ())
#check descending 13 -- NatTuple (13 + 1)

#check () -- Unit

#check (() : NatTuple 0) -- Unit


namespace subtype

--- `subtype.val` is injective
lemma val_injective {α : Type _} {p : α → Prop} : function.injective (@subtype.val α p) :=
  @subtype.eq α p

--- Relax the restriction on subtypes.
definition relax {α : Sort _} {p q : α → Prop} (f : ∀ a, p a → q a) : subtype p → subtype q :=
  λ x, subtype.cases_on x (λ a h, ⟨a, f a h⟩)

protected
definition inl {α : Sort _} {p q : α → Prop} : subtype p → subtype (λ a, p a ∨ q a) := relax (λ _, or.inl)

protected
definition inr {α : Sort _} {p q : α → Prop} : subtype q → subtype (λ a, p a ∨ q a) := relax (λ _, or.inr)

--- `relax` doesn't change the value.
lemma val_relax {α : Sort _} {p q : α → Prop} {f : ∀ a, p a → q a} : ∀ (x : subtype p), (x.relax f).val = x.val :=
  by intros x; cases x; refl

--- `inl` doesn't change the value.
lemma val_inl {α : Sort _} {p q : α → Prop} : ∀ (x : subtype p), (@subtype.inl _ p q x).val = x.val := λ x, by cases x; refl

--- `inr` doesn't change the value.
lemma val_inr {α : Sort _} {p q : α → Prop} : ∀ (x : subtype q), (@subtype.inr _ p q x).val = x.val := λ x, by cases x; refl

--- `relax` is injective function
lemma relax_inj {α : Type _} {p q : α → Prop} {f : ∀ a, p a → q a} : function.injective (relax f) :=
  begin
    intros x y,
    cases x; cases y; dunfold relax,
    dsimp *,
    exact subtype.eq ∘ congr_arg subtype.val
  end

--- Mapping into subtype yields a mapping into the underlying codomain all whose values belong to the subtype.
definition codomain {α β : Sort _} {p : β → Prop} (f : α → {b // p b}) : {f : α → β // ∀ a, p (f a)} :=
  ⟨subtype.val∘ f, λ a, (f a).property⟩

--- If all the values of a mapping satisfy a predicator `p` on the codomain, it factors through the subtype defined by `p`.
definition factor_through {α β : Sort _} (f : α → β) (p : β → Prop) (h : ∀ a, p (f a)) : α → {b // p b} :=
  λ a, ⟨f a, h a⟩

theorem codomain_of_factor_through {α β : Sort _} (f : α → β) (p : β → Prop) (h : ∀ a, p (f a)) : ∀ a, (codomain (factor_through f p h)).val a = f a :=
  λ a, rfl

theorem factor_through_of_codomain {α : Sort _} {β : Type _} {p : β → Prop} (f : α → {b // p b}) : ∀ a, (factor_through (codomain f).val p (codomain f).property) a = f a :=
  begin
    intros,
    dsimp [codomain,function.comp,subtype.val],
    dunfold factor_through,
    exact subtype.eta (f a) _,
  end

end subtype