/-
Copyright (c) 2022 Thomas Browning. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Thomas Browning
-/

import data.finset.pointwise
import group_theory.complement
import group_theory.finiteness
import group_theory.index
import tactic.group

/-!
# Schreier's Lemma

In this file we prove Schreier's lemma.

## Main results

- `closure_mul_image_eq` : **Schreier's Lemma**: If `R : set G` is a right_transversal
  of `H : subgroup G` with `1 ∈ R`, and if `G` is generated by `S : set G`,
  then `H` is generated by the `set` `(R * S).image (λ g, g * (to_fun hR g)⁻¹)`.
- `fg_of_index_ne_zero` : **Schreier's Lemma**: A finite index subgroup of a finitely generated
  group is finitely generated.
-/

open_locale pointwise

namespace subgroup

open mem_right_transversals

variables {G : Type*} [group G] {H : subgroup G} {R S : set G}

lemma closure_mul_image_mul_eq_top
  (hR : R ∈ right_transversals (H : set G)) (hR1 : (1 : G) ∈ R) (hS : closure S = ⊤) :
  (closure ((R * S).image (λ g, g * (to_fun hR g)⁻¹)) : set G) * R = ⊤ :=
begin
  let f : G → R := λ g, to_fun hR g,
  let U : set G := (R * S).image (λ g, g * (f g)⁻¹),
  change (closure U : set G) * R = ⊤,
  refine top_le_iff.mp (λ g hg, _),
  apply closure_induction_right (eq_top_iff.mp hS (mem_top g)),
  { exact ⟨1, 1, (closure U).one_mem, hR1, one_mul 1⟩ },
  { rintros - s hs ⟨u, r, hu, hr, rfl⟩,
    rw show u * r * s = u * ((r * s) * (f (r * s))⁻¹) * f (r * s), by group,
    refine set.mul_mem_mul ((closure U).mul_mem hu _) (f (r * s)).coe_prop,
    exact subset_closure ⟨r * s, set.mul_mem_mul hr hs, rfl⟩ },
  { rintros - s hs ⟨u, r, hu, hr, rfl⟩,
    rw show u * r * s⁻¹ = u * (f (r * s⁻¹) * s * r⁻¹)⁻¹ * f (r * s⁻¹), by group,
    refine set.mul_mem_mul ((closure U).mul_mem hu ((closure U).inv_mem _)) (f (r * s⁻¹)).2,
    refine subset_closure ⟨f (r * s⁻¹) * s, set.mul_mem_mul (f (r * s⁻¹)).2 hs, _⟩,
    rw [mul_right_inj, inv_inj, ←subtype.coe_mk r hr, ←subtype.ext_iff, subtype.coe_mk],
    apply (mem_right_transversals_iff_exists_unique_mul_inv_mem.mp hR (f (r * s⁻¹) * s)).unique
      (mul_inv_to_fun_mem hR (f (r * s⁻¹) * s)),
    rw [mul_assoc, ←inv_inv s, ←mul_inv_rev, inv_inv],
    exact to_fun_mul_inv_mem hR (r * s⁻¹) },
end

/-- **Schreier's Lemma**: If `R : set G` is a right_transversal of `H : subgroup G`
  with `1 ∈ R`, and if `G` is generated by `S : set G`, then `H` is generated by the `set`
  `(R * S).image (λ g, g * (to_fun hR g)⁻¹)`. -/
lemma closure_mul_image_eq
  (hR : R ∈ right_transversals (H : set G)) (hR1 : (1 : G) ∈ R) (hS : closure S = ⊤) :
  closure ((R * S).image (λ g, g * (to_fun hR g)⁻¹)) = H :=
begin
  have hU : closure ((R * S).image (λ g, g * (to_fun hR g)⁻¹)) ≤ H,
  { rw closure_le,
    rintros - ⟨g, -, rfl⟩,
    exact mul_inv_to_fun_mem hR g },
  refine le_antisymm hU (λ h hh, _),
  obtain ⟨g, r, hg, hr, rfl⟩ :=
  show h ∈ _, from eq_top_iff.mp (closure_mul_image_mul_eq_top hR hR1 hS) (mem_top h),
  suffices : (⟨r, hr⟩ : R) = (⟨1, hR1⟩ : R),
  { rwa [show r = 1, from subtype.ext_iff.mp this, mul_one] },
  apply (mem_right_transversals_iff_exists_unique_mul_inv_mem.mp hR r).unique,
  { rw [subtype.coe_mk, mul_inv_self],
    exact H.one_mem },
  { rw [subtype.coe_mk, inv_one, mul_one],
    exact (H.mul_mem_cancel_left (hU hg)).mp hh },
end

/-- **Schreier's Lemma**: If `R : set G` is a right_transversal of `H : subgroup G`
  with `1 ∈ R`, and if `G` is generated by `S : set G`, then `H` is generated by the `set`
  `(R * S).image (λ g, g * (to_fun hR g)⁻¹)`. -/
lemma closure_mul_image_eq_top
  (hR : R ∈ right_transversals (H : set G)) (hR1 : (1 : G) ∈ R) (hS : closure S = ⊤) :
  closure ((R * S).image (λ g, ⟨g * (to_fun hR g)⁻¹, mul_inv_to_fun_mem hR g⟩) : set H) = ⊤ :=
begin
  rw [eq_top_iff, ←map_subtype_le_map_subtype, monoid_hom.map_closure, set.image_image],
  exact (map_subtype_le ⊤).trans (ge_of_eq (closure_mul_image_eq hR hR1 hS)),
end

/-- **Schreier's Lemma**: If `R : finset G` is a right_transversal of `H : subgroup G`
  with `1 ∈ R`, and if `G` is generated by `S : finset G`, then `H` is generated by the `finset`
  `(R * S).image (λ g, g * (to_fun hR g)⁻¹)`. -/
lemma closure_mul_image_eq_top' [decidable_eq G] {R S : finset G}
  (hR : (R : set G) ∈ right_transversals (H : set G)) (hR1 : (1 : G) ∈ R)
  (hS : closure (S : set G) = ⊤) :
  closure ((((R * S).image (λ g, ⟨_, mul_inv_to_fun_mem hR g⟩)) : finset H) : set H) = ⊤ :=
begin
  rw [finset.coe_image, finset.coe_mul],
  exact closure_mul_image_eq_top hR hR1 hS,
end

lemma exists_finset_card_le_mul (hH : H.index ≠ 0) {S : finset G} (hS : closure (S : set G) = ⊤) :
  ∃ T : finset H, T.card ≤ H.index * S.card ∧ closure (T : set H) = ⊤ :=
begin
  haveI : decidable_eq G := classical.dec_eq G,
  obtain ⟨R₀, hR : R₀ ∈ right_transversals (H : set G), hR1⟩ := exists_right_transversal (1 : G),
  haveI : fintype (G ⧸ H) := fintype_of_index_ne_zero hH,
  haveI : fintype R₀ := fintype.of_equiv _ (mem_right_transversals.to_equiv hR),
  let R : finset G := set.to_finset R₀,
  replace hR : (R : set G) ∈ right_transversals (H : set G) := by rwa set.coe_to_finset,
  replace hR1 : (1 : G) ∈ R := by rwa set.mem_to_finset,
  refine ⟨_, _, closure_mul_image_eq_top' hR hR1 hS⟩,
  calc _ ≤ (R * S).card : finset.card_image_le
  ... ≤ (R.product S).card : finset.card_image_le
  ... = R.card * S.card : R.card_product S
  ... = H.index * S.card : congr_arg (* S.card) _,
  calc R.card = fintype.card R : (fintype.card_coe R).symm
  ... = _ : (fintype.card_congr (mem_right_transversals.to_equiv hR)).symm
  ... = fintype.card (G ⧸ H) : quotient_group.card_quotient_right_rel H
  ... = H.index : H.index_eq_card.symm,
end

/-- **Schreier's Lemma**: A finite index subgroup of a finitely generated
  group is finitely generated. -/
lemma fg_of_index_ne_zero [hG : group.fg G] (hH : H.index ≠ 0) : group.fg H :=
begin
  obtain ⟨S, hS⟩ := hG.1,
  obtain ⟨T, -, hT⟩ := exists_finset_card_le_mul hH hS,
  exact ⟨⟨T, hT⟩⟩,
end

lemma rank_le_index_mul_rank [hG : group.fg G] {H : subgroup G} (hH : H.index ≠ 0)
  [decidable_pred (λ n, ∃ (S : finset G), S.card = n ∧ subgroup.closure (S : set G) = ⊤)]
  [decidable_pred (λ n, ∃ (S : finset H), S.card = n ∧ subgroup.closure (S : set H) = ⊤)] :
  @group.rank H _ (fg_of_index_ne_zero hH) _ ≤ H.index * group.rank G :=
begin
  haveI := fg_of_index_ne_zero hH,
  obtain ⟨S, hS₀, hS⟩ := group.rank_spec G,
  obtain ⟨T, hT₀, hT⟩ := exists_finset_card_le_mul hH hS,
  calc group.rank H ≤ T.card : group.rank_le H hT
  ... ≤ H.index * S.card : hT₀
  ... = H.index * group.rank G : congr_arg ((*) H.index) hS₀,
end

end subgroup


/-
Copyright (c) 2017 Scott Morrison. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Tim Baumann, Stephen Morgan, Scott Morrison

Defines natural transformations between functors.

Introduces notations
  `F ⟹ G` for the type of natural transformations between functors `F` and `G`,
  `τ.app X` for the components of natural transformations,
  `σ ⊟ τ` for vertical compositions, and
  `σ ◫ τ` for horizontal compositions.
-/

import category_theory.functor

namespace category_theory

universes v₁ v₂ v₃ v₄ u₁ u₂ u₃ u₄ -- declare the `v`'s first; see `category_theory.category` for an explanation

variables {C : Type u₁} [𝒞 : category.{v₁} C] {D : Type u₂} [𝒟 : category.{v₂} D]
include 𝒞 𝒟

/--
`nat_trans F G` represents a natural transformation between functors `F` and `G`.

The field `app` provides the components of the natural transformation.

