/-
Copyright (c) 2022 María Inés de Frutos-Fernández. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: María Inés de Frutos-Fernández
-/
import fractional_ideal
import ring_theory.valuation.integers
import topology.algebra.localization

/-!
# The finite adèle ring of a Dedekind domain
Given a Dedekind domain `R` with field of fractions `K` and a maximal ideal `v` of `R`,
we define the completion of `K` with respect to its `v`-adic valuation, denoted `adic_completion`,
and its ring of integers, denoted `adic_completion_integers`.

We define the ring of finite adèles of a Dedekind domain. We provide two equivalent definitions of
this ring (TODO: show that they are equivalent).

We show that there is an injective ring homomorphism from the field of fractions of a Dedekind
domain of Krull dimension 1 to its finite adèle ring.

## Main definitions
- `adic_completion`   : the completion of `K` with respect to its `v`-adic valuation.
- `adic_completion_integers`   : the ring of integers of `adic_completion`.
- `R_hat` : product of `adic_completion_integers`, where `v` runs over all maximal ideals of `R`.
- `K_hat` : the product of `adic_completion`, where `v` runs over all maximal ideals of `R`.
- `finite_adele_ring'` : The finite adèle ring of `R`, defined as the restricted product
  `Π'_v adic_completion`.
- `inj_K` : The diagonal inclusion of `K` in `finite_adele_ring' R K`.
- `finite_adele_ring` : The finite adèle ring of `R`, defined as the localization of `R_hat` at the
  submonoid `R∖{0}`.
- `finite_adele.hom` : A ring homomorphism from `finite_adele_ring R K` to `finite_adele_ring' R K`.

## Main results
- `inj_K.ring_hom` : `inj_K` is a ring homomorphism.
- `inj_K.injective` : `inj_K` is injective for every Dedekind domain of Krull dimension 1.

## Implementation notes
We are only interested on Dedekind domains of Krull dimension 1 (i.e., not fields). If `R` is a
field, its finite adèle ring is just defined to be empty.

## References
* [J.W.S. Cassels, A. Frölich, *Algebraic Number Theory*][cassels1967algebraic]

## Tags
finite adèle ring, dedekind domain, completions
-/

noncomputable theory
open_locale classical
open function set

/- Auxiliary lemmas. -/
private lemma subset.three_union {α : Type*} (f g h : α → Prop):
  {a : α| ¬ (f a ∧ g a ∧ h a)} ⊆ {a : α| ¬ f a} ∪ {a : α| ¬ g a} ∪ {a : α| ¬ h a} :=
begin
  intros a ha,
  rw mem_set_of_eq at ha,
  push_neg at ha,
  by_cases hf : f a,
  { by_cases hg : g a,
    { exact mem_union_right _ (ha hf hg)},
    { exact mem_union_left _ (mem_union_right _ hg), }},
  { exact mem_union_left _ (mem_union_left _ hf),},
end

lemma mul_le_one₀ {α : Type*} [linear_ordered_comm_group_with_zero α] {x y : α} (hx : x ≤ 1)
  (hy : y ≤ 1): x*y ≤ 1 := mul_le_one' hx hy

/-- Auxiliary definition to force a definition to be noncomputable. This is used to avoid timeouts
or memory errors when Lean cannot decide whether a certain definition is computable.
Author: Gabriel Ebner. -/
noncomputable def force_noncomputable {α : Sort*} (a : α) : α :=
function.const _ a (classical.choice ⟨a⟩)

@[simp]
lemma force_noncomputable_def {α} (a : α) : force_noncomputable a = a := rfl

/-! ### Completions with respect to adic valuations
Given a Dedekind domain `R` with field of fractions `K` and a maximal ideal `v` of `R`, we define
the completion of `K` with respect to its `v`-adic valuation, denoted `adic_completion`,and its ring
of integers, denoted `adic_completion_integers`.

We define `R_hat` (resp. `K_hat`) to be the product of `adic_completion_integers` (resp.
`adic_completion`), where `v` runs over all maximal ideals of `R`. -/

variables {R : Type} {K : Type} [comm_ring R] [is_domain R] [is_dedekind_domain R] [field K]
  [algebra R K] [is_fraction_ring R K] (v : maximal_spectrum R)

namespace maximal_spectrum

/-- `K` as a valued field with the `v`-adic valuation. -/
def adic_valued : valued K (with_zero (multiplicative ℤ)) := ⟨v.valuation⟩

lemma adic_valued_def {x : K} : @valued.v K _ _ _ v.adic_valued (x) = v.valuation_def x := rfl

