/-
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
import topology.algebra.valued_field
import ring_theory.dedekind_domain.adic_valuation

/-!
# 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 is_dedekind_domain
/- 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

/-- 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 : height_one_spectrum R)

variables (R K)

/-- The product of all `adic_completion_integers`, where `v` runs over the maximal ideals of `R`. -/
def R_hat := (Π (v : height_one_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

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

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 : topological_ring (K_hat R K) :=
(infer_instance : topological_ring (Π (v : height_one_spectrum R), v.adic_completion 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.adic_valued.to_uniform_space _,
  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. -/
def group_hom_prod : add_monoid_hom (R_hat R K) (K_hat R K) := force_noncomputable
{ 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. -/
def hom_prod : ring_hom (R_hat R K) (K_hat R K)  := force_noncomputable --TODO: ask
{ 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 : height_one_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 : height_one_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`. -/
def coe' : (finite_adele_ring' R K) → K_hat R K := force_noncomputable $ λ 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 : height_one_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 : height_one_spectrum R | ¬ (x + y) v ∈  (v.adic_completion_integers K)} ⊆
    {v : height_one_spectrum R | ¬ x v ∈ (v.adic_completion_integers K)} ∪
    {v : height_one_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 : height_one_spectrum R) in filter.cofinite,
  ((0 : v.adic_completion K) ∈ v.adic_completion_integers K) :=
begin
  rw filter.eventually_cofinite,
  have h_empty : {v : height_one_spectrum R |
    ¬ ((0 : v.adic_completion K) ∈ v.adic_completion_integers K)} = ∅,
  { ext v, rw [mem_empty_iff_false, iff_false],
    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' _ },
  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 : height_one_spectrum R) in filter.cofinite,
  (-x.val v ∈ v.adic_completion_integers K) :=
begin
  cases x with x hx,
  have h : ∀ (v : height_one_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 : height_one_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 : height_one_spectrum R | ¬ (x * y) v ∈  (v.adic_completion_integers K)} ⊆
    {v : height_one_spectrum R | ¬ x v ∈ (v.adic_completion_integers K)} ∪
    {v : height_one_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 : height_one_spectrum R) in filter.cofinite,
  ((1 : v.adic_completion K) ∈ v.adic_completion_integers K) :=
begin
  rw filter.eventually_cofinite,
  have h_empty : {v : height_one_spectrum R |
    ¬ ((1 : v.adic_completion K) ∈ v.adic_completion_integers K)} = ∅,
  { ext v, rw [mem_empty_iff_false, iff_false],intro hv,
    rw mem_set_of_eq at hv, apply hv, rw adic_completion.is_integer,
    exact le_of_eq valued.v.map_one' },
  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
  rw is_open_iff_mem_nhds,
  intros x hx,
  rw [set_like.mem_coe, adic_completion.is_integer] at hx,
  rw valued.mem_nhds,
  use (1 : units (with_zero (multiplicative ℤ))),
  { intros y hy,
    rw [units.coe_one, mem_set_of_eq] at 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 : height_one_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 : height_one_spectrum R), set (v.adic_completion K)}
  (hV_int: ∀ᶠ (v : height_one_spectrum R) in filter.cofinite, V v =
    ↑(v.adic_completion_integers K)) :
  {v : height_one_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 : height_one_spectrum R), set (v.adic_completion K)}
  (hV : ∀ v : height_one_spectrum R, is_open
    ((λ p : ( v.adic_completion K × v.adic_completion K), p.fst + p.snd) ⁻¹' V v))
  (hV_int: ∀ᶠ (v : height_one_spectrum R) in filter.cofinite, V v = ↑(v.adic_completion_integers K))
  (hxy : ∀ (v : height_one_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 : height_one_spectrum R), set (v.adic_completion K)}
  (hVx : Vx = λ v, ite ( x.val v ∈ v.adic_completion_integers K ∧
    y.val v ∈ v.adic_completion_integers K ∧ V v = v.adic_completion_integers K )
    (v.adic_completion_integers K)
    (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 : height_one_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 : height_one_spectrum R | ¬ Vx v = v.adic_completion_integers K} ⊆
        {v : height_one_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 : height_one_spectrum R), set (v.adic_completion K)}
  (hV : ∀ v : height_one_spectrum R, is_open
    ((λ p : ( v.adic_completion K × v.adic_completion K), p.fst + p.snd) ⁻¹' V v))
  (hV_int: ∀ᶠ (v : height_one_spectrum R) in filter.cofinite, V v = ↑(v.adic_completion_integers K))
  (hxy : ∀ (v : height_one_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 : height_one_spectrum R), set (v.adic_completion K)}
  (hVx : Vy = λ v, ite ( x.val v ∈ v.adic_completion_integers K ∧
    y.val v ∈ v.adic_completion_integers K ∧ V v = v.adic_completion_integers K )
    (v.adic_completion_integers K) (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 : height_one_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 : height_one_spectrum R | ¬ Vy v = v.adic_completion_integers K} ⊆
        {v : height_one_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 : height_one_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 : height_one_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 : height_one_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 : height_one_spectrum R | ¬ (cond v)}.finite := set_cond_finite R K  hV_int,
  set Vx : Π (v : height_one_spectrum R), set (v.adic_completion K) := λ v, ite (cond v)
    (v.adic_completion_integers K)
    (classical.some (is_open_prod_iff.mp (hV v) _ _ (hxy' v))) with hVx,
  set Vy : Π (v : height_one_spectrum R), set (v.adic_completion K) := λ v, ite (cond v)
    (v.adic_completion_integers K) (classical.some (classical.some_spec
      (is_open_prod_iff.mp (hV v) _ _ (hxy' v))))
    with hVy,
  use [{z : finite_adele_ring' R K | ∀ v : height_one_spectrum R, z.val v ∈ Vx v },
    {z : finite_adele_ring' R K | ∀ v : height_one_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 : height_one_spectrum R), set (v.adic_completion K)}
  (hV : ∀ v : height_one_spectrum R, is_open
    ((λ p : ( v.adic_completion K × v.adic_completion K), p.fst * p.snd) ⁻¹' V v))
  (hV_int: ∀ᶠ (v : height_one_spectrum R) in filter.cofinite, V v = ↑(v.adic_completion_integers K))
  (hxy : ∀ (v : height_one_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 : height_one_spectrum R), set (v.adic_completion K)}
  (hVx : Vx = λ v, ite ( x.val v ∈ v.adic_completion_integers K ∧
    y.val v ∈ v.adic_completion_integers K ∧ V v = v.adic_completion_integers K )
    (v.adic_completion_integers K)
    (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 : height_one_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 : height_one_spectrum R | ¬ Vx v = v.adic_completion_integers K} ⊆
        {v : height_one_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 : height_one_spectrum R), set (v.adic_completion K)}
  (hV : ∀ v : height_one_spectrum R, is_open
    ((λ p : ( v.adic_completion K × v.adic_completion K), p.fst * p.snd) ⁻¹' V v))
  (hV_int: ∀ᶠ (v : height_one_spectrum R) in filter.cofinite, V v = ↑(v.adic_completion_integers K))
  (hxy : ∀ (v : height_one_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 : height_one_spectrum R), set (v.adic_completion K)}
  (hVx : Vy = λ v, ite ( x.val v ∈ v.adic_completion_integers K ∧
    y.val v ∈ v.adic_completion_integers K ∧ V v = v.adic_completion_integers K )
    (v.adic_completion_integers K) (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 : height_one_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 : height_one_spectrum R | ¬ Vy v = v.adic_completion_integers K} ⊆
        {v : height_one_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 : height_one_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 : height_one_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 : height_one_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 : height_one_spectrum R | ¬ (cond v)}.finite := set_cond_finite R K hV_int,
  set Vx : Π (v : height_one_spectrum R), set (v.adic_completion K) := λ v,
  ite (cond v) (v.adic_completion_integers K)
    (classical.some (is_open_prod_iff.mp (hV v) _ _ (hxy' v))) with hVx,
  set Vy : Π (v : height_one_spectrum R), set (v.adic_completion K) := λ v, ite (cond v)
    (v.adic_completion_integers K)
    (classical.some (classical.some_spec (is_open_prod_iff.mp (hV v) _ _ (hxy' v)))) with hVy,
  use [{z : finite_adele_ring' R K | ∀ v : height_one_spectrum R, z.val v ∈ Vx v },
    {z : finite_adele_ring' R K | ∀ v : height_one_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 : height_one_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 : height_one_spectrum R),(mul_opposite.unop x).val v ∈ v.adic_completion_integers K} :=
begin
  use {x : finite_adele_ring' R K | ∀ (v : height_one_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 : height_one_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 : height_one_spectrum R |
  ¬ (coe : K → (v.adic_completion K)) x ∈ (v.adic_completion_integers K)} :=
begin
  set supp := { v : height_one_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 : height_one_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 [← @height_one_spectrum.valuation_lt_one_iff_dvd R _ _ _ K, v.valuation_of_algebra_map],
    by_contradiction h_one_le,
    have hdeq : v.int_valuation_def d = v.int_valuation d := rfl,
    rw [adic_completion.is_integer, h_val, valued.extension_extends _, v.adic_valued_apply, ← hx,
      v.valuation_of_mk', subtype.coe_mk, ← hdeq,
        (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 : height_one_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 : height_one_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 `height_one_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 (height_one_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 : height_one_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.adic_valued.to_uniform_space _,
  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`. -/
def diag_R : submonoid (R_hat R K) := force_noncomputable
{ carrier  := (inj_R R K) '' {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

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 : height_one_spectrum R, 1/(x v : v.adic_completion K)),
  ext v,
  rw [hom_prod, force_noncomputable_def, 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.adic_valued.to_uniform_space _,
  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 [mem_compl_iff, 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 : height_one_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 : height_one_spectrum R |
    ¬ (map_to_K_hat R K x v) ∈ (v.adic_completion_integers K)} ⊆
    { v : height_one_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.restrict (diag_R R K))
        (hom_prod_diag_unit R K)) d').inv v) *
        (((hom_prod R K).to_monoid_hom.restrict (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.restrict (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.restrict
        (diag_R R K)) (hom_prod_diag_unit R K)) d').inv v))*
        ((valued.v (((hom_prod R K).to_monoid_hom.restrict (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.restrict (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',
        height_one_spectrum.valued_adic_completion_def, valued.extension_extends,
        v.adic_valued_apply] at hv,
      have h_val_r : (valued.v ((hom_prod R K) r v) : with_zero (multiplicative ℤ)) ≤ 1,
      { rw [hom_prod, force_noncomputable_def, ring_hom.coe_mk, ← subtype.val_eq_coe,
          ← adic_completion.is_integer],
        exact (r v).property, },
      exact (v.valuation_lt_one_iff_dvd d).mp (lt_of_lt_of_le hv h_val_r), }},
    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) 2020 Simon Hudon. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Simon Hudon
-/
import data.lazy_list.basic
import data.tree
import data.pnat.basic
import control.bifunctor
import control.ulift
import testing.slim_check.gen
import tactic.linarith

/-!
# `sampleable` Class

This class permits the creation samples of a given type
controlling the size of those values using the `gen` monad`. It also
helps minimize examples by creating smaller versions of given values.

When testing a proposition like `∀ n : ℕ, prime n → n ≤ 100`,
`slim_check` requires that `ℕ` have an instance of `sampleable` and for
`prime n` to be decidable.  `slim_check` will then use the instance of
`sampleable` to generate small examples of ℕ and progressively increase
in size. For each example `n`, `prime n` is tested. If it is false,
the example will be rejected (not a test success nor a failure) and
`slim_check` will move on to other examples. If `prime n` is true, `n
≤ 100` will be tested. If it is false, `n` is a counter-example of `∀
n : ℕ, prime n → n ≤ 100` and the test fails. If `n ≤ 100` is true,
the test passes and `slim_check` moves on to trying more examples.

This is a port of the Haskell QuickCheck library.

## Main definitions
  * `sampleable` class
  * `sampleable_functor` and `sampleable_bifunctor` class
  * `sampleable_ext` class

### `sampleable`

`sampleable α` provides ways of creating examples of type `α`,
and given such an example `x : α`, gives us a way to shrink it
and find simpler examples.

### `sampleable_ext`

`sampleable_ext` generalizes the behavior of `sampleable`
and makes it possible to express instances for types that
do not lend themselves to introspection, such as `ℕ → ℕ`.
If we test a quantification over functions the
counter-examples cannot be shrunken or printed meaningfully.

For that purpose, `sampleable_ext` provides a proxy representation
`proxy_repr` that can be printed and shrunken as well
as interpreted (using `interp`) as an object of the right type.

### `sampleable_functor` and `sampleable_bifunctor`

`sampleable_functor F` and `sampleable_bifunctor F` makes it possible
to create samples of and shrink `F α` given a sampling function and a
shrinking function for arbitrary `α`.

This allows us to separate the logic for generating the shape of a
collection from the logic for generating its contents. Specifically,
the contents could be generated using either `sampleable` or
`sampleable_ext` instance and the `sampleable_(bi)functor` does not
need to use that information

## Shrinking

Shrinking happens when `slim_check` find a counter-example to a
property.  It is likely that the example will be more complicated than
necessary so `slim_check` proceeds to shrink it as much as
possible. Although equally valid, a smaller counter-example is easier
for a user to understand and use.

The `sampleable` class, beside having the `sample` function, has a
`shrink` function so that we can use specialized knowledge while
shrinking a value. It is not responsible for the whole shrinking process
however. It only has to take one step in the shrinking process.
`slim_check` will repeatedly call `shrink` until no more steps can
be taken. Because `shrink` guarantees that the size of the candidates
it produces is strictly smaller than the argument, we know that
`slim_check` is guaranteed to terminate.

## Tags

random testing

## References

  * https://hackage.haskell.org/package/QuickCheck

-/
universes u v w

namespace slim_check

variables (α : Type u)

local infix ` ≺ `:50 := has_well_founded.r

/-- `sizeof_lt x y` compares the sizes of `x` and `y`. -/
def sizeof_lt {α} [has_sizeof α] (x y : α) := sizeof x < sizeof y

/-- `shrink_fn α` is the type of functions that shrink an
argument of type `α` -/
@[reducible]
def shrink_fn (α : Type*) [has_sizeof α] := Π x : α, lazy_list { y : α // sizeof_lt y x }

/-- `sampleable α` provides ways of creating examples of type `α`,
and given such an example `x : α`, gives us a way to shrink it
and find simpler examples.  -/
class sampleable :=
[wf : has_sizeof α]
(sample [] : gen α)
(shrink : Π x : α, lazy_list { y : α // @sizeof _ wf y < @sizeof _ wf x } := λ _, lazy_list.nil)

attribute [instance, priority 100] has_well_founded_of_has_sizeof default_has_sizeof
attribute [instance, priority 200] sampleable.wf

/-- `sampleable_functor F` makes it possible to create samples of and
shrink `F α` given a sampling function and a shrinking function for
arbitrary `α` -/
class sampleable_functor (F : Type u → Type v) [functor F] :=
[wf : Π α [has_sizeof α], has_sizeof (F α)]
(sample [] : ∀ {α}, gen α → gen (F α))
(shrink : ∀ α [has_sizeof α], shrink_fn α → shrink_fn (F α))
(p_repr : ∀ α, has_repr α → has_repr (F α))

/-- `sampleable_bifunctor F` makes it possible to create samples of
and shrink `F α β` given a sampling function and a shrinking function
for arbitrary `α` and `β` -/
class sampleable_bifunctor (F : Type u → Type v → Type w) [bifunctor F] :=
[wf : Π α β [has_sizeof α] [has_sizeof β], has_sizeof (F α β)]
(sample [] : ∀ {α β}, gen α → gen β → gen (F α β))
(shrink : ∀ α β [has_sizeof α] [has_sizeof β], shrink_fn α → shrink_fn β → shrink_fn (F α β))
(p_repr : ∀ α β, has_repr α → has_repr β → has_repr (F α β))

export sampleable (sample shrink)

/-- This function helps infer the proxy representation and
interpretation in `sampleable_ext` instances. -/
meta def sampleable.mk_trivial_interp : tactic unit :=
tactic.refine ``(id)

/-- `sampleable_ext` generalizes the behavior of `sampleable`
and makes it possible to express instances for types that
do not lend themselves to introspection, such as `ℕ → ℕ`.
If we test a quantification over functions the
counter-examples cannot be shrunken or printed meaningfully.

For that purpose, `sampleable_ext` provides a proxy representation
`proxy_repr` that can be printed and shrunken as well
as interpreted (using `interp`) as an object of the right type. -/
class sampleable_ext (α : Sort u) :=
(proxy_repr : Type v)
[wf : has_sizeof proxy_repr]
(interp [] : proxy_repr → α . sampleable.mk_trivial_interp)
[p_repr : has_repr proxy_repr]
(sample [] : gen proxy_repr)
(shrink : shrink_fn proxy_repr)

attribute [instance, priority 100] sampleable_ext.p_repr sampleable_ext.wf

open nat lazy_list

section prio

open sampleable_ext

set_option default_priority 50

instance sampleable_ext.of_sampleable {α} [sampleable α] [has_repr α] : sampleable_ext α :=
{ proxy_repr := α,
  sample := sampleable.sample α,
  shrink := shrink }

instance sampleable.functor {α} {F} [functor F] [sampleable_functor F] [sampleable α] :
  sampleable (F α) :=
{ wf := _,
  sample := sampleable_functor.sample F (sampleable.sample α),
  shrink := sampleable_functor.shrink α sampleable.shrink }

instance sampleable.bifunctor {α β} {F} [bifunctor F] [sampleable_bifunctor F] [sampleable α]
  [sampleable β] : sampleable (F α β) :=
{ wf := _,
  sample := sampleable_bifunctor.sample F (sampleable.sample α) (sampleable.sample β),
  shrink := sampleable_bifunctor.shrink α β sampleable.shrink sampleable.shrink }

set_option default_priority 100

instance sampleable_ext.functor {α} {F} [functor F] [sampleable_functor F] [sampleable_ext α] :
  sampleable_ext (F α) :=
{ wf := _,
  proxy_repr := F (proxy_repr α),
  interp := functor.map (interp _),
  sample := sampleable_functor.sample F (sampleable_ext.sample α),
  shrink := sampleable_functor.shrink _ sampleable_ext.shrink,
  p_repr := sampleable_functor.p_repr _ sampleable_ext.p_repr }

instance sampleable_ext.bifunctor {α β} {F} [bifunctor F] [sampleable_bifunctor F]
  [sampleable_ext α] [sampleable_ext β] : sampleable_ext (F α β) :=
{ wf := _,
  proxy_repr := F (proxy_repr α) (proxy_repr β),
  interp := bifunctor.bimap (interp _) (interp _),
  sample := sampleable_bifunctor.sample F (sampleable_ext.sample α) (sampleable_ext.sample β),
  shrink := sampleable_bifunctor.shrink _ _ sampleable_ext.shrink sampleable_ext.shrink,
  p_repr := sampleable_bifunctor.p_repr _ _ sampleable_ext.p_repr sampleable_ext.p_repr }

end prio

/-- `nat.shrink' k n` creates a list of smaller natural numbers by
successively dividing `n` by 2 and subtracting the difference from
`k`. For example, `nat.shrink 100 = [50, 75, 88, 94, 97, 99]`. -/
def nat.shrink' (k : ℕ) : Π n : ℕ, n ≤ k →
  list { m : ℕ // has_well_founded.r m k } → list { m : ℕ // has_well_founded.r m k }
| n hn ls :=
if h : n ≤ 1
  then ls.reverse
  else
    have h₂ : 0 < n, by linarith,
    have 1 * n / 2 < n,
      from nat.div_lt_of_lt_mul (nat.mul_lt_mul_of_pos_right (by norm_num) h₂),
    have n / 2 < n, by simpa,
    let m := n / 2 in
    have h₀ : m ≤ k, from le_trans (le_of_lt this) hn,
    have h₃ : 0 < m,
      by simp only [m, lt_iff_add_one_le, zero_add]; rw [nat.le_div_iff_mul_le]; linarith,
    have h₁ : k - m < k,
      from nat.sub_lt (lt_of_lt_of_le h₂ hn) h₃,
    nat.shrink' m h₀ (⟨k - m, h₁⟩ :: ls)

/-- `nat.shrink n` creates a list of smaller natural numbers by
successively dividing by 2 and subtracting the difference from
`n`. For example, `nat.shrink 100 = [50, 75, 88, 94, 97, 99]`. -/
def nat.shrink (n : ℕ) : list { m : ℕ // has_well_founded.r m n } :=
if h : n > 0 then
  have ∀ k, 1 < k → n / k < n, from
    λ k hk,
     nat.div_lt_of_lt_mul
       (suffices 1 * n < k * n, by simpa,
        nat.mul_lt_mul_of_pos_right hk h),
  ⟨n/11, this _ (by norm_num)⟩ :: ⟨n/3, this _ (by norm_num)⟩ :: nat.shrink' n n le_rfl []
else
  []

open gen

/--
Transport a `sampleable` instance from a type `α` to a type `β` using
functions between the two, going in both directions.

Function `g` is used to define the well-founded order that
`shrink` is expected to follow.
-/
def sampleable.lift (α : Type u) {β : Type u} [sampleable α] (f : α → β) (g : β → α)
  (h : ∀ (a : α), sizeof (g (f a)) ≤ sizeof a) : sampleable β :=
{ wf := ⟨ sizeof ∘ g ⟩,
  sample := f <$> sample α,
  shrink := λ x,
    have ∀ a,  sizeof a < sizeof (g x) → sizeof (g (f a)) < sizeof (g x),
      by introv h'; solve_by_elim [lt_of_le_of_lt],
    subtype.map f this <$> shrink (g x) }

instance nat.sampleable : sampleable ℕ :=
{ sample := sized $ λ sz, freq [(1, coe <$> choose_any (fin $ succ (sz^3))),
                                (3, coe <$> choose_any (fin $ succ sz))] dec_trivial,
  shrink :=  λ x, lazy_list.of_list $ nat.shrink x }

/-- `iterate_shrink p x` takes a decidable predicate `p` and a
value `x` of some sampleable type and recursively shrinks `x`.
It first calls `shrink x` to get a list of candidate sample,
finds the first that satisfies `p` and recursively tries
to shrink that one. -/
def iterate_shrink {α} [has_to_string α] [sampleable α]
  (p : α → Prop) [decidable_pred p] :
  α → option α :=
well_founded.fix has_well_founded.wf $ λ x f_rec,
  do trace sformat!"{x} : {(shrink x).to_list}" $ pure (),
     y ← (shrink x).find (λ a, p a),
     f_rec y y.property <|> some y.val .

instance fin.sampleable {n : ℕ} [ne_zero n] : sampleable (fin n) :=
sampleable.lift ℕ fin.of_nat' fin.val $
λ i, (mod_le _ _ : i % n ≤ i)

@[priority 100]
instance fin.sampleable' {n} : sampleable (fin (succ n)) :=
sampleable.lift ℕ fin.of_nat fin.val $
λ i, (mod_le _ _ : i % succ n ≤ i)

instance pnat.sampleable : sampleable ℕ+ :=
sampleable.lift ℕ nat.succ_pnat pnat.nat_pred $ λ a,
by unfold_wf; simp only [pnat.nat_pred, succ_pnat, pnat.mk_coe, tsub_zero, succ_sub_succ_eq_sub]

/-- Redefine `sizeof` for `int` to make it easier to use with `nat` -/
def int.has_sizeof : has_sizeof ℤ := ⟨ int.nat_abs ⟩

local attribute [instance, priority 2000] int.has_sizeof

instance int.sampleable : sampleable ℤ :=
{ wf := _,
  sample := sized $ λ sz,
          freq [(1, subtype.val <$> choose (-(sz^3 + 1) : ℤ) (sz^3 + 1) (neg_le_self dec_trivial)),
                (3, subtype.val <$> choose (-(sz + 1)) (sz + 1) (neg_le_self dec_trivial))]
               dec_trivial,
  shrink :=
    λ x, lazy_list.of_list $ (nat.shrink $ int.nat_abs x).bind $
    λ ⟨y,h⟩, [⟨y, h⟩, ⟨-y, by dsimp [sizeof,has_sizeof.sizeof]; rw int.nat_abs_neg; exact h ⟩] }

instance bool.sampleable : sampleable bool :=
{ wf := ⟨ λ b, if b then 1 else 0 ⟩,
  sample := do { x ← choose_any bool,
                 return x },
  shrink := λ b, if h : b then lazy_list.singleton ⟨ff, by cases h; unfold_wf⟩
                          else lazy_list.nil }

/--
Provided two shrinking functions `prod.shrink` shrinks a pair `(x, y)` by
first shrinking `x` and pairing the results with `y` and then shrinking
`y` and pairing the results with `x`.

All pairs either contain `x` untouched or `y` untouched. We rely on
shrinking being repeated for `x` to get maximally shrunken and then
for `y` to get shrunken too.
-/
def prod.shrink {α β} [has_sizeof α] [has_sizeof β]
  (shr_a : shrink_fn α) (shr_b : shrink_fn β) : shrink_fn (α × β)
| ⟨x₀,x₁⟩ :=
  let xs₀ : lazy_list { y : α × β // sizeof_lt y (x₀,x₁) } :=
          (shr_a x₀).map $ subtype.map (λ a, (a, x₁))
                           (λ x h, by dsimp [sizeof_lt]; unfold_wf; apply h),
      xs₁ : lazy_list { y : α × β // sizeof_lt y (x₀,x₁) } :=
          (shr_b x₁).map $ subtype.map (λ a, (x₀, a))
                           (λ x h, by dsimp [sizeof_lt]; unfold_wf; apply h) in
  xs₀.append xs₁

instance prod.sampleable : sampleable_bifunctor.{u v} prod :=
{ wf := _,
  sample := λ α β sama samb, do
              { ⟨x⟩ ← (uliftable.up $ sama : gen (ulift.{max u v} α)),
                ⟨y⟩ ← (uliftable.up $ samb : gen (ulift.{max u v} β)),
                pure (x,y) },
  shrink := @prod.shrink,
  p_repr := @prod.has_repr }

instance sigma.sampleable {α β} [sampleable α] [sampleable β] : sampleable (Σ _ : α, β) :=
sampleable.lift (α × β) (λ ⟨x,y⟩, ⟨x,y⟩) (λ ⟨x,y⟩, ⟨x,y⟩) $ λ ⟨x,y⟩, le_rfl

/-- shrinking function for sum types -/
def sum.shrink {α β} [has_sizeof α] [has_sizeof β] (shrink_α : shrink_fn α)
  (shrink_β : shrink_fn β) : shrink_fn (α ⊕ β)
| (sum.inr x) := (shrink_β x).map $ subtype.map sum.inr $ λ a,
  by dsimp [sizeof_lt]; unfold_wf; solve_by_elim
| (sum.inl x) := (shrink_α x).map $ subtype.map sum.inl $ λ a,
  by dsimp [sizeof_lt]; unfold_wf; solve_by_elim

instance sum.sampleable : sampleable_bifunctor.{u v} sum :=
{ wf := _,
  sample := λ (α : Type u) (β : Type v) sam_α sam_β,
            (@uliftable.up_map gen.{u} gen.{max u v} _ _ _ _ (@sum.inl α β) sam_α <|>
             @uliftable.up_map gen.{v} gen.{max v u} _ _ _ _ (@sum.inr α β) sam_β),
  shrink := λ α β Iα Iβ shr_α shr_β, @sum.shrink _ _ Iα Iβ shr_α shr_β,
  p_repr := @sum.has_repr }

instance rat.sampleable : sampleable ℚ :=
sampleable.lift (ℤ × ℕ+) (λ x, prod.cases_on x rat.mk_pnat) (λ r, (r.num, ⟨r.denom, r.pos⟩)) $
begin
  intro i,
  rcases i with ⟨x,⟨y,hy⟩⟩; unfold_wf;
  dsimp [rat.mk_pnat],
  mono*,
  { rw [← int.coe_nat_le, int.coe_nat_abs, int.coe_nat_abs],
    apply int.abs_div_le_abs },
  { change _ - 1 ≤ y-1,
    apply tsub_le_tsub_right,
    apply nat.div_le_of_le_mul,
    suffices : 1 * y ≤ x.nat_abs.gcd y * y, { simpa },
    apply nat.mul_le_mul_right,
    apply gcd_pos_of_pos_right _ hy }
end

/-- `sampleable_char` can be specialized into customized `sampleable char` instances.

The resulting instance has `1 / length` chances of making an unrestricted choice of characters
and it otherwise chooses a character from `characters` with uniform probabilities.  -/
def sampleable_char (length : nat) (characters : string) : sampleable char :=
{ sample := do { x ← choose_nat 0 length dec_trivial,
                 if x.val = 0 then do
                   n ← sample ℕ,
                   pure $ char.of_nat n
                 else do
                   i ← choose_nat 0 (characters.length - 1) dec_trivial,
                   pure (characters.mk_iterator.nextn i).curr },
  shrink := λ _, lazy_list.nil }

instance char.sampleable : sampleable char :=
sampleable_char 3 " 0123abcABC:,;`\\/"

variables {α}

section list_shrink

variables [has_sizeof α] (shr : Π x : α, lazy_list { y : α // sizeof_lt y x })

lemma list.sizeof_cons_lt_right (a b : α) {xs : list α} (h : sizeof a < sizeof b) :
  sizeof (a :: xs) < sizeof (b :: xs) :=
by unfold_wf; assumption

lemma list.sizeof_cons_lt_left (x : α) {xs xs' : list α} (h : sizeof xs < sizeof xs') :
  sizeof (x :: xs) < sizeof (x :: xs') :=
by unfold_wf; assumption

lemma list.sizeof_append_lt_left {xs ys ys' : list α} (h : sizeof ys < sizeof ys') :
  sizeof (xs ++ ys) < sizeof (xs ++ ys') :=
begin
  induction xs,
  { apply h },
  { unfold_wf,
    simp only [list.sizeof, add_lt_add_iff_left],
    exact xs_ih }
end

lemma list.one_le_sizeof (xs : list α) : 1 ≤ sizeof xs :=
by cases xs; unfold_wf; linarith

/--
`list.shrink_removes` shrinks a list by removing chunks of size `k` in
the middle of the list.
-/
def list.shrink_removes (k : ℕ) (hk : 0 < k) : Π (xs : list α) n,
  n = xs.length → lazy_list { ys : list α // sizeof_lt ys xs }
| xs n hn :=
  if hkn : k > n then lazy_list.nil
  else
  if hkn' : k = n then
    have 1 < xs.sizeof,
      by { subst_vars, cases xs, { contradiction },
           unfold_wf, apply lt_of_lt_of_le,
           show 1 < 1 + has_sizeof.sizeof xs_hd + 1, { linarith },
           { mono, apply list.one_le_sizeof, } },
    lazy_list.singleton ⟨[], this ⟩
  else
    have h₂ : k < xs.length, from hn ▸ lt_of_le_of_ne (le_of_not_gt hkn) hkn',
    match list.split_at k xs, rfl : Π ys, ys = list.split_at k xs → _ with
    |  ⟨xs₁,xs₂⟩, h :=
      have h₄ : xs₁ = xs.take k,
        by simp only [list.split_at_eq_take_drop, prod.mk.inj_iff] at h; tauto,
      have h₃ : xs₂ = xs.drop k,
        by simp only [list.split_at_eq_take_drop, prod.mk.inj_iff] at h; tauto,
      have sizeof xs₂ < sizeof xs,
        by rw h₃; solve_by_elim [list.sizeof_drop_lt_sizeof_of_lt_length],
      have h₁ : n - k = xs₂.length,
        by simp only [h₃, ←hn, list.length_drop],
      have h₅ : ∀ (a : list α), sizeof_lt a xs₂ → sizeof_lt (xs₁ ++ a) xs,
        by intros a h; rw [← list.take_append_drop k xs, ← h₃, ← h₄];
          solve_by_elim [list.sizeof_append_lt_left],
      lazy_list.cons ⟨xs₂, this⟩ $ subtype.map ((++) xs₁) h₅ <$> list.shrink_removes xs₂ (n - k) h₁
    end

/--
`list.shrink_one xs` shrinks list `xs` by shrinking only one item in
the list.
-/
def list.shrink_one : shrink_fn (list α)
| [] := lazy_list.nil
| (x :: xs) :=
  lazy_list.append
    (subtype.map (λ x', x' :: xs) (λ a,  list.sizeof_cons_lt_right _ _) <$> shr x)
    (subtype.map ((::) x) (λ _, list.sizeof_cons_lt_left _) <$> list.shrink_one xs)

/-- `list.shrink_with shrink_f xs` shrinks `xs` by first
considering `xs` with chunks removed in the middle (starting with
chunks of size `xs.length` and halving down to `1`) and then
shrinks only one element of the list.

This strategy is taken directly from Haskell's QuickCheck -/
def list.shrink_with (xs : list α) :
  lazy_list { ys : list α // sizeof_lt ys xs } :=
let n := xs.length in
lazy_list.append
  ((lazy_list.cons n $ (shrink n).reverse.map subtype.val).bind (λ k,
    if hk : 0 < k
    then list.shrink_removes k hk xs n rfl
    else lazy_list.nil ))
  (list.shrink_one shr _)

end list_shrink

instance list.sampleable : sampleable_functor list.{u} :=
{ wf := _,
  sample := λ α sam_α, list_of sam_α,
  shrink := λ α Iα shr_α, @list.shrink_with _ Iα shr_α,
  p_repr := @list.has_repr }

instance Prop.sampleable_ext : sampleable_ext Prop :=
{ proxy_repr := bool,
  interp := coe,
  sample := choose_any bool,
  shrink := λ _, lazy_list.nil }

/-- `no_shrink` is a type annotation to signal that
a certain type is not to be shrunk. It can be useful in
combination with other types: e.g. `xs : list (no_shrink ℤ)`
will result in the list being cut down but individual
integers being kept as is. -/
def no_shrink (α : Type*) := α

instance no_shrink.inhabited {α} [inhabited α] : inhabited (no_shrink α) :=
⟨ (default : α) ⟩

/-- Introduction of the `no_shrink` type. -/
def no_shrink.mk {α} (x : α) : no_shrink α := x

/-- Selector of the `no_shrink` type. -/
def no_shrink.get {α} (x : no_shrink α) : α := x

instance no_shrink.sampleable {α} [sampleable α] : sampleable (no_shrink α) :=
{ sample := no_shrink.mk <$> sample α }

instance string.sampleable : sampleable string :=
{ sample := do { x ← list_of (sample char), pure x.as_string },
  .. sampleable.lift (list char) list.as_string string.to_list $ λ _, le_rfl }

/-- implementation of `sampleable (tree α)` -/
def tree.sample (sample : gen α) : ℕ → gen (tree α) | n :=
if h : n > 0
then have n / 2 < n, from div_lt_self h (by norm_num),
     tree.node <$> sample <*> tree.sample (n / 2) <*> tree.sample (n / 2)
else pure tree.nil

/-- `rec_shrink x f_rec` takes the recursive call `f_rec` introduced
by `well_founded.fix` and turns it into a shrinking function whose
result is adequate to use in a recursive call. -/
def rec_shrink {α : Type*} [has_sizeof α] (t : α)
  (sh : Π x : α, sizeof_lt x t → lazy_list { y : α // sizeof_lt y x }) :
  shrink_fn { t' : α // sizeof_lt t' t }
| ⟨t',ht'⟩ := (λ t'' : { y : α // sizeof_lt y t' },
    ⟨⟨t''.val, lt_trans t''.property ht'⟩, t''.property⟩ ) <$> sh t' ht'

lemma tree.one_le_sizeof {α} [has_sizeof α] (t : tree α) : 1 ≤ sizeof t :=
by cases t; unfold_wf; linarith

instance : functor tree :=
{ map := @tree.map }

/--
Recursion principle for shrinking tree-like structures.
-/
def rec_shrink_with [has_sizeof α]
  (shrink_a : Π x : α, shrink_fn { y : α // sizeof_lt y x } →
    list (lazy_list { y : α // sizeof_lt y x })) :
  shrink_fn α :=
well_founded.fix (sizeof_measure_wf _) $ λ t f_rec,
lazy_list.join
    (lazy_list.of_list $
      shrink_a t $ λ ⟨t', h⟩, rec_shrink _ f_rec _)

lemma rec_shrink_with_eq [has_sizeof α]
  (shrink_a : Π x : α, shrink_fn { y : α // sizeof_lt y x } →
    list (lazy_list { y : α // sizeof_lt y x }))
  (x : α) :
  rec_shrink_with shrink_a x =
  lazy_list.join
    (lazy_list.of_list $ shrink_a x $ λ t', rec_shrink _ (λ x h', rec_shrink_with shrink_a x) _) :=
begin
  conv_lhs { rw [rec_shrink_with, well_founded.fix_eq], },
  congr, ext ⟨y, h⟩, refl
end

/-- `tree.shrink_with shrink_f t` shrinks `xs` by using the empty tree,
each subtrees, and by shrinking the subtree to recombine them.

This strategy is taken directly from Haskell's QuickCheck -/
def tree.shrink_with [has_sizeof α] (shrink_a : shrink_fn α) : shrink_fn (tree α) :=
rec_shrink_with $ λ t,
match t with
| tree.nil := λ f_rec, []
| (tree.node x t₀ t₁) :=
λ f_rec,
  have h₂ : sizeof_lt tree.nil (tree.node x t₀ t₁),
    by clear _match; have := tree.one_le_sizeof t₀;
       dsimp [sizeof_lt, sizeof, has_sizeof.sizeof] at *;
       unfold_wf; linarith,
  have h₀ : sizeof_lt t₀ (tree.node x t₀ t₁),
    by dsimp [sizeof_lt]; unfold_wf; linarith,
  have h₁ : sizeof_lt t₁ (tree.node x t₀ t₁),
    by dsimp [sizeof_lt]; unfold_wf; linarith,
  [lazy_list.of_list [⟨tree.nil, h₂⟩, ⟨t₀, h₀⟩, ⟨t₁, h₁⟩],
   (prod.shrink shrink_a (prod.shrink f_rec f_rec) (x, ⟨t₀, h₀⟩, ⟨t₁, h₁⟩)).map
    $ λ ⟨⟨y,⟨t'₀, _⟩,⟨t'₁, _⟩⟩,hy⟩, ⟨tree.node y t'₀ t'₁,
      by revert hy; dsimp [sizeof_lt]; unfold_wf; intro; linarith⟩]
end

instance sampleable_tree : sampleable_functor tree :=
{ wf := _,
  sample := λ α sam_α, sized $ tree.sample sam_α,
  shrink := λ α Iα shr_α, @tree.shrink_with _ Iα shr_α,
  p_repr := @tree.has_repr }

/-- Type tag that signals to `slim_check` to use small values for a given type. -/
def small (α : Type*) := α

/-- Add the `small` type tag -/
def small.mk {α} (x : α) : small α := x

/-- Type tag that signals to `slim_check` to use large values for a given type. -/
def large (α : Type*) := α

/-- Add the `large` type tag -/
def large.mk {α} (x : α) : large α := x

instance small.functor : functor small := id.monad.to_functor
instance large.functor : functor large := id.monad.to_functor
instance small.inhabited [inhabited α] : inhabited (small α) := ⟨ (default : α) ⟩
instance large.inhabited [inhabited α] : inhabited (large α) := ⟨ (default : α) ⟩

instance small.sampleable_functor : sampleable_functor small :=
{ wf := _,
  sample := λ α samp, gen.resize (λ n, n / 5 + 5) samp,
  shrink := λ α _, id,
  p_repr := λ α, id }

instance large.sampleable_functor : sampleable_functor large :=
{ wf := _,
  sample := λ α samp, gen.resize (λ n, n * 5) samp,
  shrink := λ α _, id,
  p_repr := λ α, id }

instance ulift.sampleable_functor : sampleable_functor ulift.{u v} :=
{ wf := λ α h, ⟨ λ ⟨x⟩, @sizeof α h x ⟩,
  sample := λ α samp, uliftable.up_map ulift.up $ samp,
  shrink := λ α _ shr ⟨x⟩, (shr x).map (subtype.map ulift.up (λ a h, h)),
  p_repr := λ α h, ⟨ @repr α h ∘ ulift.down ⟩ }

/-!
## Subtype instances

The following instances are meant to improve the testing of properties of the form
`∀ i j, i ≤ j, ...`

The naive way to test them is to choose two numbers `i` and `j` and check that
the proper ordering is satisfied. Instead, the following instances make it
so that `j` will be chosen with considerations to the required ordering
constraints. The benefit is that we will not have to discard any choice
of `j`.
 -/

/-! ### Subtypes of `ℕ` -/

instance nat_le.sampleable {y} : slim_check.sampleable { x : ℕ // x ≤ y } :=
{ sample :=
         do { ⟨x,h⟩ ← slim_check.gen.choose_nat 0 y dec_trivial,
              pure ⟨x, h.2⟩},
  shrink := λ ⟨x, h⟩, (λ a : subtype _, subtype.rec_on a $
    λ x' h', ⟨⟨x', le_trans (le_of_lt h') h⟩, h'⟩) <$> shrink x }

instance nat_ge.sampleable {x} : slim_check.sampleable { y : ℕ // x ≤ y } :=
{ sample :=
         do { (y : ℕ) ← slim_check.sampleable.sample ℕ,
              pure ⟨x+y, by norm_num⟩ },
  shrink := λ ⟨y, h⟩, (λ a : { y' // sizeof y' < sizeof (y - x) },
    subtype.rec_on a $ λ δ h', ⟨⟨x + δ, nat.le_add_right _ _⟩, lt_tsub_iff_left.mp h'⟩) <$>
      shrink (y - x) }

/- there is no `nat_lt.sampleable` instance because if `y = 0`, there is no valid choice
to satisfy `x < y` -/

instance nat_gt.sampleable {x} : slim_check.sampleable { y : ℕ // x < y } :=
{ sample :=
         do { (y : ℕ) ← slim_check.sampleable.sample ℕ,
              pure ⟨x+y+1, by linarith⟩ },
  shrink := λ x, shrink _ }

/-! ### Subtypes of any `linear_ordered_add_comm_group` -/

instance le.sampleable {y : α} [sampleable α] [linear_ordered_add_comm_group α] :
  slim_check.sampleable { x : α // x ≤ y } :=
{ sample :=
         do { x ← sample α,
              pure ⟨y - |x|, sub_le_self _ (abs_nonneg _) ⟩ },
  shrink := λ _, lazy_list.nil }

instance ge.sampleable {x : α}  [sampleable α] [linear_ordered_add_comm_group α] :
  slim_check.sampleable { y : α // x ≤ y } :=
{ sample :=
         do { y ← sample α,
              pure ⟨x + |y|, by norm_num [abs_nonneg]⟩ },
  shrink := λ _, lazy_list.nil }

/-!
### Subtypes of `ℤ`

Specializations of `le.sampleable` and `ge.sampleable` for `ℤ` to help instance search.
-/

instance int_le.sampleable {y : ℤ} : slim_check.sampleable { x : ℤ // x ≤ y } :=
sampleable.lift ℕ (λ n, ⟨y - n, int.sub_left_le_of_le_add $ by simp⟩) (λ ⟨i, h⟩, (y - i).nat_abs)
  (λ n, by unfold_wf; simp [int_le.sampleable._match_1]; ring)

instance int_ge.sampleable {x : ℤ} : slim_check.sampleable { y : ℤ // x ≤ y } :=
sampleable.lift ℕ (λ n, ⟨x + n, by simp⟩) (λ ⟨i, h⟩, (i - x).nat_abs)
  (λ n, by unfold_wf; simp [int_ge.sampleable._match_1]; ring)

instance int_lt.sampleable {y} : slim_check.sampleable { x : ℤ // x < y } :=
sampleable.lift ℕ (λ n, ⟨y - (n+1), int.sub_left_lt_of_lt_add $
    by linarith [int.coe_nat_nonneg n]⟩)
  (λ ⟨i, h⟩, (y - i - 1).nat_abs)
  (λ n, by unfold_wf; simp [int_lt.sampleable._match_1]; ring)

instance int_gt.sampleable {x} : slim_check.sampleable { y : ℤ // x < y } :=
sampleable.lift ℕ (λ n, ⟨x + (n+1), by linarith⟩) (λ ⟨i, h⟩, (i - x - 1).nat_abs)
  (λ n, by unfold_wf; simp [int_gt.sampleable._match_1]; ring)

/-! ### Subtypes of any `list` -/

instance perm.slim_check {xs : list α} : slim_check.sampleable { ys : list α // list.perm xs ys } :=
{ sample := permutation_of xs,
  shrink := λ _, lazy_list.nil }

instance perm'.slim_check {xs : list α} :
  slim_check.sampleable { ys : list α // list.perm ys xs } :=
{ sample := subtype.map id (@list.perm.symm α _) <$> permutation_of xs,
  shrink := λ _, lazy_list.nil }

setup_tactic_parser
open tactic

/--
Print (at most) 10 samples of a given type to stdout for debugging.
-/
def print_samples {t : Type u} [has_repr t] (g : gen t) : io unit := do
xs ← io.run_rand $ uliftable.down $
  do { xs ← (list.range 10).mmap $ g.run ∘ ulift.up,
       pure ⟨xs.map repr⟩ },
xs.mmap' io.put_str_ln

/-- Create a `gen α` expression from the argument of `#sample` -/
meta def mk_generator (e : expr) : tactic (expr × expr) := do
t ← infer_type e,
match t with
| `(gen %%t) := do
  repr_inst ← mk_app ``has_repr [t] >>= mk_instance,
  pure (repr_inst, e)
| _ := do
  samp_inst ← to_expr ``(sampleable_ext %%e) >>= mk_instance,
  repr_inst ← mk_mapp ``sampleable_ext.p_repr [e, samp_inst],
  gen ← mk_mapp ``sampleable_ext.sample [none, samp_inst],
  pure (repr_inst, gen)
end

/--
`#sample my_type`, where `my_type` has an instance of `sampleable`, prints ten random
values of type `my_type` of using an increasing size parameter.

```lean
#sample nat
-- prints
-- 0
-- 0
-- 2
-- 24
-- 64
-- 76
-- 5
-- 132
-- 8
-- 449
-- or some other sequence of numbers

#sample list int
-- prints
-- []
-- [1, 1]
-- [-7, 9, -6]
-- [36]
-- [-500, 105, 260]
-- [-290]
-- [17, 156]
-- [-2364, -7599, 661, -2411, -3576, 5517, -3823, -968]
-- [-643]
-- [11892, 16329, -15095, -15461]
-- or whatever
```
-/
@[user_command]
meta def sample_cmd (_ : parse $ tk "#sample") : lean.parser unit :=
do e ← texpr,
   of_tactic $ do
     e ← i_to_expr e,
     (repr_inst, gen) ← mk_generator e,
     print_samples ← mk_mapp ``print_samples [none, repr_inst, gen],
     sample ← eval_expr (io unit) print_samples,
     unsafe_run_io sample

end slim_check


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

! This file was ported from Lean 3 source module data.set.n_ary
! leanprover-community/mathlib commit 517cc149e0b515d2893baa376226ed10feb319c7
! Please do not edit these lines, except to modify the commit id
! if you have ported upstream changes.
-/
import Mathlib.Data.Set.Prod

/-!
# N-ary images of sets

This file defines `Set.image2`, the binary image of finsets. This is the finset version of
`set.image2`. This is mostly useful to define pointwise operations.

## Notes

This file is very similar to the n-ary section of `Data.Set.Basic`, to `Order.Filter.NAry` and to
`Data.Option.NAry`. Please keep them in sync.

We do not define `Set.image3` as its only purpose would be to prove properties of `Set.image2`
and `Set.image2` already fulfills this task.
-/

open Function

namespace Set
variable {α α' β β' γ γ' δ δ' ε ε' ζ ζ' ν : Type _} {f f' : α → β → γ} {g g' : α → β → γ → δ}
variable {s s' : Set α} {t t' : Set β} {u u' : Set γ} {v : Set δ} {a a' : α} {b b' : β} {c c' : γ}
  {d d' : δ}

/-- The image of a binary function `f : α → β → γ` as a function `Set α → Set β → Set γ`.
Mathematically this should be thought of as the image of the corresponding function `α × β → γ`.-/
def image2 (f : α → β → γ) (s : Set α) (t : Set β) : Set γ :=
  { c | ∃ a b, a ∈ s ∧ b ∈ t ∧ f a b = c }
#align set.image2 Set.image2

@[simp]
theorem mem_image2 : c ∈ image2 f s t ↔ ∃ a b, a ∈ s ∧ b ∈ t ∧ f a b = c :=
  Iff.rfl
#align set.mem_image2 Set.mem_image2

theorem mem_image2_of_mem (ha : a ∈ s) (hb : b ∈ t) : f a b ∈ image2 f s t :=
  ⟨a, b, ha, hb, rfl⟩
#align set.mem_image2_of_mem Set.mem_image2_of_mem

theorem mem_image2_iff (hf : Injective2 f) : f a b ∈ image2 f s t ↔ a ∈ s ∧ b ∈ t :=
  ⟨by
    rintro ⟨a', b', ha', hb', h⟩
    rcases hf h with ⟨rfl, rfl⟩
    exact ⟨ha', hb'⟩, fun ⟨ha, hb⟩ => mem_image2_of_mem ha hb⟩
#align set.mem_image2_iff Set.mem_image2_iff

/-- image2 is monotone with respect to `⊆`. -/
theorem image2_subset (hs : s ⊆ s') (ht : t ⊆ t') : image2 f s t ⊆ image2 f s' t' := by
  rintro _ ⟨a, b, ha, hb, rfl⟩
  exact mem_image2_of_mem (hs ha) (ht hb)
#align set.image2_subset Set.image2_subset

theorem image2_subset_left (ht : t ⊆ t') : image2 f s t ⊆ image2 f s t' :=
  image2_subset Subset.rfl ht
#align set.image2_subset_left Set.image2_subset_left

theorem image2_subset_right (hs : s ⊆ s') : image2 f s t ⊆ image2 f s' t :=
  image2_subset hs Subset.rfl
#align set.image2_subset_right Set.image2_subset_right

theorem image_subset_image2_left (hb : b ∈ t) : (fun a => f a b) '' s ⊆ image2 f s t :=
  ball_image_of_ball fun _ ha => mem_image2_of_mem ha hb
#align set.image_subset_image2_left Set.image_subset_image2_left

theorem image_subset_image2_right (ha : a ∈ s) : f a '' t ⊆ image2 f s t :=
  ball_image_of_ball fun _ => mem_image2_of_mem ha
#align set.image_subset_image2_right Set.image_subset_image2_right

theorem forall_image2_iff {p : γ → Prop} :
    (∀ z ∈ image2 f s t, p z) ↔ ∀ x ∈ s, ∀ y ∈ t, p (f x y) :=
  ⟨fun h x hx y hy => h _ ⟨x, y, hx, hy, rfl⟩, fun h _ ⟨x, y, hx, hy, hz⟩ => hz ▸ h x hx y hy⟩
#align set.forall_image2_iff Set.forall_image2_iff

@[simp]
theorem image2_subset_iff {u : Set γ} : image2 f s t ⊆ u ↔ ∀ x ∈ s, ∀ y ∈ t, f x y ∈ u :=
  forall_image2_iff
#align set.image2_subset_iff Set.image2_subset_iff

variable (f)

-- Porting note: Removing `simp` - LHS does not simplify
lemma image_prod : (fun x : α × β ↦ f x.1 x.2) '' s ×ˢ t = image2 f s t :=
ext $ fun a ↦
⟨ by rintro ⟨_, _, rfl⟩; exact ⟨_, _, (mem_prod.1 ‹_›).1, (mem_prod.1 ‹_›).2, rfl⟩,
  by rintro ⟨_, _, _, _, rfl⟩; exact ⟨(_, _), ⟨‹_›, ‹_›⟩, rfl⟩⟩
#align set.image_prod Set.image_prod

@[simp] lemma image_uncurry_prod (s : Set α) (t : Set β) : uncurry f '' s ×ˢ t = image2 f s t :=
image_prod _
#align set.image_uncurry_prod Set.image_uncurry_prod

@[simp] lemma image2_mk_eq_prod : image2 Prod.mk s t = s ×ˢ t := ext $ by simp
#align set.image2_mk_eq_prod Set.image2_mk_eq_prod

-- Porting note: Removing `simp` - LHS does not simplify
lemma image2_curry (f : α × β → γ) (s : Set α) (t : Set β) :
  image2 (fun a b ↦ f (a, b)) s t = f '' s ×ˢ t :=
by simp [←image_uncurry_prod, uncurry]
#align set.image2_curry Set.image2_curry

variable {f}

theorem image2_union_left : image2 f (s ∪ s') t = image2 f s t ∪ image2 f s' t := by
  ext c
  constructor
  · rintro ⟨a, b, ha | ha, hb, rfl⟩ <;> [left, right] <;> exact ⟨_, _, ‹_›, ‹_›, rfl⟩
  · rintro (⟨_, _, _, _, rfl⟩ | ⟨_, _, _, _, rfl⟩) <;> refine' ⟨_, _, _, ‹_›, rfl⟩ <;>
      simp [mem_union, *]
#align set.image2_union_left Set.image2_union_left

theorem image2_union_right : image2 f s (t ∪ t') = image2 f s t ∪ image2 f s t' := by
  ext c
  constructor
  · rintro ⟨a, b, ha, h1b | h2b, rfl⟩ <;> [left, right] <;> exact ⟨_, _, ‹_›, ‹_›, rfl⟩
  · rintro (⟨_, _, _, _, rfl⟩ | ⟨_, _, _, _, rfl⟩) <;> refine' ⟨_, _, ‹_›, _, rfl⟩ <;>
      simp [mem_union, *]
#align set.image2_union_right Set.image2_union_right

lemma image2_inter_left (hf : Injective2 f) : image2 f (s ∩ s') t = image2 f s t ∩ image2 f s' t :=
by simp_rw [←image_uncurry_prod, inter_prod, image_inter hf.uncurry]
#align set.image2_inter_left Set.image2_inter_left

lemma image2_inter_right (hf : Injective2 f) : image2 f s (t ∩ t') = image2 f s t ∩ image2 f s t' :=
by simp_rw [←image_uncurry_prod, prod_inter, image_inter hf.uncurry]
#align set.image2_inter_right Set.image2_inter_right

@[simp]
theorem image2_empty_left : image2 f ∅ t = ∅ :=
  ext <| by simp
#align set.image2_empty_left Set.image2_empty_left

@[simp]
theorem image2_empty_right : image2 f s ∅ = ∅ :=
  ext <| by simp
#align set.image2_empty_right Set.image2_empty_right

theorem Nonempty.image2 : s.Nonempty → t.Nonempty → (image2 f s t).Nonempty :=
  fun ⟨_, ha⟩ ⟨_, hb⟩ => ⟨_, mem_image2_of_mem ha hb⟩
#align set.nonempty.image2 Set.Nonempty.image2

@[simp]
theorem image2_nonempty_iff : (image2 f s t).Nonempty ↔ s.Nonempty ∧ t.Nonempty :=
  ⟨fun ⟨_, a, b, ha, hb, _⟩ => ⟨⟨a, ha⟩, b, hb⟩, fun h => h.1.image2 h.2⟩
#align set.image2_nonempty_iff Set.image2_nonempty_iff

theorem Nonempty.of_image2_left (h : (Set.image2 f s t).Nonempty) : s.Nonempty :=
  (image2_nonempty_iff.1 h).1
#align set.nonempty.of_image2_left Set.Nonempty.of_image2_left

theorem Nonempty.of_image2_right (h : (Set.image2 f s t).Nonempty) : t.Nonempty :=
  (image2_nonempty_iff.1 h).2
#align set.nonempty.of_image2_right Set.Nonempty.of_image2_right

@[simp]
theorem image2_eq_empty_iff : image2 f s t = ∅ ↔ s = ∅ ∨ t = ∅ := by
  rw [← not_nonempty_iff_eq_empty, image2_nonempty_iff, not_and_or]
  simp [not_nonempty_iff_eq_empty]
#align set.image2_eq_empty_iff Set.image2_eq_empty_iff

theorem image2_inter_subset_left : image2 f (s ∩ s') t ⊆ image2 f s t ∩ image2 f s' t := by
  rintro _ ⟨a, b, ⟨h1a, h2a⟩, hb, rfl⟩
  constructor <;> exact ⟨_, _, ‹_›, ‹_›, rfl⟩
#align set.image2_inter_subset_left Set.image2_inter_subset_left

theorem image2_inter_subset_right : image2 f s (t ∩ t') ⊆ image2 f s t ∩ image2 f s t' := by
  rintro _ ⟨a, b, ha, ⟨h1b, h2b⟩, rfl⟩
  constructor <;> exact ⟨_, _, ‹_›, ‹_›, rfl⟩
#align set.image2_inter_subset_right Set.image2_inter_subset_right

@[simp]
theorem image2_singleton_left : image2 f {a} t = f a '' t :=
  ext fun x => by simp
#align set.image2_singleton_left Set.image2_singleton_left

@[simp]
theorem image2_singleton_right : image2 f s {b} = (fun a => f a b) '' s :=
  ext fun x => by simp
#align set.image2_singleton_right Set.image2_singleton_right

theorem image2_singleton : image2 f {a} {b} = {f a b} := by simp
#align set.image2_singleton Set.image2_singleton

@[congr]
theorem image2_congr (h : ∀ a ∈ s, ∀ b ∈ t, f a b = f' a b) : image2 f s t = image2 f' s t := by
  ext
  constructor <;> rintro ⟨a, b, ha, hb, rfl⟩ <;> refine' ⟨a, b, ha, hb, by rw [h a ha b hb]⟩
#align set.image2_congr Set.image2_congr

/-- A common special case of `image2_congr` -/
theorem image2_congr' (h : ∀ a b, f a b = f' a b) : image2 f s t = image2 f' s t :=
  image2_congr fun a _ b _ => h a b
#align set.image2_congr' Set.image2_congr'

/-- The image of a ternary function `f : α → β → γ → δ` as a function
  `Set α → Set β → Set γ → Set δ`. Mathematically this should be thought of as the image of the
  corresponding function `α × β × γ → δ`.
-/
def image3 (g : α → β → γ → δ) (s : Set α) (t : Set β) (u : Set γ) : Set δ :=
  { d | ∃ a b c, a ∈ s ∧ b ∈ t ∧ c ∈ u ∧ g a b c = d }
#align set.image3 Set.image3

@[simp]
theorem mem_image3 : d ∈ image3 g s t u ↔ ∃ a b c, a ∈ s ∧ b ∈ t ∧ c ∈ u ∧ g a b c = d :=
  Iff.rfl
#align set.mem_image3 Set.mem_image3

theorem image3_mono (hs : s ⊆ s') (ht : t ⊆ t') (hu : u ⊆ u') :
    image3 g s t u ⊆ image3 g s' t' u' := fun _ =>
  Exists₃.imp fun _ _ _ ⟨ha, hb, hc, hx⟩ => ⟨hs ha, ht hb, hu hc, hx⟩
#align set.image3_mono Set.image3_mono

@[congr]
theorem image3_congr (h : ∀ a ∈ s, ∀ b ∈ t, ∀ c ∈ u, g a b c = g' a b c) :
    image3 g s t u = image3 g' s t u := by
  ext x
  constructor <;> rintro ⟨a, b, c, ha, hb, hc, rfl⟩ <;>
    exact ⟨a, b, c, ha, hb, hc, by rw [h a ha b hb c hc]⟩
#align set.image3_congr Set.image3_congr

/-- A common special case of `image3_congr` -/
theorem image3_congr' (h : ∀ a b c, g a b c = g' a b c) : image3 g s t u = image3 g' s t u :=
  image3_congr fun a _ b _ c _ => h a b c
#align set.image3_congr' Set.image3_congr'

theorem image2_image2_left (f : δ → γ → ε) (g : α → β → δ) :
    image2 f (image2 g s t) u = image3 (fun a b c => f (g a b) c) s t u := by
  ext; constructor
  · rintro ⟨_, c, ⟨a, b, ha, hb, rfl⟩, hc, rfl⟩
    refine' ⟨a, b, c, ha, hb, hc, rfl⟩
  · rintro ⟨a, b, c, ha, hb, hc, rfl⟩
    refine' ⟨_, c, ⟨a, b, ha, hb, rfl⟩, hc, rfl⟩
#align set.image2_image2_left Set.image2_image2_left

theorem image2_image2_right (f : α → δ → ε) (g : β → γ → δ) :
    image2 f s (image2 g t u) = image3 (fun a b c => f a (g b c)) s t u := by
  ext; constructor
  · rintro ⟨a, _, ha, ⟨b, c, hb, hc, rfl⟩, rfl⟩
    refine' ⟨a, b, c, ha, hb, hc, rfl⟩
  · rintro ⟨a, b, c, ha, hb, hc, rfl⟩
    refine' ⟨a, _, ha, ⟨b, c, hb, hc, rfl⟩, rfl⟩
#align set.image2_image2_right Set.image2_image2_right

theorem image_image2 (f : α → β → γ) (g : γ → δ) :
    g '' image2 f s t = image2 (fun a b => g (f a b)) s t := by
  ext; constructor
  · rintro ⟨_, ⟨a, b, ha, hb, rfl⟩, rfl⟩
    refine' ⟨a, b, ha, hb, rfl⟩
  · rintro ⟨a, b, ha, hb, rfl⟩
    refine' ⟨_, ⟨a, b, ha, hb, rfl⟩, rfl⟩
#align set.image_image2 Set.image_image2

theorem image2_image_left (f : γ → β → δ) (g : α → γ) :
    image2 f (g '' s) t = image2 (fun a b => f (g a) b) s t := by
  ext; constructor
  · rintro ⟨_, b, ⟨a, ha, rfl⟩, hb, rfl⟩
    refine' ⟨a, b, ha, hb, rfl⟩
  · rintro ⟨a, b, ha, hb, rfl⟩
    refine' ⟨_, b, ⟨a, ha, rfl⟩, hb, rfl⟩
#align set.image2_image_left Set.image2_image_left

theorem image2_image_right (f : α → γ → δ) (g : β → γ) :
    image2 f s (g '' t) = image2 (fun a b => f a (g b)) s t := by
  ext; constructor
  · rintro ⟨a, _, ha, ⟨b, hb, rfl⟩, rfl⟩
    refine' ⟨a, b, ha, hb, rfl⟩
  · rintro ⟨a, b, ha, hb, rfl⟩
    refine' ⟨a, _, ha, ⟨b, hb, rfl⟩, rfl⟩
#align set.image2_image_right Set.image2_image_right

theorem image2_swap (f : α → β → γ) (s : Set α) (t : Set β) :
    image2 f s t = image2 (fun a b => f b a) t s := by
  ext
  constructor <;> rintro ⟨a, b, ha, hb, rfl⟩ <;> refine' ⟨b, a, hb, ha, rfl⟩
#align set.image2_swap Set.image2_swap

@[simp]
theorem image2_left (h : t.Nonempty) : image2 (fun x _ => x) s t = s := by
  simp [nonempty_def.mp h, ext_iff]
#align set.image2_left Set.image2_left

@[simp]

theorem image2_assoc {f : δ → γ → ε} {g : α → β → δ} {f' : α → ε' → ε} {g' : β → γ → ε'}
    (h_assoc : ∀ a b c, f (g a b) c = f' a (g' b c)) :
    image2 f (image2 g s t) u = image2 f' s (image2 g' t u) := by
  simp only [image2_image2_left, image2_image2_right, h_assoc]
#align set.image2_assoc Set.image2_assoc

theorem image2_comm {g : β → α → γ} (h_comm : ∀ a b, f a b = g b a) : image2 f s t = image2 g t s :=
  (image2_swap _ _ _).trans <| by simp_rw [h_comm]
#align set.image2_comm Set.image2_comm

theorem image2_left_comm {f : α → δ → ε} {g : β → γ → δ} {f' : α → γ → δ'} {g' : β → δ' → ε}
    (h_left_comm : ∀ a b c, f a (g b c) = g' b (f' a c)) :
    image2 f s (image2 g t u) = image2 g' t (image2 f' s u) := by
  rw [image2_swap f', image2_swap f]
  exact image2_assoc fun _ _ _ => h_left_comm _ _ _
#align set.image2_left_comm Set.image2_left_comm

theorem image2_right_comm {f : δ → γ → ε} {g : α → β → δ} {f' : α → γ → δ'} {g' : δ' → β → ε}
    (h_right_comm : ∀ a b c, f (g a b) c = g' (f' a c) b) :
    image2 f (image2 g s t) u = image2 g' (image2 f' s u) t := by
  rw [image2_swap g, image2_swap g']
  exact image2_assoc fun _ _ _ => h_right_comm _ _ _
#align set.image2_right_comm Set.image2_right_comm

theorem image2_image2_image2_comm {f : ε → ζ → ν} {g : α → β → ε} {h : γ → δ → ζ} {f' : ε' → ζ' → ν}
    {g' : α → γ → ε'} {h' : β → δ → ζ'}
    (h_comm : ∀ a b c d, f (g a b) (h c d) = f' (g' a c) (h' b d)) :
    image2 f (image2 g s t) (image2 h u v) = image2 f' (image2 g' s u) (image2 h' t v) := by
  ext; constructor
  · rintro ⟨_, _, ⟨a, b, ha, hb, rfl⟩, ⟨c, d, hc, hd, rfl⟩, rfl⟩
    exact ⟨_, _, ⟨a, c, ha, hc, rfl⟩, ⟨b, d, hb, hd, rfl⟩, (h_comm _ _ _ _).symm⟩
  · rintro ⟨_, _, ⟨a, c, ha, hc, rfl⟩, ⟨b, d, hb, hd, rfl⟩, rfl⟩
    exact ⟨_, _, ⟨a, b, ha, hb, rfl⟩, ⟨c, d, hc, hd, rfl⟩, h_comm _ _ _ _⟩
#align set.image2_image2_image2_comm Set.image2_image2_image2_comm

theorem image_image2_distrib {g : γ → δ} {f' : α' → β' → δ} {g₁ : α → α'} {g₂ : β → β'}
    (h_distrib : ∀ a b, g (f a b) = f' (g₁ a) (g₂ b)) :
    (image2 f s t).image g = image2 f' (s.image g₁) (t.image g₂) := by
  simp_rw [image_image2, image2_image_left, image2_image_right, h_distrib]
#align set.image_image2_distrib Set.image_image2_distrib

/-- Symmetric statement to `Set.image2_image_left_comm`. -/
theorem image_image2_distrib_left {g : γ → δ} {f' : α' → β → δ} {g' : α → α'}
    (h_distrib : ∀ a b, g (f a b) = f' (g' a) b) :
    (image2 f s t).image g = image2 f' (s.image g') t :=
  (image_image2_distrib h_distrib).trans <| by rw [image_id']
#align set.image_image2_distrib_left Set.image_image2_distrib_left

/-- Symmetric statement to `Set.image_image2_right_comm`. -/
theorem image_image2_distrib_right {g : γ → δ} {f' : α → β' → δ} {g' : β → β'}
    (h_distrib : ∀ a b, g (f a b) = f' a (g' b)) :
    (image2 f s t).image g = image2 f' s (t.image g') :=
  (image_image2_distrib h_distrib).trans <| by rw [image_id']
#align set.image_image2_distrib_right Set.image_image2_distrib_right

/-- Symmetric statement to `Set.image_image2_distrib_left`. -/
theorem image2_image_left_comm {f : α' → β → γ} {g : α → α'} {f' : α → β → δ} {g' : δ → γ}
    (h_left_comm : ∀ a b, f (g a) b = g' (f' a b)) :
    image2 f (s.image g) t = (image2 f' s t).image g' :=
  (image_image2_distrib_left fun a b => (h_left_comm a b).symm).symm
#align set.image2_image_left_comm Set.image2_image_left_comm

/-- Symmetric statement to `Set.image_image2_distrib_right`. -/
theorem image_image2_right_comm {f : α → β' → γ} {g : β → β'} {f' : α → β → δ} {g' : δ → γ}
    (h_right_comm : ∀ a b, f a (g b) = g' (f' a b)) :
    image2 f s (t.image g) = (image2 f' s t).image g' :=
  (image_image2_distrib_right fun a b => (h_right_comm a b).symm).symm
#align set.image_image2_right_comm Set.image_image2_right_comm

/-- The other direction does not hold because of the `s`-`s` cross terms on the RHS. -/
theorem image2_distrib_subset_left {f : α → δ → ε} {g : β → γ → δ} {f₁ : α → β → β'}
    {f₂ : α → γ → γ'} {g' : β' → γ' → ε} (h_distrib : ∀ a b c, f a (g b c) = g' (f₁ a b) (f₂ a c)) :
    image2 f s (image2 g t u) ⊆ image2 g' (image2 f₁ s t) (image2 f₂ s u) := by
  rintro _ ⟨a, _, ha, ⟨b, c, hb, hc, rfl⟩, rfl⟩
  rw [h_distrib]
  exact mem_image2_of_mem (mem_image2_of_mem ha hb) (mem_image2_of_mem ha hc)
#align set.image2_distrib_subset_left Set.image2_distrib_subset_left

/-- The other direction does not hold because of the `u`-`u` cross terms on the RHS. -/
theorem image2_distrib_subset_right {f : δ → γ → ε} {g : α → β → δ} {f₁ : α → γ → α'}
    {f₂ : β → γ → β'} {g' : α' → β' → ε} (h_distrib : ∀ a b c, f (g a b) c = g' (f₁ a c) (f₂ b c)) :
    image2 f (image2 g s t) u ⊆ image2 g' (image2 f₁ s u) (image2 f₂ t u) := by
  rintro _ ⟨_, c, ⟨a, b, ha, hb, rfl⟩, hc, rfl⟩
  rw [h_distrib]
  exact mem_image2_of_mem (mem_image2_of_mem ha hc) (mem_image2_of_mem hb hc)
#align set.image2_distrib_subset_right Set.image2_distrib_subset_right

theorem image_image2_antidistrib {g : γ → δ} {f' : β' → α' → δ} {g₁ : β → β'} {g₂ : α → α'}
    (h_antidistrib : ∀ a b, g (f a b) = f' (g₁ b) (g₂ a)) :
    (image2 f s t).image g = image2 f' (t.image g₁) (s.image g₂) := by
  rw [image2_swap f]
  exact image_image2_distrib fun _ _ => h_antidistrib _ _
#align set.image_image2_antidistrib Set.image_image2_antidistrib

/-- Symmetric statement to `Set.image2_image_left_anticomm`. -/
theorem image_image2_antidistrib_left {g : γ → δ} {f' : β' → α → δ} {g' : β → β'}
    (h_antidistrib : ∀ a b, g (f a b) = f' (g' b) a) :
    (image2 f s t).image g = image2 f' (t.image g') s :=
  (image_image2_antidistrib h_antidistrib).trans <| by rw [image_id']
#align set.image_image2_antidistrib_left Set.image_image2_antidistrib_left

/-- Symmetric statement to `Set.image_image2_right_anticomm`. -/
theorem image_image2_antidistrib_right {g : γ → δ} {f' : β → α' → δ} {g' : α → α'}
    (h_antidistrib : ∀ a b, g (f a b) = f' b (g' a)) :
    (image2 f s t).image g = image2 f' t (s.image g') :=
  (image_image2_antidistrib h_antidistrib).trans <| by rw [image_id']
#align set.image_image2_antidistrib_right Set.image_image2_antidistrib_right

/-- Symmetric statement to `Set.image_image2_antidistrib_left`. -/
theorem image2_image_left_anticomm {f : α' → β → γ} {g : α → α'} {f' : β → α → δ} {g' : δ → γ}
    (h_left_anticomm : ∀ a b, f (g a) b = g' (f' b a)) :
    image2 f (s.image g) t = (image2 f' t s).image g' :=
  (image_image2_antidistrib_left fun a b => (h_left_anticomm b a).symm).symm
#align set.image2_image_left_anticomm Set.image2_image_left_anticomm

/-- Symmetric statement to `Set.image_image2_antidistrib_right`. -/
theorem image_image2_right_anticomm {f : α → β' → γ} {g : β → β'} {f' : β → α → δ} {g' : δ → γ}
    (h_right_anticomm : ∀ a b, f a (g b) = g' (f' b a)) :
    image2 f s (t.image g) = (image2 f' t s).image g' :=
  (image_image2_antidistrib_right fun a b => (h_right_anticomm b a).symm).symm
#align set.image_image2_right_anticomm Set.image_image2_right_anticomm

/-- If `a` is a left identity for `f : α → β → β`, then `{a}` is a left identity for
`Set.image2 f`. -/
lemma image2_left_identity {f : α → β → β} {a : α} (h : ∀ b, f a b = b) (t : Set β) :
    image2 f {a} t = t := by
  rw [image2_singleton_left, show f a = id from funext h, image_id]
#align set.image2_left_identity Set.image2_left_identity

/-- If `b` is a right identity for `f : α → β → α`, then `{b}` is a right identity for
`Set.image2 f`. -/
lemma image2_right_identity {f : α → β → α} {b : β} (h : ∀ a, f a b = a) (s : Set α) :
    image2 f s {b} = s := by
  rw [image2_singleton_right, funext h, image_id']
#align set.image2_right_identity Set.image2_right_identity

theorem image2_inter_union_subset {f : α → α → β} {s t : Set α} (hf : ∀ a b, f a b = f b a) :
    image2 f (s ∩ t) (s ∪ t) ⊆ image2 f s t := by
  rintro _ ⟨a, b, ha, hb | hb, rfl⟩
  · rw [hf]
    exact mem_image2_of_mem hb ha.2
  · exact mem_image2_of_mem ha.1 hb
#align set.image2_inter_union_subset Set.image2_inter_union_subset

theorem image2_union_inter_subset {f : α → α → β} {s t : Set α} (hf : ∀ a b, f a b = f b a) :
    image2 f (s ∪ t) (s ∩ t) ⊆ image2 f s t := by
  rw [image2_comm hf]
  exact image2_inter_union_subset hf
#align set.image2_union_inter_subset Set.image2_union_inter_subset

end Set


/-
Copyright © 2018 François G. Dorais. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
-/

import .basic

namespace tup
variables {α : Type*} {m n : ℕ}

@[reducible] definition cast (h : m = n) : α ^ m → α ^ n :=
λ xs i, xs[fin.cast (ge_of_eq h) i]

@[simp] lemma val_cast (h : m = n) (xs : α ^ m) :
∀ i, (tup.cast h xs)[i] = xs[fin.cast (ge_of_eq h) i] := λ i, rfl

@[simp] lemma val_mk_cast (h : m = n) (xs : α ^ m) (i : ℕ) (hi : i < n) :
(tup.cast h xs)[⟨i,hi⟩] = xs[⟨i, eq.substr h hi⟩] := rfl

@[simp] lemma cast_refl {n : ℕ} (xs : α ^ n) : cast rfl xs = xs := by simp [cast]

@[simp] lemma cast_trans :
∀ {l m n : ℕ} (xs : α ^ l) (hlm : l = m) (hmn : m = n),
cast hmn (cast hlm xs) = cast (eq.trans hlm hmn) xs
| n .(n) .(n) xs rfl rfl := by simp

@[simp] lemma cast_rfl {n : ℕ} (xs : α ^ n) (h : n = n) : cast h xs = xs := by simp

lemma eq_cast_symm_of_cast_eq :
∀ {m n : ℕ} {xs : α ^ m} {ys : α ^ n} {h : m = n},
cast h xs = ys → xs = cast (eq.symm h) ys
| n .(n) xs ys rfl := by simp; exact id

lemma cast_symm_eq_of_eq_cast :
∀ {m n : ℕ} {xs : α ^ m} {ys : α ^ n} {h : n = m},
xs = cast h ys → cast (eq.symm h) xs = ys
| n .(n) xs ys rfl := by simp; exact id

lemma cast_inj :
∀ {m n} (xs₁ xs₂ : α ^ m) (h : m = n), cast h xs₁ = cast h xs₂ → xs₁ = xs₂
| n .(n) xs ys rfl := by simp; exact id

@[simp] lemma cast_irrel :
∀ {m n} (xs : α ^ m) (h₁ h₂ : m = n), cast h₁ xs = cast h₂ xs
| n .(n) xs rfl rfl := by simp

lemma cast_ext : ∀ {m n : ℕ} {xs : α ^ m} {ys : α ^ n} {h : n = m},
(∀ i, xs[fin.cast (le_of_eq h) i] = ys[i]) → xs = cast h ys
| _ ._ xs ys rfl := by simp; exact ext

@[simp] lemma eq_rec_eq_cast :
Π {m n : ℕ} (h : m = n) (xs : α ^ m),
@eq.rec _ _ _ xs _ h = cast h xs
| _ ._ rfl xs := by simp

@[simp] lemma eq_rec_fun_eq_fun_cast {β : ℕ → Sort*} {f : Π (n : ℕ), α ^ n → β n} :
∀ {m n : ℕ} (xs : α ^ m) (h : m = n), @eq.rec ℕ m _ (f m xs) n h = f n (cast h xs)
| _ ._ i rfl := by simp

lemma cast_heq : ∀ {m n : ℕ} (xs : α ^ m) (h : m = n), cast h xs == xs
| _ ._ xs rfl := by simp; exact heq.refl xs

end tup