Naturality is expressed by `α.naturality_lemma`.
-/
structure nat_trans (F G : C ⥤ D) : Type (max u₁ v₂) :=
(app : Π X : C, (F.obj X) ⟶ (G.obj X))
(naturality' : ∀ {X Y : C} (f : X ⟶ Y), (F.map f) ≫ (app Y) = (app X) ≫ (G.map f) . obviously)

infixr ` ⟹ `:50  := nat_trans             -- type as \==> or ⟹

restate_axiom nat_trans.naturality'

namespace nat_trans

/-- `nat_trans.id F` is the identity natural transformation on a functor `F`. -/
protected def id (F : C ⥤ D) : F ⟹ F :=
{ app := λ X, 𝟙 (F.obj X) }

@[simp] lemma id_app (F : C ⥤ D) (X : C) : (nat_trans.id F).app X = 𝟙 (F.obj X) := rfl

open category
open category_theory.functor

section
variables {F G H I : C ⥤ D}

-- We'll want to be able to prove that two natural transformations are equal if they are componentwise equal.
@[extensionality] lemma ext (α β : F ⟹ G) (w : ∀ X : C, α.app X = β.app X) : α = β :=
begin
  induction α with α_components α_naturality,
  induction β with β_components β_naturality,
  have hc : α_components = β_components := funext w,
  subst hc
end

lemma congr_app {α β : F ⟹ G} (h : α = β) (X : C) : α.app X = β.app X := by rw h

/-- `vcomp α β` is the vertical compositions of natural transformations. -/
def vcomp (α : F ⟹ G) (β : G ⟹ H) : F ⟹ H :=
{ app         := λ X, (α.app X) ≫ (β.app X),
  naturality' := begin /- `obviously'` says: -/ intros, simp, rw [←assoc, naturality, assoc, ←naturality], end }

infixr ` ⊟ `:80 := vcomp

@[simp] lemma vcomp_app (α : F ⟹ G) (β : G ⟹ H) (X : C) : (α ⊟ β).app X = (α.app X) ≫ (β.app X) := rfl
@[simp] lemma vcomp_assoc (α : F ⟹ G) (β : G ⟹ H) (γ : H ⟹ I) : (α ⊟ β) ⊟ γ = α ⊟ (β ⊟ γ) := by tidy
end

variables {E : Type u₃} [ℰ : category.{v₃} E]
include ℰ

/-- `hcomp α β` is the horizontal composition of natural transformations. -/
def hcomp {F G : C ⥤ D} {H I : D ⥤ E} (α : F ⟹ G) (β : H ⟹ I) : (F ⋙ H) ⟹ (G ⋙ I) :=
{ app         := λ X : C, (β.app (F.obj X)) ≫ (I.map (α.app X)),
  naturality' := begin
                   /- `obviously'` says: -/
                   intros,
                   dsimp,
                   simp,
                   -- Actually, obviously doesn't use exactly this sequence of rewrites, but achieves the same result
                   rw [← assoc, naturality, assoc],
                   conv { to_rhs, rw [← map_comp, ← α.naturality, map_comp] }
                 end }

infix ` ◫ `:80 := hcomp

@[simp] lemma hcomp_app {F G : C ⥤ D} {H I : D ⥤ E} (α : F ⟹ G) (β : H ⟹ I) (X : C) :
  (α ◫ β).app X = (β.app (F.obj X)) ≫ (I.map (α.app X)) := rfl

-- Note that we don't yet prove a `hcomp_assoc` lemma here: even stating it is painful, because we need to use associativity of functor composition

lemma exchange {F G H : C ⥤ D} {I J K : D ⥤ E} (α : F ⟹ G) (β : G ⟹ H) (γ : I ⟹ J) (δ : J ⟹ K) :
  ((α ⊟ β) ◫ (γ ⊟ δ)) = ((α ◫ γ) ⊟ (β ◫ δ)) :=
begin
  -- `obviously'` says:
  ext,
  intros,
  dsimp,
  simp,
  -- again, this isn't actually what obviously says, but it achieves the same effect.
  conv { to_lhs, congr, skip, rw [←assoc, ←naturality, assoc] }
end

end nat_trans

end category_theory


/-
Copyright (c) 2021 Aaron Anderson. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Aaron Anderson

! This file was ported from Lean 3 source module model_theory.substructures
! leanprover-community/mathlib commit 0602c59878ff3d5f71dea69c2d32ccf2e93e5398
! Please do not edit these lines, except to modify the commit id
! if you have ported upstream changes.
-/
import Mathbin.Order.Closure
import Mathbin.ModelTheory.Semantics
import Mathbin.ModelTheory.Encoding

/-!
# First-Order Substructures
This file defines substructures of first-order structures in a similar manner to the various
substructures appearing in the algebra library.

## Main Definitions
* A `first_order.language.substructure` is defined so that `L.substructure M` is the type of all
substructures of the `L`-structure `M`.
* `first_order.language.substructure.closure` is defined so that if `s : set M`, `closure L s` is
the least substructure of `M` containing `s`.
* `first_order.language.substructure.comap` is defined so that `s.comap f` is the preimage of the
substructure `s` under the homomorphism `f`, as a substructure.
* `first_order.language.substructure.map` is defined so that `s.map f` is the image of the
substructure `s` under the homomorphism `f`, as a substructure.
* `first_order.language.hom.range` is defined so that `f.map` is the range of the
the homomorphism `f`, as a substructure.
* `first_order.language.hom.dom_restrict` and `first_order.language.hom.cod_restrict` restrict
the domain and codomain respectively of first-order homomorphisms to substructures.
* `first_order.language.embedding.dom_restrict` and `first_order.language.embedding.cod_restrict`
restrict the domain and codomain respectively of first-order embeddings to substructures.
* `first_order.language.substructure.inclusion` is the inclusion embedding between substructures.

## Main Results
* `L.substructure M` forms a `complete_lattice`.

-/

universe u v w

namespace FirstOrder

namespace Language

variable {L : Language.{u, v}} {M : Type w} {N P : Type _}

variable [L.Structure M] [L.Structure N] [L.Structure P]

open FirstOrder Cardinal

open Structure Cardinal

section ClosedUnder

open Set

variable {n : ℕ} (f : L.Functions n) (s : Set M)

/-- Indicates that a set in a given structure is a closed under a function symbol. -/
def ClosedUnder : Prop :=
  ∀ x : Fin n → M, (∀ i : Fin n, x i ∈ s) → funMap f x ∈ s
#align first_order.language.closed_under FirstOrder.Language.ClosedUnder

variable (L)

@[simp]
theorem closedUnder_univ : ClosedUnder f (univ : Set M) := fun _ _ => mem_univ _
#align first_order.language.closed_under_univ FirstOrder.Language.closedUnder_univ

variable {L f s} {t : Set M}

namespace ClosedUnder

theorem inter (hs : ClosedUnder f s) (ht : ClosedUnder f t) : ClosedUnder f (s ∩ t) := fun x h =>
  mem_inter (hs x fun i => mem_of_mem_inter_left (h i)) (ht x fun i => mem_of_mem_inter_right (h i))
#align first_order.language.closed_under.inter FirstOrder.Language.ClosedUnder.inter

theorem inf (hs : ClosedUnder f s) (ht : ClosedUnder f t) : ClosedUnder f (s ⊓ t) :=
  hs.inter ht
#align first_order.language.closed_under.inf FirstOrder.Language.ClosedUnder.inf

variable {S : Set (Set M)}

theorem infₛ (hS : ∀ s, s ∈ S → ClosedUnder f s) : ClosedUnder f (infₛ S) := fun x h s hs =>
  hS s hs x fun i => h i s hs
#align first_order.language.closed_under.Inf FirstOrder.Language.ClosedUnder.infₛ

end ClosedUnder

end ClosedUnder

variable (L) (M)

/-- A substructure of a structure `M` is a set closed under application of function symbols. -/
structure Substructure where
  carrier : Set M
  fun_mem : ∀ {n}, ∀ f : L.Functions n, ClosedUnder f carrier
#align first_order.language.substructure FirstOrder.Language.Substructure

variable {L} {M}

namespace Substructure

instance : SetLike (L.Substructure M) M :=
  ⟨Substructure.carrier, fun p q h => by cases p <;> cases q <;> congr ⟩

/-- See Note [custom simps projection] -/
def Simps.coe (S : L.Substructure M) : Set M :=
  S
#align first_order.language.substructure.simps.coe FirstOrder.Language.Substructure.Simps.coe

initialize_simps_projections Substructure (carrier → coe)

@[simp]
theorem mem_carrier {s : L.Substructure M} {x : M} : x ∈ s.carrier ↔ x ∈ s :=
  Iff.rfl
#align first_order.language.substructure.mem_carrier FirstOrder.Language.Substructure.mem_carrier

/-- Two substructures are equal if they have the same elements. -/
@[ext]
theorem ext {S T : L.Substructure M} (h : ∀ x, x ∈ S ↔ x ∈ T) : S = T :=
  SetLike.ext h
#align first_order.language.substructure.ext FirstOrder.Language.Substructure.ext

/-- Copy a substructure replacing `carrier` with a set that is equal to it. -/
protected def copy (S : L.Substructure M) (s : Set M) (hs : s = S) : L.Substructure M
    where
  carrier := s
  fun_mem n f := hs.symm ▸ S.fun_mem f
#align first_order.language.substructure.copy FirstOrder.Language.Substructure.copy

end Substructure

variable {S : L.Substructure M}

theorem Term.realize_mem {α : Type _} (t : L.term α) (xs : α → M) (h : ∀ a, xs a ∈ S) :
    t.realize xs ∈ S := by
  induction' t with a n f ts ih
  · exact h a
  · exact substructure.fun_mem _ _ _ ih
#align first_order.language.term.realize_mem FirstOrder.Language.Term.realize_mem

namespace Substructure

@[simp]
theorem coe_copy {s : Set M} (hs : s = S) : (S.copy s hs : Set M) = s :=
  rfl
#align first_order.language.substructure.coe_copy FirstOrder.Language.Substructure.coe_copy

theorem copy_eq {s : Set M} (hs : s = S) : S.copy s hs = S :=
  SetLike.coe_injective hs
#align first_order.language.substructure.copy_eq FirstOrder.Language.Substructure.copy_eq

theorem constants_mem (c : L.Constants) : ↑c ∈ S :=
  mem_carrier.2 (S.fun_mem c _ Fin.elim0)
#align first_order.language.substructure.constants_mem FirstOrder.Language.Substructure.constants_mem

/-- The substructure `M` of the structure `M`. -/
instance : Top (L.Substructure M) :=
  ⟨{  carrier := Set.univ
      fun_mem := fun n f x h => Set.mem_univ _ }⟩

instance : Inhabited (L.Substructure M) :=
  ⟨⊤⟩

@[simp]
theorem mem_top (x : M) : x ∈ (⊤ : L.Substructure M) :=
  Set.mem_univ x
#align first_order.language.substructure.mem_top FirstOrder.Language.Substructure.mem_top

@[simp]
theorem coe_top : ((⊤ : L.Substructure M) : Set M) = Set.univ :=
  rfl
#align first_order.language.substructure.coe_top FirstOrder.Language.Substructure.coe_top

/-- The inf of two substructures is their intersection. -/
instance : Inf (L.Substructure M) :=
  ⟨fun S₁ S₂ =>
    { carrier := S₁ ∩ S₂
      fun_mem := fun n f => (S₁.fun_mem f).inf (S₂.fun_mem f) }⟩

@[simp]
theorem coe_inf (p p' : L.Substructure M) : ((p ⊓ p' : L.Substructure M) : Set M) = p ∩ p' :=
  rfl
#align first_order.language.substructure.coe_inf FirstOrder.Language.Substructure.coe_inf