/-- The topological space structure on `K` corresponding to the `v`-adic valuation. -/
def ts' : topological_space K := @valued.topological_space K _ _ _ v.adic_valued
lemma tdr' : @topological_division_ring K _ (ts' v) :=
@valued.topological_division_ring K _ _ _ v.adic_valued
lemma tr' : @topological_ring K  (ts' v) _ := infer_instance
lemma tg' : @topological_add_group K (ts' v) _ := infer_instance
/-- The uniform space structure on `K` corresponding to the `v`-adic valuation. -/
def us' : uniform_space K := @topological_add_group.to_uniform_space K _ (ts' v) (tg' v)
lemma ug' : @uniform_add_group K (us' v) _ :=
@topological_add_group_is_uniform K _ (ts' v) (tg' v)
lemma cf' : @completable_top_field K _ (us' v) := @valued.completable K _ _ _ v.adic_valued
lemma ss : @separated_space K (us' v) := @valued_ring.separated K _ _ _ v.adic_valued

variables (K)
/-- The completion of `K` with respect to its `v`-adic valuation. -/
def adic_completion := @uniform_space.completion K (us' v)
instance : field (v.adic_completion K) := @field_completion K _ (us' v) (tdr' v) _ (ug' v)

instance : inhabited (v.adic_completion K) := ⟨0⟩

variables {K}
instance valued_adic_completion : valued (v.adic_completion K) (with_zero (multiplicative ℤ)):=
⟨@valued.extension_valuation K _ _ _ (v.adic_valued)⟩

lemma valued_adic_completion_def {x : v.adic_completion K} :
  valued.v (x) = @valued.extension K _ _ _ (v.adic_valued)  x := rfl

instance ts : topological_space (v.adic_completion K) :=
@valued.topological_space (v.adic_completion K) _ _ _ v.valued_adic_completion
instance tdr : @topological_division_ring (v.adic_completion K) _ v.ts :=
@valued.topological_division_ring (v.adic_completion K) _ _ _ v.valued_adic_completion
instance tr : @topological_ring (v.adic_completion K) v.ts _ := infer_instance
instance tg : @topological_add_group (v.adic_completion K) v.ts _ := infer_instance
instance us : uniform_space (v.adic_completion K) :=
@uniform_space.completion.uniform_space K v.us'
instance ug : @uniform_add_group (v.adic_completion K) v.us _ :=
@uniform_space.completion.uniform_add_group K v.us' _ v.ug'
instance cs : complete_space (v.adic_completion K) :=
@uniform_space.completion.complete_space K v.us'
instance : has_lift_t K (@uniform_space.completion K (us' v)) := infer_instance
instance adic_completion.has_lift_t : has_lift_t K (v.adic_completion K) :=
uniform_space.completion.has_lift_t v

variables (K)
/-- The ring of integers of `adic_completion`. -/
def adic_completion_integers : subring (v.adic_completion K) :=
@valuation.integer (v.adic_completion K) (with_zero (multiplicative ℤ)) _ _
  v.valued_adic_completion.v

end maximal_spectrum

variables (R K)

/-- The product of all `adic_completion_integers`, where `v` runs over the maximal ideals of `R`. -/
def R_hat := (Π (v : maximal_spectrum R), v.adic_completion_integers K)
instance : comm_ring (R_hat R K) := pi.comm_ring
instance : topological_space (R_hat R K) := Pi.topological_space
instance : inhabited (R_hat R K) := ⟨(λ v, 0)⟩

/-- The product of all `adic_completion`, where `v` runs over the maximal ideals of `R`. -/
def K_hat := (Π (v : maximal_spectrum R), v.adic_completion K )

instance : inhabited (K_hat R K) := ⟨(λ v, 0)⟩
instance : comm_ring (K_hat R K) := pi.comm_ring
instance : ring (K_hat R K) := infer_instance
instance : topological_space (K_hat R K) := Pi.topological_space
instance tr_hat : topological_ring (Π (v : maximal_spectrum R), v.adic_completion K) :=
pi.topological_ring
instance : topological_ring (K_hat R K) := tr_hat R K

lemma adic_completion.is_integer (x : v.adic_completion K) :
  x ∈ v.adic_completion_integers K ↔ (valued.v x : with_zero (multiplicative ℤ)) ≤ 1 := by refl

/-- The natural inclusion of `R` in `adic_completion`. -/
def inj_adic_completion_integers' : R → (v.adic_completion K) :=
λ r, (coe : K → (v.adic_completion K)) (algebra_map R K r)

/-- The natural inclusion of `R` in `adic_completion_integers`. -/
def inj_adic_completion_integers : R → (v.adic_completion_integers K) :=
λ r, ⟨(coe : K → (v.adic_completion K)) (algebra_map R K r), begin
  change @valued.extension K _ _ _ v.adic_valued (algebra_map R K r) ≤ 1,
  rw @valued.extension_extends K _ _ _ v.adic_valued (algebra_map R K r),
  exact v.valuation_le_one _,
end⟩

/-- The diagonal inclusion `r ↦ (r)_v` of `R` in `R_hat`. -/
def inj_R : R → (R_hat R K) := λ r v, inj_adic_completion_integers R K v r
lemma uniform_space.completion.coe_inj {α : Type*} [uniform_space α] [separated_space α] :
  injective  (coe : α → uniform_space.completion α) :=
uniform_embedding.inj (uniform_space.completion.uniform_embedding_coe _)

lemma inj_adic_completion_integers.injective :
  function.injective (inj_adic_completion_integers R K v) :=
begin
  intros x y hxy,
  have h_inj : function.injective (coe : K → v.adic_completion K) :=
    @uniform_space.completion.coe_inj K v.us' v.ss,
  rw [inj_adic_completion_integers, subtype.mk_eq_mk] at hxy,
  exact (is_fraction_ring.injective R K) ((h_inj) hxy),
end

lemma inj_adic_completion_integers.map_one : inj_adic_completion_integers R K v 1 = 1 :=
by { rw inj_adic_completion_integers, simp_rw ring_hom.map_one, refl, }

lemma inj_R.map_one : inj_R R K 1 = 1 :=
by { rw inj_R, ext v, simp_rw inj_adic_completion_integers.map_one R K v, refl, }

lemma inj_adic_completion_integers.map_mul (x y : R) : inj_adic_completion_integers R K v (x*y) =
  (inj_adic_completion_integers R K v x) * (inj_adic_completion_integers R K v y) :=
begin
  rw inj_adic_completion_integers,
  simp_rw ring_hom.map_mul,
  ext,
  rw [subtype.coe_mk, subring.coe_mul, subtype.coe_mk, subtype.coe_mk,
    uniform_space.completion.coe_mul],
end

lemma inj_R.map_mul (x y : R): inj_R R K (x*y) = (inj_R R K x) * (inj_R R K y) :=
by { rw inj_R, ext v, apply congr_arg _ (inj_adic_completion_integers.map_mul R K v x y), }

/-- The inclusion of `R_hat` in `K_hat` is a homomorphism of additive monoids. -/
noncomputable! def group_hom_prod : add_monoid_hom (R_hat R K) (K_hat R K) :=
{ to_fun    := λ x v, x v,
  map_zero' := rfl,
  map_add'  := λ x y, by { ext v, rw [pi.add_apply, pi.add_apply, subring.coe_add], }}

/-- The inclusion of `R_hat` in `K_hat` is a ring homomorphism. -/
noncomputable! def hom_prod : ring_hom (R_hat R K) (K_hat R K)  :=
{ to_fun   := λ x v, x v,
  map_one' := rfl,
  map_mul' := λ x y, by {ext p, rw [pi.mul_apply, pi.mul_apply, subring.coe_mul], },
  ..group_hom_prod R K, }

/-! ### The finite adèle ring of a Dedekind domain
We define the finite adèle ring of `R` as the restricted product over all maximal ideals `v` of `R`
of `adic_completion` with respect to `adic_completion_integers`. We prove that it is a commutative
ring and give it a topology that makes it into a topological ring. -/

/-- A tuple `(x_v)_v` is in the restricted product of the `adic_completion` with respect to
`adic_completion_integers` if for all but finitely many `v`, `x_v ∈ adic_completion_integers`. -/
def restricted : K_hat R K → Prop := λ x,
 ∀ᶠ (v : maximal_spectrum R) in filter.cofinite, (x v ∈ v.adic_completion_integers K)

/-- The finite adèle ring of `R` is the restricted product over all maximal ideals `v` of `R`
of `adic_completion` with respect to `adic_completion_integers`.-/
def finite_adele_ring' := { x : (K_hat R K) //
  ∀ᶠ (v : maximal_spectrum R) in filter.cofinite, (x v ∈ v.adic_completion_integers K) }

/-- The coercion map from `finite_adele_ring' R K` to `K_hat R K`. -/
noncomputable! def coe' : (finite_adele_ring' R K) → K_hat R K := λ x, x.val
instance has_coe' : has_coe (finite_adele_ring' R K) (K_hat R K) := {coe := coe' R K }
instance has_lift_t' : has_lift_t (finite_adele_ring' R K) (K_hat R K) := {lift := coe' R K }

/-- The sum of two finite adèles is a finite adèle. -/
lemma restr_add (x y : finite_adele_ring' R K) : ∀ᶠ (v : maximal_spectrum R) in filter.cofinite,
  ((x.val + y.val) v ∈ v.adic_completion_integers K) :=
begin
  cases x with x hx,
  cases y with y hy,
  simp only [restricted] at hx hy ⊢,
  rw filter.eventually_cofinite at hx hy ⊢,
  have h_subset : {v : maximal_spectrum R | ¬ (x + y) v ∈  (v.adic_completion_integers K)} ⊆
    {v : maximal_spectrum R | ¬ x v ∈ (v.adic_completion_integers K)} ∪
    {v : maximal_spectrum R | ¬ y v ∈ (v.adic_completion_integers K)},
  { intros v hv,
    rw [mem_union, mem_set_of_eq, mem_set_of_eq],
    rw mem_set_of_eq at hv,
    by_contradiction h,
    push_neg at h,
    apply hv,
    rw [adic_completion.is_integer, adic_completion.is_integer, ← max_le_iff] at h,
    rw [adic_completion.is_integer, pi.add_apply],
    exact le_trans (valued.v.map_add_le_max' (x v) (y v)) h },
  exact finite.subset (finite.union hx hy) h_subset,
end

/-- Addition on the finite adèle. ring. -/
def add' (x y : finite_adele_ring' R K) : finite_adele_ring' R K :=
⟨x.val + y.val, restr_add R K x y⟩

/-- The tuple `(0)_v` is a finite adèle. -/
lemma restr_zero : ∀ᶠ (v : maximal_spectrum R) in filter.cofinite,
  ((0 : v.adic_completion K) ∈ v.adic_completion_integers K) :=
begin
  rw filter.eventually_cofinite,
  have h_empty : {v : maximal_spectrum R |
    ¬ ((0 : v.adic_completion K) ∈ v.adic_completion_integers K)} = ∅,
  { ext v, rw mem_empty_eq, split; intro hv,
    { rw mem_set_of_eq at hv, apply hv, rw adic_completion.is_integer,
      have h_zero : (valued.v (0 : v.adic_completion K) : (with_zero(multiplicative ℤ))) = 0 :=
      valued.v.map_zero',
      rw h_zero, exact zero_le_one' },
    { exfalso, exact hv }},
  rw h_empty,
  exact finite_empty,
end

/-- The negative of a finite adèle is a finite adèle. -/
lemma restr_neg (x : finite_adele_ring' R K)  : ∀ᶠ (v : maximal_spectrum R) in filter.cofinite,
  (-x.val v ∈ v.adic_completion_integers K) :=
begin
  cases x with x hx,
  have h : ∀ (v : maximal_spectrum R), (-x v ∈ v.adic_completion_integers K) ↔
    (x v ∈ v.adic_completion_integers K),
  { intro v,
    rw [adic_completion.is_integer, adic_completion.is_integer, valuation.map_neg], },
  simpa only [h] using hx,
end

/-- Negation on the finite adèle ring. -/
def neg' (x : finite_adele_ring' R K) : finite_adele_ring' R K := ⟨-x.val, restr_neg R K x⟩

/-- The product of two finite adèles is a finite adèle. -/
lemma restr_mul (x y : finite_adele_ring' R K) : ∀ᶠ (v : maximal_spectrum R) in filter.cofinite,
  ((x.val * y.val) v ∈ v.adic_completion_integers K) :=
begin
  cases x with x hx,
  cases y with y hy,
  simp only [restricted] at hx hy ⊢,
  rw filter.eventually_cofinite at hx hy ⊢,
  have h_subset : {v : maximal_spectrum R | ¬ (x * y) v ∈  (v.adic_completion_integers K)} ⊆
    {v : maximal_spectrum R | ¬ x v ∈ (v.adic_completion_integers K)} ∪
    {v : maximal_spectrum R | ¬ y v ∈ (v.adic_completion_integers K)},
  { intros v hv,
    rw [mem_union, mem_set_of_eq, mem_set_of_eq],
    rw mem_set_of_eq at hv,
    by_contradiction h,
    push_neg at h,
    apply hv,
    rw [adic_completion.is_integer, adic_completion.is_integer] at h,
    have h_mul : valued.v (x v * y v) = (valued.v (x v)) * (valued.v (y v))
    := (valued.v).map_mul' (x v) (y v),
    rw [adic_completion.is_integer, pi.mul_apply, h_mul,
      ← mul_one (1 : with_zero (multiplicative ℤ ))],
    exact @mul_le_one' (with_zero (multiplicative ℤ)) _ _
      (ordered_comm_monoid.to_covariant_class_left _) _ _ _ h.left h.right,  },
  exact finite.subset (finite.union hx hy) h_subset,
end

/-- Multiplication on the finite adèle ring. -/
def mul' (x y : finite_adele_ring' R K) : finite_adele_ring' R K :=
⟨x.val * y.val, restr_mul R K x y⟩

/-- The tuple `(1)_v` is a finite adèle. -/
lemma restr_one : ∀ᶠ (v : maximal_spectrum R) in filter.cofinite,
  ((1 : v.adic_completion K) ∈ v.adic_completion_integers K) :=
begin
  rw filter.eventually_cofinite,
  have h_empty : {v : maximal_spectrum R |
    ¬ ((1 : v.adic_completion K) ∈ v.adic_completion_integers K)} = ∅,
  { ext v, rw mem_empty_eq, split; intro hv,
    { rw mem_set_of_eq at hv, apply hv, rw adic_completion.is_integer,
      exact le_of_eq valued.v.map_one' },
    { exfalso, exact hv }},
  rw h_empty,
  exact finite_empty,
end

/-- `finite_adele_ring' R K` is a commutative additive group. -/
instance : add_comm_group (finite_adele_ring' R K) :=
{ add          := add' R K,
  add_assoc    := λ ⟨x, hx⟩ ⟨y, hy⟩ ⟨z, hz⟩,
  by { dsimp only [add'], rw [subtype.mk_eq_mk], exact add_assoc _ _ _, },
  zero         := ⟨0, restr_zero R K⟩,
  zero_add     := λ x, by { simp_rw [add', zero_add, subtype.val_eq_coe, subtype.coe_eta] },
  add_zero     := λ x, by { simp_rw [add', add_zero, subtype.val_eq_coe, subtype.coe_eta] },
  neg          := λ x, ⟨-x.val, restr_neg R K x⟩,
  add_left_neg := λ x, by { unfold_projs,  dsimp only [add'], ext,
    rw [subtype.coe_mk, subtype.coe_mk, pi.add_apply, add_left_neg], refl, },
  add_comm     := λ x y, by { unfold_projs,  dsimp only [add'], ext,
    rw [subtype.coe_mk, subtype.coe_mk, pi.add_apply, pi.add_apply, add_comm], }}

/-- `finite_adele_ring' R K` is a commutative ring. -/
instance : comm_ring (finite_adele_ring' R K) :=
{ mul           := mul' R K,
  mul_assoc     := λ x y z, by { unfold_projs, simp_rw [mul'],
    rw [subtype.mk_eq_mk, mul_assoc]},
  one           := ⟨1, restr_one R K⟩,
  one_mul       := λ x, by { simp_rw [mul', one_mul, subtype.val_eq_coe, subtype.coe_eta] },
  mul_one       := λ x, by { simp_rw [mul', mul_one, subtype.val_eq_coe, subtype.coe_eta] },
  left_distrib  := λ x y z, by { unfold_projs, simp_rw [mul', add', left_distrib], },
  right_distrib := λ x y z, by { unfold_projs, simp_rw [mul', add', right_distrib], },
  mul_comm      := λ x y, by { unfold_projs, rw [mul', mul', subtype.mk_eq_mk, mul_comm], },
  ..(finite_adele_ring'.add_comm_group R K)}

@[norm_cast] lemma finite_adele_ring'.coe_add (x y : finite_adele_ring' R K) :
  (↑(x + y) : K_hat R K) = ↑x + ↑y := rfl

@[norm_cast] lemma finite_adele_ring'.coe_zero : (↑(0 : finite_adele_ring' R K) : K_hat R K) = 0 :=
rfl

@[norm_cast] lemma finite_adele_ring'.coe_neg (x : finite_adele_ring' R K) :
  (↑(-x) : K_hat R K) = -↑x  := rfl

@[norm_cast] lemma finite_adele_ring'.coe_mul (x y : finite_adele_ring' R K) :
  (↑(x * y) : K_hat R K) = ↑x * ↑y := rfl

@[norm_cast] lemma finite_adele_ring'.coe_one : (↑(1 : finite_adele_ring' R K) : K_hat R K) = 1 :=
rfl

instance finite_adele_ring'.inhabited : inhabited (finite_adele_ring' R K) :=
{ default := ⟨0, restr_zero R K⟩ }

/-- The ring of integers `adic_completion_integers` is an open subset of `adic_completion`. -/
lemma adic_completion.is_open_adic_completion_integers :
  is_open (v.adic_completion_integers K : set (v.adic_completion K)) :=
begin
  intros x hx,
  rw [set_like.mem_coe, adic_completion.is_integer] at hx,
  rw [← add_group_filter_basis.nhds_eq, valued.mem_nhds],
  use (1 : units (with_zero (multiplicative ℤ))),
  { intros y hy,
    rw [set_like.mem_coe, adic_completion.is_integer, ← sub_add_cancel y x],
    refine le_trans _ (max_le (le_of_lt hy) hx),
    exact valuation.map_add _ _ _ }
end

/-- A generating set for the topology on the finite adèle ring of `R` consists on products `∏_v U_v`
of open sets such that `U_v = adic_completion_integers` for all but finitely many maximal ideals
`v`. -/
def finite_adele_ring'.generating_set : set (set (finite_adele_ring' R K)) :=
{ U : set (finite_adele_ring' R K) |
  ∃ (V : Π (v : maximal_spectrum R), set (v.adic_completion K)),
  (∀ x : finite_adele_ring' R K, x ∈ U ↔ ∀ v, x.val v ∈ V v) ∧
  (∀ v, is_open (V v)) ∧ ∀ᶠ v in filter.cofinite, V v = v.adic_completion_integers K }

/-- The topology on the finite adèle ring of `R`. -/
instance : topological_space (finite_adele_ring' R K) := topological_space.generate_from
  (finite_adele_ring'.generating_set R K)

private lemma set_cond_finite {x y: finite_adele_ring' R K}
  {V : Π (v : maximal_spectrum R), set (v.adic_completion K)}
  (hV_int: ∀ᶠ (v : maximal_spectrum R) in filter.cofinite, V v =
    ↑(v.adic_completion_integers K)) :
  {v : maximal_spectrum R | ¬ (x.val v ∈ v.adic_completion_integers K ∧
    y.val v ∈ v.adic_completion_integers K ∧ V v = v.adic_completion_integers K)}.finite :=
begin
  have h_subset := subset.three_union (λ v, x.val v ∈ v.adic_completion_integers K)
    (λ v, y.val v ∈ v.adic_completion_integers K)
    (λ v, V v = v.adic_completion_integers K),
  exact finite.subset (finite.union (finite.union x.property y.property) hV_int) h_subset,
end

private lemma is_open_Vx  {x y: finite_adele_ring' R K}
  {V : Π (v : maximal_spectrum R), set (v.adic_completion K)}
  (hV : ∀ v : maximal_spectrum R, is_open
    ((λ p : ( v.adic_completion K × v.adic_completion K), p.fst + p.snd) ⁻¹' V v))
  (hV_int: ∀ᶠ (v : maximal_spectrum R) in filter.cofinite, V v = ↑(v.adic_completion_integers K))
  (hxy : ∀ (v : maximal_spectrum R), (x.val v, y.val v) ∈
    (λ p : (v.adic_completion K) × (v.adic_completion K), p.fst + p.snd) ⁻¹' V v )
  {Vx : Π (v : maximal_spectrum R), set (v.adic_completion K)}
  (hVx : Vx = λ v, if ( x.val v ∈ v.adic_completion_integers K ∧
    y.val v ∈ v.adic_completion_integers K ∧ V v = v.adic_completion_integers K ) then
    (v.adic_completion_integers K) else
    (classical.some (is_open_prod_iff.mp (hV v) (x.val v) (y.val v) (hxy v)))) :
  is_open {z : finite_adele_ring' R K | ∀ (v : maximal_spectrum R), z.val v ∈ Vx v} :=
begin
  use Vx,
  refine ⟨λ x, by refl,_,_⟩,
  { intro v, simp only [hVx], split_ifs,
    { exact adic_completion.is_open_adic_completion_integers R K v },
    { exact (classical.some_spec (classical.some_spec (is_open_prod_iff.mp (hV v)
        (x.val v) (y.val v) (hxy v)))).1 },},
    { have h_subset : {v : maximal_spectrum R | ¬ Vx v = v.adic_completion_integers K} ⊆
        {v : maximal_spectrum R | ¬ (x.val v ∈ v.adic_completion_integers K ∧
          y.val v ∈ v.adic_completion_integers K ∧ V v = v.adic_completion_integers K)},
    { intros v hv h_cond_v,
      simp only [mem_set_of_eq, hVx, if_pos h_cond_v] at hv,
      exact hv (eq.refl _), },
    apply finite.subset _ h_subset,
    apply set_cond_finite R K hV_int },
end

private lemma is_open_Vy {x y : finite_adele_ring' R K}
  {V : Π (v : maximal_spectrum R), set (v.adic_completion K)}
  (hV : ∀ v : maximal_spectrum R, is_open
    ((λ p : ( v.adic_completion K × v.adic_completion K), p.fst + p.snd) ⁻¹' V v))
  (hV_int: ∀ᶠ (v : maximal_spectrum R) in filter.cofinite, V v = ↑(v.adic_completion_integers K))
  (hxy : ∀ (v : maximal_spectrum R), (x.val v, y.val v) ∈
    (λ p : (v.adic_completion K) × (v.adic_completion K), p.fst + p.snd) ⁻¹' V v )
  {Vy : Π (v : maximal_spectrum R), set (v.adic_completion K)}
  (hVx : Vy = λ v, if ( x.val v ∈ v.adic_completion_integers K ∧
    y.val v ∈ v.adic_completion_integers K ∧ V v = v.adic_completion_integers K ) then
    (v.adic_completion_integers K) else (classical.some (classical.some_spec
      (is_open_prod_iff.mp (hV v) (x.val v) (y.val v) (hxy v))))) :
  is_open {z : finite_adele_ring' R K | ∀ (v : maximal_spectrum R), z.val v ∈ Vy v} :=
begin
  use Vy,
  refine ⟨λ x, by refl,_,_⟩,
  { intro v, simp only [hVx], split_ifs,
    { exact adic_completion.is_open_adic_completion_integers R K v },
    { exact (classical.some_spec (classical.some_spec (is_open_prod_iff.mp (hV v)
        (x.val v) (y.val v) (hxy v)))).2.1 },},
    { have h_subset : {v : maximal_spectrum R | ¬ Vy v = v.adic_completion_integers K} ⊆
        {v : maximal_spectrum R | ¬ (x.val v ∈ v.adic_completion_integers K ∧
          y.val v ∈ v.adic_completion_integers K ∧ V v = v.adic_completion_integers K)},
    { intros v hv h_cond_v,
      rw mem_set_of_eq at hv,
      simp only [hVx] at hv,
      rw if_pos h_cond_v at hv,
      exact hv (eq.refl _), },
    apply finite.subset _ h_subset,
    exact set_cond_finite R K hV_int },
end

/-- Addition on the finite adèle ring of `R` is continuous. -/
lemma finite_adele_ring'.continuous_add :
  continuous (λ (p : finite_adele_ring' R K × finite_adele_ring' R K), p.fst + p.snd) :=
begin
  apply continuous_generated_from,
  rintros U ⟨V, hUV, hV_open, hV_int⟩,
  have hV : ∀ v : maximal_spectrum R, is_open
    ((λ p : ( v.adic_completion K × v.adic_completion K), p.fst + p.snd) ⁻¹' V v) :=
  λ v, continuous.is_open_preimage continuous_add (V v) (hV_open v),
  rw is_open_prod_iff,
  intros x y hxy,
  have hxy' : ∀ (v : maximal_spectrum R), (x.val v, y.val v) ∈
    (λ p : (v.adic_completion K) × (v.adic_completion K), p.fst + p.snd) ⁻¹' V v :=
  λ v, (hUV _).mp hxy v,
  set cond := λ v : maximal_spectrum R, x.val v ∈ v.adic_completion_integers K ∧
    y.val v ∈ v.adic_completion_integers K ∧ V v = v.adic_completion_integers K with h_cond,
  have hS_fin : {v : maximal_spectrum R | ¬ (cond v)}.finite := set_cond_finite R K  hV_int,
  set Vx : Π (v : maximal_spectrum R), set (v.adic_completion K) := λ v, if (cond v) then
    (v.adic_completion_integers K) else
    (classical.some (is_open_prod_iff.mp (hV v) _ _ (hxy' v))) with hVx,
  set Vy : Π (v : maximal_spectrum R), set (v.adic_completion K) := λ v, if (cond v) then
    (v.adic_completion_integers K) else (classical.some (classical.some_spec
      (is_open_prod_iff.mp (hV v) _ _ (hxy' v))))
    with hVy,
  use [{z : finite_adele_ring' R K | ∀ v : maximal_spectrum R, z.val v ∈ Vx v },
    {z : finite_adele_ring' R K | ∀ v : maximal_spectrum R, z.val v ∈ Vy v }],
  refine ⟨is_open_Vx R K hV hV_int hxy' hVx, is_open_Vy R K hV hV_int hxy' hVy, _, _,_⟩,
  { rw [mem_set_of_eq],
    intro v,
    simp only [hVx],
    split_ifs,
    { exact h.1,},
    { exact (classical.some_spec (classical.some_spec
        (is_open_prod_iff.mp (hV v) _ _ (hxy' v)))).2.2.1 },},
  { rw [mem_set_of_eq],
    intro v,
    simp only [hVy],
    split_ifs,
    { exact h.2.1 },
    { exact (classical.some_spec (classical.some_spec
        (is_open_prod_iff.mp (hV v) _ _ (hxy' v)))).2.2.2.1 }},
  { intros p hp,
    rw [mem_prod, mem_set_of_eq, mem_set_of_eq] at hp,
    rw [mem_preimage, hUV],
    intro v,
    have hp' : prod.mk (p.fst.val v) (p.snd.val v) ∈ (Vx v) ×ˢ (Vy v) :=
    mem_prod.mpr ⟨hp.1 v, hp.2 v⟩,
    by_cases h_univ : V v = univ,
    { rw h_univ, exact mem_univ _},
    { simp only [hVx, hVy, if_neg h_univ] at hp',
      by_cases hv : cond v,
      { rw [if_pos hv, if_pos hv, mem_prod, set_like.mem_coe, adic_completion.is_integer,
          set_like.mem_coe, adic_completion.is_integer] at hp',
        rw [hv.2.2, set_like.mem_coe, adic_completion.is_integer],
        have h_max : valued.v ((p.fst + p.snd).val v) ≤ max (valued.v ((p.fst).val v))
          (valued.v ((p.snd).val v)) := valuation.map_add _ _ _,
        exact le_trans h_max (max_le hp'.1 hp'.2), },
      { rw [if_neg hv, if_neg hv] at hp',
        { exact (classical.some_spec (classical.some_spec
         (is_open_prod_iff.mp (hV v) _ _ (hxy' v)))).2.2.2.2 hp'}, }}}
end

private lemma is_open_Vx_mul  {x y: finite_adele_ring' R K}
  {V : Π (v : maximal_spectrum R), set (v.adic_completion K)}
  (hV : ∀ v : maximal_spectrum R, is_open
    ((λ p : ( v.adic_completion K × v.adic_completion K), p.fst * p.snd) ⁻¹' V v))
  (hV_int: ∀ᶠ (v : maximal_spectrum R) in filter.cofinite, V v = ↑(v.adic_completion_integers K))
  (hxy : ∀ (v : maximal_spectrum R), (x.val v, y.val v) ∈
    (λ p : (v.adic_completion K) × (v.adic_completion K), p.fst * p.snd) ⁻¹' V v )
  {Vx : Π (v : maximal_spectrum R), set (v.adic_completion K)}
  (hVx : Vx = λ v, if ( x.val v ∈ v.adic_completion_integers K ∧
    y.val v ∈ v.adic_completion_integers K ∧ V v = v.adic_completion_integers K ) then
    (v.adic_completion_integers K) else
    (classical.some (is_open_prod_iff.mp (hV v) (x.val v) (y.val v) (hxy v)))) :
  is_open {z : finite_adele_ring' R K | ∀ (v : maximal_spectrum R), z.val v ∈ Vx v} :=
begin
  use Vx,
  refine ⟨λ x, by refl,_,_⟩,
  { intro v, simp only [hVx], split_ifs,
    { exact adic_completion.is_open_adic_completion_integers R K v },
    { exact (classical.some_spec (classical.some_spec (is_open_prod_iff.mp (hV v)
        (x.val v) (y.val v) (hxy v)))).1 },},
    { have h_subset : {v : maximal_spectrum R | ¬ Vx v = v.adic_completion_integers K} ⊆
        {v : maximal_spectrum R | ¬ (x.val v ∈ v.adic_completion_integers K ∧
          y.val v ∈ v.adic_completion_integers K ∧ V v = v.adic_completion_integers K)},
    { intros v hv h_cond_v,
      simp only [mem_set_of_eq, hVx, if_pos h_cond_v] at hv,
      exact hv (eq.refl _), },
    apply finite.subset _ h_subset,
    apply set_cond_finite R K hV_int },
end

private lemma is_open_Vy_mul {x y : finite_adele_ring' R K}
  {V : Π (v : maximal_spectrum R), set (v.adic_completion K)}
  (hV : ∀ v : maximal_spectrum R, is_open
    ((λ p : ( v.adic_completion K × v.adic_completion K), p.fst * p.snd) ⁻¹' V v))
  (hV_int: ∀ᶠ (v : maximal_spectrum R) in filter.cofinite, V v = ↑(v.adic_completion_integers K))
  (hxy : ∀ (v : maximal_spectrum R), (x.val v, y.val v) ∈
    (λ p : (v.adic_completion K) × (v.adic_completion K), p.fst * p.snd) ⁻¹' V v )
  {Vy : Π (v : maximal_spectrum R), set (v.adic_completion K)}
  (hVx : Vy = λ v, if ( x.val v ∈ v.adic_completion_integers K ∧
    y.val v ∈ v.adic_completion_integers K ∧ V v = v.adic_completion_integers K ) then
    (v.adic_completion_integers K) else (classical.some (classical.some_spec
      (is_open_prod_iff.mp (hV v) (x.val v) (y.val v) (hxy v))))) :
  is_open {z : finite_adele_ring' R K | ∀ (v : maximal_spectrum R), z.val v ∈ Vy v} :=
begin
  use Vy,
  refine ⟨λ x, by refl,_,_⟩,
  { intro v, simp only [hVx], split_ifs,
    { exact adic_completion.is_open_adic_completion_integers R K v },
    { exact (classical.some_spec (classical.some_spec (is_open_prod_iff.mp (hV v)
        (x.val v) (y.val v) (hxy v)))).2.1 },},
    { have h_subset : {v : maximal_spectrum R | ¬ Vy v = v.adic_completion_integers K} ⊆
        {v : maximal_spectrum R | ¬ (x.val v ∈ v.adic_completion_integers K ∧
          y.val v ∈ v.adic_completion_integers K ∧ V v = v.adic_completion_integers K)},
    { intros v hv h_cond_v,
      rw mem_set_of_eq at hv,
      simp only [hVx] at hv,
      rw if_pos h_cond_v at hv,
      exact hv (eq.refl _), },
    apply finite.subset _ h_subset,
    exact set_cond_finite R K hV_int },
end

/-- Multiplication on the finite adèle ring of `R` is continuous. -/
lemma finite_adele_ring'.continuous_mul :
  continuous (λ (p : finite_adele_ring' R K × finite_adele_ring' R K), p.fst * p.snd) :=
begin
 apply continuous_generated_from,
  rintros U ⟨V, hUV, hV_open, hV_int⟩,
  have hV : ∀ v : maximal_spectrum R, is_open
    ((λ p : ( v.adic_completion K × v.adic_completion K), p.fst * p.snd) ⁻¹' V v) :=
  λ v, continuous.is_open_preimage continuous_mul (V v) (hV_open v),
  rw is_open_prod_iff,
  intros x y hxy,
  have hxy' : ∀ (v : maximal_spectrum R), (x.val v, y.val v) ∈
    (λ p : (v.adic_completion K) × (v.adic_completion K), p.fst * p.snd) ⁻¹' V v :=
  λ v, (hUV _).mp hxy v,
  set cond := λ v : maximal_spectrum R, x.val v ∈ v.adic_completion_integers K ∧
    y.val v ∈ v.adic_completion_integers K ∧ V v = v.adic_completion_integers K with h_cond,
  have hS_fin : {v : maximal_spectrum R | ¬ (cond v)}.finite := set_cond_finite R K hV_int,
  set Vx : Π (v : maximal_spectrum R), set (v.adic_completion K) := λ v,
  if (cond v) then (v.adic_completion_integers K) else
    (classical.some (is_open_prod_iff.mp (hV v) _ _ (hxy' v))) with hVx,
  set Vy : Π (v : maximal_spectrum R), set (v.adic_completion K) := λ v, if (cond v) then
    (v.adic_completion_integers K) else
    (classical.some (classical.some_spec (is_open_prod_iff.mp (hV v) _ _ (hxy' v)))) with hVy,
  use [{z : finite_adele_ring' R K | ∀ v : maximal_spectrum R, z.val v ∈ Vx v },
    {z : finite_adele_ring' R K | ∀ v : maximal_spectrum R, z.val v ∈ Vy v }],
  refine ⟨is_open_Vx_mul R K hV hV_int hxy' hVx, is_open_Vy_mul R K hV hV_int hxy' hVy, _, _,_⟩,
  { rw [mem_set_of_eq],
    intro v,
    simp only [hVx],
    split_ifs,
    { exact h.1,},
    { exact (classical.some_spec (classical.some_spec
        (is_open_prod_iff.mp (hV v) _ _ (hxy' v)))).2.2.1 },},
  { rw [mem_set_of_eq],
    intro v,
    simp only [hVy],
    split_ifs,
    { exact h.2.1 },
    { exact (classical.some_spec (classical.some_spec
        (is_open_prod_iff.mp (hV v) _ _ (hxy' v)))).2.2.2.1 }},
  { intros p hp,
    rw [mem_prod, mem_set_of_eq, mem_set_of_eq] at hp,
    rw [mem_preimage, hUV],
    intro v,
    have hp' : prod.mk (p.fst.val v) (p.snd.val v) ∈ (Vx v) ×ˢ (Vy v) :=
    mem_prod.mpr ⟨hp.1 v, hp.2 v⟩,
    by_cases h_univ : V v = univ,
    { rw h_univ, exact mem_univ _},
    { simp only [hVx, hVy, if_neg h_univ] at hp',
      by_cases hv : cond v,
      { rw [if_pos hv, if_pos hv, mem_prod, set_like.mem_coe, adic_completion.is_integer,
          set_like.mem_coe, adic_completion.is_integer] at hp',
        rw [hv.2.2, set_like.mem_coe, adic_completion.is_integer],
        have h_mul : valued.v ((p.fst * p.snd).val v) = (valued.v ((p.fst).val v)) *
          (valued.v ((p.snd).val v)) := valuation.map_mul _ _ _,
        rw h_mul,
        apply mul_le_one₀ hp'.1 hp'.2, },
      { rw [if_neg hv, if_neg hv] at hp',
        { exact (classical.some_spec (classical.some_spec
         (is_open_prod_iff.mp (hV v) _ _ (hxy' v)))).2.2.2.2 hp'}, }}}
end

instance : has_continuous_mul (finite_adele_ring' R K) := ⟨finite_adele_ring'.continuous_mul R K⟩

/-- The finite adèle ring of `R` is a topological ring. -/
instance : topological_ring (finite_adele_ring' R K) :=
{ continuous_add := finite_adele_ring'.continuous_add R K,
  continuous_neg := topological_semiring.has_continuous_neg_of_mul.continuous_neg,
  ..finite_adele_ring'.has_continuous_mul R K }

/-- The product `∏_v adic_completion_integers` is an open subset of the finite adèle ring of `R`. -/
lemma finite_adele_ring'.is_open_integer_subring :
  is_open {x : finite_adele_ring' R K |
    ∀ (v : maximal_spectrum R), x.val v ∈ v.adic_completion_integers K} :=
begin
  apply topological_space.generate_open.basic,
  rw finite_adele_ring'.generating_set,
  use λ v, v.adic_completion_integers K,
  refine ⟨_, _,_⟩,
  { intro v, refl, },
  { intro v, exact adic_completion.is_open_adic_completion_integers R K v },
  { rw filter.eventually_cofinite,
    simp_rw [eq_self_iff_true, not_true, set_of_false, finite_empty] },
end

lemma finite_adele_ring'.is_open_integer_subring_opp : is_open
  {x : (finite_adele_ring' R K)ᵐᵒᵖ |
    ∀ (v : maximal_spectrum R),(mul_opposite.unop x).val v ∈ v.adic_completion_integers K} :=
begin
  use {x : finite_adele_ring' R K | ∀ (v : maximal_spectrum R),
    x.val v ∈ v.adic_completion_integers K},
  use finite_adele_ring'.is_open_integer_subring R K,
  refl,
end

instance : comm_ring { x : (K_hat R K) //
  ∀ᶠ (v : maximal_spectrum R) in filter.cofinite, (x v ∈ v.adic_completion_integers K)  } :=
finite_adele_ring'.comm_ring R K

lemma mul_apply (x y : finite_adele_ring' R K) :
(⟨x.val * y.val, restr_mul R K x y⟩ : finite_adele_ring' R K) = x * y := rfl

lemma mul_apply_val (x y : finite_adele_ring' R K) :
x.val * y.val = (x * y).val := rfl

@[simp] lemma one_def : (⟨1, restr_one R K⟩ : finite_adele_ring' R K) = 1 := rfl

@[simp] lemma zero_def : (⟨0, restr_zero R K⟩ : finite_adele_ring' R K) = 0 := rfl

/-- For any `x ∈ K`, the tuple `(x)_v` is a finite adèle. -/
lemma inj_K_image (x : K) : set.finite { v : maximal_spectrum R |
  ¬ (coe : K → (v.adic_completion K)) x ∈ (v.adic_completion_integers K)} :=
begin
  set supp := { v : maximal_spectrum R |
    ¬ (coe : K → (v.adic_completion K)) x ∈ (v.adic_completion_integers K)} with h_supp,
  obtain ⟨r, ⟨d, hd⟩, hx⟩ := is_localization.mk'_surjective (non_zero_divisors R) x,
  have hd_ne_zero : ideal.span{d} ≠ (0 : ideal R),
  { rw [ideal.zero_eq_bot, ne.def, ideal.span_singleton_eq_bot],
    apply non_zero_divisors.ne_zero hd, },
  obtain ⟨f, h_irred, h_assoc⟩:= wf_dvd_monoid.exists_factors (ideal.span{d}) hd_ne_zero,
  have hsubset : supp ⊆ { v : maximal_spectrum R | v.as_ideal ∣ ideal.span({d})},
  { rw h_supp,
    intros v hv,
    rw mem_set_of_eq at hv ⊢,
    have h_val : valued.v ((coe : K → (v.adic_completion K)) x) =
      @valued.extension K _ _ _ v.adic_valued x := rfl,
    rw [adic_completion.is_integer, h_val, valued.extension_extends _, v.adic_valued_def,
      maximal_spectrum.valuation_def] at hv,
    let sx : non_zero_divisors R := (classical.some (maximal_spectrum.valuation_def._proof_2 x)),
    have h_loc : is_localization.mk' K
      (classical.some (maximal_spectrum.valuation_def._proof_1 x)) sx =
      is_localization.mk' K r ⟨d, hd⟩,
    { rw hx, exact (classical.some_spec (maximal_spectrum.valuation_def._proof_2 x)) },
      dsimp only at hv,
      rw ← maximal_spectrum.int_valuation_lt_one_iff_dvd,
      by_contradiction h_one_le,
      rw [maximal_spectrum.valuation_well_defined K v h_loc, subtype.coe_mk,
        (le_antisymm (v.int_valuation_le_one d) (not_lt.mp h_one_le)), div_one] at hv,
      exact hv (v.int_valuation_le_one r) },
  exact finite.subset (finite_factors d hd_ne_zero) hsubset,
end

/-- The diagonal inclusion `k ↦ (k)_v` of `K` into the finite adèle ring of `R`. -/
@[simps coe] def inj_K : K → finite_adele_ring' R K :=
λ x, ⟨(λ v : maximal_spectrum R, (coe : K → (v.adic_completion K)) x), inj_K_image R K x⟩

lemma inj_K_apply (k : K) : inj_K R K  k =
  ⟨(λ v : maximal_spectrum R, (coe : K → (v.adic_completion K)) k), inj_K_image R K k⟩ := rfl

@[simp] lemma inj_K.map_zero : inj_K R K 0 = 0 := by { rw inj_K, ext v, rw [subtype.coe_mk], refl }

@[simp] lemma inj_K.map_add (x y : K) : inj_K R K (x + y) = (inj_K R K x) + (inj_K R K y) :=
begin
  rw inj_K, ext v, unfold_projs, simp only [add'],
  rw [subtype.coe_mk, subtype.coe_mk, pi.add_apply],
  norm_cast,
end

@[simp] lemma inj_K.map_one : inj_K R K 1 = 1 := by { rw inj_K, ext v, rw [subtype.coe_mk], refl }

@[simp] lemma inj_K.map_mul (x y : K) : inj_K R K (x*y) = (inj_K R K x) * (inj_K R K y) :=
begin
  rw inj_K, ext v, unfold_projs, simp only [mul'],
  rw [subtype.coe_mk, subtype.coe_mk, pi.mul_apply],
  norm_cast,
end

/-- The map `inj_K` is an additive group homomorphism. -/
def inj_K.add_group_hom : add_monoid_hom K (finite_adele_ring' R K) :=
{ to_fun    := inj_K R K,
  map_zero' := inj_K.map_zero R K,
  map_add'  := inj_K.map_add R K, }

/-- The map `inj_K` is a ring homomorphism. -/
def inj_K.ring_hom : ring_hom K (finite_adele_ring' R K)  :=
{ to_fun   := inj_K R K,
  map_one' := inj_K.map_one R K,
  map_mul' := inj_K.map_mul R K,
  ..inj_K.add_group_hom R K }

lemma inj_K.ring_hom_apply {k : K} : inj_K.ring_hom R K k = inj_K R K k := rfl

/-- If `maximal_spectrum R` is nonempty, then `inj_K` is injective. Note that the nonemptiness
hypothesis is satisfied for every Dedekind domain that is not a field. -/
lemma inj_K.injective [inh : nonempty (maximal_spectrum R)] : injective (inj_K.ring_hom R K) :=
begin
  rw [ring_hom.injective_iff_ker_eq_bot, ring_hom.ker_eq_bot_iff_eq_zero],
  intros x hx,
  rw [inj_K.ring_hom, ring_hom.coe_mk, inj_K] at hx,
  dsimp only at hx,
  unfold_projs at hx,
  rw [subtype.mk_eq_mk] at hx,
  let v : maximal_spectrum R := (classical.inhabited_of_nonempty inh).default,
  have hv := congr_fun hx v,
  dsimp only at hv,
  have h_inj : function.injective (coe : K → (v.adic_completion K)) :=
    @uniform_space.completion.coe_inj K v.us' v.ss,
  apply h_inj hv,
end

/-! ### Alternative definition of the finite adèle ring
We can also define the finite adèle ring of `R` as the localization of `R_hat` at `R∖{0}`. We denote
this definition by `finite_adele_ring` and construct a ring homomorphism from `finite_adele_ring R`
to `finite_adele_ring' R`.
TODO: show that this homomorphism is in fact an isomorphism of topological rings. -/

/-- `R∖{0}` is a submonoid of `R_hat R K`, via the inclusion `r ↦ (r)_v`. -/
noncomputable! def diag_R : submonoid (R_hat R K) :=
{ carrier  := (inj_R R K) '' set.compl {0},
  one_mem' :=  ⟨1, set.mem_compl_singleton_iff.mpr one_ne_zero, inj_R.map_one R K⟩,
  mul_mem' :=
  begin
    rintros a b ⟨za, hza, rfl⟩ ⟨zb, hzb, rfl⟩,
    exact ⟨za*zb, mul_ne_zero hza hzb, inj_R.map_mul R K za zb⟩,
  end }

/-- The finite adèle ring of `R` as the localization of `R_hat` at `R∖{0}`. -/
def finite_adele_ring := localization (diag_R R K)
instance : comm_ring (finite_adele_ring R K) := localization.comm_ring
instance : algebra (R_hat R K) (finite_adele_ring R K) := localization.algebra
instance : is_localization (diag_R R K) (finite_adele_ring R K):= localization.is_localization
instance : topological_space (finite_adele_ring R K) := localization.topological_space
instance : topological_ring (finite_adele_ring R K) := localization.topological_ring
instance : inhabited (finite_adele_ring R K) := localization.inhabited _

lemma preimage_diag_R (x : diag_R R K) : ∃ r : R, r ≠ 0 ∧ inj_R R K r = (x : R_hat R K) :=
x.property

/-- For every `r ∈ R`, `(r)_v` is a unit of `K_hat R K`. -/
lemma hom_prod_diag_unit : ∀ x : (diag_R R K), is_unit (hom_prod R K x) :=
begin
  rintro ⟨x, r, hr, hrx⟩,
  rw [is_unit_iff_exists_inv, subtype.coe_mk],
  use (λ v : maximal_spectrum R, 1/(x v : v.adic_completion K)),
  ext v,
  rw [hom_prod, ring_hom.coe_mk, pi.mul_apply, pi.one_apply,
  ← mul_div_assoc, mul_one, div_self],
  rw  [ne.def, subring.coe_eq_zero_iff, ← hrx, inj_R],
  simp only [inj_adic_completion_integers],
  have h : (0 : v.adic_completion K) ∈ v.adic_completion_integers K,
  { rw [adic_completion.is_integer R K, valuation.map_zero], exact zero_le_one',},
  have h_zero : (0 : v.adic_completion_integers K) = ⟨(0 : v.adic_completion K), h⟩ := rfl,
  have h_inj : function.injective (coe : K → (v.adic_completion K)) :=
    @uniform_space.completion.coe_inj K v.us' v.ss,
  rw [h_zero, subtype.mk_eq_mk, ← uniform_space.completion.coe_zero,
    ← (algebra_map R K).map_zero, ← ne.def,
    injective.ne_iff (injective.comp h_inj (is_fraction_ring.injective R K))],
  rw [compl_eq_compl, mem_compl_eq, mem_singleton_iff] at hr,
  exact hr,
end

/-- The map from `finite_adele_ring R K` to `K_hat R K` induced by `hom_prod`. -/
def map_to_K_hat (x : finite_adele_ring R K) : K_hat R K :=
is_localization.lift (hom_prod_diag_unit R K) x

/-- The image of `map_to_K_hat R K` is contained in `finite_adele_ring' R K`. -/
lemma restricted_image (x : finite_adele_ring R K) : set.finite
  { v : maximal_spectrum R | ¬ (map_to_K_hat R K x v) ∈ (v.adic_completion_integers K)} :=
begin
  obtain ⟨r, d', hx⟩ := is_localization.mk'_surjective (diag_R R K) x,
  obtain ⟨d, hd_ne_zero, hd_inj⟩ := d'.property,
  have hd : ideal.span{d} ≠ (0 : ideal R),
  { rw [ideal.zero_eq_bot, ne.def, ideal.span_singleton_eq_bot],
    exact hd_ne_zero, },
  obtain ⟨f, h_irred, h_assoc⟩:= wf_dvd_monoid.exists_factors (ideal.span{d}) hd,
  have hsubset : { v : maximal_spectrum R |
    ¬ (map_to_K_hat R K x v) ∈ (v.adic_completion_integers K)} ⊆
    { v : maximal_spectrum R | v.as_ideal ∣ ideal.span({d})},
  { intros v hv,
    rw mem_set_of_eq at hv ⊢,
    rw [map_to_K_hat, ← hx, is_localization.lift_mk', pi.mul_apply] at hv,
    by_cases hr : hom_prod R K r v = 0,
    { rw [hr, zero_mul, adic_completion.is_integer, valuation.map_zero] at hv,
      exact absurd (with_zero.zero_le 1) hv, },
    { have h_inv : (((is_unit.lift_right ((hom_prod R K).to_monoid_hom.mrestrict (diag_R R K))
        (hom_prod_diag_unit R K)) d').inv v) *
        (((hom_prod R K).to_monoid_hom.mrestrict (diag_R R K)) d' v) = 1,
      { rw [units.inv_eq_coe_inv, ← pi.mul_apply, is_unit.lift_right_inv_mul
          ((hom_prod R K).to_monoid_hom.mrestrict (diag_R R K)) (hom_prod_diag_unit R K) d',
          pi.one_apply]},
      have h_val : (valued.v (((is_unit.lift_right ((hom_prod R K).to_monoid_hom.mrestrict
        (diag_R R K)) (hom_prod_diag_unit R K)) d').inv v))*
        ((valued.v (((hom_prod R K).to_monoid_hom.mrestrict (diag_R R K)) d' v)) :
          with_zero(multiplicative ℤ)) = 1,
      { rw [← valuation.map_mul, h_inv, valuation.map_one], },
      have h_coe : (((hom_prod R K).to_monoid_hom.mrestrict (diag_R R K)) d') v =
        ((d' : R_hat R K) v) := rfl,
      have hd' : ((d'.val) v).val = (coe : K → v.adic_completion K) (algebra_map R K d),
      { rw ← hd_inj, dsimp only [inj_R], rw inj_adic_completion_integers, },
      rw [adic_completion.is_integer, valuation.map_mul, ← units.inv_eq_coe_inv,
        eq_one_div_of_mul_eq_one_left h_val, ← mul_div_assoc, mul_one,
        div_le_iff₀ (right_ne_zero_of_mul_eq_one h_val), one_mul, not_le, h_coe,
        ← subtype.val_eq_coe, ← subtype.val_eq_coe, hd', v.valued_adic_completion_def,
        valued.extension_extends, v.adic_valued_def] at hv,
      have h_val_r : (valued.v ((hom_prod R K) r v) : with_zero (multiplicative ℤ)) ≤ 1,
      { rw [hom_prod, ring_hom.coe_mk, ← subtype.val_eq_coe, ← adic_completion.is_integer],
        exact (r v).property, },
      have h_val_d : v.valuation_def (algebra_map R K d)  < 1 := lt_of_lt_of_le hv h_val_r,
      exact (v.valuation_lt_one_iff_dvd d).mp h_val_d, }},
    exact finite.subset (finite_factors d hd) hsubset,
end

lemma map_to_K_hat.map_one : map_to_K_hat R K 1 = 1 :=
by { rw [map_to_K_hat, ring_hom.map_one] }

lemma map_to_K_hat.map_mul (x y : finite_adele_ring R K) :
  map_to_K_hat R K (x*y) = map_to_K_hat R K x * map_to_K_hat R K y :=
by { rw [map_to_K_hat, map_to_K_hat, map_to_K_hat, ring_hom.map_mul], }

lemma map_to_K_hat.map_add (x y : finite_adele_ring R K) : map_to_K_hat R K (x + y) =
  map_to_K_hat R K x + map_to_K_hat R K y :=
by { rw [map_to_K_hat, map_to_K_hat, map_to_K_hat, ring_hom.map_add], }

lemma map_to_K_hat.map_zero : map_to_K_hat R K 0 = 0 :=
by { rw [map_to_K_hat, ring_hom.map_zero] }

/-- `map_to_K_hat` is a ring homomorphism between our two definitions of finite adèle ring.  -/
def finite_adele.hom : (finite_adele_ring R K) →+* (finite_adele_ring' R K) :=
{ to_fun    := λ x, ⟨(map_to_K_hat R K x), restricted_image R K x⟩,
  map_one'  := begin
    have h_one : (1 : finite_adele_ring' R K) = ⟨1, restr_one R K⟩ := rfl,
    rw [h_one, subtype.mk_eq_mk],
    exact map_to_K_hat.map_one R K,
  end,
  map_mul'  := λ x y,
  by { unfold_projs, simp only [mul'], exact subtype.mk_eq_mk.mpr (map_to_K_hat.map_mul R K x y) },
  map_zero' := begin
    have h_zero : (0 : finite_adele_ring' R K) = ⟨0, restr_zero R K⟩ := rfl,
    rw [h_zero, subtype.mk_eq_mk],
    exact map_to_K_hat.map_zero R K,
  end,
  map_add'  := λ x y,
  by { unfold_projs, simp only [add'], exact subtype.mk_eq_mk.mpr (map_to_K_hat.map_add R K x y) }}


/-
Copyright (c) 2021 OpenAI. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Kunhao Zheng, Stanislas Polu, David Renshaw, OpenAI GPT-f
-/
import mathzoo.imports.miniF2F

open_locale nat rat real big_operators topological_space

theorem algebra_sqineq_2unitcircatblt1
  (a b : ℝ)
  (h₀ : a^2 + b^2 = 2) :
  a * b ≤ 1 :=
begin
  nlinarith [sq_nonneg (b - a)],
end


import natural.definition natural.addition natural.multiplication
import lambda_integer.definition lambda_integer.addition lambda_integer.substruction

namespace Z'

def mul (a b : Z'): Z' := ⟦((norm a).fst * (norm b).fst + (norm a).snd * (norm b).snd, (norm a).fst * (norm b).snd + (norm a).snd * (norm b).fst)⟧

instance : has_mul Z' := ⟨ mul ⟩

lemma mul_deconstruct (a b : Z'): a * b = ⟦((norm a).fst * (norm b).fst + (norm a).snd * (norm b).snd, (norm a).fst * (norm b).snd + (norm a).snd * (norm b).fst)⟧ := rfl

def pair_mul (a b : N × N) : N × N := (a.fst * b.fst + a.snd * b.snd, a.fst * b.snd + a.snd * b.fst)

instance : has_mul (N × N) := ⟨ pair_mul ⟩

lemma pair_mul_deconstruct (a b : N × N) : a * b = (a.fst * b.fst + a.snd * b.snd, a.fst * b.snd + a.snd * b.fst) := rfl

theorem mul_zero (a : Z') : a * 0 = 0 := begin
  rw mul_deconstruct,
  rw zero_norm,
  rw fst_eq 0,
  rw snd_eq 0 0,
  repeat {rw N.mul_zero},
  rw N.zero_add,
  rw zero_eq_zero, rw zero,
end

theorem zero_mul (a: Z') : 0 * a = 0 := begin
  rw mul_deconstruct,
  rw zero_norm,
  rw fst_eq 0,
  rw snd_eq 0 0,
  repeat {rw N.zero_mul},
  rw N.zero_add,
  rw zero_eq_zero, rw zero,
end

theorem mul_comm (a b : Z') : a * b = b * a := begin
  repeat {rw mul_deconstruct},
  repeat {rw N.mul_comm a.norm.fst},
  repeat {rw N.mul_comm a.norm.snd},
  rw N.add_comm (b.norm.fst * a.norm.snd),
end

theorem one_mul (a : Z') : 1 * a = a := begin
  rw mul_deconstruct,
  rw one_norm,
  rw fst_eq 1 0,
  rw snd_eq 1 0,
  repeat {rw N.one_mul},
  repeat {rw N.zero_mul},
  repeat {rw N.add_zero},
  rw a_norm_eq_a,
end

theorem mul_one (a : Z') : a * 1 = a := begin
  rw mul_comm,
  exact one_mul a,
end

instance : has_mul (quot z_rel) := ⟨ mul ⟩

lemma mul_neg_eqq: ∀ (b c d : N), (0, b) * (eqq (c, d)) = eqq (b * d, b * c)
| b 0 d := begin
  rw eqq_0_a,
  rw N.mul_zero,
  rw eqq_a_0,
  rw pair_mul_deconstruct,
  repeat {rw fst_eq},
  repeat {rw snd_eq},
  repeat {rw N.mul_zero},
  rw N.zero_mul,
  repeat {rw N.zero_add},
end
| b c 0 := begin
  rw eqq_a_0,
  rw N.mul_zero,
  rw eqq_0_a,
  rw pair_mul_deconstruct,
  repeat {rw fst_eq},
  repeat {rw snd_eq},
  repeat {rw N.zero_mul},
  rw N.mul_zero,
  repeat {rw N.zero_add},
end
| b (N.succ c) (N.succ d) := begin
  rw eqq_succ_succ,
  repeat {rw N.mul_succ},
  rw eqq_plus_right _ _ _,
  exact mul_neg_eqq _ _ _,
end

lemma mul_pos_eqq: ∀ (a c d : N), (a, 0) * (eqq (c, d)) = eqq (a * c, a * d)
| a 0 d := begin
  rw N.mul_zero,
  repeat {rw eqq_0_a},
  rw pair_mul_deconstruct,
  repeat {rw fst_eq},
  repeat {rw snd_eq},
  repeat {rw N.zero_mul},
  rw N.mul_zero,
  repeat {rw N.add_zero},
end
| a c 0 := begin
  rw N.mul_zero,
  repeat {rw eqq_a_0},
  rw pair_mul_deconstruct,
  repeat {rw fst_eq},
  repeat {rw snd_eq},
  repeat {rw N.mul_zero},
  rw N.zero_mul,
  repeat {rw N.add_zero},
end
| a (N.succ c) (N.succ d) := begin
  rw eqq_succ_succ,
  repeat {rw N.mul_succ},
  rw eqq_plus_right,
  exact mul_pos_eqq _ _ _,
end

lemma eqq_mul: ∀ (a b c d : N), eqq ((a, b) * (c, d)) = (eqq (a, b)) * (eqq (c, d))
| 0 b c d := begin
  rw eqq_0_a,
  rw pair_mul_deconstruct,
  repeat {rw fst_eq},
  repeat {rw snd_eq},
  repeat {rw N.zero_mul},
  repeat {rw N.zero_add},
  rw mul_neg_eqq _ _ _,
end
| a 0 c d := begin
  rw eqq_a_0,
  rw pair_mul_deconstruct,
  repeat {rw fst_eq},
  repeat {rw snd_eq},
  repeat {rw N.zero_mul},
  repeat {rw N.add_zero},
  rw mul_pos_eqq _ _ _,
end
| (N.succ a) (N.succ b) c d := begin
  rw eqq_succ_succ,
  rw pair_mul_deconstruct,
  repeat {rw fst_eq},
  repeat {rw snd_eq},
  repeat {rw N.succ_mul},
  rw N.add_assoc (a * c) c _,
  rw N.add_comm c _,
  rw ← N.add_assoc (a * c) _ _,
  rw ← N.add_assoc (a * d + d) _ _,
  rw eqq_plus_right,
  rw ← N.add_assoc,
  rw N.add_assoc (a * d) _ _,
  rw N.add_comm d _,
  rw ← N.add_assoc,
  rw eqq_plus_right,
  rw ← fst_eq a b,
  rw ← fst_eq c d,
  rw ← snd_eq a b,
  rw ← snd_eq c d,
  rw ← pair_mul_deconstruct,
  repeat {rw fst_eq},
  repeat {rw snd_eq},
  exact eqq_mul a b c d,
end

lemma mul_distrib (a b : N × N): quot.mk z_rel a * quot.mk z_rel b = quot.mk z_rel (a * b) := begin
  rw mul_deconstruct,
  rw ← pair_mul_deconstruct,
  cases a,
  cases b,
  repeat {rw ← paren_eq_mk},
  repeat {rw norm_deconstruction},
  rw ← eqq_mul,
  cases ((a_fst, a_snd) * (b_fst, b_snd)),
  rw ← norm_deconstruction,
  rw norm_eq_a,
end

lemma pair_mul_assoc (a b c : N × N) : (a * b) * c = a * (b * c) := begin
  repeat {rw pair_mul_deconstruct},
  cases a,
  cases b,
  cases c,
  repeat {rw fst_eq},
  repeat {rw snd_eq},
  repeat {rw N.mul_left_distrib_add},
  repeat {rw N.mul_right_distrib_add},
  repeat {rw N.mul_assoc},
  repeat {rw N.add_assoc},
  rw N.add_comm (a_snd * (b_snd * c_fst)) _,
  rw N.add_comm (a_snd * (b_snd * c_snd)) _,
  repeat {rw N.add_assoc},
end

theorem mul_assoc (a b c : Z') : (a * b) * c = a * (b * c) := begin
  rw ← a_norm_eq_a a,
  rw ← a_norm_eq_a b,
  rw ← a_norm_eq_a c,
  repeat {rw paren_eq_mk},
  repeat {rw mul_distrib},
  rw pair_mul_assoc,
end

theorem left_distrib (a b c : Z') : a * (b + c) = a * b + a * c := begin
  rw ← a_norm_eq_a a,
  rw ← a_norm_eq_a b,
  rw ← a_norm_eq_a c,
  repeat {rw paren_eq_mk},
  repeat {rw mul_distrib},
  repeat {rw add_distrib},
  rw pair_add_deconstruction,
  rw mul_distrib,
  rw pair_mul_deconstruct,
  rw fst_eq (b.norm.fst + c.norm.fst) (b.norm.snd + c.norm.snd),
  rw snd_eq (b.norm.fst + c.norm.fst) (b.norm.snd + c.norm.snd),
  repeat {rw pair_mul_deconstruct},
  rw fst_eq a.norm.fst a.norm.snd,
  rw snd_eq a.norm.fst a.norm.snd,
  rw fst_eq b.norm.fst b.norm.snd,
  rw snd_eq b.norm.fst b.norm.snd,
  rw fst_eq c.norm.fst c.norm.snd,
  rw snd_eq c.norm.fst c.norm.snd,
  rw pair_add_deconstruction,
  repeat {rw N.add_assoc},
  rw ← N.add_assoc (a.norm.snd * b.norm.snd) _ _,
  rw N.add_comm (a.norm.snd * b.norm.snd) _,
  rw ← N.add_assoc (a.norm.snd * b.norm.fst) _ _,
  rw N.add_comm (a.norm.snd * b.norm.fst) _,
  repeat {rw N.add_assoc},
  rw ← N.add_assoc (a.norm.fst * b.norm.fst) _ _,
  rw ← N.add_assoc (a.norm.fst * b.norm.snd) _ _,
  repeat {rw N.mul_left_distrib_add},
end

theorem right_distrib (a b c : Z') : (a + b) * c = a * c + b * c := begin
  rw mul_comm (a + b) _,
  rw left_distrib,
  repeat {rw mul_comm c _},
end

lemma n_mul_norm_fst (a : N) (b : Z') : a * b.norm.fst = ((fromN a) * b).norm.fst := begin
  rw fromN,
  rw mul_deconstruct,
  rw norm_deconstruction a 0,
  rw eqq_a_0,
  rw fst_eq a 0,
  rw snd_eq a 0,
  repeat {rw N.zero_mul},
  repeat {rw N.add_zero},
  have q := norm_cont_zero b,
  cases q,
  rw q,
  rw N.mul_zero,
  rw norm_deconstruction,
  rw eqq_0_a,
  rw q,
  rw N.mul_zero,
  rw norm_deconstruction,
  rw eqq_a_0,
end

lemma n_mul_norm_snd (a : N) (b : Z') : a * b.norm.snd = ((fromN a) * b).norm.snd := begin
  rw fromN,
  rw mul_deconstruct,
  rw norm_deconstruction a 0,
  rw eqq_a_0,
  rw fst_eq a 0,
  rw snd_eq a 0,
  repeat {rw N.zero_mul},
  repeat {rw N.add_zero},
  have q := norm_cont_zero b,
  cases q,
  rw q,
  rw N.mul_zero,
  rw norm_deconstruction,
  rw eqq_0_a,
  rw q,
  rw N.mul_zero,
  rw norm_deconstruction,
  rw eqq_a_0,
end

private lemma neg_distrib_left_helper (a b c d : N) : neg (⟦(a, b)⟧ * ⟦(c, d)⟧) = (neg ⟦(a, b)⟧) * ⟦(c, d)⟧ := begin
  rw neg_pair,
  rw mul_deconstruct,
  rw neg_pair,
  rw norm_symm b a,
  rw fst_eq,
  rw snd_eq ((norm ⟦(b, a)⟧).snd) ((norm ⟦(b, a)⟧).fst),
  rw N.add_comm (((norm ⟦(b, a)⟧).snd) * ((norm ⟦(c, d)⟧).snd)) _,
  rw N.add_comm ((norm ⟦(b, a)⟧).snd * (norm ⟦(c, d)⟧).fst) _,
  rw ← mul_deconstruct,
end

lemma neg_distrib_left (a b : Z') : neg (a * b) = (neg a) * b := begin
  rw ← a_norm_eq_a a,
  rw ← a_norm_eq_a b,
  exact neg_distrib_left_helper _ _ _ _,
end

def zsmul (a : ℤ) (b : Z') : Z' := (int_cast a) * b
lemma zsmul_zero (b : Z') : zsmul 0 b = 0 := begin
  rw zsmul,
  rw int_cast_zero,
  rw zero_mul,
end
lemma zsmul_succ (a : ℕ) (b : Z') : zsmul (int.of_nat (a.succ)) b = b + zsmul (int.of_nat a) b := begin
  repeat {rw zsmul},
  rw int_cast,
  rw mul_deconstruct,
  rw norm_deconstruction,
  rw eqq_a_0,
  rw fst_eq,
  rw snd_eq _ 0,
  repeat {rw N.zero_mul},
  repeat {rw N.add_zero},
  rw N.nat_cast,
  repeat {rw N.succ_mul},
  rw N.add_comm _ b.norm.snd,
  rw n_mul_norm_fst,
  rw n_mul_norm_snd,
  rw ← add_deconstruct,
  rw add_comm,
  rw fromN,
  rw int_cast,
end
lemma zsmul_neg (a : ℕ) (b : Z') : zsmul (int.neg_succ_of_nat a) b = -zsmul (int.of_nat (a.succ)) b := begin
  repeat {rw zsmul},
  repeat {rw int_cast},
  rw ← neg_deconstruct,
  rw neg_distrib_left,
  rw neg_pair,
end

def npow: ∀ (a : ℕ) (b : Z'), Z'
| 0 b := 1
| (nat.succ a) b := b * (npow a b)

lemma npow_zero (b : Z') : npow 0 b = 1 := rfl
lemma npow_succ (a : ℕ) (b : Z') : npow (a.succ) b = b * (npow a b) := rfl

instance : comm_ring Z' := ⟨ add, add_assoc, zero, zero_add, add_zero, nsmul, nsmul_zero, nsmul_succ, neg, sub, sub_eq_add_neg, zsmul, zsmul_zero, zsmul_succ, zsmul_neg, add_left_neg, add_comm, mul, mul_assoc, one, one_mul, mul_one, npow, npow_zero, npow_succ, left_distrib, right_distrib, mul_comm, ⟩

end Z'


/-
Copyright (c) 2020 Bhavik Mehta, Edward Ayers, Thomas Read. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Bhavik Mehta, Edward Ayers, Thomas Read

! This file was ported from Lean 3 source module category_theory.closed.cartesian
! leanprover-community/mathlib commit 239d882c4fb58361ee8b3b39fb2091320edef10a
! Please do not edit these lines, except to modify the commit id
! if you have ported upstream changes.
-/
import Mathbin.CategoryTheory.EpiMono
import Mathbin.CategoryTheory.Limits.Shapes.FiniteProducts
import Mathbin.CategoryTheory.Monoidal.OfHasFiniteProducts
import Mathbin.CategoryTheory.Limits.Preserves.Shapes.BinaryProducts
import Mathbin.CategoryTheory.Adjunction.Limits
import Mathbin.CategoryTheory.Adjunction.Mates
import Mathbin.CategoryTheory.Closed.Monoidal

/-!
# Cartesian closed categories

Given a category with finite products, the cartesian monoidal structure is provided by the local
instance `monoidal_of_has_finite_products`.

We define exponentiable objects to be closed objects with respect to this monoidal structure,
i.e. `(X × -)` is a left adjoint.

We say a category is cartesian closed if every object is exponentiable
(equivalently, that the category equipped with the cartesian monoidal structure is closed monoidal).

Show that exponential forms a difunctor and define the exponential comparison morphisms.

## TODO
Some of the results here are true more generally for closed objects and
for closed monoidal categories, and these could be generalised.
-/

universe v u u₂

noncomputable section

namespace CategoryTheory

open CategoryTheory CategoryTheory.Category CategoryTheory.Limits

attribute [local instance] monoidal_of_has_finite_products

/-- An object `X` is *exponentiable* if `(X × -)` is a left adjoint.
We define this as being `closed` in the cartesian monoidal structure.
-/
abbrev Exponentiable {C : Type u} [Category.{v} C] [HasFiniteProducts C] (X : C) :=
  Closed X
#align category_theory.exponentiable CategoryTheory.Exponentiable

/-- If `X` and `Y` are exponentiable then `X ⨯ Y` is.
This isn't an instance because it's not usually how we want to construct exponentials, we'll usually
prove all objects are exponential uniformly.
-/
def binaryProductExponentiable {C : Type u} [Category.{v} C] [HasFiniteProducts C] {X Y : C}
    (hX : Exponentiable X) (hY : Exponentiable Y) : Exponentiable (X ⨯ Y) :=
  tensorClosed hX hY
#align category_theory.binary_product_exponentiable CategoryTheory.binaryProductExponentiable

/-- The terminal object is always exponentiable.
This isn't an instance because most of the time we'll prove cartesian closed for all objects
at once, rather than just for this one.
-/
def terminalExponentiable {C : Type u} [Category.{v} C] [HasFiniteProducts C] :
    Exponentiable (⊤_ C) :=
  unitClosed
#align category_theory.terminal_exponentiable CategoryTheory.terminalExponentiable

/-- A category `C` is cartesian closed if it has finite products and every object is exponentiable.
We define this as `monoidal_closed` with respect to the cartesian monoidal structure.
-/
abbrev CartesianClosed (C : Type u) [Category.{v} C] [HasFiniteProducts C] :=
  MonoidalClosed C
#align category_theory.cartesian_closed CategoryTheory.CartesianClosed

variable {C : Type u} [Category.{v} C] (A B : C) {X X' Y Y' Z : C}

variable [HasFiniteProducts C] [Exponentiable A]

/-- This is (-)^A. -/
abbrev exp : C ⥤ C :=
  ihom A
#align category_theory.exp CategoryTheory.exp

namespace Exp

/-- The adjunction between A ⨯ - and (-)^A. -/
abbrev adjunction : prod.functor.obj A ⊣ exp A :=
  ihom.adjunction A
#align category_theory.exp.adjunction CategoryTheory.exp.adjunction

/-- The evaluation natural transformation. -/
abbrev ev : exp A ⋙ prod.functor.obj A ⟶ 𝟭 C :=
  ihom.ev A
#align category_theory.exp.ev CategoryTheory.exp.ev

/-- The coevaluation natural transformation. -/
abbrev coev : 𝟭 C ⟶ prod.functor.obj A ⋙ exp A :=
  ihom.coev A
#align category_theory.exp.coev CategoryTheory.exp.coev

-- mathport name: «expr ⟹ »
notation:20 A " ⟹ " B:19 => (exp A).obj B

-- mathport name: «expr ^^ »
notation:30 B " ^^ " A:30 => (exp A).obj B

@[simp, reassoc.1]
theorem ev_coev : Limits.prod.map (𝟙 A) ((coev A).app B) ≫ (ev A).app (A ⨯ B) = 𝟙 (A ⨯ B) :=
  ihom.ev_coev A B
#align category_theory.exp.ev_coev CategoryTheory.exp.ev_coev

@[simp, reassoc.1]
theorem coev_ev : (coev A).app (A ⟹ B) ≫ (exp A).map ((ev A).app B) = 𝟙 (A ⟹ B) :=
  ihom.coev_ev A B
#align category_theory.exp.coev_ev CategoryTheory.exp.coev_ev

end Exp

instance : PreservesColimits (prod.functor.obj A) :=
  (ihom.adjunction A).leftAdjointPreservesColimits

variable {A}

-- Wrap these in a namespace so we don't clash with the core versions.
namespace CartesianClosed

/-- Currying in a cartesian closed category. -/
def curry : (A ⨯ Y ⟶ X) → (Y ⟶ A ⟹ X) :=
  (exp.adjunction A).homEquiv _ _
#align category_theory.cartesian_closed.curry CategoryTheory.CartesianClosed.curry

/-- Uncurrying in a cartesian closed category. -/
def uncurry : (Y ⟶ A ⟹ X) → (A ⨯ Y ⟶ X) :=
  ((exp.adjunction A).homEquiv _ _).symm
#align category_theory.cartesian_closed.uncurry CategoryTheory.CartesianClosed.uncurry

@[simp]
theorem homEquiv_apply_eq (f : A ⨯ Y ⟶ X) : (exp.adjunction A).homEquiv _ _ f = curry f :=
  rfl
#align category_theory.cartesian_closed.hom_equiv_apply_eq CategoryTheory.CartesianClosed.homEquiv_apply_eq

@[simp]
theorem homEquiv_symm_apply_eq (f : Y ⟶ A ⟹ X) :
    ((exp.adjunction A).homEquiv _ _).symm f = uncurry f :=
  rfl
#align category_theory.cartesian_closed.hom_equiv_symm_apply_eq CategoryTheory.CartesianClosed.homEquiv_symm_apply_eq

@[reassoc.1]
theorem curry_natural_left (f : X ⟶ X') (g : A ⨯ X' ⟶ Y) :
    curry (Limits.prod.map (𝟙 _) f ≫ g) = f ≫ curry g :=
  Adjunction.homEquiv_naturality_left _ _ _
#align category_theory.cartesian_closed.curry_natural_left CategoryTheory.CartesianClosed.curry_natural_left

@[reassoc.1]
theorem curry_natural_right (f : A ⨯ X ⟶ Y) (g : Y ⟶ Y') :
    curry (f ≫ g) = curry f ≫ (exp _).map g :=
  Adjunction.homEquiv_naturality_right _ _ _
#align category_theory.cartesian_closed.curry_natural_right CategoryTheory.CartesianClosed.curry_natural_right

@[reassoc.1]
theorem uncurry_natural_right (f : X ⟶ A ⟹ Y) (g : Y ⟶ Y') :
    uncurry (f ≫ (exp _).map g) = uncurry f ≫ g :=
  Adjunction.homEquiv_naturality_right_symm _ _ _
#align category_theory.cartesian_closed.uncurry_natural_right CategoryTheory.CartesianClosed.uncurry_natural_right

@[reassoc.1]
theorem uncurry_natural_left (f : X ⟶ X') (g : X' ⟶ A ⟹ Y) :
    uncurry (f ≫ g) = Limits.prod.map (𝟙 _) f ≫ uncurry g :=
  Adjunction.homEquiv_naturality_left_symm _ _ _
#align category_theory.cartesian_closed.uncurry_natural_left CategoryTheory.CartesianClosed.uncurry_natural_left

@[simp]
theorem uncurry_curry (f : A ⨯ X ⟶ Y) : uncurry (curry f) = f :=
  (Closed.isAdj.adj.homEquiv _ _).left_inv f
#align category_theory.cartesian_closed.uncurry_curry CategoryTheory.CartesianClosed.uncurry_curry

@[simp]
theorem curry_uncurry (f : X ⟶ A ⟹ Y) : curry (uncurry f) = f :=
  (Closed.isAdj.adj.homEquiv _ _).right_inv f
#align category_theory.cartesian_closed.curry_uncurry CategoryTheory.CartesianClosed.curry_uncurry

theorem curry_eq_iff (f : A ⨯ Y ⟶ X) (g : Y ⟶ A ⟹ X) : curry f = g ↔ f = uncurry g :=
  Adjunction.homEquiv_apply_eq _ f g
#align category_theory.cartesian_closed.curry_eq_iff CategoryTheory.CartesianClosed.curry_eq_iff

theorem eq_curry_iff (f : A ⨯ Y ⟶ X) (g : Y ⟶ A ⟹ X) : g = curry f ↔ uncurry g = f :=
  Adjunction.eq_homEquiv_apply _ f g
#align category_theory.cartesian_closed.eq_curry_iff CategoryTheory.CartesianClosed.eq_curry_iff

-- I don't think these two should be simp.
theorem uncurry_eq (g : Y ⟶ A ⟹ X) : uncurry g = Limits.prod.map (𝟙 A) g ≫ (exp.ev A).app X :=
  Adjunction.homEquiv_counit _
#align category_theory.cartesian_closed.uncurry_eq CategoryTheory.CartesianClosed.uncurry_eq

theorem curry_eq (g : A ⨯ Y ⟶ X) : curry g = (exp.coev A).app Y ≫ (exp A).map g :=
  Adjunction.homEquiv_unit _
#align category_theory.cartesian_closed.curry_eq CategoryTheory.CartesianClosed.curry_eq

theorem uncurry_id_eq_ev (A X : C) [Exponentiable A] : uncurry (𝟙 (A ⟹ X)) = (exp.ev A).app X := by
  rw [uncurry_eq, prod.map_id_id, id_comp]
#align category_theory.cartesian_closed.uncurry_id_eq_ev CategoryTheory.CartesianClosed.uncurry_id_eq_ev

theorem curry_id_eq_coev (A X : C) [Exponentiable A] : curry (𝟙 _) = (exp.coev A).app X :=
  by
  rw [curry_eq, (exp A).map_id (A ⨯ _)]
  apply comp_id
#align category_theory.cartesian_closed.curry_id_eq_coev CategoryTheory.CartesianClosed.curry_id_eq_coev

theorem curry_injective : Function.Injective (curry : (A ⨯ Y ⟶ X) → (Y ⟶ A ⟹ X)) :=
  (Closed.isAdj.adj.homEquiv _ _).Injective
#align category_theory.cartesian_closed.curry_injective CategoryTheory.CartesianClosed.curry_injective

theorem uncurry_injective : Function.Injective (uncurry : (Y ⟶ A ⟹ X) → (A ⨯ Y ⟶ X)) :=
  (Closed.isAdj.adj.homEquiv _ _).symm.Injective
#align category_theory.cartesian_closed.uncurry_injective CategoryTheory.CartesianClosed.uncurry_injective

end CartesianClosed

open CartesianClosed

/-- Show that the exponential of the terminal object is isomorphic to itself, i.e. `X^1 ≅ X`.

The typeclass argument is explicit: any instance can be used.
-/
def expTerminalIsoSelf [Exponentiable (⊤_ C)] : (⊤_ C) ⟹ X ≅ X :=
  Yoneda.ext ((⊤_ C) ⟹ X) X (fun Y f => (prod.leftUnitor Y).inv ≫ CartesianClosed.uncurry f)
    (fun Y f => CartesianClosed.curry ((prod.leftUnitor Y).Hom ≫ f))
    (fun Z g => by rw [curry_eq_iff, iso.hom_inv_id_assoc]) (fun Z g => by simp) fun Z W f g => by
    rw [uncurry_natural_left, prod.left_unitor_inv_naturality_assoc f]
#align category_theory.exp_terminal_iso_self CategoryTheory.expTerminalIsoSelf

/-- The internal element which points at the given morphism. -/
def internalizeHom (f : A ⟶ Y) : ⊤_ C ⟶ A ⟹ Y :=
  CartesianClosed.curry (Limits.prod.fst ≫ f)
#align category_theory.internalize_hom CategoryTheory.internalizeHom

section Pre

variable {B}

/-- Pre-compose an internal hom with an external hom. -/
def pre (f : B ⟶ A) [Exponentiable B] : exp A ⟶ exp B :=
  transferNatTransSelf (exp.adjunction _) (exp.adjunction _) (prod.functor.map f)
#align category_theory.pre CategoryTheory.pre

theorem prod_map_pre_app_comp_ev (f : B ⟶ A) [Exponentiable B] (X : C) :
    Limits.prod.map (𝟙 B) ((pre f).app X) ≫ (exp.ev B).app X =
      Limits.prod.map f (𝟙 (A ⟹ X)) ≫ (exp.ev A).app X :=
  transferNatTransSelf_counit _ _ (prod.functor.map f) X
#align category_theory.prod_map_pre_app_comp_ev CategoryTheory.prod_map_pre_app_comp_ev

theorem uncurry_pre (f : B ⟶ A) [Exponentiable B] (X : C) :
    CartesianClosed.uncurry ((pre f).app X) = Limits.prod.map f (𝟙 _) ≫ (exp.ev A).app X := by
  rw [uncurry_eq, prod_map_pre_app_comp_ev]
#align category_theory.uncurry_pre CategoryTheory.uncurry_pre

theorem coev_app_comp_pre_app (f : B ⟶ A) [Exponentiable B] :
    (exp.coev A).app X ≫ (pre f).app (A ⨯ X) =
      (exp.coev B).app X ≫ (exp B).map (Limits.prod.map f (𝟙 _)) :=
  unit_transferNatTransSelf _ _ (prod.functor.map f) X
#align category_theory.coev_app_comp_pre_app CategoryTheory.coev_app_comp_pre_app

@[simp]
theorem pre_id (A : C) [Exponentiable A] : pre (𝟙 A) = 𝟙 _ := by simp [pre]
#align category_theory.pre_id CategoryTheory.pre_id

@[simp]
theorem pre_map {A₁ A₂ A₃ : C} [Exponentiable A₁] [Exponentiable A₂] [Exponentiable A₃]
    (f : A₁ ⟶ A₂) (g : A₂ ⟶ A₃) : pre (f ≫ g) = pre g ≫ pre f := by
  rw [pre, pre, pre, transfer_nat_trans_self_comp, prod.functor.map_comp]
#align category_theory.pre_map CategoryTheory.pre_map

end Pre

/-- The internal hom functor given by the cartesian closed structure. -/
def internalHom [CartesianClosed C] : Cᵒᵖ ⥤ C ⥤ C
    where
  obj X := exp X.unop
  map X Y f := pre f.unop
#align category_theory.internal_hom CategoryTheory.internalHom

/-- If an initial object `I` exists in a CCC, then `A ⨯ I ≅ I`. -/
@[simps]
def zeroMul {I : C} (t : IsInitial I) : A ⨯ I ≅ I
    where
  Hom := Limits.prod.snd
  inv := t.to _
  hom_inv_id' :=
    by
    have : (limits.prod.snd : A ⨯ I ⟶ I) = cartesian_closed.uncurry (t.to _)
    rw [← curry_eq_iff]
    apply t.hom_ext
    rw [this, ← uncurry_natural_right, ← eq_curry_iff]
    apply t.hom_ext
  inv_hom_id' := t.hom_ext _ _
#align category_theory.zero_mul CategoryTheory.zeroMul

/-- If an initial object `0` exists in a CCC, then `0 ⨯ A ≅ 0`. -/
def mulZero {I : C} (t : IsInitial I) : I ⨯ A ≅ I :=
  Limits.prod.braiding _ _ ≪≫ zeroMul t
#align category_theory.mul_zero CategoryTheory.mulZero

/-- If an initial object `0` exists in a CCC then `0^B ≅ 1` for any `B`. -/
def powZero {I : C} (t : IsInitial I) [CartesianClosed C] : I ⟹ B ≅ ⊤_ C
    where
  Hom := default
  inv := CartesianClosed.curry ((mulZero t).Hom ≫ t.to _)
  hom_inv_id' :=
    by
    rw [← curry_natural_left, curry_eq_iff, ← cancel_epi (MulZeroClass.mul_zero t).inv]
    · apply t.hom_ext
    · infer_instance
    · infer_instance
#align category_theory.pow_zero CategoryTheory.powZero

-- TODO: Generalise the below to its commutated variants.
-- TODO: Define a distributive category, so that zero_mul and friends can be derived from this.
/-- In a CCC with binary coproducts, the distribution morphism is an isomorphism. -/
def prodCoprodDistrib [HasBinaryCoproducts C] [CartesianClosed C] (X Y Z : C) :
    (Z ⨯ X) ⨿ Z ⨯ Y ≅ Z ⨯ X ⨿ Y
    where
  Hom := coprod.desc (Limits.prod.map (𝟙 _) coprod.inl) (Limits.prod.map (𝟙 _) coprod.inr)
  inv :=
    CartesianClosed.uncurry
      (coprod.desc (CartesianClosed.curry coprod.inl) (CartesianClosed.curry coprod.inr))
  hom_inv_id' := by
    apply coprod.hom_ext
    rw [coprod.inl_desc_assoc, comp_id, ← uncurry_natural_left, coprod.inl_desc, uncurry_curry]
    rw [coprod.inr_desc_assoc, comp_id, ← uncurry_natural_left, coprod.inr_desc, uncurry_curry]
  inv_hom_id' := by
    rw [← uncurry_natural_right, ← eq_curry_iff]
    apply coprod.hom_ext
    rw [coprod.inl_desc_assoc, ← curry_natural_right, coprod.inl_desc, ← curry_natural_left,
      comp_id]
    rw [coprod.inr_desc_assoc, ← curry_natural_right, coprod.inr_desc, ← curry_natural_left,
      comp_id]
#align category_theory.prod_coprod_distrib CategoryTheory.prodCoprodDistrib

/-- If an initial object `I` exists in a CCC then it is a strict initial object,
i.e. any morphism to `I` is an iso.
This actually shows a slightly stronger version: any morphism to an initial object from an
exponentiable object is an isomorphism.
-/
theorem strict_initial {I : C} (t : IsInitial I) (f : A ⟶ I) : IsIso f :=
  by
  haveI : mono (limits.prod.lift (𝟙 A) f ≫ (MulZeroClass.zero_mul t).Hom) := mono_comp _ _
  rw [zero_mul_hom, prod.lift_snd] at _inst
  haveI : is_split_epi f := is_split_epi.mk' ⟨t.to _, t.hom_ext _ _⟩
  apply is_iso_of_mono_of_is_split_epi
#align category_theory.strict_initial CategoryTheory.strict_initial

instance to_initial_isIso [HasInitial C] (f : A ⟶ ⊥_ C) : IsIso f :=
  strict_initial initialIsInitial _
#align category_theory.to_initial_is_iso CategoryTheory.to_initial_isIso

/-- If an initial object `0` exists in a CCC then every morphism from it is monic. -/
theorem initial_mono {I : C} (B : C) (t : IsInitial I) [CartesianClosed C] : Mono (t.to B) :=
  ⟨fun B g h _ => by
    haveI := strict_initial t g
    haveI := strict_initial t h
    exact eq_of_inv_eq_inv (t.hom_ext _ _)⟩
#align category_theory.initial_mono CategoryTheory.initial_mono

instance Initial.mono_to [HasInitial C] (B : C) [CartesianClosed C] : Mono (initial.to B) :=
  initial_mono B initialIsInitial
#align category_theory.initial.mono_to CategoryTheory.Initial.mono_to

variable {D : Type u₂} [Category.{v} D]

section Functor

variable [HasFiniteProducts D]

/-- Transport the property of being cartesian closed across an equivalence of categories.

Note we didn't require any coherence between the choice of finite products here, since we transport
along the `prod_comparison` isomorphism.
-/
def cartesianClosedOfEquiv (e : C ≌ D) [h : CartesianClosed C] : CartesianClosed D
    where closed' X :=
    {
      isAdj := by
        haveI q : exponentiable (e.inverse.obj X) := inferInstance
        have : is_left_adjoint (prod.functor.obj (e.inverse.obj X)) := q.is_adj
        have : e.functor ⋙ prod.functor.obj X ⋙ e.inverse ≅ prod.functor.obj (e.inverse.obj X)
        apply nat_iso.of_components _ _
        intro Y
        · apply as_iso (prod_comparison e.inverse X (e.functor.obj Y)) ≪≫ _
          apply prod.map_iso (iso.refl _) (e.unit_iso.app Y).symm
        · intro Y Z g
          dsimp [prod_comparison]
          simp [prod.comp_lift, ← e.inverse.map_comp, ← e.inverse.map_comp_assoc]
          -- I wonder if it would be a good idea to make `map_comp` a simp lemma the other way round
          dsimp
          simp
        -- See note [dsimp, simp]
        · have : is_left_adjoint (e.functor ⋙ prod.functor.obj X ⋙ e.inverse) :=
            adjunction.left_adjoint_of_nat_iso this.symm
          have : is_left_adjoint (e.inverse ⋙ e.functor ⋙ prod.functor.obj X ⋙ e.inverse) :=
            adjunction.left_adjoint_of_comp e.inverse _
          have :
            (e.inverse ⋙ e.functor ⋙ prod.functor.obj X ⋙ e.inverse) ⋙ e.functor ≅
              prod.functor.obj X :=
            by
            apply iso_whisker_right e.counit_iso (prod.functor.obj X ⋙ e.inverse ⋙ e.functor) ≪≫ _
            change prod.functor.obj X ⋙ e.inverse ⋙ e.functor ≅ prod.functor.obj X
            apply iso_whisker_left (prod.functor.obj X) e.counit_iso
          skip
          apply adjunction.left_adjoint_of_nat_iso this }
#align category_theory.cartesian_closed_of_equiv CategoryTheory.cartesianClosedOfEquiv

end Functor

end CategoryTheory


namespace morphism_composition
/-
    Goal to make effective the composition
-/
open morphism
variables {M1 : Type w}  [add_comm_group M1] [module R M1]
          {M2 : Type w'} [add_comm_group M2] [module R M2]
          {M3 : Type w''} [add_comm_group M3] [module R M3]
          {ρ1 : group_representation G R M1}
          {ρ2  : group_representation G R M2}
          {ρ3 : group_representation G R M3}
          {M4 : Type w'''} [add_comm_group M4] [module R M4]
          {ρ4 : group_representation G R M4}

lemma 𝒞_o_e_r_s_i_o_n (f : M1 →ₗ[R] M2)(g : M2→ₗ[R] M3) : ⇑ (g ⊚ f)  = (⇑g ∘ ⇑f)  := rfl
lemma 𝒞_o_e_r_s_i_o_n₂ (f : M1 ≃ₗ[R] M1)(g : M1→ₗ[R] M1) : ⇑(g *  (f : M1 →ₗ[R]M1) )  = (⇑g ∘  ⇑f)  := rfl

lemma Endomorphism.apply (ρ : group_representation G R M1) ( f : Endomorphism ρ ) (x : M1) (g : G) :
f.ℓ (ρ g x) =  ρ g (f.ℓ x) := begin
  erw ← function.comp_apply ⇑f.ℓ ⇑(ρ g) x, erw ← 𝒞_o_e_r_s_i_o_n₂ ((ρ g)),rw f.commute, exact rfl,
end
theorem Endomorphism_to_morphism (f : Endomorphism ρ1 ) : ρ1 ⟶ ρ1 := { ℓ := f.ℓ ,
  commute := begin intros g, rw ← 𝒞_o_e_r_s_i_o_n₂ (ρ1 g ) f.ℓ, rw f.commute, exact rfl,  end }

def compo  (f2 : ρ1 ⟶ ρ2)(f3 : ρ2 ⟶ ρ3) : ρ1 ⟶ ρ3 :=
  {ℓ :=  (f3.ℓ : M2 →ₗ[R] M3) *  (f2.ℓ : M1 →ₗ[R] M2),
  commute := begin
    intros,ext x, erw  𝒞_o_e_r_s_i_o_n _ _  ,
    iterate 4 {rw function.comp_apply},
    erw commute_apply ρ1,
    erw commute_apply ρ2,
    exact rfl,
   end}
infixr ` ≫ `:80 := compo  -- Same sens has category
@[simp]lemma comp_ext (f2 : ρ1 ⟶ ρ2)(f3 : ρ2 ⟶ ρ3) : (f2 ≫ f3).ℓ  = f3.ℓ  ∘  f2.ℓ := rfl
variables
@[simp]theorem comp_assoc  (f2 : ρ1 ⟶ ρ2)(f3 : ρ2 ⟶ ρ3) (f4 : ρ3 ⟶ ρ4)  : (f2 ≫  f3) ≫ f4 = f2 ≫ (f3 ≫ f4) :=
begin ext, exact rfl, end

@[simp]lemma comp_apply (f2 : ρ1 ⟶ ρ2)(f3 : ρ2 ⟶ ρ3) ( x1 : M1 ) : (f2 ≫ f3) x1 = f3( f2 x1) := rfl

end morphism_composition
namespace One
variables {M1 : Type w}  [add_comm_group M1] [module R M1]
          {M2 : Type w'} [add_comm_group M2] [module R M2]
          {ρ1 : group_representation G R M1}
          {ρ2  : group_representation G R M2}

@[ext]lemma one_ext (ρ1 : group_representation G R M1) : (one ρ1).ℓ = linear_map.id := rfl
notation `𝟙 ` ρ1 := one ρ1
@[simp]lemma id_comp (f2 : ρ1 ⟶ ρ2) : (𝟙 ρ1) ≫ f2 = f2 := by {ext, exact rfl}
@[simp]lemma comp_id  (f2 : ρ1 ⟶ ρ2) : f2 ≫ (𝟙 ρ2) = f2 := by { ext, exact rfl}
end One


import tactic
open classical

universes u v

attribute [instance, priority 0] classical.prop_decidable

structure kripke_frame :=
(world : Type u)
(rel : world → world → Prop)

variables (F : kripke_frame) {α : Type*}

namespace kripke_frame

class T := (reflexivity : ∀ w, F.rel w w)

class B := (symmetry : ∀ {w v}, F.rel w v → F.rel v w)

class Four := (transitive : ∀ {w v u}, F.rel w v → F.rel v u → F.rel w u)

class S5 extends T F, B F, Four F

instance : has_coe_to_sort kripke_frame (Type*) := ⟨kripke_frame.world⟩

abbreviation prop := set F

variables {F}
def mverum : F.prop := λ w, true
notation `⊤ₘ` := mverum

def mfalsum : F.prop := λ w, false
notation `⊥ₘ` := mfalsum

def mnot : F.prop → F.prop := λ φ w, ¬φ w
prefix `¬ₘ`:70 := mnot

def mand : F.prop → F.prop → F.prop := λ φ ψ w, φ w ∧ ψ w
infixl ` ∧ₘ `:67 := mand

def mor : F.prop → F.prop → F.prop := λ φ ψ w, φ w ∨ ψ w
infixl ` ∨ₘ `:66 := mor

def mimplies : F.prop → F.prop → F.prop := λ φ ψ w, φ w → ψ w
infixr ` ⟶ `:65 := mimplies

def miff : F.prop → F.prop → F.prop := λ φ ψ w, φ w ↔ ψ w
infix ` ⟷ `:60 := miff

def mforall : Π {α}, (α → F.prop) → F.prop := λ α φ w, ∀ x, φ x w
notation `∀ₘ` binders `, ` r:(scoped p, mforall p) := r

def mexists : Π {α}, (α → F.prop) → F.prop := λ α φ w, ∃ x, φ x w
notation `∃ₘ` binders `, ` r:(scoped p, mexists p) := r

def mbox : F.prop → F.prop := λ φ w, ∀ v, F.rel w v → φ v
prefix `□`:70 := mbox

def mdia : F.prop → F.prop := λ φ w, ∃ v, F.rel w v ∧ φ v
prefix `◇`:70 := mdia

def valid (φ : F.prop) : Prop := ∀ w, φ w
prefix `⊧ `:30 := valid

end kripke_frame

namespace ml
open kripke_frame
variables {F} {φ ψ : F.prop}

lemma mK {φ ψ : F.prop} : ⊧ □(φ ⟶ ψ) ⟶ □φ ⟶ □ψ :=
λ w h₁ h₂ v hv, h₁ v hv (h₂ v hv)

lemma mnot_mbox_eq {φ : F.prop} : ¬ₘ□φ = ◇¬ₘφ :=
funext (λ w, by simp[mnot, mbox, mdia])

lemma mnot_mforall_eq {φ : α → F.prop} : ¬ₘ(∀ₘ x, φ x) = ∃ₘ x, ¬ₘφ x :=
funext (λ w, by simp[mforall, mexists, mnot])

lemma em : ⊧ φ ∨ₘ ¬ₘφ := λ w, classical.em (φ w)

lemma N : (⊧ φ) → (⊧ □φ) := λ h w v hv, h v

theorem box_implies [T F] : ⊧ □φ ⟶ φ := λ w h, h w (T.reflexivity w)

theorem implies_box_dia [B F] : ⊧ φ ⟶ □◇φ := λ w h v hv, ⟨w, B.symmetry hv, h⟩

theorem box_implies_box_box [Four F] : ⊧ □φ ⟶ □□φ :=
λ w h v hv u hu, h u (Four.transitive hv hu)

theorem dia_box_implies_box [S5 F] : ⊧ ◇□φ ⟶ □φ :=
λ w ⟨v, hv, h⟩ u hu, by { have : F.rel v u, from Four.transitive (B.symmetry hv) hu, refine h u this }

end ml


import Mathlib.Tactic.Nontriviality
import Mathlib.Algebra.Order.Ring.Defs
import Mathlib.Data.Nat.Basic
-- import Mathlib.Data.Set.Basic

/-! ### Test `nontriviality` with inequality hypotheses -/

example {R : Type} [OrderedRing R] {a : R} (h : 0 < a) : 0 < a := by
  nontriviality
  rename_i inst; guard_hyp inst : Nontrivial R
  assumption

/-! ### Test `nontriviality` with equality or non-strict inequality goals -/

example {R : Type} [CommRing R] {r s : R} : r * s = s * r := by
  nontriviality
  rename_i inst; guard_hyp inst : Nontrivial R
  apply mul_comm

/-! ### Test deducing `nontriviality` by instance search -/

example {R : Type} [OrderedRing R] : 0 ≤ (1 : R) := by
  nontriviality R
  rename_i inst; guard_hyp inst : Nontrivial R
  exact zero_le_one

example {R : Type} [OrderedRing R] : 0 ≤ (1 : R) := by
  nontriviality ℕ
  rename_i inst; guard_hyp inst : Nontrivial ℕ
  exact zero_le_one

example {R : Type} [OrderedRing R] : 0 ≤ (2 : R) := by
  fail_if_success nontriviality PUnit
  exact zero_le_two

example {R : Type} [OrderedRing R] {a : R} (h : 0 < a) : 2 ∣ 4 := by
  nontriviality R
  rename_i inst; guard_hyp inst : Nontrivial R
  decide

/-! Test using `@[nontriviality]` lemmas in `nontriviality and custom `simp` lemmas -/

def EmptyOrUniv {α : Type _} (s : Set α) : Prop :=
  s = ∅ ∨ s = Set.univ

theorem Subsingleton.set_empty_or_univ {α} [Subsingleton α] (s : Set α) : s = ∅ ∨ s = Set.univ :=
  sorry

theorem Subsingleton.set_empty_or_univ' {α} [Subsingleton α] (s : Set α) : EmptyOrUniv s :=
  Subsingleton.set_empty_or_univ s

theorem Set.empty_union (a : Set α) : ∅ ∪ a = a := sorry

example {α : Type _} (s : Set α) (hs : s = ∅ ∪ Set.univ) : EmptyOrUniv s := by
  fail_if_success nontriviality α
  rw [Set.empty_union] at hs
  exact Or.inr hs

section

attribute [local nontriviality] Subsingleton.set_empty_or_univ

example {α : Type _} (s : Set α) (hs : s = ∅ ∪ Set.univ) : EmptyOrUniv s := by
  fail_if_success nontriviality α
  nontriviality α using Subsingleton.set_empty_or_univ'
  rw [Set.empty_union] at hs
  exact Or.inr hs

end

attribute [local nontriviality] Subsingleton.set_empty_or_univ'

example {α : Type _} (s : Set α) (hs : s = ∅ ∪ Set.univ) : EmptyOrUniv s := by
  nontriviality α
  rw [Set.empty_union] at hs
  exact Or.inr hs

/-! Test with nonatomic type argument -/

example (α : ℕ → Type) (a b : α 0) (h : a = b) : a = b := by
  nontriviality α 0 using Nat.zero_lt_one
  rename_i inst; guard_hyp inst : Nontrivial (α 0)
  exact h

class Foo (α : Type) : Prop
instance : Foo α := {}

example (α : Type) : Foo α := by nontriviality α; infer_instance


/-
Copyright (c) 2020 Yury G. Kudryashov. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Yury G. Kudryashov
-/
import order.conditionally_complete_lattice
import logic.function.conjugate
import order.ord_continuous
import data.equiv.mul_add

/-!
# Semiconjugate by `Sup`

In this file we prove two facts about semiconjugate (families of) functions.

First, if an order isomorphism `fa : α → α` is semiconjugate to an order embedding `fb : β → β` by
`g : α → β`, then `fb` is semiconjugate to `fa` by `y ↦ Sup {x | g x ≤ y}`, see
`semiconj.symm_adjoint`.

Second, consider two actions `f₁ f₂ : G → α → α` of a group on a complete lattice by order
isomorphisms. Then the map `x ↦ ⨆ g : G, (f₁ g)⁻¹ (f₂ g x)` semiconjugates each `f₁ g'` to `f₂ g'`,
see `function.Sup_div_semiconj`.  In the case of a conditionally complete lattice, a similar
statement holds true under an additional assumption that each set `{(f₁ g)⁻¹ (f₂ g x) | g : G}` is
bounded above, see `function.cSup_div_semiconj`.

The lemmas come from [Étienne Ghys, Groupes d'homeomorphismes du cercle et cohomologie
bornee][ghys87:groupes], Proposition 2.1 and 5.4 respectively. In the paper they are formulated for
homeomorphisms of the circle, so in order to apply results from this file one has to lift these
homeomorphisms to the real line first.
-/

variables {α β γ : Type*}

open set

/-- We say that `g : β → α` is an order right adjoint function for `f : α → β` if it sends each `y`
to a least upper bound for `{x | f x ≤ y}`. If `α` is a partial order, and `f : α → β` has
a right adjoint, then this right adjoint is unique. -/
def is_order_right_adjoint [preorder α] [preorder β] (f : α → β) (g : β → α) :=
∀ y, is_lub {x | f x ≤ y} (g y)

lemma is_order_right_adjoint_Sup [complete_lattice α] [preorder β] (f : α → β) :
  is_order_right_adjoint f (λ y, Sup {x | f x ≤ y}) :=
λ y, is_lub_Sup _

lemma is_order_right_adjoint_cSup [conditionally_complete_lattice α] [preorder β] (f : α → β)
  (hne : ∀ y, ∃ x, f x ≤ y) (hbdd : ∀ y, bdd_above {x | f x ≤ y}) :
  is_order_right_adjoint f (λ y, Sup {x | f x ≤ y}) :=
λ y, is_lub_cSup (hne y) (hbdd y)

namespace is_order_right_adjoint

protected

lemma right_mono [preorder α] [preorder β] {f : α → β} {g : β → α}
  (h : is_order_right_adjoint f g) :
  monotone g :=
λ y₁ y₂ hy, (h y₁).mono (h y₂) $ λ x hx, le_trans hx hy

lemma order_iso_comp [preorder α] [preorder β] [preorder γ] {f : α → β} {g : β → α}
  (h : is_order_right_adjoint f g) (e : β ≃o γ) :
  is_order_right_adjoint (e ∘ f) (g ∘ e.symm) :=
λ y, by simpa [e.le_symm_apply] using h (e.symm y)

lemma comp_order_iso [preorder α] [preorder β] [preorder γ] {f : α → β} {g : β → α}
  (h : is_order_right_adjoint f g) (e : γ ≃o α) :
  is_order_right_adjoint (f ∘ e) (e.symm ∘ g) :=
begin
  intro y,
  change is_lub (e ⁻¹' {x | f x ≤ y}) (e.symm (g y)),
  rw [e.is_lub_preimage, e.apply_symm_apply],
  exact h y
end

end is_order_right_adjoint

namespace function

/-- If an order automorphism `fa` is semiconjugate to an order embedding `fb` by a function `g`
and `g'` is an order right adjoint of `g` (i.e. `g' y = Sup {x | f x ≤ y}`), then `fb` is
semiconjugate to `fa` by `g'`.

This is a version of Proposition 2.1 from [Étienne Ghys, Groupes d'homeomorphismes du cercle et
cohomologie bornee][ghys87:groupes]. -/
lemma semiconj.symm_adjoint [partial_order α] [preorder β]
  {fa : α ≃o α}
  {fb : β ↪o β} {g : α → β}
  (h : function.semiconj g fa fb) {g' : β → α} (hg' : is_order_right_adjoint g g') :
  function.semiconj g' fb fa :=
begin
  refine λ y, (hg' _).unique _,
  rw [← fa.surjective.image_preimage {x | g x ≤ fb y}, preimage_set_of_eq],
  simp only [h.eq, fb.le_iff_le, fa.left_ord_continuous (hg' _)]
end

variable {G : Type*}

lemma semiconj_of_is_lub [partial_order α] [group G]
  (f₁ f₂ : G →* (α ≃o α)) {h : α → α}
  (H : ∀ x, is_lub (range (λ g', (f₁ g')⁻¹ (f₂ g' x))) (h x)) (g : G) :
  function.semiconj h (f₂ g) (f₁ g) :=
begin
  refine λ y, (H _).unique _,
  have := (f₁ g).left_ord_continuous (H y),
  rw [← range_comp, ← (equiv.mul_right g).surjective.range_comp _] at this,
  simpa [(∘)] using this
end

/-- Consider two actions `f₁ f₂ : G → α → α` of a group on a complete lattice by order
isomorphisms. Then the map `x ↦ ⨆ g : G, (f₁ g)⁻¹ (f₂ g x)` semiconjugates each `f₁ g'` to `f₂ g'`.

This is a version of Proposition 5.4 from [Étienne Ghys, Groupes d'homeomorphismes du cercle et
cohomologie bornee][ghys87:groupes]. -/
lemma Sup_div_semiconj [complete_lattice α] [group G]
  (f₁ f₂ : G →* (α ≃o α)) (g : G) :
  function.semiconj (λ x, ⨆ g' : G, (f₁ g')⁻¹ (f₂ g' x)) (f₂ g) (f₁ g) :=
semiconj_of_is_lub f₁ f₂ (λ x, is_lub_supr) _

/-- Consider two actions `f₁ f₂ : G → α → α` of a group on a conditionally complete lattice by order
isomorphisms. Suppose that each set $s(x)=\{f_1(g)^{-1} (f_2(g)(x)) | g \in G\}$ is bounded above.
Then the map `x ↦ Sup s(x)` semiconjugates each `f₁ g'` to `f₂ g'`.

This is a version of Proposition 5.4 from [Étienne Ghys, Groupes d'homeomorphismes du cercle et
cohomologie bornee][ghys87:groupes]. -/
lemma cSup_div_semiconj [conditionally_complete_lattice α] [group G]
  (f₁ f₂ : G →* (α ≃o α))
  (hbdd : ∀ x, bdd_above (range $ λ g, (f₁ g)⁻¹ (f₂ g x))) (g : G) :
  function.semiconj (λ x, ⨆ g' : G, (f₁ g')⁻¹ (f₂ g' x)) (f₂ g) (f₁ g) :=
semiconj_of_is_lub f₁ f₂ (λ x, is_lub_cSup (range_nonempty _) (hbdd x)) _

end function


import data.nat.basic
import data.rat.basic
import data.real.basic
import analysis.special_functions.exp_log
import analysis.special_functions.pow

set_option eqn_compiler.zeta true

#check nat.factors

--http://sms.math.nus.edu.sg/Simo/IMO_Problems/97.pdf
lemma IMO1997Q5_aux :
∀ (a t : ℕ), a > 1 ∧ t ≥ 1 → ¬ (a ^ (2 * t) = a * t) :=
sorry

#check  mul_div_cancel_left

lemma IMO1997Q5_aux2 :
∀ (a p q : ℕ), (
  q ≠ 0 →
  nat.coprime p q →
  (∃ (n : ℕ), (a : ℝ) ^ (p / q : ℝ) = (n : ℝ)) →
  (∃ (m : ℕ), (a : ℝ) ^ (1 / q : ℝ) = (m : ℝ))) :=
begin
  rintros a p q hqneq0 hpq ⟨n, hn⟩,
  have hqneq0' : (q : ℝ) ≠ 0 := λ h, hqneq0 (nat.cast_eq_zero.1 h),
  suffices hsuff : ∃ (k : ℕ), a = k ^ q,
  { cases hsuff with k hk,
    existsi k,
    have h0lek : 0 ≤ (k : ℝ) := (nat.cast_le.2 (nat.zero_le k)),
    rw [hk, nat.cast_pow, ←real.rpow_nat_cast, one_div, ←real.rpow_mul h0lek],
    rw [mul_comm, inv_mul_cancel hqneq0'],
    norm_num, },
  -- ∃ (k : ℕ), a = k ^ q
  replace hn := congr_arg (λ x, x ^ (q : ℝ)) hn; dsimp at hn,
  rw [←real.rpow_mul (nat.cast_le.2 (nat.zero_le a))] at hn,
  rw [mul_comm, ←mul_div_assoc, mul_div_cancel_left _ hqneq0'] at hn,
  iterate 2 { rw [real.rpow_nat_cast, ←nat.cast_pow] at hn, },
  replace hn := nat.cast_inj.1 hn,
  have hnfactors := congr_arg nat.factors hn,
  -- Idea: Use pnat.factors_multiset instead.
  sorry,
end

lemma IMO1997Q5 :
∀ (a b : ℕ),
a ≥ 1 ∧ b ≥ 1 ∧ a ^ (b ^ 2) = b ^ a →
(a = 1 ∧ b = 1) ∨ (a = 27 ∧ b = 3) ∨ (a = 16 ∧ b = 2) :=
begin
    rintros a b ⟨ha, hb, h⟩,
    replace ha := eq_or_lt_of_le ha,
    replace hb := eq_or_lt_of_le hb,
    cases ha with h1eqa h1lta;
    cases hb with h1eqb h1ltb,
    -- Easy cases if a = 1 or b = 1.
    { left,
      exact ⟨h1eqa.symm, h1eqb.symm⟩, },
    { left,
      rw [←h1eqa, one_pow, pow_one] at h,
      exact ⟨h1eqa.symm, h.symm⟩, },
    { left,
      rw [←h1eqb, one_pow, pow_one, one_pow] at h,
      exact ⟨h, h1eqb.symm⟩, },
    -- Otherwise, a, b > 1.
    { right,
      have haneq0 : (a : ℝ) ≠ 0,
      { intros hc,
        replace hc := nat.cast_eq_zero.1 hc,
        rw [hc] at h1lta,
        cases h1lta, },
      have h0lea : 0 < (a : ℝ) := nat.cast_lt.2 (nat.lt_trans nat.zero_lt_one h1lta),
      have h0leb : 0 < (b : ℝ) := nat.cast_lt.2 (nat.lt_trans nat.zero_lt_one h1ltb),
      let t := ((b : ℝ) ^ 2) / (a : ℝ),
      have hb2 : (b : ℝ) ^ 2 = (a : ℝ) * t,
      { rw [←mul_div_assoc, div_eq_mul_inv, mul_comm _ ((↑a)⁻¹), ←mul_assoc],
        rw [inv_mul_cancel haneq0, one_mul], },
      have hb : (b : ℝ) = (a : ℝ) ^ (t : ℝ),
      { have hlog := congr_arg real.log (congr_arg coe h),
        iterate 2 { rw [nat.cast_pow] at hlog, },
        rw [←real.rpow_nat_cast a, ←real.rpow_nat_cast b a] at hlog,
        rw [real.rpow_def_of_pos h0lea, real.rpow_def_of_pos h0leb] at hlog,
        iterate 2 { rw [real.log_exp] at hlog, },
        replace hlog := congr_arg (λ x, x / ↑a) hlog; simp at hlog,
        rw [mul_comm _ ↑a, mul_div_cancel_left _ haneq0, mul_div_assoc] at hlog,
        replace hlog := congr_arg real.exp hlog,
        rw [real.exp_log h0leb, ←real.rpow_def_of_pos h0lea] at hlog,
        rw ←hlog, },
      have hat : (a : ℝ) ^ (2 * t) = (a : ℝ) * t,
      { rw [mul_comm _ t, real.rpow_mul (le_of_lt h0lea)],
        rw [←hb, ←hb2, ←real.rpow_nat_cast],
        norm_num, },
      let tpq : ℚ := rat.mk (b ^ 2) a,
      have ht : (tpq : ℝ) = t,
      { rw rat.cast_mk,
        norm_num, },
      have hq : 1 < tpq.denom,
      { have hqle1 := nat.add_one_le_iff.2 tpq.pos,
        rw zero_add at hqle1,
        suffices hsuff : tpq.denom ≠ 1,
        { rw ←not_le,
          intros hc,
          apply hsuff,
          exact (le_antisymm hc hqle1), },
        intros hq1,
        rw [←ht] at hat,
        rw [←(rat.denom_eq_one_iff tpq).1 hq1] at hat,
        have hpgt1 : tpq.num.to_nat ≥ 1,
        { sorry, },
        apply (IMO1997Q5_aux a (int.to_nat tpq.num) ⟨h1lta, hpgt1⟩),
        rw [←(@nat.cast_inj ℝ _ _ _), nat.cast_pow, nat.cast_mul],
        simp at hat,
        --rw [←nat.cast_mul] at hat,
        --rw real.rpow_nat_cast at hat,
        --have H := int.to_nat_of_nonneg (le_trans (le_of_lt int.zero_lt_one) (ge_iff_le.1 hpgt1)),
        sorry,
        },
      },
end


import ..sup_inf.supProdConst
import ..sets.sets_level09

namespace xena -- hide

/-
# Chapter 3 : Sup and Inf

## Level 9

An intermediary result to be used in the next level.
-/

-- main result in lemma sup_mem_prod_of_sets
-- begin hide
--def mem_prod_sets (A : set ℝ) (B : set ℝ) := { x : ℝ | ∃ y ∈ A, ∃ z ∈ B, x = y * z}
-- end hide

/-
Prove that a given real number is the supremum of a particular set.
-/

/- Lemma
Given two sets of reals $A$ and $B$, show that given real number is the LUB
of their elementwise product `mem_prod_sets`.
-/
lemma mem_prod_sets_lub_proof :
  is_lub (mem_prod_sets (set.Icc (-2:ℝ) (-1:ℝ)) (set.Icc (0:ℝ) (3:ℝ)) ) 0 :=
begin
  split,
  intros x h1,
  cases h1 with a hh, cases hh with ha h2,
  cases h2 with b h3, cases h3 with hb hx,
  have H : a ≤ 0,
    cases ha with hg hl,
    linarith,
  have G : b ≥ 0,
    cases hb with hg hl, exact hg,
  rw hx, exact mul_nonpos_of_nonpos_of_nonneg H G,
  intros x hx,
  by_contradiction hnx,
  push_neg at hnx,
  --TODO: kmb doesn't know what zero_in_prod is, and it's not compiling
  have E := zero_in_prod,
  have D := hx 0 E, linarith, done
  --sorry
end

end xena -- hide