@[simp]
theorem mem_inf {p p' : L.Substructure M} {x : M} : x ∈ p ⊓ p' ↔ x ∈ p ∧ x ∈ p' :=
  Iff.rfl
#align first_order.language.substructure.mem_inf FirstOrder.Language.Substructure.mem_inf

instance : InfSet (L.Substructure M) :=
  ⟨fun s =>
    { carrier := ⋂ t ∈ s, ↑t
      fun_mem := fun n f =>
        ClosedUnder.infₛ
          (by
            rintro _ ⟨t, rfl⟩
            by_cases h : t ∈ s
            · simpa [h] using t.fun_mem f
            · simp [h]) }⟩

@[simp, norm_cast]
theorem coe_infₛ (S : Set (L.Substructure M)) :
    ((infₛ S : L.Substructure M) : Set M) = ⋂ s ∈ S, ↑s :=
  rfl
#align first_order.language.substructure.coe_Inf FirstOrder.Language.Substructure.coe_infₛ

theorem mem_infₛ {S : Set (L.Substructure M)} {x : M} : x ∈ infₛ S ↔ ∀ p ∈ S, x ∈ p :=
  Set.mem_interᵢ₂
#align first_order.language.substructure.mem_Inf FirstOrder.Language.Substructure.mem_infₛ

theorem mem_infᵢ {ι : Sort _} {S : ι → L.Substructure M} {x : M} : (x ∈ ⨅ i, S i) ↔ ∀ i, x ∈ S i :=
  by simp only [infᵢ, mem_Inf, Set.forall_range_iff]
#align first_order.language.substructure.mem_infi FirstOrder.Language.Substructure.mem_infᵢ

@[simp, norm_cast]
theorem coe_infᵢ {ι : Sort _} {S : ι → L.Substructure M} : (↑(⨅ i, S i) : Set M) = ⋂ i, S i := by
  simp only [infᵢ, coe_Inf, Set.binterᵢ_range]
#align first_order.language.substructure.coe_infi FirstOrder.Language.Substructure.coe_infᵢ

/-- Substructures of a structure form a complete lattice. -/
instance : CompleteLattice (L.Substructure M) :=
  {
    completeLatticeOfInf (L.Substructure M) fun s =>
      IsGLB.of_image (fun S T => show (S : Set M) ≤ T ↔ S ≤ T from SetLike.coe_subset_coe)
        isGLB_binfᵢ with
    le := (· ≤ ·)
    lt := (· < ·)
    top := ⊤
    le_top := fun S x hx => mem_top x
    inf := (· ⊓ ·)
    infₛ := InfSet.infₛ
    le_inf := fun a b c ha hb x hx => ⟨ha hx, hb hx⟩
    inf_le_left := fun a b x => And.left
    inf_le_right := fun a b x => And.right }

variable (L)

/-- The `L.substructure` generated by a set. -/
def closure : LowerAdjoint (coe : L.Substructure M → Set M) :=
  ⟨fun s => infₛ { S | s ⊆ S }, fun s S =>
    ⟨Set.Subset.trans fun x hx => mem_infₛ.2 fun S hS => hS hx, fun h => infₛ_le h⟩⟩
#align first_order.language.substructure.closure FirstOrder.Language.Substructure.closure

variable {L} {s : Set M}

theorem mem_closure {x : M} : x ∈ closure L s ↔ ∀ S : L.Substructure M, s ⊆ S → x ∈ S :=
  mem_infₛ
#align first_order.language.substructure.mem_closure FirstOrder.Language.Substructure.mem_closure

/-- The substructure generated by a set includes the set. -/
@[simp]
theorem subset_closure : s ⊆ closure L s :=
  (closure L).le_closure s
#align first_order.language.substructure.subset_closure FirstOrder.Language.Substructure.subset_closure

theorem not_mem_of_not_mem_closure {P : M} (hP : P ∉ closure L s) : P ∉ s := fun h =>
  hP (subset_closure h)
#align first_order.language.substructure.not_mem_of_not_mem_closure FirstOrder.Language.Substructure.not_mem_of_not_mem_closure

@[simp]
theorem closed (S : L.Substructure M) : (closure L).closed (S : Set M) :=
  congr rfl ((closure L).eq_of_le Set.Subset.rfl fun x xS => mem_closure.2 fun T hT => hT xS)
#align first_order.language.substructure.closed FirstOrder.Language.Substructure.closed

open Set

/-- A substructure `S` includes `closure L s` if and only if it includes `s`. -/
@[simp]
theorem closure_le : closure L s ≤ S ↔ s ⊆ S :=
  (closure L).closure_le_closed_iff_le s S.closed
#align first_order.language.substructure.closure_le FirstOrder.Language.Substructure.closure_le

/-- Substructure closure of a set is monotone in its argument: if `s ⊆ t`,
then `closure L s ≤ closure L t`. -/
theorem closure_mono ⦃s t : Set M⦄ (h : s ⊆ t) : closure L s ≤ closure L t :=
  (closure L).Monotone h
#align first_order.language.substructure.closure_mono FirstOrder.Language.Substructure.closure_mono

theorem closure_eq_of_le (h₁ : s ⊆ S) (h₂ : S ≤ closure L s) : closure L s = S :=
  (closure L).eq_of_le h₁ h₂
#align first_order.language.substructure.closure_eq_of_le FirstOrder.Language.Substructure.closure_eq_of_le

theorem coe_closure_eq_range_term_realize :
    (closure L s : Set M) = range (@Term.realize L _ _ _ (coe : s → M)) :=
  by
  let S : L.substructure M := ⟨range (term.realize coe), fun n f x hx => _⟩
  · change _ = (S : Set M)
    rw [← SetLike.ext'_iff]
    refine' closure_eq_of_le (fun x hx => ⟨var ⟨x, hx⟩, rfl⟩) (le_infₛ fun S' hS' => _)
    · rintro _ ⟨t, rfl⟩
      exact t.realize_mem _ fun i => hS' i.2
  · simp only [mem_range] at *
    refine' ⟨func f fun i => Classical.choose (hx i), _⟩
    simp only [term.realize, fun i => Classical.choose_spec (hx i)]
#align first_order.language.substructure.coe_closure_eq_range_term_realize FirstOrder.Language.Substructure.coe_closure_eq_range_term_realize

instance small_closure [Small.{u} s] : Small.{u} (closure L s) :=
  by
  rw [← SetLike.coe_sort_coe, substructure.coe_closure_eq_range_term_realize]
  exact small_range _
#align first_order.language.substructure.small_closure FirstOrder.Language.Substructure.small_closure

theorem mem_closure_iff_exists_term {x : M} :
    x ∈ closure L s ↔ ∃ t : L.term s, t.realize (coe : s → M) = x := by
  rw [← SetLike.mem_coe, coe_closure_eq_range_term_realize, mem_range]
#align first_order.language.substructure.mem_closure_iff_exists_term FirstOrder.Language.Substructure.mem_closure_iff_exists_term

theorem lift_card_closure_le_card_term : Cardinal.lift.{max u w} (#closure L s) ≤ (#L.term s) :=
  by
  rw [← SetLike.coe_sort_coe, coe_closure_eq_range_term_realize]
  rw [← Cardinal.lift_id'.{w, max u w} (#L.term s)]
  exact Cardinal.mk_range_le_lift
#align first_order.language.substructure.lift_card_closure_le_card_term FirstOrder.Language.Substructure.lift_card_closure_le_card_term

theorem lift_card_closure_le :
    Cardinal.lift.{u, w} (#closure L s) ≤
      max ℵ₀ (Cardinal.lift.{u, w} (#s) + Cardinal.lift.{w, u} (#Σi, L.Functions i)) :=
  by
  rw [← lift_umax]
  refine' lift_card_closure_le_card_term.trans (term.card_le.trans _)
  rw [mk_sum, lift_umax]
#align first_order.language.substructure.lift_card_closure_le FirstOrder.Language.Substructure.lift_card_closure_le

variable (L)

theorem Set.Countable.substructure_closure [Countable (Σl, L.Functions l)] (h : s.Countable) :
    Countable.{w + 1} (closure L s) :=
  by
  haveI : Countable s := h.to_subtype
  rw [← mk_le_aleph_0_iff, ← lift_le_aleph_0]
  exact lift_card_closure_le_card_term.trans mk_le_aleph_0
#align set.countable.substructure_closure Set.Countable.substructure_closure

variable {L} (S)

/-- An induction principle for closure membership. If `p` holds for all elements of `s`, and
is preserved under function symbols, then `p` holds for all elements of the closure of `s`. -/
@[elab_as_elim]
theorem closure_induction {p : M → Prop} {x} (h : x ∈ closure L s) (Hs : ∀ x ∈ s, p x)
    (Hfun : ∀ {n : ℕ} (f : L.Functions n), ClosedUnder f (setOf p)) : p x :=
  (@closure_le L M _ ⟨setOf p, fun n => Hfun⟩ _).2 Hs h
#align first_order.language.substructure.closure_induction FirstOrder.Language.Substructure.closure_induction

/-- If `s` is a dense set in a structure `M`, `substructure.closure L s = ⊤`, then in order to prove
that some predicate `p` holds for all `x : M` it suffices to verify `p x` for `x ∈ s`, and verify
that `p` is preserved under function symbols. -/
@[elab_as_elim]
theorem dense_induction {p : M → Prop} (x : M) {s : Set M} (hs : closure L s = ⊤)
    (Hs : ∀ x ∈ s, p x) (Hfun : ∀ {n : ℕ} (f : L.Functions n), ClosedUnder f (setOf p)) : p x :=
  by
  have : ∀ x ∈ closure L s, p x := fun x hx => closure_induction hx Hs fun n => Hfun
  simpa [hs] using this x
#align first_order.language.substructure.dense_induction FirstOrder.Language.Substructure.dense_induction

variable (L) (M)

/-- `closure` forms a Galois insertion with the coercion to set. -/
protected def gi : GaloisInsertion (@closure L M _) coe
    where
  choice s _ := closure L s
  gc := (closure L).gc
  le_l_u s := subset_closure
  choice_eq s h := rfl
#align first_order.language.substructure.gi FirstOrder.Language.Substructure.gi

variable {L} {M}

/-- Closure of a substructure `S` equals `S`. -/
@[simp]
theorem closure_eq : closure L (S : Set M) = S :=
  (Substructure.gi L M).l_u_eq S
#align first_order.language.substructure.closure_eq FirstOrder.Language.Substructure.closure_eq

@[simp]
theorem closure_empty : closure L (∅ : Set M) = ⊥ :=
  (Substructure.gi L M).gc.l_bot
#align first_order.language.substructure.closure_empty FirstOrder.Language.Substructure.closure_empty

@[simp]
theorem closure_univ : closure L (univ : Set M) = ⊤ :=
  @coe_top L M _ ▸ closure_eq ⊤
#align first_order.language.substructure.closure_univ FirstOrder.Language.Substructure.closure_univ

theorem closure_union (s t : Set M) : closure L (s ∪ t) = closure L s ⊔ closure L t :=
  (Substructure.gi L M).gc.l_sup
#align first_order.language.substructure.closure_union FirstOrder.Language.Substructure.closure_union

theorem closure_unionᵢ {ι} (s : ι → Set M) : closure L (⋃ i, s i) = ⨆ i, closure L (s i) :=
  (Substructure.gi L M).gc.l_supᵢ
#align first_order.language.substructure.closure_Union FirstOrder.Language.Substructure.closure_unionᵢ

instance small_bot : Small.{u} (⊥ : L.Substructure M) :=
  by
  rw [← closure_empty]
  exact substructure.small_closure
#align first_order.language.substructure.small_bot FirstOrder.Language.Substructure.small_bot

/-!
### `comap` and `map`
-/

/-- The preimage of a substructure along a homomorphism is a substructure. -/
@[simps]
def comap (φ : M →[L] N) (S : L.Substructure N) : L.Substructure M
    where
  carrier := φ ⁻¹' S
  fun_mem n f x hx := by
    rw [mem_preimage, φ.map_fun]
    exact S.fun_mem f (φ ∘ x) hx
#align first_order.language.substructure.comap FirstOrder.Language.Substructure.comap

@[simp]
theorem mem_comap {S : L.Substructure N} {f : M →[L] N} {x : M} : x ∈ S.comap f ↔ f x ∈ S :=
  Iff.rfl
#align first_order.language.substructure.mem_comap FirstOrder.Language.Substructure.mem_comap

theorem comap_comap (S : L.Substructure P) (g : N →[L] P) (f : M →[L] N) :
    (S.comap g).comap f = S.comap (g.comp f) :=
  rfl
#align first_order.language.substructure.comap_comap FirstOrder.Language.Substructure.comap_comap

@[simp]
theorem comap_id (S : L.Substructure P) : S.comap (Hom.id _ _) = S :=
  ext (by simp)
#align first_order.language.substructure.comap_id FirstOrder.Language.Substructure.comap_id

/-- The image of a substructure along a homomorphism is a substructure. -/
@[simps]
def map (φ : M →[L] N) (S : L.Substructure M) : L.Substructure N
    where
  carrier := φ '' S
  fun_mem n f x hx :=
    (mem_image _ _ _).1
      ⟨funMap f fun i => Classical.choose (hx i),
        S.fun_mem f _ fun i => (Classical.choose_spec (hx i)).1,
        by
        simp only [hom.map_fun, SetLike.mem_coe]
        exact congr rfl (funext fun i => (Classical.choose_spec (hx i)).2)⟩
#align first_order.language.substructure.map FirstOrder.Language.Substructure.map

@[simp]
theorem mem_map {f : M →[L] N} {S : L.Substructure M} {y : N} : y ∈ S.map f ↔ ∃ x ∈ S, f x = y :=
  mem_image_iff_bex
#align first_order.language.substructure.mem_map FirstOrder.Language.Substructure.mem_map

theorem mem_map_of_mem (f : M →[L] N) {S : L.Substructure M} {x : M} (hx : x ∈ S) : f x ∈ S.map f :=
  mem_image_of_mem f hx
#align first_order.language.substructure.mem_map_of_mem FirstOrder.Language.Substructure.mem_map_of_mem

theorem apply_coe_mem_map (f : M →[L] N) (S : L.Substructure M) (x : S) : f x ∈ S.map f :=
  mem_map_of_mem f x.Prop
#align first_order.language.substructure.apply_coe_mem_map FirstOrder.Language.Substructure.apply_coe_mem_map

theorem map_map (g : N →[L] P) (f : M →[L] N) : (S.map f).map g = S.map (g.comp f) :=
  SetLike.coe_injective <| image_image _ _ _
#align first_order.language.substructure.map_map FirstOrder.Language.Substructure.map_map

theorem map_le_iff_le_comap {f : M →[L] N} {S : L.Substructure M} {T : L.Substructure N} :
    S.map f ≤ T ↔ S ≤ T.comap f :=
  image_subset_iff
#align first_order.language.substructure.map_le_iff_le_comap FirstOrder.Language.Substructure.map_le_iff_le_comap

theorem gc_map_comap (f : M →[L] N) : GaloisConnection (map f) (comap f) := fun S T =>
  map_le_iff_le_comap
#align first_order.language.substructure.gc_map_comap FirstOrder.Language.Substructure.gc_map_comap

theorem map_le_of_le_comap {T : L.Substructure N} {f : M →[L] N} : S ≤ T.comap f → S.map f ≤ T :=
  (gc_map_comap f).l_le
#align first_order.language.substructure.map_le_of_le_comap FirstOrder.Language.Substructure.map_le_of_le_comap

theorem le_comap_of_map_le {T : L.Substructure N} {f : M →[L] N} : S.map f ≤ T → S ≤ T.comap f :=
  (gc_map_comap f).le_u
#align first_order.language.substructure.le_comap_of_map_le FirstOrder.Language.Substructure.le_comap_of_map_le

theorem le_comap_map {f : M →[L] N} : S ≤ (S.map f).comap f :=
  (gc_map_comap f).le_u_l _
#align first_order.language.substructure.le_comap_map FirstOrder.Language.Substructure.le_comap_map

theorem map_comap_le {S : L.Substructure N} {f : M →[L] N} : (S.comap f).map f ≤ S :=
  (gc_map_comap f).l_u_le _
#align first_order.language.substructure.map_comap_le FirstOrder.Language.Substructure.map_comap_le

theorem monotone_map {f : M →[L] N} : Monotone (map f) :=
  (gc_map_comap f).monotone_l
#align first_order.language.substructure.monotone_map FirstOrder.Language.Substructure.monotone_map

theorem monotone_comap {f : M →[L] N} : Monotone (comap f) :=
  (gc_map_comap f).monotone_u
#align first_order.language.substructure.monotone_comap FirstOrder.Language.Substructure.monotone_comap

@[simp]
theorem map_comap_map {f : M →[L] N} : ((S.map f).comap f).map f = S.map f :=
  (gc_map_comap f).l_u_l_eq_l _
#align first_order.language.substructure.map_comap_map FirstOrder.Language.Substructure.map_comap_map

@[simp]
theorem comap_map_comap {S : L.Substructure N} {f : M →[L] N} :
    ((S.comap f).map f).comap f = S.comap f :=
  (gc_map_comap f).u_l_u_eq_u _
#align first_order.language.substructure.comap_map_comap FirstOrder.Language.Substructure.comap_map_comap

theorem map_sup (S T : L.Substructure M) (f : M →[L] N) : (S ⊔ T).map f = S.map f ⊔ T.map f :=
  (gc_map_comap f).l_sup
#align first_order.language.substructure.map_sup FirstOrder.Language.Substructure.map_sup

theorem map_supᵢ {ι : Sort _} (f : M →[L] N) (s : ι → L.Substructure M) :
    (supᵢ s).map f = ⨆ i, (s i).map f :=
  (gc_map_comap f).l_supᵢ
#align first_order.language.substructure.map_supr FirstOrder.Language.Substructure.map_supᵢ

theorem comap_inf (S T : L.Substructure N) (f : M →[L] N) :
    (S ⊓ T).comap f = S.comap f ⊓ T.comap f :=
  (gc_map_comap f).u_inf
#align first_order.language.substructure.comap_inf FirstOrder.Language.Substructure.comap_inf

theorem comap_infᵢ {ι : Sort _} (f : M →[L] N) (s : ι → L.Substructure N) :
    (infᵢ s).comap f = ⨅ i, (s i).comap f :=
  (gc_map_comap f).u_infᵢ
#align first_order.language.substructure.comap_infi FirstOrder.Language.Substructure.comap_infᵢ

@[simp]
theorem map_bot (f : M →[L] N) : (⊥ : L.Substructure M).map f = ⊥ :=
  (gc_map_comap f).l_bot
#align first_order.language.substructure.map_bot FirstOrder.Language.Substructure.map_bot

@[simp]
theorem comap_top (f : M →[L] N) : (⊤ : L.Substructure N).comap f = ⊤ :=
  (gc_map_comap f).u_top
#align first_order.language.substructure.comap_top FirstOrder.Language.Substructure.comap_top

@[simp]
theorem map_id (S : L.Substructure M) : S.map (Hom.id L M) = S :=
  ext fun x => ⟨fun ⟨_, h, rfl⟩ => h, fun h => ⟨_, h, rfl⟩⟩
#align first_order.language.substructure.map_id FirstOrder.Language.Substructure.map_id

theorem map_closure (f : M →[L] N) (s : Set M) : (closure L s).map f = closure L (f '' s) :=
  Eq.symm <|
    closure_eq_of_le (Set.image_subset f subset_closure) <|
      map_le_iff_le_comap.2 <| closure_le.2 fun x hx => subset_closure ⟨x, hx, rfl⟩
#align first_order.language.substructure.map_closure FirstOrder.Language.Substructure.map_closure

@[simp]
theorem closure_image (f : M →[L] N) : closure L (f '' s) = map f (closure L s) :=
  (map_closure f s).symm
#align first_order.language.substructure.closure_image FirstOrder.Language.Substructure.closure_image

section GaloisCoinsertion

variable {ι : Type _} {f : M →[L] N} (hf : Function.Injective f)

include hf

/-- `map f` and `comap f` form a `galois_coinsertion` when `f` is injective. -/
def gciMapComap : GaloisCoinsertion (map f) (comap f) :=
  (gc_map_comap f).toGaloisCoinsertion fun S x => by simp [mem_comap, mem_map, hf.eq_iff]
#align first_order.language.substructure.gci_map_comap FirstOrder.Language.Substructure.gciMapComap

theorem comap_map_eq_of_injective (S : L.Substructure M) : (S.map f).comap f = S :=
  (gciMapComap hf).u_l_eq _
#align first_order.language.substructure.comap_map_eq_of_injective FirstOrder.Language.Substructure.comap_map_eq_of_injective

theorem comap_surjective_of_injective : Function.Surjective (comap f) :=
  (gciMapComap hf).u_surjective
#align first_order.language.substructure.comap_surjective_of_injective FirstOrder.Language.Substructure.comap_surjective_of_injective

theorem map_injective_of_injective : Function.Injective (map f) :=
  (gciMapComap hf).l_injective
#align first_order.language.substructure.map_injective_of_injective FirstOrder.Language.Substructure.map_injective_of_injective

theorem comap_inf_map_of_injective (S T : L.Substructure M) : (S.map f ⊓ T.map f).comap f = S ⊓ T :=
  (gciMapComap hf).u_inf_l _ _
#align first_order.language.substructure.comap_inf_map_of_injective FirstOrder.Language.Substructure.comap_inf_map_of_injective

theorem comap_infᵢ_map_of_injective (S : ι → L.Substructure M) :
    (⨅ i, (S i).map f).comap f = infᵢ S :=
  (gciMapComap hf).u_infᵢ_l _
#align first_order.language.substructure.comap_infi_map_of_injective FirstOrder.Language.Substructure.comap_infᵢ_map_of_injective

theorem comap_sup_map_of_injective (S T : L.Substructure M) : (S.map f ⊔ T.map f).comap f = S ⊔ T :=
  (gciMapComap hf).u_sup_l _ _
#align first_order.language.substructure.comap_sup_map_of_injective FirstOrder.Language.Substructure.comap_sup_map_of_injective

theorem comap_supᵢ_map_of_injective (S : ι → L.Substructure M) :
    (⨆ i, (S i).map f).comap f = supᵢ S :=
  (gciMapComap hf).u_supᵢ_l _
#align first_order.language.substructure.comap_supr_map_of_injective FirstOrder.Language.Substructure.comap_supᵢ_map_of_injective

theorem map_le_map_iff_of_injective {S T : L.Substructure M} : S.map f ≤ T.map f ↔ S ≤ T :=
  (gciMapComap hf).l_le_l_iff
#align first_order.language.substructure.map_le_map_iff_of_injective FirstOrder.Language.Substructure.map_le_map_iff_of_injective

theorem map_strictMono_of_injective : StrictMono (map f) :=
  (gciMapComap hf).strictMono_l
#align first_order.language.substructure.map_strict_mono_of_injective FirstOrder.Language.Substructure.map_strictMono_of_injective

end GaloisCoinsertion

section GaloisInsertion

variable {ι : Type _} {f : M →[L] N} (hf : Function.Surjective f)

include hf

/-- `map f` and `comap f` form a `galois_insertion` when `f` is surjective. -/
def giMapComap : GaloisInsertion (map f) (comap f) :=
  (gc_map_comap f).toGaloisInsertion fun S x h =>
    let ⟨y, hy⟩ := hf x
    mem_map.2 ⟨y, by simp [hy, h]⟩
#align first_order.language.substructure.gi_map_comap FirstOrder.Language.Substructure.giMapComap

theorem map_comap_eq_of_surjective (S : L.Substructure N) : (S.comap f).map f = S :=
  (giMapComap hf).l_u_eq _
#align first_order.language.substructure.map_comap_eq_of_surjective FirstOrder.Language.Substructure.map_comap_eq_of_surjective

theorem map_surjective_of_surjective : Function.Surjective (map f) :=
  (giMapComap hf).l_surjective
#align first_order.language.substructure.map_surjective_of_surjective FirstOrder.Language.Substructure.map_surjective_of_surjective

theorem comap_injective_of_surjective : Function.Injective (comap f) :=
  (giMapComap hf).u_injective
#align first_order.language.substructure.comap_injective_of_surjective FirstOrder.Language.Substructure.comap_injective_of_surjective

theorem map_inf_comap_of_surjective (S T : L.Substructure N) :
    (S.comap f ⊓ T.comap f).map f = S ⊓ T :=
  (giMapComap hf).l_inf_u _ _
#align first_order.language.substructure.map_inf_comap_of_surjective FirstOrder.Language.Substructure.map_inf_comap_of_surjective

theorem map_infᵢ_comap_of_surjective (S : ι → L.Substructure N) :
    (⨅ i, (S i).comap f).map f = infᵢ S :=
  (giMapComap hf).l_infᵢ_u _
#align first_order.language.substructure.map_infi_comap_of_surjective FirstOrder.Language.Substructure.map_infᵢ_comap_of_surjective

theorem map_sup_comap_of_surjective (S T : L.Substructure N) :
    (S.comap f ⊔ T.comap f).map f = S ⊔ T :=
  (giMapComap hf).l_sup_u _ _
#align first_order.language.substructure.map_sup_comap_of_surjective FirstOrder.Language.Substructure.map_sup_comap_of_surjective

theorem map_supᵢ_comap_of_surjective (S : ι → L.Substructure N) :
    (⨆ i, (S i).comap f).map f = supᵢ S :=
  (giMapComap hf).l_supᵢ_u _
#align first_order.language.substructure.map_supr_comap_of_surjective FirstOrder.Language.Substructure.map_supᵢ_comap_of_surjective

theorem comap_le_comap_iff_of_surjective {S T : L.Substructure N} : S.comap f ≤ T.comap f ↔ S ≤ T :=
  (giMapComap hf).u_le_u_iff
#align first_order.language.substructure.comap_le_comap_iff_of_surjective FirstOrder.Language.Substructure.comap_le_comap_iff_of_surjective

theorem comap_strictMono_of_surjective : StrictMono (comap f) :=
  (giMapComap hf).strictMono_u
#align first_order.language.substructure.comap_strict_mono_of_surjective FirstOrder.Language.Substructure.comap_strictMono_of_surjective

end GaloisInsertion

instance inducedStructure {S : L.Substructure M} : L.Structure S
    where
  funMap n f x := ⟨funMap f fun i => x i, S.fun_mem f (fun i => x i) fun i => (x i).2⟩
  rel_map n r x := RelMap r fun i => (x i : M)
#align first_order.language.substructure.induced_Structure FirstOrder.Language.Substructure.inducedStructure

/-- The natural embedding of an `L.substructure` of `M` into `M`. -/
def subtype (S : L.Substructure M) : S ↪[L] M
    where
  toFun := coe
  inj' := Subtype.coe_injective
#align first_order.language.substructure.subtype FirstOrder.Language.Substructure.subtype

@[simp]
theorem coeSubtype : ⇑S.Subtype = coe :=
  rfl
#align first_order.language.substructure.coe_subtype FirstOrder.Language.Substructure.coeSubtype

/-- The equivalence between the maximal substructure of a structure and the structure itself. -/
def topEquiv : (⊤ : L.Substructure M) ≃[L] M
    where
  toFun := subtype ⊤
  invFun m := ⟨m, mem_top m⟩
  left_inv m := by simp
  right_inv m := rfl
#align first_order.language.substructure.top_equiv FirstOrder.Language.Substructure.topEquiv

@[simp]
theorem coe_topEquiv : ⇑(topEquiv : (⊤ : L.Substructure M) ≃[L] M) = coe :=
  rfl
#align first_order.language.substructure.coe_top_equiv FirstOrder.Language.Substructure.coe_topEquiv

/-- A dependent version of `substructure.closure_induction`. -/
@[elab_as_elim]
theorem closure_induction' (s : Set M) {p : ∀ x, x ∈ closure L s → Prop}
    (Hs : ∀ (x) (h : x ∈ s), p x (subset_closure h))
    (Hfun : ∀ {n : ℕ} (f : L.Functions n), ClosedUnder f { x | ∃ hx, p x hx }) {x}
    (hx : x ∈ closure L s) : p x hx :=
  by
  refine' Exists.elim _ fun (hx : x ∈ closure L s) (hc : p x hx) => hc
  exact closure_induction hx (fun x hx => ⟨subset_closure hx, Hs x hx⟩) @Hfun
#align first_order.language.substructure.closure_induction' FirstOrder.Language.Substructure.closure_induction'

end Substructure

namespace Lhom

open Substructure

variable {L' : Language} [L'.Structure M] (φ : L →ᴸ L') [φ.IsExpansionOn M]

include φ

/-- Reduces the language of a substructure along a language hom. -/
def substructureReduct : L'.Substructure M ↪o L.Substructure M
    where
  toFun S :=
    { carrier := S
      fun_mem := fun n f x hx =>
        by
        have h := S.fun_mem (φ.on_function f) x hx
        simp only [Lhom.map_on_function, substructure.mem_carrier] at h
        exact h }
  inj' S T h := by
    simp only [SetLike.coe_set_eq] at h
    exact h
  map_rel_iff' S T := Iff.rfl
#align first_order.language.Lhom.substructure_reduct FirstOrder.Language.Lhom.substructureReduct

@[simp]
theorem mem_substructureReduct {x : M} {S : L'.Substructure M} :
    x ∈ φ.substructureReduct S ↔ x ∈ S :=
  Iff.rfl
#align first_order.language.Lhom.mem_substructure_reduct FirstOrder.Language.Lhom.mem_substructureReduct

@[simp]
theorem coe_substructureReduct {S : L'.Substructure M} : (φ.substructureReduct S : Set M) = ↑S :=
  rfl
#align first_order.language.Lhom.coe_substructure_reduct FirstOrder.Language.Lhom.coe_substructureReduct

end Lhom

namespace Substructure

/-- Turns any substructure containing a constant set `A` into a `L[[A]]`-substructure. -/
def withConstants (S : L.Substructure M) {A : Set M} (h : A ⊆ S) : L[[A]].Substructure M
    where
  carrier := S
  fun_mem n f := by
    cases f
    · exact S.fun_mem f
    · cases n
      · exact fun _ _ => h f.2
      · exact isEmptyElim f
#align first_order.language.substructure.with_constants FirstOrder.Language.Substructure.withConstants

variable {A : Set M} {s : Set M} (h : A ⊆ S)

@[simp]
theorem mem_withConstants {x : M} : x ∈ S.withConstants h ↔ x ∈ S :=
  Iff.rfl
#align first_order.language.substructure.mem_with_constants FirstOrder.Language.Substructure.mem_withConstants

@[simp]
theorem coe_withConstants : (S.withConstants h : Set M) = ↑S :=
  rfl
#align first_order.language.substructure.coe_with_constants FirstOrder.Language.Substructure.coe_withConstants

@[simp]
theorem reduct_withConstants : (L.lhomWithConstants A).substructureReduct (S.withConstants h) = S :=
  by
  ext
  simp
#align first_order.language.substructure.reduct_with_constants FirstOrder.Language.Substructure.reduct_withConstants

theorem subset_closure_withConstants : A ⊆ closure (L[[A]]) s :=
  by
  intro a ha
  simp only [SetLike.mem_coe]
  let a' : L[[A]].Constants := Sum.inr ⟨a, ha⟩
  exact constants_mem a'
#align first_order.language.substructure.subset_closure_with_constants FirstOrder.Language.Substructure.subset_closure_withConstants

theorem closure_withConstants_eq :
    closure (L[[A]]) s =
      (closure L (A ∪ s)).withConstants ((A.subset_union_left s).trans subset_closure) :=
  by
  refine' closure_eq_of_le ((A.subset_union_right s).trans subset_closure) _
  rw [← (L.Lhom_with_constants A).substructureReduct.le_iff_le]
  simp only [subset_closure, reduct_with_constants, closure_le, Lhom.coe_substructure_reduct,
    Set.union_subset_iff, and_true_iff]
  · exact subset_closure_with_constants
  · infer_instance
  · infer_instance
#align first_order.language.substructure.closure_with_constants_eq FirstOrder.Language.Substructure.closure_withConstants_eq

end Substructure

namespace Hom

open Substructure

/-- The restriction of a first-order hom to a substructure `s ⊆ M` gives a hom `s → N`. -/
@[simps]
def domRestrict (f : M →[L] N) (p : L.Substructure M) : p →[L] N :=
  f.comp p.Subtype.toHom
#align first_order.language.hom.dom_restrict FirstOrder.Language.Hom.domRestrict

/-- A first-order hom `f : M → N` whose values lie in a substructure `p ⊆ N` can be restricted to a
hom `M → p`. -/
@[simps]
def codRestrict (p : L.Substructure N) (f : M →[L] N) (h : ∀ c, f c ∈ p) : M →[L] p
    where
  toFun c := ⟨f c, h c⟩
  map_rel' n R x h := f.map_rel R x h
#align first_order.language.hom.cod_restrict FirstOrder.Language.Hom.codRestrict

@[simp]
theorem comp_codRestrict (f : M →[L] N) (g : N →[L] P) (p : L.Substructure P) (h : ∀ b, g b ∈ p) :
    ((codRestrict p g h).comp f : M →[L] p) = codRestrict p (g.comp f) fun b => h _ :=
  ext fun b => rfl
#align first_order.language.hom.comp_cod_restrict FirstOrder.Language.Hom.comp_codRestrict

@[simp]
theorem subtype_comp_codRestrict (f : M →[L] N) (p : L.Substructure N) (h : ∀ b, f b ∈ p) :
    p.Subtype.toHom.comp (codRestrict p f h) = f :=
  ext fun b => rfl
#align first_order.language.hom.subtype_comp_cod_restrict FirstOrder.Language.Hom.subtype_comp_codRestrict

/-- The range of a first-order hom `f : M → N` is a submodule of `N`.
See Note [range copy pattern]. -/
def range (f : M →[L] N) : L.Substructure N :=
  (map f ⊤).copy (Set.range f) Set.image_univ.symm
#align first_order.language.hom.range FirstOrder.Language.Hom.range

theorem range_coe (f : M →[L] N) : (range f : Set N) = Set.range f :=
  rfl
#align first_order.language.hom.range_coe FirstOrder.Language.Hom.range_coe

@[simp]
theorem mem_range {f : M →[L] N} {x} : x ∈ range f ↔ ∃ y, f y = x :=
  Iff.rfl
#align first_order.language.hom.mem_range FirstOrder.Language.Hom.mem_range

theorem range_eq_map (f : M →[L] N) : f.range = map f ⊤ :=
  by
  ext
  simp
#align first_order.language.hom.range_eq_map FirstOrder.Language.Hom.range_eq_map

theorem mem_range_self (f : M →[L] N) (x : M) : f x ∈ f.range :=
  ⟨x, rfl⟩
#align first_order.language.hom.mem_range_self FirstOrder.Language.Hom.mem_range_self

@[simp]
theorem range_id : range (id L M) = ⊤ :=
  SetLike.coe_injective Set.range_id
#align first_order.language.hom.range_id FirstOrder.Language.Hom.range_id

theorem range_comp (f : M →[L] N) (g : N →[L] P) : range (g.comp f : M →[L] P) = map g (range f) :=
  SetLike.coe_injective (Set.range_comp g f)
#align first_order.language.hom.range_comp FirstOrder.Language.Hom.range_comp

theorem range_comp_le_range (f : M →[L] N) (g : N →[L] P) : range (g.comp f : M →[L] P) ≤ range g :=
  SetLike.coe_mono (Set.range_comp_subset_range f g)
#align first_order.language.hom.range_comp_le_range FirstOrder.Language.Hom.range_comp_le_range

theorem range_eq_top {f : M →[L] N} : range f = ⊤ ↔ Function.Surjective f := by
  rw [SetLike.ext'_iff, range_coe, coe_top, Set.range_iff_surjective]
#align first_order.language.hom.range_eq_top FirstOrder.Language.Hom.range_eq_top

theorem range_le_iff_comap {f : M →[L] N} {p : L.Substructure N} : range f ≤ p ↔ comap f p = ⊤ := by
  rw [range_eq_map, map_le_iff_le_comap, eq_top_iff]
#align first_order.language.hom.range_le_iff_comap FirstOrder.Language.Hom.range_le_iff_comap

theorem map_le_range {f : M →[L] N} {p : L.Substructure M} : map f p ≤ range f :=
  SetLike.coe_mono (Set.image_subset_range f p)
#align first_order.language.hom.map_le_range FirstOrder.Language.Hom.map_le_range

/-- The substructure of elements `x : M` such that `f x = g x` -/
def eqLocus (f g : M →[L] N) : Substructure L M
    where
  carrier := { x : M | f x = g x }
  fun_mem n fn x hx :=
    by
    have h : f ∘ x = g ∘ x := by
      ext
      repeat' rw [Function.comp_apply]
      apply hx
    simp [h]
#align first_order.language.hom.eq_locus FirstOrder.Language.Hom.eqLocus

/-- If two `L.hom`s are equal on a set, then they are equal on its substructure closure. -/
theorem eqOn_closure {f g : M →[L] N} {s : Set M} (h : Set.EqOn f g s) :
    Set.EqOn f g (closure L s) :=
  show closure L s ≤ f.eqLocus g from closure_le.2 h
#align first_order.language.hom.eq_on_closure FirstOrder.Language.Hom.eqOn_closure

theorem eq_of_eqOn_top {f g : M →[L] N} (h : Set.EqOn f g (⊤ : Substructure L M)) : f = g :=
  ext fun x => h trivial
#align first_order.language.hom.eq_of_eq_on_top FirstOrder.Language.Hom.eq_of_eqOn_top

variable {s : Set M}

theorem eq_of_eqOn_dense (hs : closure L s = ⊤) {f g : M →[L] N} (h : s.EqOn f g) : f = g :=
  eq_of_eqOn_top <| hs ▸ eqOn_closure h
#align first_order.language.hom.eq_of_eq_on_dense FirstOrder.Language.Hom.eq_of_eqOn_dense

end Hom

namespace Embedding

open Substructure

/-- The restriction of a first-order embedding to a substructure `s ⊆ M` gives an embedding `s → N`.
-/
def domRestrict (f : M ↪[L] N) (p : L.Substructure M) : p ↪[L] N :=
  f.comp p.Subtype
#align first_order.language.embedding.dom_restrict FirstOrder.Language.Embedding.domRestrict

@[simp]
theorem domRestrict_apply (f : M ↪[L] N) (p : L.Substructure M) (x : p) : f.domRestrict p x = f x :=
  rfl
#align first_order.language.embedding.dom_restrict_apply FirstOrder.Language.Embedding.domRestrict_apply

/-- A first-order embedding `f : M → N` whose values lie in a substructure `p ⊆ N` can be restricted
to an embedding `M → p`. -/
def codRestrict (p : L.Substructure N) (f : M ↪[L] N) (h : ∀ c, f c ∈ p) : M ↪[L] p
    where
  toFun := f.toHom.codRestrict p h
  inj' a b ab := f.Injective (Subtype.mk_eq_mk.1 ab)
  map_fun' n F x := (f.toHom.codRestrict p h).map_fun' F x
  map_rel' n r x := by
    simp only
    rw [← p.subtype.map_rel, Function.comp.assoc]
    change rel_map r (hom.comp p.subtype.to_hom (f.to_hom.cod_restrict p h) ∘ x) ↔ _
    rw [hom.subtype_comp_cod_restrict, ← f.map_rel]
    rfl
#align first_order.language.embedding.cod_restrict FirstOrder.Language.Embedding.codRestrict

@[simp]
theorem codRestrict_apply (p : L.Substructure N) (f : M ↪[L] N) {h} (x : M) :
    (codRestrict p f h x : N) = f x :=
  rfl
#align first_order.language.embedding.cod_restrict_apply FirstOrder.Language.Embedding.codRestrict_apply

@[simp]
theorem comp_codRestrict (f : M ↪[L] N) (g : N ↪[L] P) (p : L.Substructure P) (h : ∀ b, g b ∈ p) :
    ((codRestrict p g h).comp f : M ↪[L] p) = codRestrict p (g.comp f) fun b => h _ :=
  ext fun b => rfl
#align first_order.language.embedding.comp_cod_restrict FirstOrder.Language.Embedding.comp_codRestrict

@[simp]
theorem subtype_comp_codRestrict (f : M ↪[L] N) (p : L.Substructure N) (h : ∀ b, f b ∈ p) :
    p.Subtype.comp (codRestrict p f h) = f :=
  ext fun b => rfl
#align first_order.language.embedding.subtype_comp_cod_restrict FirstOrder.Language.Embedding.subtype_comp_codRestrict

/-- The equivalence between a substructure `s` and its image `s.map f.to_hom`, where `f` is an
  embedding. -/
noncomputable def substructureEquivMap (f : M ↪[L] N) (s : L.Substructure M) : s ≃[L] s.map f.toHom
    where
  toFun := codRestrict (s.map f.toHom) (f.domRestrict s) fun ⟨m, hm⟩ => ⟨m, hm, rfl⟩
  invFun n := ⟨Classical.choose n.2, (Classical.choose_spec n.2).1⟩
  left_inv := fun ⟨m, hm⟩ =>
    Subtype.mk_eq_mk.2
      (f.Injective
        (Classical.choose_spec
            (codRestrict (s.map f.toHom) (f.domRestrict s) (fun ⟨m, hm⟩ => ⟨m, hm, rfl⟩)
                ⟨m, hm⟩).2).2)
  right_inv := fun ⟨n, hn⟩ => Subtype.mk_eq_mk.2 (Classical.choose_spec hn).2
#align first_order.language.embedding.substructure_equiv_map FirstOrder.Language.Embedding.substructureEquivMap

@[simp]
theorem substructureEquivMap_apply (f : M ↪[L] N) (p : L.Substructure M) (x : p) :
    (f.substructureEquivMap p x : N) = f x :=
  rfl
#align first_order.language.embedding.substructure_equiv_map_apply FirstOrder.Language.Embedding.substructureEquivMap_apply

/-- The equivalence between the domain and the range of an embedding `f`. -/
noncomputable def equivRange (f : M ↪[L] N) : M ≃[L] f.toHom.range
    where
  toFun := codRestrict f.toHom.range f f.toHom.mem_range_self
  invFun n := Classical.choose n.2
  left_inv m :=
    f.Injective (Classical.choose_spec (codRestrict f.toHom.range f f.toHom.mem_range_self m).2)
  right_inv := fun ⟨n, hn⟩ => Subtype.mk_eq_mk.2 (Classical.choose_spec hn)
#align first_order.language.embedding.equiv_range FirstOrder.Language.Embedding.equivRange

@[simp]
theorem equivRange_apply (f : M ↪[L] N) (x : M) : (f.equivRange x : N) = f x :=
  rfl
#align first_order.language.embedding.equiv_range_apply FirstOrder.Language.Embedding.equivRange_apply

end Embedding

namespace Equiv

theorem toHom_range (f : M ≃[L] N) : f.toHom.range = ⊤ :=
  by
  ext n
  simp only [hom.mem_range, coe_to_hom, substructure.mem_top, iff_true_iff]
  exact ⟨f.symm n, apply_symm_apply _ _⟩
#align first_order.language.equiv.to_hom_range FirstOrder.Language.Equiv.toHom_range

end Equiv

namespace Substructure

/-- The embedding associated to an inclusion of substructures. -/
def inclusion {S T : L.Substructure M} (h : S ≤ T) : S ↪[L] T :=
  S.Subtype.codRestrict _ fun x => h x.2
#align first_order.language.substructure.inclusion FirstOrder.Language.Substructure.inclusion

@[simp]
theorem coe_inclusion {S T : L.Substructure M} (h : S ≤ T) :
    (inclusion h : S → T) = Set.inclusion h :=
  rfl
#align first_order.language.substructure.coe_inclusion FirstOrder.Language.Substructure.coe_inclusion

theorem range_subtype (S : L.Substructure M) : S.Subtype.toHom.range = S :=
  by
  ext x
  simp only [hom.mem_range, embedding.coe_to_hom, coeSubtype]
  refine' ⟨_, fun h => ⟨⟨x, h⟩, rfl⟩⟩
  rintro ⟨⟨y, hy⟩, rfl⟩
  exact hy
#align first_order.language.substructure.range_subtype FirstOrder.Language.Substructure.range_subtype

end Substructure

end Language

end FirstOrder


/-
Copyright (c) 2020 Bhavik Mehta. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Bhavik Mehta
-/
import Mathlib.PrePort
import Mathlib.Lean3Lib.init.default
import Mathlib.category_theory.limits.shapes.pullbacks
import Mathlib.category_theory.limits.preserves.basic
import Mathlib.PostPort

universes u₁ u₂ v

namespace Mathlib

/-!
# Preserving pullbacks

Constructions to relate the notions of preserving pullbacks and reflecting pullbacks to concrete
pullback cones.

In particular, we show that `pullback_comparison G f g` is an isomorphism iff `G` preserves
the pullback of `f` and `g`.

## TODO

* Dualise to pushouts
* Generalise to wide pullbacks

-/

namespace category_theory.limits

/--
The map of a pullback cone is a limit iff the fork consisting of the mapped morphisms is a limit.
This essentially lets us commute `pullback_cone.mk` with `functor.map_cone`.
-/
def is_limit_map_cone_pullback_cone_equiv {C : Type u₁} [category C] {D : Type u₂} [category D] (G : C ⥤ D) {W : C} {X : C} {Y : C} {Z : C} {f : X ⟶ Z} {g : Y ⟶ Z} {h : W ⟶ X} {k : W ⟶ Y} (comm : h ≫ f = k ≫ g) : is_limit (functor.map_cone G (pullback_cone.mk h k comm)) ≃
  is_limit
    (pullback_cone.mk (functor.map G h) (functor.map G k) (is_limit_map_cone_pullback_cone_equiv._proof_1 G comm)) :=
  equiv.trans
    (equiv.symm
      (is_limit.postcompose_hom_equiv (diagram_iso_cospan (cospan f g ⋙ G))
        (functor.map_cone G (pullback_cone.mk h k comm))))
    (is_limit.equiv_iso_limit
      (cones.ext
        (iso.refl
          (cone.X
            (functor.obj (cones.postcompose (iso.hom (diagram_iso_cospan (cospan f g ⋙ G))))
              (functor.map_cone G (pullback_cone.mk h k comm)))))
        sorry))

/-- The property of preserving pullbacks expressed in terms of binary fans. -/
def is_limit_pullback_cone_map_of_is_limit {C : Type u₁} [category C] {D : Type u₂} [category D] (G : C ⥤ D) {W : C} {X : C} {Y : C} {Z : C} {f : X ⟶ Z} {g : Y ⟶ Z} {h : W ⟶ X} {k : W ⟶ Y} (comm : h ≫ f = k ≫ g) [preserves_limit (cospan f g) G] (l : is_limit (pullback_cone.mk h k comm)) : is_limit (pullback_cone.mk (functor.map G h) (functor.map G k) (is_limit_map_cone_pullback_cone_equiv._proof_1 G comm)) :=
  coe_fn (is_limit_map_cone_pullback_cone_equiv G comm) (preserves_limit.preserves l)

/-- The property of reflecting pullbacks expressed in terms of binary fans. -/
def is_limit_of_is_limit_pullback_cone_map {C : Type u₁} [category C] {D : Type u₂} [category D] (G : C ⥤ D) {W : C} {X : C} {Y : C} {Z : C} {f : X ⟶ Z} {g : Y ⟶ Z} {h : W ⟶ X} {k : W ⟶ Y} (comm : h ≫ f = k ≫ g) [reflects_limit (cospan f g) G] (l : is_limit (pullback_cone.mk (functor.map G h) (functor.map G k) (is_limit_map_cone_pullback_cone_equiv._proof_1 G comm))) : is_limit (pullback_cone.mk h k comm) :=
  reflects_limit.reflects (coe_fn (equiv.symm (is_limit_map_cone_pullback_cone_equiv G comm)) l)

/--
If `G` preserves pullbacks and `C` has them, then the pullback cone constructed of the mapped
morphisms of the pullback cone is a limit.
-/
def is_limit_of_has_pullback_of_preserves_limit {C : Type u₁} [category C] {D : Type u₂} [category D] (G : C ⥤ D) {X : C} {Y : C} {Z : C} (f : X ⟶ Z) (g : Y ⟶ Z) [has_pullback f g] [preserves_limit (cospan f g) G] : is_limit
  (pullback_cone.mk (functor.map G pullback.fst) (functor.map G pullback.snd)
    (is_limit_of_has_pullback_of_preserves_limit._proof_1 G f g)) :=
  is_limit_pullback_cone_map_of_is_limit G pullback.condition (pullback_is_pullback f g)

/--
If the pullback comparison map for `G` at `(f,g)` is an isomorphism, then `G` preserves the
pullback of `(f,g)`.
-/
def preserves_pullback.of_iso_comparison {C : Type u₁} [category C] {D : Type u₂} [category D] (G : C ⥤ D) {X : C} {Y : C} {Z : C} (f : X ⟶ Z) (g : Y ⟶ Z) [has_pullback f g] [has_pullback (functor.map G f) (functor.map G g)] [i : is_iso (pullback_comparison G f g)] : preserves_limit (cospan f g) G :=
  preserves_limit_of_preserves_limit_cone (pullback_is_pullback f g)
    (coe_fn (equiv.symm (is_limit_map_cone_pullback_cone_equiv G pullback.condition))
      (is_limit.of_point_iso (limit.is_limit (cospan (functor.map G f) (functor.map G g)))))

/--
If `G` preserves the pullback of `(f,g)`, then the pullback comparison map for `G` at `(f,g)` is
an isomorphism.
-/
def preserves_pullback.iso {C : Type u₁} [category C] {D : Type u₂} [category D] (G : C ⥤ D) {X : C} {Y : C} {Z : C} (f : X ⟶ Z) (g : Y ⟶ Z) [has_pullback f g] [has_pullback (functor.map G f) (functor.map G g)] [preserves_limit (cospan f g) G] : functor.obj G (pullback f g) ≅ pullback (functor.map G f) (functor.map G g) :=
  is_limit.cone_point_unique_up_to_iso (is_limit_of_has_pullback_of_preserves_limit G f g)
    (limit.is_limit (cospan (functor.map G f) (functor.map G g)))

@[simp] theorem preserves_pullback.iso_hom {C : Type u₁} [category C] {D : Type u₂} [category D] (G : C ⥤ D) {X : C} {Y : C} {Z : C} (f : X ⟶ Z) (g : Y ⟶ Z) [has_pullback f g] [has_pullback (functor.map G f) (functor.map G g)] [preserves_limit (cospan f g) G] : iso.hom (preserves_pullback.iso G f g) = pullback_comparison G f g :=
  rfl

protected instance pullback_comparison.category_theory.is_iso {C : Type u₁} [category C] {D : Type u₂} [category D] (G : C ⥤ D) {X : C} {Y : C} {Z : C} (f : X ⟶ Z) (g : Y ⟶ Z) [has_pullback f g] [has_pullback (functor.map G f) (functor.map G g)] [preserves_limit (cospan f g) G] : is_iso (pullback_comparison G f g) :=
  eq.mpr sorry (is_iso.of_iso (preserves_pullback.iso G f g))


import tactic.simpa
import logic.equiv.basic
import logic.encodable.basic
import tactic.apply_fun
import tactic.derive_fintype
import data.tree

@[derive decidable_eq]
inductive ptree
| nil
| node (left : ptree) (right : ptree)

namespace ptree

instance : inhabited ptree := ⟨nil⟩

/-- A non-nil ptree -/
abbreviation non_nil := node nil nil

@[simp] lemma non_nil_ne : non_nil ≠ nil := by trivial

@[simp] def left : ptree → ptree
| nil := nil
| (node l r) := l

@[simp] def right : ptree → ptree
| nil := nil
| (node l r) := r

def elim {α : Type*} (b : α) (f : ptree → ptree → α) : ptree → α
| nil := b
| (node a b) := f a b

attribute [simp] ptree.nil.sizeof_spec
attribute [simp] ptree.node.sizeof_spec

@[simp] lemma sizeof_eq_sizeof (t : ptree) : sizeof t = t.sizeof := rfl

lemma left_sizeof_le (t : ptree) : t.left.sizeof ≤ t.sizeof :=
begin
  cases t, { simp },
  simp only [node.sizeof_spec, left],
  rw [nat.add_comm 1, nat.add_assoc],
  apply nat.le.intro rfl
end

lemma right_sizeof_le (t : ptree) : t.right.sizeof ≤ t.sizeof :=
begin
  cases t, { simp, },
  simp only [node.sizeof_spec, right],
  rw nat.add_comm,
  apply nat.le.intro rfl,
end

@[simp] def reverse : ptree → ptree
| nil := nil
| (node a b) := node b.reverse a.reverse

@[simp] lemma reverse_left (t : ptree) : t.reverse.left = t.right.reverse := by cases t; simp
@[simp] lemma reverse_right (t : ptree) : t.reverse.right = t.left.reverse := by cases t; simp

@[simp] lemma reverse_reverse (t : ptree) : t.reverse.reverse = t := by induction t; simp [*]

def as_list : ptree → list ptree
| nil := []
| (node a b) := a :: b.as_list

def of_list : list ptree → ptree
| [] := nil
| (a :: xs) := node a (of_list xs)

def equiv_list : ptree ≃ list ptree :=
{ to_fun := as_list,
  inv_fun := of_list,
  left_inv := λ t, by { induction t, { simp [as_list, of_list], }, simpa [as_list, of_list] },
  right_inv := λ l, by { induction l, { simp [as_list, of_list], }, simpa [as_list, of_list], } }

@[simp] lemma equiv_list_nil : equiv_list nil = [] := rfl
@[simp] lemma equiv_list_node (a b : ptree) : equiv_list (node a b) = a :: b.equiv_list := rfl
@[simp] lemma equiv_list_symm_nil : equiv_list.symm [] = nil := rfl
@[simp] lemma equiv_list_symm_conds (a : ptree) (b : list ptree) : equiv_list.symm (a :: b) = node a (equiv_list.symm b) := rfl

def to_option : ptree → option ptree
| ptree.nil := none
| x := some x.right

def of_option : option ptree → ptree
| none := ptree.nil
| (some x) := ptree.nil.node x

@[simp] lemma of_option_to_option (x : option ptree) : (of_option x).to_option  = x :=
by cases x; simp [to_option, of_option]

@[simp] lemma to_option_none (x : ptree) : x.to_option = none ↔ x = ptree.nil :=
by cases x; simp [to_option]

@[simp] lemma to_option_some (x v : ptree) : x.to_option = some v ↔ x ≠ ptree.nil ∧ x.right = v :=
by cases x; simp [to_option]

def to_nat : ptree → ℕ
| nil := 0
| (node a b) := (nat.mkpair a.to_nat b.to_nat) + 1

def of_nat : ℕ → ptree
| 0 := nil
| (n + 1) :=
  have wf₁ : (nat.unpair n).1 < n + 1 := nat.lt_succ_of_le (nat.unpair_left_le _),
  have wf₂ : (nat.unpair n).2 < n + 1 := nat.lt_succ_of_le (nat.unpair_right_le _),
node (of_nat (nat.unpair n).1) (of_nat (nat.unpair n).2)

@[simp] lemma of_nat_to_nat (x : ptree) : of_nat x.to_nat = x :=
by { induction x; simp [of_nat, to_nat, *], }

instance : encodable ptree :=
{ encode := ptree.to_nat,
  decode := some ∘ ptree.of_nat,
  encodek := λ x, by simp }

class pencodable (α : Type*) :=
(encode : α → ptree)
(decode : ptree → α)
(encodek : ∀ x, decode (encode x) = x)

attribute [simp, higher_order] pencodable.encodek
namespace pencodable

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

instance encode_ptree : pencodable ptree := ⟨id, id, λ _, rfl⟩
@[simp] lemma encode_ptree_def : (@encode ptree _) = id := rfl
@[simp] lemma decode_ptree_def : (@decode ptree _) = id := rfl

instance : pencodable (α × β) :=
{ encode := λ x, node (encode x.1) (encode x.2),
  decode := λ y, (decode y.left, decode y.right),
  encodek := λ x, by simp }
lemma encode_pair_def (x : α) (y : β) : encode (x, y) = node (encode x) (encode y) := rfl
lemma decode_pair_def (v : ptree) : @decode (α × β) _ v = (decode v.left, decode v.right) := rfl

@[priority 50]
instance : nonempty α := ⟨decode nil⟩

instance : pencodable bool :=
{ encode := λ b, cond b ptree.nil ptree.non_nil,
  decode := λ v, v = ptree.nil,
  encodek := λ b, by cases b; simp }
lemma encode_bool_def (b : bool) : encode b = cond b ptree.nil ptree.non_nil := rfl
lemma decode_bool_def (v : ptree) : (decode v : bool) ↔ v = ptree.nil := by simp [decode]
lemma decode_bool_def' (v : ptree) : (decode v : bool) = (v = ptree.nil) := rfl

instance : pencodable unit :=
{ encode := λ _, ptree.nil,
  decode := λ _, (),
  encodek := λ x, by simp }
lemma encode_unit_def : encode () = nil := rfl

protected def mk' {γ : Type*} (enc : γ → α) (dec : α → γ) (h : ∀ x, dec (enc x) = x): pencodable γ :=
{ encode := λ x, encode (enc x),
  decode := λ y, dec (decode y),
  encodek := λ x, by simp [h] }

def of_equiv {γ : Type*} (eqv : γ ≃ α) : pencodable γ :=
pencodable.mk' eqv eqv.symm (by simp)

instance : pencodable (list α) :=
{ encode := λ l, equiv_list.symm (l.map encode),
  decode := λ v, v.equiv_list.map decode,
  encodek := λ l, by simp }
lemma encode_list_def (l : list α) : encode l = equiv_list.symm (l.map encode) := rfl

lemma decode_list_def (v : ptree) : (decode v : list α) = v.equiv_list.map decode := rfl

@[simp] lemma encode_ptree_list (l : list ptree) :
  encode l = equiv_list.symm l :=
by simp [encode_list_def]

@[simp] lemma decode_ptree_list (l : ptree) :
  (decode l : list ptree) = l.equiv_list :=
by simp [decode_list_def]

lemma encode_injective : function.injective (@encode α _) :=
function.left_inverse.injective encodek

@[simp] lemma encode_inj_iff {x y : α} : encode x = encode y ↔ x = y :=
(@encode_injective α _).eq_iff

instance : pencodable (option α) :=
{ encode := λ x, ptree.of_option (x.map encode),
  decode := λ v, (ptree.to_option v).map decode,
  encodek := λ x, by simp, }

def to_encodable : encodable α :=
encodable.of_left_inverse encode decode (by simp)

end pencodable

universes u

@[simp]
def crec {α : Type u} {motive : Type u} (base : α → motive) (pre₁ pre₂ : ptree → α → α) (post : motive → motive → ptree → α → motive) : ptree → α → motive
| nil d := base d
| T@(node x y) d := post (crec x (pre₁ T d)) (crec y (pre₂ T d)) T d

lemma _root_.list.map_head' {α β} (x : list α) (f : α → β) :
  (x.map f).head' = x.head'.map f :=
by cases x; simp

inductive iterator_stack (α β : Type*)
| start : ptree → α → iterator_stack
| mid : ptree → α → β → iterator_stack
| result : β → iterator_stack

-- Rules:
-- If res ≠ none:
    -- If prev.left_res ≠ none:
      -- prev.left_res = res
    -- Else:
      -- prev.res = post prev.left_res res prev.tree prev.arg
    -- delete current
-- Else If tree ≠ nil:
    -- if left_res = none:
      -- append tree.left to stack with arg = pre₁ tree arg
    -- else:
      -- append tree.right to stack with arg = pre₂ tree arg
-- Else (i.e. res = none ∧ tree = nil):
    -- res := base arg

variables {α : Type u} {β : Type u} (base : α → β) (pre₁ pre₂ : ptree → α → α) (post : β → β → ptree → α → β)
open iterator_stack
@[simp] def stack_step :
  list (iterator_stack α β) → list (iterator_stack α β)
| (result res :: start tree arg :: xs) := mid tree arg res :: xs
| (result res :: mid tree arg left_res :: xs) := result (post left_res res tree arg) :: xs
| L@(mid tree arg left_res :: xs) := (start tree.right (pre₂ tree arg)) :: L
| (start nil arg :: xs) := result (base arg) :: xs
| L@(start (node x y) arg :: xs) := start x (pre₁ (node x y) arg) :: L
| x := x

@[simp] lemma stack_step_nil : stack_step base pre₁ pre₂ post [] = [] := rfl
@[simp] lemma stack_step_singleton (res : β) : stack_step base pre₁ pre₂ post [result res] = [result res] := rfl

def time_steps : ptree → ℕ
| nil := 1
| (node a b) := a.time_steps + b.time_steps + 4

@[simp] lemma time_steps_nil : time_steps nil = 1 := rfl
lemma time_steps_node (a b) : time_steps (node a b) = 1 + b.time_steps + 2 + a.time_steps + 1 :=
by { rw [time_steps, (show 4 = 1 + 2 + 1, from rfl)], ac_refl, }

lemma stack_step_iterate (x : ptree) (arg : α) (xs : list (iterator_stack α β)) :
  (stack_step base pre₁ pre₂ post)^[x.time_steps] (start x arg :: xs) = (result $ x.crec base pre₁ pre₂ post arg) :: xs :=
by induction x generalizing arg xs; simp [time_steps_node, function.iterate_add, *]

-- example : stack_step base pre₁ pre₂ post = id :=
-- by { ext x : 1, delta stack_step, delta id_rhs, dsimp, }

@[simp] def length : ptree → ℕ
| nil := 1
| (node a b) := a.length + b.length

end ptree


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

The (classical) real numbers ℝ. This is a direct construction
from Cauchy sequences.
-/
import order.conditionally_complete_lattice data.real.cau_seq_completion
  algebra.big_operators algebra.archimedean order.bounds

def real := @cau_seq.completion.Cauchy ℚ _ _ _ abs _
notation `ℝ` := real
local attribute [reducible] real

namespace real
open cau_seq cau_seq.completion

def of_rat (x : ℚ) : ℝ := of_rat x

instance : comm_ring ℝ := cau_seq.completion.comm_ring

/- Extra instances to short-circuit type class resolution -/
instance : ring ℝ               := by apply_instance
instance : comm_semiring ℝ      := by apply_instance
instance : semiring ℝ           := by apply_instance
instance : add_comm_group ℝ     := by apply_instance
instance : add_group ℝ          := by apply_instance
instance : add_comm_monoid ℝ    := by apply_instance
instance : add_monoid ℝ         := by apply_instance
instance : add_left_cancel_semigroup ℝ := by apply_instance
instance : add_right_cancel_semigroup ℝ := by apply_instance
instance : add_comm_semigroup ℝ := by apply_instance
instance : add_semigroup ℝ      := by apply_instance
instance : comm_monoid ℝ        := by apply_instance
instance : monoid ℝ             := by apply_instance
instance : comm_semigroup ℝ     := by apply_instance
instance : semigroup ℝ          := by apply_instance
instance : inhabited ℝ := ⟨0⟩

theorem of_rat_sub (x y : ℚ) : of_rat (x - y) = of_rat x - of_rat y :=
congr_arg mk (const_sub _ _)

instance : has_lt ℝ :=
⟨λ x y, quotient.lift_on₂ x y (<) $
  λ f₁ g₁ f₂ g₂ hf hg, propext $
  ⟨λ h, lt_of_eq_of_lt (setoid.symm hf) (lt_of_lt_of_eq h hg),
   λ h, lt_of_eq_of_lt hf (lt_of_lt_of_eq h (setoid.symm hg))⟩⟩

@[simp] theorem mk_lt {f g : cau_seq ℚ abs} : mk f < mk g ↔ f < g := iff.rfl

@[simp] theorem mk_pos {f : cau_seq ℚ abs} : 0 < mk f ↔ pos f :=
iff_of_eq (congr_arg pos (sub_zero f))

instance : has_le ℝ := ⟨λ x y, x < y ∨ x = y⟩

@[simp] theorem mk_le {f g : cau_seq ℚ abs} : mk f ≤ mk g ↔ f ≤ g :=
or_congr iff.rfl quotient.eq

theorem add_lt_add_iff_left {a b : ℝ} (c : ℝ) : c + a < c + b ↔ a < b :=
quotient.induction_on₃ a b c (λ f g h,
  iff_of_eq (congr_arg pos $ by rw add_sub_add_left_eq_sub))

instance : linear_order ℝ :=
{ le := (≤), lt := (<),
  le_refl := λ a, or.inr rfl,
  le_trans := λ a b c, quotient.induction_on₃ a b c $
    λ f g h, by simpa using le_trans,
  lt_iff_le_not_le := λ a b, quotient.induction_on₂ a b $
    λ f g, by simpa using lt_iff_le_not_le,
  le_antisymm := λ a b, quotient.induction_on₂ a b $
    λ f g, by simpa [mk_eq] using @cau_seq.le_antisymm _ _ f g,
  le_total := λ a b, quotient.induction_on₂ a b $
    λ f g, by simpa using le_total f g }

instance : partial_order ℝ := by apply_instance
instance : preorder ℝ      := by apply_instance

theorem of_rat_lt {x y : ℚ} : of_rat x < of_rat y ↔ x < y := const_lt

protected theorem zero_lt_one : (0 : ℝ) < 1 := of_rat_lt.2 zero_lt_one

protected theorem mul_pos {a b : ℝ} : 0 < a → 0 < b → 0 < a * b :=
quotient.induction_on₂ a b $ λ f g, by simpa using cau_seq.mul_pos

instance : linear_ordered_comm_ring ℝ :=
{ add_le_add_left := λ a b h c,
    (le_iff_le_iff_lt_iff_lt.2 $ real.add_lt_add_iff_left c).2 h,
  zero_ne_one := ne_of_lt real.zero_lt_one,
  mul_nonneg := λ a b a0 b0,
    match a0, b0 with
    | or.inl a0, or.inl b0 := le_of_lt (real.mul_pos a0 b0)
    | or.inr a0, _ := by simp [a0.symm]
    | _, or.inr b0 := by simp [b0.symm]
    end,
  mul_pos := @real.mul_pos,
  zero_lt_one := real.zero_lt_one,
  add_lt_add_left := λ a b h c, (real.add_lt_add_iff_left c).2 h,
  ..real.comm_ring, ..real.linear_order }

/- Extra instances to short-circuit type class resolution -/
instance : linear_ordered_ring ℝ        := by apply_instance
instance : ordered_ring ℝ               := by apply_instance
instance : linear_ordered_semiring ℝ    := by apply_instance
instance : ordered_semiring ℝ           := by apply_instance
instance : ordered_comm_group ℝ         := by apply_instance
instance : ordered_cancel_comm_monoid ℝ := by apply_instance
instance : ordered_comm_monoid ℝ        := by apply_instance
instance : domain ℝ                     := by apply_instance

local attribute [instance] classical.prop_decidable

noncomputable instance : discrete_linear_ordered_field ℝ :=
{ inv            := has_inv.inv,
  inv_mul_cancel := @cau_seq.completion.inv_mul_cancel _ _ _ _ _ _,
  mul_inv_cancel := λ x x0, by rw [mul_comm, cau_seq.completion.inv_mul_cancel x0],
  inv_zero       := inv_zero,
  decidable_le   := by apply_instance,
  ..real.linear_ordered_comm_ring }

/- Extra instances to short-circuit type class resolution -/
noncomputable instance : linear_ordered_field ℝ    := by apply_instance
noncomputable instance : decidable_linear_ordered_comm_ring ℝ := by apply_instance
noncomputable instance : decidable_linear_ordered_semiring ℝ := by apply_instance
noncomputable instance : decidable_linear_ordered_comm_group ℝ := by apply_instance
noncomputable instance real.discrete_field : discrete_field ℝ          := by apply_instance
noncomputable instance : field ℝ                   := by apply_instance
noncomputable instance : division_ring ℝ           := by apply_instance
noncomputable instance : integral_domain ℝ         := by apply_instance
noncomputable instance : nonzero_comm_ring ℝ       := by apply_instance
noncomputable instance : decidable_linear_order ℝ  := by apply_instance
noncomputable instance : lattice.distrib_lattice ℝ := by apply_instance
noncomputable instance : lattice.lattice ℝ         := by apply_instance
noncomputable instance : lattice.semilattice_inf ℝ := by apply_instance
noncomputable instance : lattice.semilattice_sup ℝ := by apply_instance
noncomputable instance : lattice.has_inf ℝ         := by apply_instance
noncomputable instance : lattice.has_sup ℝ         := by apply_instance

open rat

@[simp] theorem of_rat_eq_cast : ∀ x : ℚ, of_rat x = x :=
eq_cast of_rat rfl of_rat_add of_rat_mul

theorem le_mk_of_forall_le {x : ℝ} {f : cau_seq ℚ abs} :
  (∃ i, ∀ j ≥ i, x ≤ f j) → x ≤ mk f :=
quotient.induction_on x $ λ g h, le_of_not_lt $
λ ⟨K, K0, hK⟩,
let ⟨i, H⟩ := exists_forall_ge_and h $
  exists_forall_ge_and hK (f.cauchy₃ $ half_pos K0) in
begin
  apply not_lt_of_le (H _ (le_refl _)).1,
  rw ← of_rat_eq_cast,
  refine ⟨_, half_pos K0, i, λ j ij, _⟩,
  have := add_le_add (H _ ij).2.1
    (le_of_lt (abs_lt.1 $ (H _ (le_refl _)).2.2 _ ij).1),
  rwa [← sub_eq_add_neg, sub_self_div_two, sub_apply, sub_add_sub_cancel] at this
end

theorem mk_le_of_forall_le {f : cau_seq ℚ abs} {x : ℝ} :
  (∃ i, ∀ j ≥ i, (f j : ℝ) ≤ x) → mk f ≤ x
| ⟨i, H⟩ := by rw [← neg_le_neg_iff, mk_neg]; exact
  le_mk_of_forall_le ⟨i, λ j ij, by simp [H _ ij]⟩

theorem mk_near_of_forall_near {f : cau_seq ℚ abs} {x : ℝ} {ε : ℝ}
  (H : ∃ i, ∀ j ≥ i, abs ((f j : ℝ) - x) ≤ ε) : abs (mk f - x) ≤ ε :=
abs_sub_le_iff.2
  ⟨sub_le_iff_le_add'.2 $ mk_le_of_forall_le $
    H.imp $ λ i h j ij, sub_le_iff_le_add'.1 (abs_sub_le_iff.1 $ h j ij).1,
  sub_le.1 $ le_mk_of_forall_le $
    H.imp $ λ i h j ij, sub_le.1 (abs_sub_le_iff.1 $ h j ij).2⟩

instance : archimedean ℝ :=
archimedean_iff_rat_le.2 $ λ x, quotient.induction_on x $ λ f,
let ⟨M, M0, H⟩ := f.bounded' 0 in
⟨M, mk_le_of_forall_le ⟨0, λ i _,
  rat.cast_le.2 $ le_of_lt (abs_lt.1 (H i)).2⟩⟩

noncomputable instance : floor_ring ℝ := archimedean.floor_ring _

theorem is_cau_seq_iff_lift {f : ℕ → ℚ} : is_cau_seq abs f ↔ is_cau_seq abs (λ i, (f i : ℝ)) :=
⟨λ H ε ε0,
  let ⟨δ, δ0, δε⟩ := exists_pos_rat_lt ε0 in
  (H _ δ0).imp $ λ i hi j ij, lt_trans
    (by simpa using (@rat.cast_lt ℝ _ _ _).2 (hi _ ij)) δε,
 λ H ε ε0, (H _ (rat.cast_pos.2 ε0)).imp $
   λ i hi j ij, (@rat.cast_lt ℝ _ _ _).1 $ by simpa using hi _ ij⟩

theorem of_near (f : ℕ → ℚ) (x : ℝ)
  (h : ∀ ε > 0, ∃ i, ∀ j ≥ i, abs ((f j : ℝ) - x) < ε) :
  ∃ h', cau_seq.completion.mk ⟨f, h'⟩ = x :=
⟨is_cau_seq_iff_lift.2 (of_near _ (const abs x) h),
 sub_eq_zero.1 $ abs_eq_zero.1 $
  eq_of_le_of_forall_le_of_dense (abs_nonneg _) $ λ ε ε0,
    mk_near_of_forall_near $
    (h _ ε0).imp (λ i h j ij, le_of_lt (h j ij))⟩

theorem exists_floor (x : ℝ) : ∃ (ub : ℤ), (ub:ℝ) ≤ x ∧
   ∀ (z : ℤ), (z:ℝ) ≤ x → z ≤ ub :=
int.exists_greatest_of_bdd
  (let ⟨n, hn⟩ := exists_int_gt x in ⟨n, λ z h',
    int.cast_le.1 $ le_trans h' $ le_of_lt hn⟩)
  (let ⟨n, hn⟩ := exists_int_lt x in ⟨n, le_of_lt hn⟩)

theorem exists_sup (S : set ℝ) : (∃ x, x ∈ S) → (∃ x, ∀ y ∈ S, y ≤ x) →
  ∃ x, ∀ y, x ≤ y ↔ ∀ z ∈ S, z ≤ y
| ⟨L, hL⟩ ⟨U, hU⟩ := begin
  have,
  { refine λ d : ℕ, @int.exists_greatest_of_bdd
      (λ n, ∃ y ∈ S, (n:ℝ) ≤ y * d) _ _ _,
    { cases exists_int_gt U with k hk,
      refine ⟨k * d, λ z h, _⟩,
      rcases h with ⟨y, yS, hy⟩,
      refine int.cast_le.1 (le_trans hy _),
      simp,
      exact mul_le_mul_of_nonneg_right
        (le_trans (hU _ yS) (le_of_lt hk)) (nat.cast_nonneg _) },
    { exact ⟨⌊L * d⌋, L, hL, floor_le _⟩ } },
  cases classical.axiom_of_choice this with f hf,
  dsimp at f hf,
  have hf₁ : ∀ n > 0, ∃ y ∈ S, ((f n / n:ℚ):ℝ) ≤ y := λ n n0,
    let ⟨y, yS, hy⟩ := (hf n).1 in
    ⟨y, yS, by simpa using (div_le_iff (nat.cast_pos.2 n0)).2 hy⟩,
  have hf₂ : ∀ (n > 0) (y ∈ S), (y - (n:ℕ)⁻¹ : ℝ) < (f n / n:ℚ),
  { intros n n0 y yS,
    have := lt_of_lt_of_le (sub_one_lt_floor _)
      (int.cast_le.2 $ (hf n).2 _ ⟨y, yS, floor_le _⟩),
    simp [-sub_eq_add_neg],
    rwa [lt_div_iff (nat.cast_pos.2 n0), sub_mul, _root_.inv_mul_cancel],
    exact ne_of_gt (nat.cast_pos.2 n0) },
  suffices hg, let g : cau_seq ℚ abs := ⟨λ n, f n / n, hg⟩,
  refine ⟨mk g, λ y, ⟨λ h x xS, le_trans _ h, λ h, _⟩⟩,
  { refine le_of_forall_ge_of_dense (λ z xz, _),
    cases exists_nat_gt (x - z)⁻¹ with K hK,
    refine le_mk_of_forall_le ⟨K, λ n nK, _⟩,
    replace xz := sub_pos.2 xz,
    replace hK := le_trans (le_of_lt hK) (nat.cast_le.2 nK),
    have n0 : 0 < n := nat.cast_pos.1 (lt_of_lt_of_le (inv_pos xz) hK),
    refine le_trans _ (le_of_lt $ hf₂ _ n0 _ xS),
    rwa [le_sub, inv_le (nat.cast_pos.2 n0) xz] },
  { exact mk_le_of_forall_le ⟨1, λ n n1,
      let ⟨x, xS, hx⟩ := hf₁ _ n1 in le_trans hx (h _ xS)⟩ },
  intros ε ε0,
  suffices : ∀ j k ≥ nat_ceil ε⁻¹, (f j / j - f k / k : ℚ) < ε,
  { refine ⟨_, λ j ij, abs_lt.2 ⟨_, this _ _ ij (le_refl _)⟩⟩,
    rw [neg_lt, neg_sub], exact this _ _ (le_refl _) ij },
  intros j k ij ik,
  replace ij := le_trans (le_nat_ceil _) (nat.cast_le.2 ij),
  replace ik := le_trans (le_nat_ceil _) (nat.cast_le.2 ik),
  have j0 := nat.cast_pos.1 (lt_of_lt_of_le (inv_pos ε0) ij),
  have k0 := nat.cast_pos.1 (lt_of_lt_of_le (inv_pos ε0) ik),
  rcases hf₁ _ j0 with ⟨y, yS, hy⟩,
  refine lt_of_lt_of_le ((@rat.cast_lt ℝ _ _ _).1 _)
    ((inv_le ε0 (nat.cast_pos.2 k0)).1 ik),
  simpa using sub_lt_iff_lt_add'.2
    (lt_of_le_of_lt hy $ sub_lt_iff_lt_add.1 $ hf₂ _ k0 _ yS)
end

noncomputable def Sup (S : set ℝ) : ℝ :=
if h : (∃ x, x ∈ S) ∧ (∃ x, ∀ y ∈ S, y ≤ x)
then classical.some (exists_sup S h.1 h.2) else 0

theorem Sup_le (S : set ℝ) (h₁ : ∃ x, x ∈ S) (h₂ : ∃ x, ∀ y ∈ S, y ≤ x)
  {y} : Sup S ≤ y ↔ ∀ z ∈ S, z ≤ y :=
by simp [Sup, h₁, h₂]; exact
classical.some_spec (exists_sup S h₁ h₂) y

theorem lt_Sup (S : set ℝ) (h₁ : ∃ x, x ∈ S) (h₂ : ∃ x, ∀ y ∈ S, y ≤ x)
  {y} : y < Sup S ↔ ∃ z ∈ S, y < z :=
by simpa [not_forall] using not_congr (@Sup_le S h₁ h₂ y)

theorem le_Sup (S : set ℝ) (h₂ : ∃ x, ∀ y ∈ S, y ≤ x) {x} (xS : x ∈ S) : x ≤ Sup S :=
(Sup_le S ⟨_, xS⟩ h₂).1 (le_refl _) _ xS

theorem Sup_le_ub (S : set ℝ) (h₁ : ∃ x, x ∈ S) {ub} (h₂ : ∀ y ∈ S, y ≤ ub) : Sup S ≤ ub :=
(Sup_le S h₁ ⟨_, h₂⟩).2 h₂

protected lemma is_lub_Sup {s : set ℝ} {a b : ℝ} (ha : a ∈ s) (hb : b ∈ upper_bounds s) :
  is_lub s (Sup s) :=
⟨λ x xs, real.le_Sup s ⟨_, hb⟩ xs,
 λ u h, real.Sup_le_ub _ ⟨_, ha⟩ h⟩

noncomputable def Inf (S : set ℝ) : ℝ := -Sup {x | -x ∈ S}

theorem le_Inf (S : set ℝ) (h₁ : ∃ x, x ∈ S) (h₂ : ∃ x, ∀ y ∈ S, x ≤ y)
  {y} : y ≤ Inf S ↔ ∀ z ∈ S, y ≤ z :=
begin
  refine le_neg.trans ((Sup_le _ _ _).trans _),
  { cases h₁ with x xS, exact ⟨-x, by simp [xS]⟩ },
  { cases h₂ with ub h, exact ⟨-ub, λ y hy, le_neg.1 $ h _ hy⟩ },
  split; intros H z hz,
  { exact neg_le_neg_iff.1 (H _ $ by simp [hz]) },
  { exact le_neg.2 (H _ hz) }
end

theorem Inf_lt (S : set ℝ) (h₁ : ∃ x, x ∈ S) (h₂ : ∃ x, ∀ y ∈ S, x ≤ y)
  {y} : Inf S < y ↔ ∃ z ∈ S, z < y :=
by simpa [not_forall] using not_congr (@le_Inf S h₁ h₂ y)

theorem Inf_le (S : set ℝ) (h₂ : ∃ x, ∀ y ∈ S, x ≤ y) {x} (xS : x ∈ S) : Inf S ≤ x :=
(le_Inf S ⟨_, xS⟩ h₂).1 (le_refl _) _ xS

theorem lb_le_Inf (S : set ℝ) (h₁ : ∃ x, x ∈ S) {lb} (h₂ : ∀ y ∈ S, lb ≤ y) : lb ≤ Inf S :=
(le_Inf S h₁ ⟨_, h₂⟩).2 h₂

open lattice
noncomputable instance lattice : lattice ℝ := by apply_instance

noncomputable instance : conditionally_complete_linear_order ℝ :=
{ Sup := real.Sup,
  Inf := real.Inf,
  le_cSup :=
    assume (s : set ℝ) (a : ℝ) (_ : bdd_above s) (_ : a ∈ s),
    show a ≤ Sup s,
      from le_Sup s ‹bdd_above s› ‹a ∈ s›,
  cSup_le :=
    assume (s : set ℝ) (a : ℝ) (_ : s ≠ ∅) (H : ∀b∈s, b ≤ a),
    show Sup s ≤ a,
      from Sup_le_ub s (set.exists_mem_of_ne_empty ‹s ≠ ∅›) H,
  cInf_le :=
    assume (s : set ℝ) (a : ℝ) (_ : bdd_below s) (_ : a ∈ s),
    show Inf s ≤ a,
      from Inf_le s ‹bdd_below s› ‹a ∈ s›,
  le_cInf :=
    assume (s : set ℝ) (a : ℝ) (_ : s ≠ ∅) (H : ∀b∈s, a ≤ b),
    show a ≤ Inf s,
      from lb_le_Inf s (set.exists_mem_of_ne_empty ‹s ≠ ∅›) H,
 ..real.linear_order, ..real.lattice}

theorem Sup_empty : lattice.Sup (∅ : set ℝ) = 0 := dif_neg $ by simp

theorem Sup_of_not_bdd_above {s : set ℝ} (hs : ¬ bdd_above s) : lattice.Sup s = 0 :=
dif_neg $ assume h, hs h.2

theorem Inf_empty : lattice.Inf (∅ : set ℝ) = 0 :=
show Inf ∅ = 0, by simp [Inf]; exact Sup_empty

theorem Inf_of_not_bdd_below {s : set ℝ} (hs : ¬ bdd_below s) : lattice.Inf s = 0 :=
have bdd_above {x | -x ∈ s} → bdd_below s, from
  assume ⟨b, hb⟩, ⟨-b, assume x hxs, neg_le.2 $ hb _ $ by simp [hxs]⟩,
have ¬ bdd_above {x | -x ∈ s}, from mt this hs,
neg_eq_zero.2 $ Sup_of_not_bdd_above $ this

theorem cau_seq_converges (f : cau_seq ℝ abs) : ∃ x, f ≈ const abs x :=
begin
  let S := {x : ℝ | const abs x < f},
  have lb : ∃ x, x ∈ S := exists_lt f,
  have ub' : ∀ x, f < const abs x → ∀ y ∈ S, y ≤ x :=
    λ x h y yS, le_of_lt $ const_lt.1 $ cau_seq.lt_trans yS h,
  have ub : ∃ x, ∀ y ∈ S, y ≤ x := (exists_gt f).imp ub',
  refine ⟨Sup S,
    ((lt_total _ _).resolve_left (λ h, _)).resolve_right (λ h, _)⟩,
  { rcases h with ⟨ε, ε0, i, ih⟩,
    refine not_lt_of_le (Sup_le_ub S lb (ub' _ _))
      ((sub_lt_self_iff _).2 (half_pos ε0)),
    refine ⟨_, half_pos ε0, i, λ j ij, _⟩,
    rw [sub_apply, const_apply, sub_right_comm,
      le_sub_iff_add_le, add_halves],
    exact ih _ ij },
  { rcases h with ⟨ε, ε0, i, ih⟩,
    refine not_lt_of_le (le_Sup S ub _)
      ((lt_add_iff_pos_left _).2 (half_pos ε0)),
    refine ⟨_, half_pos ε0, i, λ j ij, _⟩,
    rw [sub_apply, const_apply, add_comm, ← sub_sub,
      le_sub_iff_add_le, add_halves],
    exact ih _ ij }
end

section lim

open cau_seq

noncomputable def lim (f : ℕ → ℝ) : ℝ :=
if hf : is_cau_seq abs f then
  classical.some (cau_seq_converges ⟨f, hf⟩)
else 0

theorem equiv_lim (f : cau_seq ℝ abs) : f ≈ const abs (lim f) :=
by simp [lim, f.is_cau]; cases f with f hf;
   exact classical.some_spec (cau_seq_converges ⟨f, hf⟩)

lemma eq_lim_of_const_equiv {f : cau_seq ℝ abs} {x : ℝ} (h : cau_seq.const abs x ≈ f) : x = lim f :=
const_equiv.mp $ setoid.trans h $ equiv_lim f

lemma lim_eq_of_equiv_const {f : cau_seq ℝ abs} {x : ℝ} (h : f ≈ cau_seq.const abs x) : lim f = x :=
(eq_lim_of_const_equiv $ setoid.symm h).symm

lemma lim_eq_lim_of_equiv {f g : cau_seq ℝ abs} (h : f ≈ g) : lim f = lim g :=
lim_eq_of_equiv_const $ setoid.trans h $ equiv_lim g

@[simp] lemma lim_const (x : ℝ) : lim (const abs x) = x :=
lim_eq_of_equiv_const $ setoid.refl _

lemma lim_add (f g : cau_seq ℝ abs) : lim f + lim g = lim ⇑(f + g) :=
eq_lim_of_const_equiv $ show lim_zero (const abs (lim ⇑f + lim ⇑g) - (f + g)),
  by rw [const_add, add_sub_comm];
  exact add_lim_zero (setoid.symm (equiv_lim f)) (setoid.symm (equiv_lim g))

lemma lim_mul_lim (f g : cau_seq ℝ abs) : lim f * lim g = lim ⇑(f * g) :=
eq_lim_of_const_equiv $ show lim_zero (const abs (lim ⇑f * lim ⇑g) - f * g),
  from have h : const abs (lim ⇑f * lim ⇑g) - f * g = g * (const abs (lim f) - f)
      + const abs (lim f) * (const abs (lim g) - g) :=
    by simp [mul_sub, mul_comm, const_mul, mul_add],
  by rw h; exact add_lim_zero (mul_lim_zero _ (setoid.symm (equiv_lim f)))
      (mul_lim_zero _ (setoid.symm (equiv_lim g)))

lemma lim_mul (f : cau_seq ℝ abs) (x : ℝ) : lim f * x = lim ⇑(f * const abs x) :=
by rw [← lim_mul_lim, lim_const]

lemma lim_neg (f : cau_seq ℝ abs) : lim ⇑(-f) = -lim f :=
lim_eq_of_equiv_const (show lim_zero (-f - const abs (-lim ⇑f)),
  by rw [const_neg, sub_neg_eq_add, add_comm];
  exact setoid.symm (equiv_lim f))

lemma lim_eq_zero_iff (f : cau_seq ℝ abs) : lim f = 0 ↔ lim_zero f :=
⟨assume h,
  by have hf := equiv_lim f;
  rw h at hf;
  exact (lim_zero_congr hf).mpr (const_lim_zero.mpr rfl),
assume h,
  have h₁ : f = (f - const abs 0) := ext (λ n, by simp [sub_apply, const_apply]),
  by rw h₁ at h; exact lim_eq_of_equiv_const h ⟩

lemma lim_inv {f : cau_seq ℝ abs} (hf : ¬ lim_zero f) : lim ⇑(inv f hf) = (lim f)⁻¹ :=
have hl : lim f ≠ 0 := by rwa ← lim_eq_zero_iff at hf,
lim_eq_of_equiv_const $ show lim_zero (inv f hf - const abs (lim ⇑f)⁻¹),
  from have h₁ : ∀ (g f : cau_seq ℝ abs) (hf : ¬ lim_zero f), lim_zero (g - f * inv f hf * g) :=
    λ g f hf, by rw [← one_mul g, ← mul_assoc, ← sub_mul, mul_one, mul_comm, mul_comm f];
    exact mul_lim_zero _ (setoid.symm (cau_seq.inv_mul_cancel _)),
  have h₂ : lim_zero ((inv f hf - const abs (lim ⇑f)⁻¹) - (const abs (lim f) - f) *
      (inv f hf * const abs (lim ⇑f)⁻¹)) :=
    by rw [sub_mul, ← sub_add, sub_sub, sub_add_eq_sub_sub, sub_right_comm, sub_add];
    exact show lim_zero (inv f hf - const abs (lim ⇑f) * (inv f hf * const abs (lim ⇑f)⁻¹)
      - (const abs (lim ⇑f)⁻¹ - f * (inv f hf * const abs (lim ⇑f)⁻¹))),
    from sub_lim_zero
      (by rw [← mul_assoc, mul_right_comm, const_inv hl]; exact h₁ _ _ _)
      (by rw [← mul_assoc]; exact h₁ _ _ _),
  (lim_zero_congr h₂).mpr $ by rw mul_comm; exact mul_lim_zero _ (setoid.symm (equiv_lim f))

end lim

theorem sqrt_exists : ∀ {x : ℝ}, 0 ≤ x → ∃ y, 0 ≤ y ∧ y * y = x :=
suffices H : ∀ {x : ℝ}, 0 < x → x ≤ 1 → ∃ y, 0 < y ∧ y * y = x, begin
  intros x x0, cases x0,
  cases le_total x 1 with x1 x1,
  { rcases H x0 x1 with ⟨y, y0, hy⟩,
    exact ⟨y, le_of_lt y0, hy⟩ },
  { have := (inv_le_inv x0 zero_lt_one).2 x1,
    rw inv_one at this,
    rcases H (inv_pos x0) this with ⟨y, y0, hy⟩,
    refine ⟨y⁻¹, le_of_lt (inv_pos y0), _⟩, rw [← mul_inv', hy, inv_inv'] },
  { exact ⟨0, by simp [x0.symm]⟩ }
end,
λ x x0 x1, begin
  let S := {y | 0 < y ∧ y * y ≤ x},
  have lb : x ∈ S := ⟨x0, by simpa using (mul_le_mul_right x0).2 x1⟩,
  have ub : ∀ y ∈ S, (y:ℝ) ≤ 1,
  { intros y yS, cases yS with y0 yx,
    refine (mul_self_le_mul_self_iff (le_of_lt y0) zero_le_one).2 _,
    simpa using le_trans yx x1 },
  have S0 : 0 < Sup S := lt_of_lt_of_le x0 (le_Sup _ ⟨_, ub⟩ lb),
  refine ⟨Sup S, S0, le_antisymm (not_lt.1 $ λ h, _) (not_lt.1 $ λ h, _)⟩,
  { rw [← div_lt_iff S0, lt_Sup S ⟨_, lb⟩ ⟨_, ub⟩] at h,
    rcases h with ⟨y, ⟨y0, yx⟩, hy⟩,
    rw [div_lt_iff S0, ← div_lt_iff' y0, lt_Sup S ⟨_, lb⟩ ⟨_, ub⟩] at hy,
    rcases hy with ⟨z, ⟨z0, zx⟩, hz⟩,
    rw [div_lt_iff y0] at hz,
    exact not_lt_of_lt
      ((mul_lt_mul_right y0).1 (lt_of_le_of_lt yx hz))
      ((mul_lt_mul_left z0).1 (lt_of_le_of_lt zx hz)) },
  { let s := Sup S, let y := s + (x - s * s) / 3,
    replace h : 0 < x - s * s := sub_pos.2 h,
    have _30 := bit1_pos zero_le_one,
    have : s < y := (lt_add_iff_pos_right _).2 (div_pos h _30),
    refine not_le_of_lt this (le_Sup S ⟨_, ub⟩ ⟨lt_trans S0 this, _⟩),
    rw [add_mul_self_eq, add_assoc, ← le_sub_iff_add_le', ← add_mul,
      ← le_div_iff (div_pos h _30), div_div_cancel (ne_of_gt h)],
    apply add_le_add,
    { simpa using (mul_le_mul_left (@two_pos ℝ _)).2 (Sup_le_ub _ ⟨_, lb⟩ ub) },
    { rw [div_le_one_iff_le _30],
      refine le_trans (sub_le_self _ (mul_self_nonneg _)) (le_trans x1 _),
      exact (le_add_iff_nonneg_left _).2 (le_of_lt two_pos) } }
end

def sqrt_aux (f : cau_seq ℚ abs) : ℕ → ℚ
| 0       := rat.mk_nat (f 0).num.to_nat.sqrt (f 0).denom.sqrt
| (n + 1) := let s := sqrt_aux n in max 0 $ (s + f (n+1) / s) / 2

theorem sqrt_aux_nonneg (f : cau_seq ℚ abs) : ∀ i : ℕ, 0 ≤ sqrt_aux f i
| 0       := by rw [sqrt_aux, mk_nat_eq, mk_eq_div];
  apply div_nonneg'; exact int.cast_nonneg.2 (int.of_nat_nonneg _)
| (n + 1) := le_max_left _ _

/- TODO(Mario): finish the proof
theorem sqrt_aux_converges (f : cau_seq ℚ abs) : ∃ h x, 0 ≤ x ∧ x * x = max 0 (mk f) ∧
  mk ⟨sqrt_aux f, h⟩ = x :=
begin
  rcases sqrt_exists (le_max_left 0 (mk f)) with ⟨x, x0, hx⟩,
  suffices : ∃ h, mk ⟨sqrt_aux f, h⟩ = x,
  { exact this.imp (λ h e, ⟨x, x0, hx, e⟩) },
  apply of_near,

  suffices : ∃ δ > 0, ∀ i, abs (↑(sqrt_aux f i) - x) < δ / 2 ^ i,
  { rcases this with ⟨δ, δ0, hδ⟩,
    intros,
     }
end -/

noncomputable def sqrt (x : ℝ) : ℝ :=
classical.some (sqrt_exists (le_max_left 0 x))
/-quotient.lift_on x
  (λ f, mk ⟨sqrt_aux f, (sqrt_aux_converges f).fst⟩)
  (λ f g e, begin
    rcases sqrt_aux_converges f with ⟨hf, x, x0, xf, xs⟩,
    rcases sqrt_aux_converges g with ⟨hg, y, y0, yg, ys⟩,
    refine xs.trans (eq.trans _ ys.symm),
    rw [← @mul_self_inj_of_nonneg ℝ _ x y x0 y0, xf, yg],
    congr' 1, exact quotient.sound e
  end)-/

theorem sqrt_prop (x : ℝ) : 0 ≤ sqrt x ∧ sqrt x * sqrt x = max 0 x :=
classical.some_spec (sqrt_exists (le_max_left 0 x))
/-quotient.induction_on x $ λ f,
by rcases sqrt_aux_converges f with ⟨hf, _, x0, xf, rfl⟩; exact ⟨x0, xf⟩-/

theorem sqrt_eq_zero_of_nonpos {x : ℝ} (h : x ≤ 0) : sqrt x = 0 :=
eq_zero_of_mul_self_eq_zero $ (sqrt_prop x).2.trans $ max_eq_left h

theorem sqrt_nonneg (x : ℝ) : 0 ≤ sqrt x := (sqrt_prop x).1

@[simp] theorem mul_self_sqrt {x : ℝ} (h : 0 ≤ x) : sqrt x * sqrt x = x :=
(sqrt_prop x).2.trans (max_eq_right h)

@[simp] theorem sqrt_mul_self {x : ℝ} (h : 0 ≤ x) : sqrt (x * x) = x :=
(mul_self_inj_of_nonneg (sqrt_nonneg _) h).1 (mul_self_sqrt (mul_self_nonneg _))

theorem sqrt_eq_iff_mul_self_eq {x y : ℝ} (hx : 0 ≤ x) (hy : 0 ≤ y) :
  sqrt x = y ↔ y * y = x :=
⟨λ h, by rw [← h, mul_self_sqrt hx],
 λ h, by rw [← h, sqrt_mul_self hy]⟩

@[simp] theorem sqr_sqrt {x : ℝ} (h : 0 ≤ x) : sqrt x ^ 2 = x :=
by rw [pow_two, mul_self_sqrt h]

@[simp] theorem sqrt_sqr {x : ℝ} (h : 0 ≤ x) : sqrt (x ^ 2) = x :=
by rw [pow_two, sqrt_mul_self h]

theorem sqrt_eq_iff_sqr_eq {x y : ℝ} (hx : 0 ≤ x) (hy : 0 ≤ y) :
  sqrt x = y ↔ y ^ 2 = x :=
by rw [pow_two, sqrt_eq_iff_mul_self_eq hx hy]

theorem sqrt_mul_self_eq_abs (x : ℝ) : sqrt (x * x) = abs x :=
(le_total 0 x).elim
  (λ h, (sqrt_mul_self h).trans (abs_of_nonneg h).symm)
  (λ h, by rw [← neg_mul_neg,
    sqrt_mul_self (neg_nonneg.2 h), abs_of_nonpos h])

theorem sqrt_sqr_eq_abs (x : ℝ) : sqrt (x ^ 2) = abs x :=
by rw [pow_two, sqrt_mul_self_eq_abs]

@[simp] theorem sqrt_zero : sqrt 0 = 0 :=
by simpa using sqrt_mul_self (le_refl _)

@[simp] theorem sqrt_one : sqrt 1 = 1 :=
by simpa using sqrt_mul_self zero_le_one

@[simp] theorem sqrt_le {x y : ℝ} (hx : 0 ≤ x) (hy : 0 ≤ y) : sqrt x ≤ sqrt y ↔ x ≤ y :=
by rw [mul_self_le_mul_self_iff (sqrt_nonneg _) (sqrt_nonneg _),
       mul_self_sqrt hx, mul_self_sqrt hy]

@[simp] theorem sqrt_lt {x y : ℝ} (hx : 0 ≤ x) (hy : 0 ≤ y) : sqrt x < sqrt y ↔ x < y :=
le_iff_le_iff_lt_iff_lt.1 (sqrt_le hy hx)

@[simp] theorem sqrt_inj {x y : ℝ} (hx : 0 ≤ x) (hy : 0 ≤ y) : sqrt x = sqrt y ↔ x = y :=
by simp [le_antisymm_iff, hx, hy]

@[simp] theorem sqrt_eq_zero {x : ℝ} (h : 0 ≤ x) : sqrt x = 0 ↔ x = 0 :=
by simpa using sqrt_inj h (le_refl _)

theorem sqrt_eq_zero' {x : ℝ} : sqrt x = 0 ↔ x ≤ 0 :=
(le_total x 0).elim
  (λ h, by simp [h, sqrt_eq_zero_of_nonpos])
  (λ h, by simp [h]; simp [le_antisymm_iff, h])

@[simp] theorem sqrt_pos {x : ℝ} : 0 < sqrt x ↔ 0 < x :=
le_iff_le_iff_lt_iff_lt.1 (iff.trans
  (by simp [le_antisymm_iff, sqrt_nonneg]) sqrt_eq_zero')

@[simp] theorem sqrt_mul' (x) {y : ℝ} (hy : 0 ≤ y) : sqrt (x * y) = sqrt x * sqrt y :=
begin
  cases le_total 0 x with hx hx,
  { refine (mul_self_inj_of_nonneg _ (mul_nonneg _ _)).1 _; try {apply sqrt_nonneg},
    rw [mul_self_sqrt (mul_nonneg hx hy), mul_assoc,
        mul_left_comm (sqrt y), mul_self_sqrt hy, ← mul_assoc, mul_self_sqrt hx] },
  { rw [sqrt_eq_zero'.2 (mul_nonpos_of_nonpos_of_nonneg hx hy),
        sqrt_eq_zero'.2 hx, zero_mul] }
end

@[simp] theorem sqrt_mul {x : ℝ} (hx : 0 ≤ x) (y : ℝ) : sqrt (x * y) = sqrt x * sqrt y :=
by rw [mul_comm, sqrt_mul' _ hx, mul_comm]

@[simp] theorem sqrt_inv (x : ℝ) : sqrt x⁻¹ = (sqrt x)⁻¹ :=
(le_or_lt x 0).elim
  (λ h, by simp [sqrt_eq_zero'.2, inv_nonpos, h])
  (λ h, by rw [
    ← mul_self_inj_of_nonneg (sqrt_nonneg _) (le_of_lt $ inv_pos $ sqrt_pos.2 h),
    mul_self_sqrt (le_of_lt $ inv_pos h), ← mul_inv', mul_self_sqrt (le_of_lt h)])

@[simp] theorem sqrt_div {x : ℝ} (hx : 0 ≤ x) (y : ℝ) : sqrt (x / y) = sqrt x / sqrt y :=
by rw [division_def, sqrt_mul hx, sqrt_inv]; refl

end real