/-
Copyright (c) 2020 Johan Commelin. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Johan Commelin
-/
import algebra.group_power.lemmas
import data.int.bitwise

/-!
# Powers of elements of groups with an adjoined zero element

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

In this file we define integer power functions for groups with an adjoined zero element.
This generalises the integer power function on a division ring.
-/

section group_with_zero
variables {G₀ : Type*} [group_with_zero G₀] {a : G₀} {m n : ℕ}

section nat_pow

theorem pow_sub₀ (a : G₀) {m n : ℕ} (ha : a ≠ 0) (h : n ≤ m) : a ^ (m - n) = a ^ m * (a ^ n)⁻¹ :=
have h1 : m - n + n = m, from tsub_add_cancel_of_le h,
have h2 : a ^ (m - n) * a ^ n = a ^ m, by rw [←pow_add, h1],
by simpa only [div_eq_mul_inv] using eq_div_of_mul_eq (pow_ne_zero _ ha) h2

lemma pow_sub_of_lt (a : G₀) {m n : ℕ} (h : n < m) : a ^ (m - n) = a ^ m * (a ^ n)⁻¹ :=
begin
  obtain rfl | ha := eq_or_ne a 0,
  { rw [zero_pow (tsub_pos_of_lt h), zero_pow (n.zero_le.trans_lt h), zero_mul] },
  { exact pow_sub₀ _ ha h.le }
end

theorem pow_inv_comm₀ (a : G₀) (m n : ℕ) : (a⁻¹) ^ m * a ^ n = a ^ n * (a⁻¹) ^ m :=
(commute.refl a).inv_left₀.pow_pow m n

lemma inv_pow_sub₀ (ha : a ≠ 0) (h : n ≤ m) : a⁻¹ ^ (m - n) = (a ^ m)⁻¹ * a ^ n :=
by rw [pow_sub₀ _ (inv_ne_zero ha) h, inv_pow, inv_pow, inv_inv]

lemma inv_pow_sub_of_lt (a : G₀) (h : n < m) : a⁻¹ ^ (m - n) = (a ^ m)⁻¹ * a ^ n :=
by rw [pow_sub_of_lt a⁻¹ h, inv_pow, inv_pow, inv_inv]

end nat_pow

end group_with_zero

section zpow
open int
variables {G₀ : Type*} [group_with_zero G₀]

local attribute [ematch] le_of_lt

lemma zero_zpow : ∀ z : ℤ, z ≠ 0 → (0 : G₀) ^ z = 0
| (n : ℕ) h := by { rw [zpow_coe_nat, zero_pow'], simpa using h }
| -[1+n]  h := by simp

lemma zero_zpow_eq (n : ℤ) : (0 : G₀) ^ n = if n = 0 then 1 else 0 :=
begin
  split_ifs with h,
  { rw [h, zpow_zero] },
  { rw [zero_zpow _ h] }
end

lemma zpow_add_one₀ {a : G₀} (ha : a ≠ 0) : ∀ n : ℤ, a ^ (n + 1) = a ^ n * a
| (n : ℕ)    := by simp only [← int.coe_nat_succ, zpow_coe_nat, pow_succ']
| -[1+0]     := by erw [zpow_zero, zpow_neg_succ_of_nat, pow_one, inv_mul_cancel ha]
| -[1+(n+1)] := by rw [int.neg_succ_of_nat_eq, zpow_neg, neg_add, neg_add_cancel_right, zpow_neg,
  ← int.coe_nat_succ, zpow_coe_nat, zpow_coe_nat, pow_succ _ (n + 1), mul_inv_rev, mul_assoc,
  inv_mul_cancel ha, mul_one]

lemma zpow_sub_one₀ {a : G₀} (ha : a ≠ 0) (n : ℤ) : a ^ (n - 1) = a ^ n * a⁻¹ :=
calc a ^ (n - 1) = a ^ (n - 1) * a * a⁻¹ : by rw [mul_assoc, mul_inv_cancel ha, mul_one]
             ... = a^n * a⁻¹             : by rw [← zpow_add_one₀ ha, sub_add_cancel]

lemma zpow_add₀ {a : G₀} (ha : a ≠ 0) (m n : ℤ) : a ^ (m + n) = a ^ m * a ^ n :=
begin
  induction n using int.induction_on with n ihn n ihn,
  case hz : { simp },
  { simp only [← add_assoc, zpow_add_one₀ ha, ihn, mul_assoc] },
  { rw [zpow_sub_one₀ ha, ← mul_assoc, ← ihn, ← zpow_sub_one₀ ha, add_sub_assoc] }
end

lemma zpow_add' {a : G₀} {m n : ℤ} (h : a ≠ 0 ∨ m + n ≠ 0 ∨ m = 0 ∧ n = 0) :
  a ^ (m + n) = a ^ m * a ^ n :=
begin
  by_cases hm : m = 0, { simp [hm] },
  by_cases hn : n = 0, { simp [hn] },
  by_cases ha : a = 0,
  { subst a,
    simp only [false_or, eq_self_iff_true, not_true, ne.def, hm, hn, false_and, or_false] at h,
    rw [zero_zpow _ h, zero_zpow _ hm, zero_mul] },
  { exact zpow_add₀ ha m n }
end

theorem zpow_one_add₀ {a : G₀} (h : a ≠ 0) (i : ℤ) : a ^ (1 + i) = a * a ^ i :=
by rw [zpow_add₀ h, zpow_one]

theorem semiconj_by.zpow_right₀ {a x y : G₀} (h : semiconj_by a x y) :
  ∀ m : ℤ, semiconj_by a (x^m) (y^m)
| (n : ℕ) := by simp [h.pow_right n]
| -[1+n]  := by simp [(h.pow_right (n + 1)).inv_right₀]

theorem commute.zpow_right₀ {a b : G₀} (h : commute a b) : ∀ m : ℤ, commute a (b^m) :=
h.zpow_right₀

theorem commute.zpow_left₀ {a b : G₀} (h : commute a b) (m : ℤ) : commute (a^m) b :=
(h.symm.zpow_right₀ m).symm

theorem commute.zpow_zpow₀ {a b : G₀} (h : commute a b) (m n : ℤ) : commute (a^m) (b^n) :=
(h.zpow_left₀ m).zpow_right₀ n

theorem commute.zpow_self₀ (a : G₀) (n : ℤ) : commute (a^n) a := (commute.refl a).zpow_left₀ n

theorem commute.self_zpow₀ (a : G₀) (n : ℤ) : commute a (a^n) := (commute.refl a).zpow_right₀ n

theorem commute.zpow_zpow_self₀ (a : G₀) (m n : ℤ) : commute (a^m) (a^n) :=
(commute.refl a).zpow_zpow₀ m n

theorem zpow_bit1₀ (a : G₀) (n : ℤ) : a ^ bit1 n = a ^ n * a ^ n * a :=
begin
  rw [← zpow_bit0, bit1, zpow_add', zpow_one],
  right, left,
  apply bit1_ne_zero
end

lemma zpow_ne_zero_of_ne_zero {a : G₀} (ha : a ≠ 0) : ∀ (z : ℤ), a ^ z ≠ 0
| (n : ℕ) := by { rw zpow_coe_nat, exact pow_ne_zero _ ha }
| -[1+n]  := by { rw zpow_neg_succ_of_nat, exact inv_ne_zero (pow_ne_zero _ ha) }

lemma zpow_sub₀ {a : G₀} (ha : a ≠ 0) (z1 z2 : ℤ) : a ^ (z1 - z2) = a ^ z1 / a ^ z2 :=
by rw [sub_eq_add_neg, zpow_add₀ ha, zpow_neg, div_eq_mul_inv]

theorem zpow_bit1' (a : G₀) (n : ℤ) : a ^ bit1 n = (a * a) ^ n * a :=
by rw [zpow_bit1₀, (commute.refl a).mul_zpow]

lemma zpow_eq_zero {x : G₀} {n : ℤ} (h : x ^ n = 0) : x = 0 :=
classical.by_contradiction $ λ hx, zpow_ne_zero_of_ne_zero hx n h

lemma zpow_eq_zero_iff {a : G₀} {n : ℤ} (hn : n ≠ 0) :
  a ^ n = 0 ↔ a = 0 :=
⟨zpow_eq_zero, λ ha, ha.symm ▸ zero_zpow _ hn⟩

lemma zpow_ne_zero {x : G₀} (n : ℤ) : x ≠ 0 → x ^ n ≠ 0 :=
mt zpow_eq_zero

theorem zpow_neg_mul_zpow_self (n : ℤ) {x : G₀} (h : x ≠ 0) :
  x ^ (-n) * x ^ n = 1 :=
begin
  rw [zpow_neg],
  exact inv_mul_cancel (zpow_ne_zero n h)
end

end zpow

section
variables {G₀ : Type*} [comm_group_with_zero G₀]

lemma div_sq_cancel (a b : G₀) : a ^ 2 * b / a = a * b :=
begin
  by_cases ha : a = 0,
  { simp [ha] },
  rw [sq, mul_assoc, mul_div_cancel_left _ ha]
end

end

/-- If a monoid homomorphism `f` between two `group_with_zero`s maps `0` to `0`, then it maps `x^n`,
`n : ℤ`, to `(f x)^n`. -/
@[simp] lemma map_zpow₀ {F G₀ G₀' : Type*} [group_with_zero G₀] [group_with_zero G₀']
  [monoid_with_zero_hom_class F G₀ G₀'] (f : F) (x : G₀) (n : ℤ) :
  f (x ^ n) = f x ^ n :=
map_zpow' f (map_inv₀ f) x n


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

/-!
# Laurent Series

## Main Definitions
* Defines `laurent_series` as an abbreviation for `hahn_series ℤ`.
* Provides a coercion `power_series R` into `laurent_series R` given by
  `hahn_series.of_power_series`.
* Defines `laurent_series.power_series_part`
* Defines the localization map `laurent_series.of_power_series_localization` which evaluates to
  `hahn_series.of_power_series`.

-/

open hahn_series
open_locale big_operators classical polynomial
noncomputable theory

universe u

/-- A `laurent_series` is implemented as a `hahn_series` with value group `ℤ`. -/
abbreviation laurent_series (R : Type*) [has_zero R] := hahn_series ℤ R

variables {R : Type u}

namespace laurent_series

section semiring
variable [semiring R]

instance : has_coe (power_series R) (laurent_series R) :=
⟨hahn_series.of_power_series ℤ R⟩

lemma coe_power_series (x : power_series R) : (x : laurent_series R) =
  hahn_series.of_power_series ℤ R x := rfl

@[simp] lemma coeff_coe_power_series (x : power_series R) (n : ℕ) :
  hahn_series.coeff (x : laurent_series R) n = power_series.coeff R n x :=
by rw [coe_power_series, of_power_series_apply_coeff]

/-- This is a power series that can be multiplied by an integer power of `X` to give our
  Laurent series. If the Laurent series is nonzero, `power_series_part` has a nonzero
  constant term.  -/
def power_series_part (x : laurent_series R) : power_series R :=
power_series.mk (λ n, x.coeff (x.order + n))

@[simp] lemma power_series_part_coeff (x : laurent_series R) (n : ℕ) :
  power_series.coeff R n x.power_series_part = x.coeff (x.order + n) :=
power_series.coeff_mk _ _

@[simp] lemma power_series_part_zero : power_series_part (0 : laurent_series R) = 0 :=
by { ext, simp }

@[simp] lemma power_series_part_eq_zero (x : laurent_series R) :
  x.power_series_part = 0 ↔ x = 0 :=
begin
  split,
  { contrapose!,
    intro h,
    rw [power_series.ext_iff, not_forall],
    refine ⟨0, _⟩,
    simp [coeff_order_ne_zero h] },
  { rintro rfl,
    simp }
end

@[simp] lemma single_order_mul_power_series_part (x : laurent_series R) :
  (single x.order 1 : laurent_series R) * x.power_series_part = x :=
begin
  ext n,
  rw [← sub_add_cancel n x.order, single_mul_coeff_add, sub_add_cancel, one_mul],
  by_cases h : x.order ≤ n,
  { rw [int.eq_nat_abs_of_zero_le (sub_nonneg_of_le h), coeff_coe_power_series,
      power_series_part_coeff, ← int.eq_nat_abs_of_zero_le (sub_nonneg_of_le h),
      add_sub_cancel'_right] },
  { rw [coe_power_series, of_power_series_apply, emb_domain_notin_range],
    { contrapose! h,
      exact order_le_of_coeff_ne_zero h.symm },
    { contrapose! h,
      simp only [set.mem_range, rel_embedding.coe_fn_mk, function.embedding.coe_fn_mk] at h,
      obtain ⟨m, hm⟩ := h,
      rw [← sub_nonneg, ← hm],
      exact int.zero_le_of_nat _ } }
end

lemma of_power_series_power_series_part (x : laurent_series R) :
  of_power_series ℤ R x.power_series_part = single (-x.order) 1 * x :=
begin
  refine eq.trans _ (congr rfl x.single_order_mul_power_series_part),
  rw [← mul_assoc, single_mul_single, neg_add_self, mul_one, ← C_apply, C_one, one_mul,
    coe_power_series],
end

end semiring

instance [comm_semiring R] : algebra (power_series R) (laurent_series R) :=
(hahn_series.of_power_series ℤ R).to_algebra

@[simp] lemma coe_algebra_map [comm_semiring R] :
  ⇑(algebra_map (power_series R) (laurent_series R)) = hahn_series.of_power_series ℤ R :=
rfl

/-- The localization map from power series to Laurent series. -/
@[simps] instance of_power_series_localization [comm_ring R] :
  is_localization (submonoid.powers (power_series.X : power_series R)) (laurent_series R) :=
{ map_units := (begin rintro ⟨_, n, rfl⟩,
    refine ⟨⟨single (n : ℤ) 1, single (-n : ℤ) 1, _, _⟩, _⟩,
    { simp only [single_mul_single, mul_one, add_right_neg],
      refl },
    { simp only [single_mul_single, mul_one, add_left_neg],
      refl },
    { simp } end),
 surj := (begin intro z,
    by_cases h : 0 ≤ z.order,
    { refine ⟨⟨power_series.X ^ (int.nat_abs z.order) * power_series_part z, 1⟩, _⟩,
      simp only [ring_hom.map_one, mul_one, ring_hom.map_mul, coe_algebra_map,
        of_power_series_X_pow, submonoid.coe_one],
      rw [int.nat_abs_of_nonneg h, ← coe_power_series, single_order_mul_power_series_part] },
    { refine ⟨⟨power_series_part z, power_series.X ^ (int.nat_abs z.order), ⟨_, rfl⟩⟩, _⟩,
      simp only [coe_algebra_map, of_power_series_power_series_part],
      rw [mul_comm _ z],
      refine congr rfl _,
      rw [subtype.coe_mk, of_power_series_X_pow, int.of_nat_nat_abs_of_nonpos],
      exact le_of_not_ge h } end),
  eq_iff_exists := (begin intros x y,
    rw [coe_algebra_map, of_power_series_injective.eq_iff],
    split,
    { rintro rfl,
      exact ⟨1, rfl⟩ },
    { rintro ⟨⟨_, n, rfl⟩, hc⟩,
      rw [← sub_eq_zero, ← mul_sub, power_series.ext_iff] at hc,
      rw [← sub_eq_zero, power_series.ext_iff],
      intro m,
      have h := hc (m + n),
      rwa [linear_map.map_zero, subtype.coe_mk, power_series.X_pow_eq, power_series.monomial,
        add_comm m, power_series.coeff, finsupp.single_add, mv_power_series.coeff_add_monomial_mul,
        one_mul] at h } end) }

instance {K : Type u} [field K] : is_fraction_ring (power_series K) (laurent_series K) :=
is_localization.of_le (submonoid.powers (power_series.X : power_series K)) _
  (powers_le_non_zero_divisors_of_no_zero_divisors power_series.X_ne_zero)
  (λ f hf, is_unit_of_mem_non_zero_divisors $ map_mem_non_zero_divisors _
    hahn_series.of_power_series_injective hf)

end laurent_series

namespace power_series

open laurent_series

variables {R' : Type*} [semiring R] [ring R'] (f g : power_series R) (f' g' : power_series R')

@[simp, norm_cast] lemma coe_zero : ((0 : power_series R) : laurent_series R) = 0 :=
(of_power_series ℤ R).map_zero

@[simp, norm_cast] lemma coe_one : ((1 : power_series R) : laurent_series R) = 1 :=
(of_power_series ℤ R).map_one

@[simp, norm_cast] lemma coe_add : ((f + g : power_series R) : laurent_series R) = f + g :=
(of_power_series ℤ R).map_add _ _

@[simp, norm_cast] lemma coe_sub : ((f' - g' : power_series R') : laurent_series R') = f' - g' :=
(of_power_series ℤ R').map_sub _ _

@[simp, norm_cast]

@[simp, norm_cast] lemma coe_mul : ((f * g : power_series R) : laurent_series R) = f * g :=
(of_power_series ℤ R).map_mul _ _

lemma coeff_coe (i : ℤ) :
  ((f : power_series R) : laurent_series R).coeff i =
    if i < 0 then 0 else power_series.coeff R i.nat_abs f :=
begin
  cases i,
  { rw [int.nat_abs_of_nat_core, int.of_nat_eq_coe, coeff_coe_power_series,
        if_neg (int.coe_nat_nonneg _).not_lt] },
  { rw [coe_power_series, of_power_series_apply, emb_domain_notin_image_support,
        if_pos (int.neg_succ_lt_zero _)],
    simp only [not_exists, rel_embedding.coe_fn_mk, set.mem_image, not_and,
               function.embedding.coe_fn_mk, ne.def, to_power_series_symm_apply_coeff, mem_support,
               int.coe_nat_eq, implies_true_iff, not_false_iff] }
end

@[simp, norm_cast] lemma coe_C (r : R) : ((C R r : power_series R) : laurent_series R) =
  hahn_series.C r :=
of_power_series_C _

@[simp] lemma coe_X : ((X : power_series R) : laurent_series R) = single 1 1 :=
of_power_series_X

@[simp, norm_cast] lemma coe_smul {S : Type*} [semiring S] [module R S]
  (r : R) (x : power_series S) : ((r • x : power_series S) : laurent_series S) = r • x :=
by { ext, simp [coeff_coe, coeff_smul, smul_ite] }

@[simp, norm_cast] lemma coe_bit0 :
  ((bit0 f : power_series R) : laurent_series R) = bit0 f :=
(of_power_series ℤ R).map_bit0 _

@[simp, norm_cast] lemma coe_bit1 :
  ((bit1 f : power_series R) : laurent_series R) = bit1 f :=
(of_power_series ℤ R).map_bit1 _

@[simp, norm_cast] lemma coe_pow (n : ℕ) :
  ((f ^ n : power_series R) : laurent_series R) = f ^ n :=
(of_power_series ℤ R).map_pow _ _

end power_series


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

! This file was ported from Lean 3 source module data.vector.zip
! leanprover-community/mathlib commit 63f84d91dd847f50bae04a01071f3a5491934e36
! Please do not edit these lines, except to modify the commit id
! if you have ported upstream changes.
-/
import Mathbin.Data.Vector.Basic
import Mathbin.Data.List.Zip

/-!
# The `zip_with` operation on vectors.

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

namespace Vector

section ZipWith

variable {α β γ : Type _} {n : ℕ} (f : α → β → γ)

#print Vector.zipWith /-
/-- Apply the function `f : α → β → γ` to each corresponding pair of elements from two vectors. -/
def zipWith : Vector α n → Vector β n → Vector γ n := fun x y => ⟨List.zipWith f x.1 y.1, by simp⟩
#align vector.zip_with Vector.zipWith
-/

/- warning: vector.zip_with_to_list -> Vector.zipWith_toList is a dubious translation:
lean 3 declaration is
  forall {α : Type.{u1}} {β : Type.{u2}} {γ : Type.{u3}} {n : Nat} (f : α -> β -> γ) (x : Vector.{u1} α n) (y : Vector.{u2} β n), Eq.{succ u3} (List.{u3} γ) (Vector.toList.{u3} γ n (Vector.zipWith.{u1, u2, u3} α β γ n f x y)) (List.zipWith.{u1, u2, u3} α β γ f (Vector.toList.{u1} α n x) (Vector.toList.{u2} β n y))
but is expected to have type
  forall {α : Type.{u3}} {β : Type.{u2}} {γ : Type.{u1}} {n : Nat} (f : α -> β -> γ) (x : Vector.{u3} α n) (y : Vector.{u2} β n), Eq.{succ u1} (List.{u1} γ) (Vector.toList.{u1} γ n (Vector.zipWith.{u3, u2, u1} α β γ n f x y)) (List.zipWith.{u3, u2, u1} α β γ f (Vector.toList.{u3} α n x) (Vector.toList.{u2} β n y))
Case conversion may be inaccurate. Consider using '#align vector.zip_with_to_list Vector.zipWith_toListₓ'. -/
@[simp]
theorem zipWith_toList (x : Vector α n) (y : Vector β n) :
    (Vector.zipWith f x y).toList = List.zipWith f x.toList y.toList :=
  rfl
#align vector.zip_with_to_list Vector.zipWith_toList

/- warning: vector.zip_with_nth -> Vector.zipWith_get is a dubious translation:
lean 3 declaration is
  forall {α : Type.{u1}} {β : Type.{u2}} {γ : Type.{u3}} {n : Nat} (f : α -> β -> γ) (x : Vector.{u1} α n) (y : Vector.{u2} β n) (i : Fin n), Eq.{succ u3} γ (Vector.get.{u3} γ n (Vector.zipWith.{u1, u2, u3} α β γ n f x y) i) (f (Vector.get.{u1} α n x i) (Vector.get.{u2} β n y i))
but is expected to have type
  forall {α : Type.{u3}} {β : Type.{u2}} {γ : Type.{u1}} {n : Nat} (f : α -> β -> γ) (x : Vector.{u3} α n) (y : Vector.{u2} β n) (i : Fin n), Eq.{succ u1} γ (Vector.get.{u1} γ n (Vector.zipWith.{u3, u2, u1} α β γ n f x y) i) (f (Vector.get.{u3} α n x i) (Vector.get.{u2} β n y i))
Case conversion may be inaccurate. Consider using '#align vector.zip_with_nth Vector.zipWith_getₓ'. -/
@[simp]
theorem zipWith_get (x : Vector α n) (y : Vector β n) (i) :
    (Vector.zipWith f x y).get? i = f (x.get? i) (y.get? i) :=
  by
  dsimp only [Vector.zipWith, Vector.get]
  cases x; cases y
  simp only [List.nthLe_zipWith, Subtype.coe_mk]
  congr
#align vector.zip_with_nth Vector.zipWith_get

/- warning: vector.zip_with_tail -> Vector.zipWith_tail is a dubious translation:
lean 3 declaration is
  forall {α : Type.{u1}} {β : Type.{u2}} {γ : Type.{u3}} {n : Nat} (f : α -> β -> γ) (x : Vector.{u1} α n) (y : Vector.{u2} β n), Eq.{succ u3} (Vector.{u3} γ (HSub.hSub.{0, 0, 0} Nat Nat Nat (instHSub.{0} Nat Nat.hasSub) n (OfNat.ofNat.{0} Nat 1 (OfNat.mk.{0} Nat 1 (One.one.{0} Nat Nat.hasOne))))) (Vector.tail.{u3} γ n (Vector.zipWith.{u1, u2, u3} α β γ n f x y)) (Vector.zipWith.{u1, u2, u3} α β γ (HSub.hSub.{0, 0, 0} Nat Nat Nat (instHSub.{0} Nat Nat.hasSub) n (OfNat.ofNat.{0} Nat 1 (OfNat.mk.{0} Nat 1 (One.one.{0} Nat Nat.hasOne)))) f (Vector.tail.{u1} α n x) (Vector.tail.{u2} β n y))
but is expected to have type
  forall {α : Type.{u3}} {β : Type.{u2}} {γ : Type.{u1}} {n : Nat} (f : α -> β -> γ) (x : Vector.{u3} α n) (y : Vector.{u2} β n), Eq.{succ u1} (Vector.{u1} γ (HSub.hSub.{0, 0, 0} Nat Nat Nat (instHSub.{0} Nat instSubNat) n (OfNat.ofNat.{0} Nat 1 (instOfNatNat 1)))) (Vector.tail.{u1} γ n (Vector.zipWith.{u3, u2, u1} α β γ n f x y)) (Vector.zipWith.{u3, u2, u1} α β γ (HSub.hSub.{0, 0, 0} Nat Nat Nat (instHSub.{0} Nat instSubNat) n (OfNat.ofNat.{0} Nat 1 (instOfNatNat 1))) f (Vector.tail.{u3} α n x) (Vector.tail.{u2} β n y))
Case conversion may be inaccurate. Consider using '#align vector.zip_with_tail Vector.zipWith_tailₓ'. -/
@[simp]
theorem zipWith_tail (x : Vector α n) (y : Vector β n) :
    (Vector.zipWith f x y).tail = Vector.zipWith f x.tail y.tail :=
  by
  ext
  simp [nth_tail]
#align vector.zip_with_tail Vector.zipWith_tail

/- warning: vector.prod_mul_prod_eq_prod_zip_with -> Vector.prod_mul_prod_eq_prod_zipWith is a dubious translation:
lean 3 declaration is
  forall {α : Type.{u1}} {n : Nat} [_inst_1 : CommMonoid.{u1} α] (x : Vector.{u1} α n) (y : Vector.{u1} α n), Eq.{succ u1} α (HMul.hMul.{u1, u1, u1} α α α (instHMul.{u1} α (MulOneClass.toHasMul.{u1} α (Monoid.toMulOneClass.{u1} α (CommMonoid.toMonoid.{u1} α _inst_1)))) (List.prod.{u1} α (MulOneClass.toHasMul.{u1} α (Monoid.toMulOneClass.{u1} α (CommMonoid.toMonoid.{u1} α _inst_1))) (MulOneClass.toHasOne.{u1} α (Monoid.toMulOneClass.{u1} α (CommMonoid.toMonoid.{u1} α _inst_1))) (Vector.toList.{u1} α n x)) (List.prod.{u1} α (MulOneClass.toHasMul.{u1} α (Monoid.toMulOneClass.{u1} α (CommMonoid.toMonoid.{u1} α _inst_1))) (MulOneClass.toHasOne.{u1} α (Monoid.toMulOneClass.{u1} α (CommMonoid.toMonoid.{u1} α _inst_1))) (Vector.toList.{u1} α n y))) (List.prod.{u1} α (MulOneClass.toHasMul.{u1} α (Monoid.toMulOneClass.{u1} α (CommMonoid.toMonoid.{u1} α _inst_1))) (MulOneClass.toHasOne.{u1} α (Monoid.toMulOneClass.{u1} α (CommMonoid.toMonoid.{u1} α _inst_1))) (Vector.toList.{u1} α n (Vector.zipWith.{u1, u1, u1} α α α n (HMul.hMul.{u1, u1, u1} α α α (instHMul.{u1} α (MulOneClass.toHasMul.{u1} α (Monoid.toMulOneClass.{u1} α (CommMonoid.toMonoid.{u1} α _inst_1))))) x y)))
but is expected to have type
  forall {α : Type.{u1}} {n : Nat} [_inst_1 : CommMonoid.{u1} α] (x : Vector.{u1} α n) (y : Vector.{u1} α n), Eq.{succ u1} α (HMul.hMul.{u1, u1, u1} α α α (instHMul.{u1} α (MulOneClass.toMul.{u1} α (Monoid.toMulOneClass.{u1} α (CommMonoid.toMonoid.{u1} α _inst_1)))) (List.prod.{u1} α (MulOneClass.toMul.{u1} α (Monoid.toMulOneClass.{u1} α (CommMonoid.toMonoid.{u1} α _inst_1))) (Monoid.toOne.{u1} α (CommMonoid.toMonoid.{u1} α _inst_1)) (Vector.toList.{u1} α n x)) (List.prod.{u1} α (MulOneClass.toMul.{u1} α (Monoid.toMulOneClass.{u1} α (CommMonoid.toMonoid.{u1} α _inst_1))) (Monoid.toOne.{u1} α (CommMonoid.toMonoid.{u1} α _inst_1)) (Vector.toList.{u1} α n y))) (List.prod.{u1} α (MulOneClass.toMul.{u1} α (Monoid.toMulOneClass.{u1} α (CommMonoid.toMonoid.{u1} α _inst_1))) (Monoid.toOne.{u1} α (CommMonoid.toMonoid.{u1} α _inst_1)) (Vector.toList.{u1} α n (Vector.zipWith.{u1, u1, u1} α α α n (fun (x._@.Mathlib.Data.Vector.Zip._hyg.241 : α) (x._@.Mathlib.Data.Vector.Zip._hyg.243 : α) => HMul.hMul.{u1, u1, u1} α α α (instHMul.{u1} α (MulOneClass.toMul.{u1} α (Monoid.toMulOneClass.{u1} α (CommMonoid.toMonoid.{u1} α _inst_1)))) x._@.Mathlib.Data.Vector.Zip._hyg.241 x._@.Mathlib.Data.Vector.Zip._hyg.243) x y)))
Case conversion may be inaccurate. Consider using '#align vector.prod_mul_prod_eq_prod_zip_with Vector.prod_mul_prod_eq_prod_zipWithₓ'. -/
@[to_additive]
theorem prod_mul_prod_eq_prod_zipWith [CommMonoid α] (x y : Vector α n) :
    x.toList.Prod * y.toList.Prod = (Vector.zipWith (· * ·) x y).toList.Prod :=
  List.prod_mul_prod_eq_prod_zipWith_of_length_eq x.toList y.toList
    ((toList_length x).trans (toList_length y).symm)
#align vector.prod_mul_prod_eq_prod_zip_with Vector.prod_mul_prod_eq_prod_zipWith
#align vector.sum_add_sum_eq_sum_zip_with Vector.sum_add_sum_eq_sum_zipWith

end ZipWith

end Vector


/-
Copyright (c) 2018 Scott Morrison. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Scott Morrison
-/
import tactic.elementwise
import category_theory.concrete_category.bundled_hom
import algebra.punit_instances
import category_theory.reflects_isomorphisms

/-!
# Category instances for monoid, add_monoid, comm_monoid, and add_comm_monoid.

We introduce the bundled categories:
* `Mon`
* `AddMon`
* `CommMon`
* `AddCommMon`
along with the relevant forgetful functors between them.
-/

universes u v

open category_theory

/-- The category of monoids and monoid morphisms. -/
@[to_additive AddMon]
def Mon : Type (u+1) := bundled monoid

/-- The category of additive monoids and monoid morphisms. -/
add_decl_doc AddMon

namespace Mon

/-- `monoid_hom` doesn't actually assume associativity. This alias is needed to make the category
theory machinery work. -/
@[to_additive "`add_monoid_hom` doesn't actually assume associativity. This alias is needed to make
the category theory machinery work."]
abbreviation assoc_monoid_hom (M N : Type*) [monoid M] [monoid N] := monoid_hom M N

@[to_additive]
instance bundled_hom : bundled_hom assoc_monoid_hom :=
⟨λ M N [monoid M] [monoid N], by exactI @monoid_hom.to_fun M N _ _,
 λ M [monoid M], by exactI @monoid_hom.id M _,
 λ M N P [monoid M] [monoid N] [monoid P], by exactI @monoid_hom.comp M N P _ _ _,
 λ M N [monoid M] [monoid N], by exactI @monoid_hom.coe_inj M N _ _⟩

attribute [derive [large_category, concrete_category]] Mon
attribute [to_additive] Mon.large_category Mon.concrete_category

@[to_additive] instance : has_coe_to_sort Mon Type* := bundled.has_coe_to_sort

/-- Construct a bundled `Mon` from the underlying type and typeclass. -/
@[to_additive]
def of (M : Type u) [monoid M] : Mon := bundled.of M

/-- Construct a bundled `Mon` from the underlying type and typeclass. -/
add_decl_doc AddMon.of

/-- Typecheck a `monoid_hom` as a morphism in `Mon`. -/
@[to_additive] def of_hom {X Y : Type u} [monoid X] [monoid Y] (f : X →* Y) :
  of X ⟶ of Y := f

/-- Typecheck a `add_monoid_hom` as a morphism in `AddMon`. -/
add_decl_doc AddMon.of_hom

@[to_additive]
instance : inhabited Mon :=
-- The default instance for `monoid punit` is derived via `punit.comm_ring`,
-- which breaks to_additive.
⟨@of punit $ @group.to_monoid _ $ @comm_group.to_group _ punit.comm_group⟩

@[to_additive]
instance (M : Mon) : monoid M := M.str

@[simp, to_additive] lemma coe_of (R : Type u) [monoid R] : (Mon.of R : Type u) = R := rfl

end Mon

/-- The category of commutative monoids and monoid morphisms. -/
@[to_additive AddCommMon]
def CommMon : Type (u+1) := bundled comm_monoid

/-- The category of additive commutative monoids and monoid morphisms. -/
add_decl_doc AddCommMon

namespace CommMon

@[to_additive]
instance : bundled_hom.parent_projection comm_monoid.to_monoid := ⟨⟩

attribute [derive [large_category, concrete_category]] CommMon
attribute [to_additive] CommMon.large_category CommMon.concrete_category

@[to_additive] instance : has_coe_to_sort CommMon Type* := bundled.has_coe_to_sort

/-- Construct a bundled `CommMon` from the underlying type and typeclass. -/
@[to_additive]
def of (M : Type u) [comm_monoid M] : CommMon := bundled.of M

/-- Construct a bundled `AddCommMon` from the underlying type and typeclass. -/
add_decl_doc AddCommMon.of

@[to_additive]
instance : inhabited CommMon :=
-- The default instance for `comm_monoid punit` is derived via `punit.comm_ring`,
-- which breaks to_additive.
⟨@of punit $ @comm_group.to_comm_monoid _ punit.comm_group⟩

@[to_additive]
instance (M : CommMon) : comm_monoid M := M.str

@[simp, to_additive] lemma coe_of (R : Type u) [comm_monoid R] : (CommMon.of R : Type u) = R := rfl

@[to_additive has_forget_to_AddMon]
instance has_forget_to_Mon : has_forget₂ CommMon Mon := bundled_hom.forget₂ _ _

end CommMon

-- We verify that the coercions of morphisms to functions work correctly:
example {R S : Mon}     (f : R ⟶ S) : (R : Type) → (S : Type) := f
example {R S : CommMon} (f : R ⟶ S) : (R : Type) → (S : Type) := f

-- We verify that when constructing a morphism in `CommMon`,
-- when we construct the `to_fun` field, the types are presented as `↥R`,
-- rather than `R.α` or (as we used to have) `↥(bundled.map comm_monoid.to_monoid R)`.
example (R : CommMon.{u}) : R ⟶ R :=
{ to_fun := λ x,
  begin
    match_target (R : Type u),
    match_hyp x : (R : Type u),
    exact x * x
  end ,
  map_one' := by simp,
  map_mul' := λ x y,
  begin rw [mul_assoc x y (x * y), ←mul_assoc y x y, mul_comm y x, mul_assoc, mul_assoc], end, }

variables {X Y : Type u}

section
variables [monoid X] [monoid Y]

/-- Build an isomorphism in the category `Mon` from a `mul_equiv` between `monoid`s. -/
@[to_additive add_equiv.to_AddMon_iso "Build an isomorphism in the category `AddMon` from
an `add_equiv` between `add_monoid`s.", simps]
def mul_equiv.to_Mon_iso (e : X ≃* Y) : Mon.of X ≅ Mon.of Y :=
{ hom := e.to_monoid_hom,
  inv := e.symm.to_monoid_hom }

end

section
variables [comm_monoid X] [comm_monoid Y]

/-- Build an isomorphism in the category `CommMon` from a `mul_equiv` between `comm_monoid`s. -/
@[to_additive add_equiv.to_AddCommMon_iso "Build an isomorphism in the category `AddCommMon`
from an `add_equiv` between `add_comm_monoid`s.", simps]
def mul_equiv.to_CommMon_iso (e : X ≃* Y) : CommMon.of X ≅ CommMon.of Y :=
{ hom := e.to_monoid_hom,
  inv := e.symm.to_monoid_hom }

end

namespace category_theory.iso

/-- Build a `mul_equiv` from an isomorphism in the category `Mon`. -/
@[to_additive AddMon_iso_to_add_equiv "Build an `add_equiv` from an isomorphism in the category
`AddMon`."]
def Mon_iso_to_mul_equiv {X Y : Mon} (i : X ≅ Y) : X ≃* Y :=
i.hom.to_mul_equiv i.inv i.hom_inv_id i.inv_hom_id

/-- Build a `mul_equiv` from an isomorphism in the category `CommMon`. -/
@[to_additive "Build an `add_equiv` from an isomorphism in the category
`AddCommMon`."]
def CommMon_iso_to_mul_equiv {X Y : CommMon} (i : X ≅ Y) : X ≃* Y :=
i.hom.to_mul_equiv i.inv i.hom_inv_id i.inv_hom_id

end category_theory.iso

/-- multiplicative equivalences between `monoid`s are the same as (isomorphic to) isomorphisms
in `Mon` -/
@[to_additive add_equiv_iso_AddMon_iso "additive equivalences between `add_monoid`s are the same
as (isomorphic to) isomorphisms in `AddMon`"]
def mul_equiv_iso_Mon_iso {X Y : Type u} [monoid X] [monoid Y] :
  (X ≃* Y) ≅ (Mon.of X ≅ Mon.of Y) :=
{ hom := λ e, e.to_Mon_iso,
  inv := λ i, i.Mon_iso_to_mul_equiv, }

/-- multiplicative equivalences between `comm_monoid`s are the same as (isomorphic to) isomorphisms
in `CommMon` -/
@[to_additive add_equiv_iso_AddCommMon_iso "additive equivalences between `add_comm_monoid`s are
the same as (isomorphic to) isomorphisms in `AddCommMon`"]
def mul_equiv_iso_CommMon_iso {X Y : Type u} [comm_monoid X] [comm_monoid Y] :
  (X ≃* Y) ≅ (CommMon.of X ≅ CommMon.of Y) :=
{ hom := λ e, e.to_CommMon_iso,
  inv := λ i, i.CommMon_iso_to_mul_equiv, }

@[to_additive]
instance Mon.forget_reflects_isos : reflects_isomorphisms (forget Mon.{u}) :=
{ reflects := λ X Y f _,
  begin
    resetI,
    let i := as_iso ((forget Mon).map f),
    let e : X ≃* Y := { ..f, ..i.to_equiv },
    exact ⟨(is_iso.of_iso e.to_Mon_iso).1⟩,
  end }

@[to_additive]
instance CommMon.forget_reflects_isos : reflects_isomorphisms (forget CommMon.{u}) :=
{ reflects := λ X Y f _,
  begin
    resetI,
    let i := as_iso ((forget CommMon).map f),
    let e : X ≃* Y := { ..f, ..i.to_equiv },
    exact ⟨(is_iso.of_iso e.to_CommMon_iso).1⟩,
  end }

/-!
Once we've shown that the forgetful functors to type reflect isomorphisms,
we automatically obtain that the `forget₂` functors between our concrete categories
reflect isomorphisms.
-/
example : reflects_isomorphisms (forget₂ CommMon Mon) := by apply_instance


/-
Copyright (c) 2020 Kenny Lau. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Kenny Lau, Yuyang Zhao
-/

import algebra.algebra.tower
import data.polynomial.algebra_map

/-!
# Algebra towers for polynomial

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

This file proves some basic results about the algebra tower structure for the type `R[X]`.

This structure itself is provided elsewhere as `polynomial.is_scalar_tower`

When you update this file, you can also try to make a corresponding update in
`ring_theory.mv_polynomial.tower`.
-/

open_locale polynomial

variables (R A B : Type*)

namespace polynomial

section semiring
variables [comm_semiring R] [comm_semiring A] [semiring B]
variables [algebra R A] [algebra A B] [algebra R B]
variables [is_scalar_tower R A B]

variables {R B}

@[simp] theorem aeval_map_algebra_map (x : B) (p : R[X]) :
  aeval x (map (algebra_map R A) p) = aeval x p :=
by rw [aeval_def, aeval_def, eval₂_map, is_scalar_tower.algebra_map_eq R A B]

end semiring

section comm_semiring
variables [comm_semiring R] [comm_semiring A] [semiring B]
variables [algebra R A] [algebra A B] [algebra R B] [is_scalar_tower R A B]

variables {R A}

lemma aeval_algebra_map_apply (x : A) (p : R[X]) :
  aeval (algebra_map A B x) p = algebra_map A B (aeval x p) :=
by rw [aeval_def, aeval_def, hom_eval₂, ←is_scalar_tower.algebra_map_eq]

@[simp] lemma aeval_algebra_map_eq_zero_iff [no_zero_smul_divisors A B] [nontrivial B]
  (x : A) (p : R[X]) :
  aeval (algebra_map A B x) p = 0 ↔ aeval x p = 0 :=
by rw [aeval_algebra_map_apply, algebra.algebra_map_eq_smul_one, smul_eq_zero,
  iff_false_intro (one_ne_zero' B), or_false]

variables {B}

lemma aeval_algebra_map_eq_zero_iff_of_injective
  {x : A} {p : R[X]}
  (h : function.injective (algebra_map A B)) :
  aeval (algebra_map A B x) p = 0 ↔ aeval x p = 0 :=
by rw [aeval_algebra_map_apply, ← (algebra_map A B).map_zero, h.eq_iff]

end comm_semiring

end polynomial

namespace subalgebra

open polynomial

section comm_semiring

variables {R A} [comm_semiring R] [comm_semiring A] [algebra R A]

@[simp]

end comm_semiring

end subalgebra


/-
Copyright (c) 2017 Scott Morrison. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Stephen Morgan, Scott Morrison, Johannes Hölzl, Reid Barton
-/
import combinatorics.quiver.basic

/-!
# Categories

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

Defines a category, as a type class parametrised by the type of objects.

## Notations

Introduces notations
* `X ⟶ Y` for the morphism spaces (type as `\hom`),
* `𝟙 X` for the identity morphism on `X` (type as `\b1`),
* `f ≫ g` for composition in the 'arrows' convention (type as `\gg`).

Users may like to add `f ⊚ g` for composition in the standard convention, using
```lean
local notation f ` ⊚ `:80 g:80 := category.comp g f    -- type as \oo
```
-/

/--
The typeclass `category C` describes morphisms associated to objects of type `C : Type u`.

The universe levels of the objects and morphisms are independent, and will often need to be
specified explicitly, as `category.{v} C`.

Typically any concrete example will either be a `small_category`, where `v = u`,
which can be introduced as
```
universes u
variables {C : Type u} [small_category C]
```
or a `large_category`, where `u = v+1`, which can be introduced as
```
universes u
variables {C : Type (u+1)} [large_category C]
```

In order for the library to handle these cases uniformly,
we generally work with the unconstrained `category.{v u}`,
for which objects live in `Type u` and morphisms live in `Type v`.

Because the universe parameter `u` for the objects can be inferred from `C`
when we write `category C`, while the universe parameter `v` for the morphisms
can not be automatically inferred, through the category theory library
we introduce universe parameters with morphism levels listed first,
as in
```
universes v u
```
or
```
universes v₁ v₂ u₁ u₂
```
when multiple independent universes are needed.

This has the effect that we can simply write `category.{v} C`
(that is, only specifying a single parameter) while `u` will be inferred.

Often, however, it's not even necessary to include the `.{v}`.
(Although it was in earlier versions of Lean.)
If it is omitted a "free" universe will be used.
-/
library_note "category_theory universes"

universes v u

namespace category_theory

/-- A preliminary structure on the way to defining a category,
containing the data, but none of the axioms. -/
class category_struct (obj : Type u)
extends quiver.{v+1} obj : Type (max u (v+1)) :=
(id       : Π X : obj, hom X X)
(comp     : Π {X Y Z : obj}, (X ⟶ Y) → (Y ⟶ Z) → (X ⟶ Z))

notation `𝟙` := category_struct.id -- type as \b1
infixr ` ≫ `:80 := category_struct.comp -- type as \gg

/--
The typeclass `category C` describes morphisms associated to objects of type `C`.
The universe levels of the objects and morphisms are unconstrained, and will often need to be
specified explicitly, as `category.{v} C`. (See also `large_category` and `small_category`.)

See <https://stacks.math.columbia.edu/tag/0014>.
-/
class category (obj : Type u)
extends category_struct.{v} obj : Type (max u (v+1)) :=
(id_comp' : ∀ {X Y : obj} (f : hom X Y), 𝟙 X ≫ f = f . obviously)
(comp_id' : ∀ {X Y : obj} (f : hom X Y), f ≫ 𝟙 Y = f . obviously)
(assoc'   : ∀ {W X Y Z : obj} (f : hom W X) (g : hom X Y) (h : hom Y Z),
  (f ≫ g) ≫ h = f ≫ (g ≫ h) . obviously)

-- `restate_axiom` is a command that creates a lemma from a structure field,
-- discarding any auto_param wrappers from the type.
-- (It removes a backtick from the name, if it finds one, and otherwise adds "_lemma".)
restate_axiom category.id_comp'
restate_axiom category.comp_id'
restate_axiom category.assoc'
attribute [simp] category.id_comp category.comp_id category.assoc
attribute [trans] category_struct.comp

/--
A `large_category` has objects in one universe level higher than the universe level of
the morphisms. It is useful for examples such as the category of types, or the category
of groups, etc.
-/
abbreviation large_category (C : Type (u+1)) : Type (u+1) := category.{u} C
/--
A `small_category` has objects and morphisms in the same universe level.
-/
abbreviation small_category (C : Type u) : Type (u+1) := category.{u} C

section
variables {C : Type u} [category.{v} C] {X Y Z : C}

initialize_simps_projections category (to_category_struct_to_quiver_hom → hom,
  to_category_struct_comp → comp, to_category_struct_id → id, -to_category_struct)

/-- postcompose an equation between morphisms by another morphism -/
lemma eq_whisker {f g : X ⟶ Y} (w : f = g) (h : Y ⟶ Z) : f ≫ h = g ≫ h :=
by rw w
/-- precompose an equation between morphisms by another morphism -/
lemma whisker_eq (f : X ⟶ Y) {g h : Y ⟶ Z} (w : g = h) : f ≫ g = f ≫ h :=
by rw w

infixr ` =≫ `:80 := eq_whisker
infixr ` ≫= `:80 := whisker_eq

lemma eq_of_comp_left_eq {f g : X ⟶ Y} (w : ∀ {Z : C} (h : Y ⟶ Z), f ≫ h = g ≫ h) : f = g :=
by { convert w (𝟙 Y), tidy }
lemma eq_of_comp_right_eq {f g : Y ⟶ Z} (w : ∀ {X : C} (h : X ⟶ Y), h ≫ f = h ≫ g) : f = g :=
by { convert w (𝟙 Y), tidy }

lemma eq_of_comp_left_eq' (f g : X ⟶ Y)
  (w : (λ {Z : C} (h : Y ⟶ Z), f ≫ h) = (λ {Z : C} (h : Y ⟶ Z), g ≫ h)) : f = g :=
eq_of_comp_left_eq (λ Z h, by convert congr_fun (congr_fun w Z) h)
lemma eq_of_comp_right_eq' (f g : Y ⟶ Z)
  (w : (λ {X : C} (h : X ⟶ Y), h ≫ f) = (λ {X : C} (h : X ⟶ Y), h ≫ g)) : f = g :=
eq_of_comp_right_eq (λ X h, by convert congr_fun (congr_fun w X) h)

lemma id_of_comp_left_id (f : X ⟶ X) (w : ∀ {Y : C} (g : X ⟶ Y), f ≫ g = g) : f = 𝟙 X :=
by { convert w (𝟙 X), tidy }
lemma id_of_comp_right_id (f : X ⟶ X) (w : ∀ {Y : C} (g : Y ⟶ X), g ≫ f = g) : f = 𝟙 X :=
by { convert w (𝟙 X), tidy }

lemma comp_ite {P : Prop} [decidable P]
  {X Y Z : C} (f : X ⟶ Y) (g g' : (Y ⟶ Z)) :
  (f ≫ if P then g else g') = (if P then f ≫ g else f ≫ g') :=
by { split_ifs; refl }

lemma ite_comp {P : Prop} [decidable P]
  {X Y Z : C} (f f' : (X ⟶ Y))  (g : Y ⟶ Z) :
  (if P then f else f') ≫ g = (if P then f ≫ g else f' ≫ g) :=
by { split_ifs; refl }

lemma dite_comp {P : Prop} [decidable P]
  {X Y Z : C} (f : P → (X ⟶ Y)) (f' : ¬P → (X ⟶ Y)) (g : Y ⟶ Z) :
  (if h : P then f h else f' h) ≫ g = (if h : P then f h ≫ g else f' h ≫ g) :=
by { split_ifs; refl }

/--
A morphism `f` is an epimorphism if it can be "cancelled" when precomposed:
`f ≫ g = f ≫ h` implies `g = h`.

See <https://stacks.math.columbia.edu/tag/003B>.
-/
class epi (f : X ⟶ Y) : Prop :=
(left_cancellation : Π {Z : C} (g h : Y ⟶ Z) (w : f ≫ g = f ≫ h), g = h)

/--
A morphism `f` is a monomorphism if it can be "cancelled" when postcomposed:
`g ≫ f = h ≫ f` implies `g = h`.

See <https://stacks.math.columbia.edu/tag/003B>.
-/
class mono (f : X ⟶ Y) : Prop :=
(right_cancellation : Π {Z : C} (g h : Z ⟶ X) (w : g ≫ f = h ≫ f), g = h)

instance (X : C) : epi (𝟙 X) :=
⟨λ Z g h w, by simpa using w⟩
instance (X : C) : mono (𝟙 X) :=
⟨λ Z g h w, by simpa using w⟩

lemma cancel_epi (f : X ⟶ Y) [epi f] {g h : Y ⟶ Z} : (f ≫ g = f ≫ h) ↔ g = h :=
⟨λ p, epi.left_cancellation g h p, congr_arg _⟩
lemma cancel_mono (f : X ⟶ Y) [mono f] {g h : Z ⟶ X} : (g ≫ f = h ≫ f) ↔ g = h :=
⟨λ p, mono.right_cancellation g h p, congr_arg _⟩

lemma cancel_epi_id (f : X ⟶ Y) [epi f] {h : Y ⟶ Y} : (f ≫ h = f) ↔ h = 𝟙 Y :=
by { convert cancel_epi f, simp, }
lemma cancel_mono_id (f : X ⟶ Y) [mono f] {g : X ⟶ X} : (g ≫ f = f) ↔ g = 𝟙 X :=
by { convert cancel_mono f, simp, }

lemma epi_comp {X Y Z : C} (f : X ⟶ Y) [epi f] (g : Y ⟶ Z) [epi g] : epi (f ≫ g) :=
begin
  split, intros Z a b w,
  apply (cancel_epi g).1,
  apply (cancel_epi f).1,
  simpa using w,
end
lemma mono_comp {X Y Z : C} (f : X ⟶ Y) [mono f] (g : Y ⟶ Z) [mono g] : mono (f ≫ g) :=
begin
  split, intros Z a b w,
  apply (cancel_mono f).1,
  apply (cancel_mono g).1,
  simpa using w,
end

lemma mono_of_mono {X Y Z : C} (f : X ⟶ Y) (g : Y ⟶ Z) [mono (f ≫ g)] : mono f :=
begin
  split, intros Z a b w,
  replace w := congr_arg (λ k, k ≫ g) w,
  dsimp at w,
  rw [category.assoc, category.assoc] at w,
  exact (cancel_mono _).1 w,
end

lemma mono_of_mono_fac {X Y Z : C} {f : X ⟶ Y} {g : Y ⟶ Z} {h : X ⟶ Z} [mono h] (w : f ≫ g = h) :
  mono f :=
by { substI h, exact mono_of_mono f g, }

lemma epi_of_epi {X Y Z : C} (f : X ⟶ Y) (g : Y ⟶ Z) [epi (f ≫ g)] : epi g :=
begin
  split, intros Z a b w,
  replace w := congr_arg (λ k, f ≫ k) w,
  dsimp at w,
  rw [←category.assoc, ←category.assoc] at w,
  exact (cancel_epi _).1 w,
end

lemma epi_of_epi_fac {X Y Z : C} {f : X ⟶ Y} {g : Y ⟶ Z} {h : X ⟶ Z} [epi h] (w : f ≫ g = h) :
  epi g :=
by substI h; exact epi_of_epi f g
end

section
variable (C : Type u)
variable [category.{v} C]

universe u'

instance ulift_category : category.{v} (ulift.{u'} C) :=
{ hom  := λ X Y, (X.down ⟶ Y.down),
  id   := λ X, 𝟙 X.down,
  comp := λ _ _ _ f g, f ≫ g }

-- We verify that this previous instance can lift small categories to large categories.
example (D : Type u) [small_category D] : large_category (ulift.{u+1} D) := by apply_instance
end

end category_theory

/--
Many proofs in the category theory library use the `dsimp, simp` pattern,
which typically isn't necessary elsewhere.

One would usually hope that the same effect could be achieved simply with `simp`.

The essential issue is that composition of morphisms involves dependent types.
When you have a chain of morphisms being composed, say `f : X ⟶ Y` and `g : Y ⟶ Z`,
then `simp` can operate succesfully on the morphisms
(e.g. if `f` is the identity it can strip that off).

However if we have an equality of objects, say `Y = Y'`,
then `simp` can't operate because it would break the typing of the composition operations.
We rarely have interesting equalities of objects
(because that would be "evil" --- anything interesting should be expressed as an isomorphism
and tracked explicitly),
except of course that we have plenty of definitional equalities of objects.

`dsimp` can apply these safely, even inside a composition.

After `dsimp` has cleared up the object level, `simp` can resume work on the morphism level ---
but without the `dsimp` step, because `simp` looks at expressions syntactically,
the relevant lemmas might not fire.

There's no bound on how many times you potentially could have to switch back and forth,
if the `simp` introduced new objects we again need to `dsimp`.
In practice this does occur, but only rarely, because `simp` tends to shorten chains of compositions
(i.e. not introduce new objects at all).
-/
library_note "dsimp, simp"


/-
Following the tradition of other programming languages,
gensym.lean contains the definition of an object to generate
fresh variable names for CNF encodings. Also included in this
file are the proofs of the freshness of variable generation.

Authors: Cayden Codel, Jeremy Avigad, Marijn Heule
Carnegie Mellon University
-/

import cnf.cnf
import data.list.basic
import data.nat.basic
import data.set.basic

open nat
open function
open prod
open list

universe u

variables {α : Type*}-- [decidable_eq α] [inhabited α]

/- Essentially, a gensym object only tracks a position along the natural number
   line. When provided with an injective function from the naturals to the
   boolean variable type, the gensym will provably generate fresh variables,
   with respect to those variables already generated.
-/
structure gensym (α : Type*) :=
(offset : nat)
(f : nat → α)
(f_inj : injective f)

namespace gensym

variables {f : nat → α} (hf : injective f) {a : α} (g : gensym α)

/-! # Gensym creation -/

/- Initial gensym that starts at 0 -/
def init : gensym α := { offset := 0, f := f, f_inj := hf }

/- We can create a gensym that doesn't ever generate variables in a list
   when we provide a bijection between α and the naturals. Simply start the
   gensym's offset at one more than the maximum element in the list. -/
def seed (fi : α → nat) (fi_inj : injective fi)
  (rinv : right_inverse f fi) : list α → gensym α
| [] := init hf
| l  := { offset := 1 + max_nat (map fi l), f := f, f_inj := hf }

/-! # fresh -/

-- Note: the operation below acts like a state monad
-- Future work on this file could convert gensym into a monad

/- Generates a new variable and returns an updated gensym -/
def fresh : (α × gensym α) :=
⟨g.f (g.offset), ⟨g.offset + 1, g.f, g.f_inj⟩⟩

@[simp] theorem fresh_offset :
  (fresh g).2.offset = g.offset + 1 := rfl

@[simp] theorem fresh_f : (fresh g).2.f = g.f := rfl

theorem fresh_var : (fresh g).1 = g.f g.offset := rfl

theorem fresh_f_injective : injective (fresh g).2.f :=
(fresh g).2.f_inj

/-! # nfresh -/

/- Generates a list of n new variables and returns the gensym at the end -/
def nfresh : gensym α → nat → (list α × gensym α)
| g 0       := ⟨[], g⟩
| g (n + 1) := let ⟨a, g₂⟩ := fresh g in
               prod.map (λ l, a :: l) id (nfresh g₂ n)

@[simp] theorem nfresh_zero : nfresh g 0 = ⟨[], g⟩ := rfl

@[simp] theorem nfresh_one : (nfresh g 1).2 = (fresh g).2 := rfl

@[simp] theorem nfresh_offset (n : nat) :
  (nfresh g n).2.offset = g.offset + n :=
begin
  induction n with n ih generalizing g,
  { refl },
  { simp [nfresh, fresh, ih, nat.add_succ, nat.succ_add] }
end

@[simp] theorem nfresh_f (n : nat) : (nfresh g n).2.f = g.f :=
begin
  induction n with n ih generalizing g,
  { refl },
  { simp only [nfresh, fresh, ih, id.def, prod_map] }
end

theorem nfresh_f_injective (n : nat) :
  injective (nfresh g n).2.f := (nfresh g n).2.f_inj

theorem nfresh_one_eq_fresh :
  prod.map (λ a, [a]) id (fresh g) = nfresh g 1 :=
by simp only [fresh, nfresh, map_mk, eq_self_iff_true]

theorem nfresh_succ_eq_nfresh_fresh (n : nat) :
  nfresh g (n + 1) = ⟨(fresh g).1 :: (nfresh (fresh g).2 n).1,
                      (fresh (nfresh g n).2).2⟩ :=
begin
  induction n with n ih generalizing g,
  { refl },
  { simp [nfresh, fresh, ih, nat.add_succ, nat.succ_add] }
end

theorem nfresh_succ_gensym_eq_fresh_nfresh_gensym (n : nat) :
  (nfresh g (n + 1)).2 = (fresh (nfresh g n).2).2 :=
by simp only [nfresh_succ_eq_nfresh_fresh]

theorem nfresh_succ_gensym_eq_nfresh_fresh_gensym (n : nat) :
  (nfresh g (n + 1)).2 = (nfresh (fresh g).2 n).2 :=
by simp [nfresh_succ_eq_nfresh_fresh, nfresh, fresh]

/- nfresh can be split across two sets of calls -/
-- TODO later include both list and gensym objets in theorem
theorem nfresh_concat {n m₁ m₂ : nat} :
  n = m₁ + m₂ → (nfresh g n).2 = (nfresh (nfresh g m₁).2 m₂).2 :=
begin
  induction n with n ih generalizing m₁ m₂,
  { intro h,
    rw [nat.eq_zero_of_add_eq_zero_left h.symm,
      nat.eq_zero_of_add_eq_zero_right h.symm],
    refl },
  { cases m₂,
    { rw add_zero, rintro rfl, refl },
    { simp only [succ_eq_add_one, ← add_assoc],
      intro h,
      simp only [ih (nat.succ.inj h),
        nfresh_succ_gensym_eq_fresh_nfresh_gensym] } }
end

theorem length_list_nfresh (n : nat) :
  length (nfresh g n).1 = n :=
begin
  induction n with n ih generalizing g,
  { refl },
  { simp only [nfresh_succ_eq_nfresh_fresh, ih, length_cons] }
end

/-! # stock -/

/- Any gensym has a set of values it can produce
   A variable is in the stock if offset could reach it. -/
def stock : set α := { a | ∃ (n : nat), g.f (g.offset + n) = a }

-- TODO this can be cleaned up - right induction proof?
@[simp] theorem mem_stock {g : gensym α} :
  a ∈ g.stock ↔ a = g.fresh.1 ∨ a ∈ stock g.fresh.2 :=
begin
  split,
  { unfold stock,
    rw set.mem_set_of_eq,
    rintros ⟨n, hn⟩,
    induction n with n ih generalizing g,
    { rw add_zero at hn,
      exact or.inl hn.symm },
    { right,
      rw set.mem_set_of_eq,
      have : g.fresh.2.f (g.fresh.2.offset + n) = a,
      { rw [fresh_f, fresh_offset, add_assoc, ← succ_eq_one_add],
        exact hn },
      rcases ih this with (hm | hm),
      { simp [fresh] at hm,
        use 0,
        rw [fresh_f, fresh_offset, add_zero],
        exact hm.symm },
      { rw set.mem_set_of_eq at hm,
        rcases hm with ⟨m, hm⟩,
        use m + 1,
        simp at hm,
        simp,
        rw add_comm m 1,
        rw ← add_assoc _ 1 m,
        exact hm } } },
  { rintros (ha | ha),
    { unfold stock, rw set.mem_set_of_eq,
      simp [fresh] at ha,
      use 0, simp [ha] },
    { unfold stock at ha, rw set.mem_set_of_eq at ha,
      rcases ha with ⟨n, hn⟩,
      unfold stock, rw set.mem_set_of_eq,
      use n + 1,
      simp at hn,
      rw [add_comm n 1, ← add_assoc _ 1 n],
      exact hn } }
end

theorem fresh_mem_stock : g.fresh.1 ∈ g.stock :=
mem_stock.mpr (or.inl (refl g.fresh.1))

theorem fresh_fresh_mem_stock : g.fresh.2.fresh.1 ∈ g.stock :=
mem_stock.mpr (or.inr (fresh_mem_stock g.fresh.2))

theorem mem_stock_of_mem_fresh_stock {g : gensym α} :
  a ∈ g.fresh.2.stock → a ∈ g.stock :=
assume h, mem_stock.mpr (or.inr h)

theorem fresh_stock_subset : g.fresh.2.stock ⊆ g.stock :=
begin
  intros a ha,
  unfold stock at ha, rw set.mem_set_of_eq at ha,
  rcases ha with ⟨n, hn⟩,
  simp only [fresh_f, fresh_offset, add_assoc] at hn,
  unfold stock, rw set.mem_set_of_eq,
  use [1 + n, hn]
end

theorem fresh_not_mem_fresh_stock : g.fresh.1 ∉ g.fresh.2.stock :=
begin
  intro h,
  rcases mem_stock.mp h with hf | hf,
  { simp only [fresh] at hf,
    exact absurd (g.3.eq_iff.mp hf).symm (nat.succ_ne_self g.offset) },
  { unfold stock at hf,
    rw set.mem_set_of_eq at hf,
    rcases hf with ⟨n, hn⟩,
    simp [fresh] at hn,
    rw [add_assoc, ← succ_eq_add_one] at hn,
    exact absurd (g.3.eq_iff.mp hn) (ne_succ_add _ _) }
end

-- TODO can make one line
theorem fresh_stock_ssubset : stock g.fresh.2 ⊂ g.stock :=
begin
  apply (set.ssubset_iff_of_subset (fresh_stock_subset g)).mpr,
  use [g.fresh.1, fresh_mem_stock g, fresh_not_mem_fresh_stock g]
end

-- # nth

def nth (g : gensym α) (n : nat) : α := g.f (n + g.offset)

theorem nth_ne_of_ne {i j : nat} : i ≠ j → ∀ (g : gensym α), nth g i ≠ nth g j :=
assume hne g, g.f_inj.ne_iff.mpr ((add_ne_add_left g.offset).mpr hne)

theorem eq_of_nth_eq {i j : nat} {g : gensym α} : nth g i = nth g j → i = j :=
assume h, (add_left_inj g.offset).mp (g.f_inj.eq_iff.mp h)

theorem nth_zero_eq_fresh : ∀ (g : gensym α), g.nth 0 = g.fresh.1 :=
by { intro g, rw [nth, fresh, zero_add] }

-- TODO figure out what mem stock really means
theorem nth_mem_stock : ∀ (g : gensym α) (n : nat), g.nth n ∈ g.stock :=
begin
  intros g n,
  rw [nth, stock],
  simp, use n, rw add_comm,
end

-- Disjointness
theorem forall_nth_not_mem_of_disjoint {g : gensym α} {l : set α} :
  disjoint g.stock l → ∀ (n : nat), g.nth n ∉ l :=
λ h n, set.disjoint_left.mp h (nth_mem_stock g n)

-- Coercion is silly
theorem forall_nth_not_mem_of_disjoint' {g : gensym α} {l : finset α} :
  disjoint g.stock l → ∀ (n : nat), g.nth n ∉ l :=
forall_nth_not_mem_of_disjoint

end gensym


import data.set.finite
import tactic.induction
import tactic.linarith
import tactic.rcases

abbreviation atom := ℕ

@[derive [decidable_eq]]
structure literal :=
mk :: (atom : atom) (negated : bool)

@[instance] def literal.has_repr : has_repr literal :=
{
  repr :=
  λ x, match x with
  | {atom := atom, negated := n} :=
    "{literal . atom := " ++ repr atom ++ ", negated := " ++ repr n ++ "}"
  end
}

def l_not : literal → literal
| {atom := a, negated := n} := {atom := a, negated := !n}

@[simp] lemma literal_neq : ∀ l, l ≠ l_not l := begin
  intro l,
  cases' l,
  rw l_not,
  simp,
  intro h,
  cases' negated;
  finish,
end

@[simp] lemma l_inv : ∀ l, l_not (l_not l) = l := begin
  intro l,
  cases l,
  rw l_not,
  rw l_not,
  simp,
end

@[simp] lemma not_preserves_atom : ∀ l, (l_not l).atom = l.atom := begin
  intro l,
  cases l,
  rw l_not,
end

@[simp] lemma atom_must_be_equal : ∀ (a b : literal),
a = b → a.atom = b.atom :=
begin
  intros a b,
  cases' a,
  cases' b,
  simp,
  intros h _,
  assumption,
end

@[simp] lemma eq_atom_iff : ∀ (a b : literal),
  a.atom = b.atom ↔ a = b ∨ a = l_not b :=
begin
  intros a b,
  apply iff.intro;
  intro h;
  cases' a;
  cases' b;
  simp at h,
  {
    rw h,
    rw l_not,
    simp,
    cases' negated;
    cases' negated_1;
    simp,
  },
  {
    rw l_not at h,
    simp at h,
    simp,
    cases' h;
    simp [h],
  },
end

@[simp] lemma bool_neq_neg : ∀ (b : bool),  b ≠ !b := begin
  intro b,
  cases' b;
  simp,
end

@[simp] lemma l_not_neq : ∀ l, l ≠ l_not l := begin
  intro l,
  cases l,
  rw l_not,
  simp,
end

abbreviation clause := list literal

abbreviation formula := list clause

def assignment := {s : list literal // ∀ l, l ∈ s → l_not l ∉ s}

@[instance] def assignment.has_mem :
has_mem literal assignment :=
{
  mem := λ l as, l ∈ as.val
}

def clause_sat (a : assignment) (c : clause) := ∃ l, l ∈ a ∧ l ∈ c
def formula_sat (a : assignment) (f : formula) :=
  ∀ c, c ∈ f → clause_sat a c
def sat (f : formula) := ∃ a, formula_sat a f

def formula_size (f : formula) : ℕ := f.join.length

def non_empty_formula := {f : formula // f.join ≠ []}

def choice_func :=
  {g : non_empty_formula → literal //
   ∀ (f : non_empty_formula),
     g f ∈ f.val.join ∨ l_not (g f) ∈ f.val.join}

def non_empty_list {α : Type} := {l : list α // l ≠ []}

def extract_first  {α : Type} : non_empty_list → α
| ⟨[], h⟩ := (h rfl).elim
| ⟨a::_, h⟩ := a

def naive_choice_func : choice_func := subtype.mk
(λ f, extract_first (subtype.mk f.val.join f.property))
(begin
  intro f,
  apply or.inl,
  cases' joined : f.val.join,
  {
    apply classical.by_contradiction,
    intros,
    exact f.property joined,
  },
  {
    let non_empty_first : non_empty_list := ⟨list.join f.val, f.property⟩,
    have eq : non_empty_first = ⟨hd::x, by simp⟩ := begin
      simp,
      rw ←joined,
      simp,
    end,
    simp only [non_empty_first] at eq,
    rw eq,
    rw extract_first,
    rw joined,
    simp,
  },
end)

def example_sat_formula : formula := [[{atom := 3, negated := tt}]]
def example_unsat_formula : formula :=
  [[{atom := 3, negated := tt}], [{atom := 3, negated := ff}]]
def example_complex_formula : formula := [
  [{atom := 3, negated := tt}, {atom := 2, negated := ff}],
  [{atom := 3, negated := tt}, {atom := 2, negated := ff}],
  [{atom := 1, negated := tt}, {atom := 2, negated := ff}],
  [{atom := 1, negated := tt}, {atom := 3, negated := ff}]
]

def is_pure_literal (l : literal) (f: formula) : bool :=
  ∀ c ∈ f, l_not l ∉ c

def is_pure_literal' (l : literal) (f: formula) : bool :=
  (l_not l) ∉ list.join f

@[simp]
lemma is_pure_literal_iff (l f) : is_pure_literal l f ↔ is_pure_literal' l f :=
by simp [is_pure_literal, is_pure_literal']


import algebra.category.Mon.basic
import tactic.elementwise

open category_theory

universes w v u

@[elementwise]
lemma foo {C : Type u} [category.{v} C]
  {M N K : C} {f : M ⟶ N} {g : N ⟶ K} {h : M ⟶ K} (w : f ≫ g = h) : f ≫ 𝟙 N ≫ g = h :=
by simp [w]

@[elementwise]
lemma foo' {C : Type*} [category C]
  {M N K : C} {f : M ⟶ N} {g : N ⟶ K} {h : M ⟶ K} (w : f ≫ g = h) : f ≫ 𝟙 N ≫ g = h :=
by simp [w]

local attribute [instance] concrete_category.has_coe_to_sort concrete_category.has_coe_to_fun

lemma bar {C : Type u} [category.{v} C] [concrete_category.{w} C]
  {M N K : C} {f : M ⟶ N} {g : N ⟶ K} {h : M ⟶ K} (w : f ≫ g = h) (x : M) : g (f x) = h x :=
by apply foo_apply w

lemma bar' {M N K : Mon.{u}} {f : M ⟶ N} {g : N ⟶ K} {h : M ⟶ K} (w : f ≫ g = h) (x : M) :
  g (f x) = h x :=
by exact foo_apply w x

lemma bar'' {M N K : Mon.{0}} {f : M ⟶ N} {g : N ⟶ K} {h : M ⟶ K} (w : f ≫ g = h) (x : M) :
  g (f x) = h x :=
by apply foo_apply w

lemma bar''' {M N K : Mon} {f : M ⟶ N} {g : N ⟶ K} {h : M ⟶ K} (w : f ≫ g = h) (x : M) :
  g (f x) = h x :=
by apply foo_apply w

example (M N K : Mon.{u}) (f : M ⟶ N) (g : N ⟶ K) (h : M ⟶ K) (w : f ≫ g = h) (m : M) :
  g (f m) = h m :=
begin
  rw elementwise_of w,
end

example (M N K : Mon.{0}) (f : M ⟶ N) (g : N ⟶ K) (h : M ⟶ K) (w : f ≫ g = h) (m : M) :
  g (f m) = h m :=
begin
  elementwise! w,
  apply w,
end

example {α β : Type} (f g : α ⟶ β) (w : f = g) (a : α) : f a = g a :=
begin
  elementwise! w, -- make sure this works even when there is no simplification to do
  rw w,
end

example {α β : Type} (f g : α ⟶ β) (w : f ≫ 𝟙 β = g) (a : α) : f a = g a :=
begin
  elementwise! w,
  rw w,  -- this used to not work, because we produced `w : ⇑f a = ⇑g a`.
end


import tactic
import tactic.induction
import data.list.basic
import logic.function.iterate

noncomputable theory
open_locale classical

def mem_loop {α : Type} (f : α → α) (x : α) (l : list α) : Prop :=
∀ (n : ℕ), l.nth (n % l.length) = some ((f^[n]) x)

def mem_shortest_loop {α : Type} (f : α → α) (x : α) (l : list α) : Prop :=
mem_loop f x l ∧ ∀ (l' : list α), mem_loop f x l' → l.length ≤ l'.length

def mk_list {α : Type} (f : ℕ → α) : ℕ → list α
| 0 := []
| (n+1) := mk_list n ++ [f n]

def mk_finset {α : Type} (f : ℕ → α) (n : ℕ) : finset α :=
(mk_list f n).to_finset

-----

lemma finset_union_singleton {α : Type} {s : finset α} {x : α} :
  s ∪ {x} = insert x s :=
begin
  ext y,
  rw [finset.mem_union, finset.mem_singleton, finset.mem_insert],
  tauto,
end

lemma mk_finset_zero {α : Type} {f : ℕ → α} : mk_finset f 0 = ∅ :=
rfl

lemma mk_finset_succ {α : Type} {f : ℕ → α} {n : ℕ} :
  mk_finset f n.succ = insert (f n) (mk_finset f n) :=
begin
  simp_rw mk_finset,
  rw [mk_list, list.to_finset_append, list.to_finset_cons, list.to_finset_nil],
  nth_rewrite 0 finset_union_singleton,
end

lemma mem_mk_finset {α : Type} {f : ℕ → α} {n : ℕ} {x : α} :
  x ∈ mk_finset f n ↔ ∃ (i : ℕ), i < n ∧ f i = x :=
begin
  induction n with n ih,
  { rw mk_finset_zero,
    apply iff_of_false (finset.not_mem_empty _),
    push_neg,
    rintro i h,
    cases h },
  { rw [mk_finset_succ, finset.mem_insert],
    split; intro h,
    { cases h,
      { subst h,
        exact ⟨_, lt_add_one _, rfl⟩ },
      { rw ih at h,
        rcases h with ⟨i, h, rfl⟩,
        exact ⟨_, nat.lt_succ_of_lt h, rfl⟩ }},
    { rcases h with ⟨i, h, rfl⟩,
      rw [nat.lt_succ_iff, le_iff_eq_or_lt] at h,
      cases h,
      { left, subst h },
      { right, rw ih, exact ⟨_, h, rfl⟩ }}},
end

lemma iter_add {α : Type} {f : α → α} {x : α} {m n : ℕ} :
  (f^[m + n]) x = (f^[n]) ((f^[m]) x) :=
by rw [add_comm, function.iterate_add_apply]

lemma iter_add_mul_eq_of_add_eq {α : Type}
  {f : α → α} {x : α} {n m d : ℕ}
  (h : (f^[n + d]) x = (f^[n]) x) :
  (f^[n + d * m]) x = (f^[n]) x :=
begin
  induction m with m ih,
  { refl },
  { rwa [nat.mul_succ, ←nat.add_assoc, nat.add_comm n, nat.add_assoc,
    function.iterate_add_apply, h, ←iter_add] },
end

lemma iter_mul_eq_of_eq {α : Type}
  {f : α → α} {x : α} {m d : ℕ}
  (h : (f^[d]) x = x) :
  (f^[d * m]) x = x :=
begin
  rw ←nat.zero_add (d * m),
  apply iter_add_mul_eq_of_add_eq,
  rwa nat.zero_add,
end

lemma list_nth_le_eq_iff {α : Type}
  {l : list α} {n : ℕ} {x : α} {h} :
  l.nth_le n h = x ↔ l.nth n = some x :=
by { rw list.nth_eq_some, tauto }

lemma list_some_nth_le_eq {α : Type}
  {l : list α} {n : ℕ} {h} :
  some (l.nth_le n h) = l.nth n :=
by { symmetry, rw list.nth_eq_some, tauto }

lemma list_nodup_iff {α : Type} {l : list α} :
  l.nodup ↔ ∀ (i j : ℕ), i < j → j < l.length → l.nth i ≠ l.nth j :=
begin
  rw list.nodup_iff_nth_le_inj,
  simp only [list_nth_le_eq_iff, list_some_nth_le_eq],
  split; rintro h i j h₁ h₂,
  { exact mt (h i j (h₁.trans h₂) h₂) (ne_of_lt h₁) },
  { intro h₃,
    by_contra h₄,
    wlog h₅ : i < j,
    { exact ne_iff_lt_or_gt.mp h₄ },
    exact h i j h₅ h₂ h₃ },
end

lemma nat_sub_lt_of_lt {a b c : ℕ} (h : a < b) : a - c < b :=
gt_of_gt_of_ge h (nat.sub_le _ _)

lemma loop_length_pos {α : Type}
  {f : α → α} {x : α} {l : list α}
  (h : mem_loop f x l) :
  0 < l.length :=
begin
  cases l,
  { cases h 0 },
  { dec_trivial },
end

lemma exi_list_func_of_mem_loop {α : Type}
  {f : α → α} {x : α} {l : list α}
  (h : mem_loop f x l) :
  ∃ {g : option α → option α}, ∀ (i : ℕ),
    l.nth (i % l.length) = ((g^[i]) (some x)) :=
begin
  let k := l.length,
  have hk : 0 < k := loop_length_pos h,
  let g : option α → option α,
  { rintro (_ | x),
    { exact none },
    { exact some (f x) }},
  use g,
  rintro i,
  induction i with i ih,
  { exact h 0 },
  { rw [function.iterate_succ_apply', ←ih],
    cases h₁ : l.nth (i % k) with y,
    { rw list.nth_eq_none_iff at h₁,
      contrapose! h₁,
      exact nat.mod_lt _ hk },
    { change _ = some (f y),
      simp_rw [list.nth_eq_some, list_nth_le_eq_iff],
      use [nat.mod_lt _ hk],
      rw [h, option.some.inj_eq] at h₁ ⊢,
      rw [function.iterate_succ_apply', h₁] }},
end

lemma nat_add_sub {a b : ℕ} (h : a ≤ b) : a + (b - a) = b :=
by rw [←nat.add_sub_assoc h, add_tsub_cancel_left]

lemma nat_find_spec_lt {P : ℕ → Prop}
  (h : ∃ (n : ℕ), P n) :
  ∀ (n : ℕ), n < nat.find h → ¬P n :=
λ n h₁, (nat.lt_find_iff h _).mp h₁ n (le_refl _)

lemma nat_mul_add_mod {a b c : ℕ} : (a * b + c) % b = c % b :=
by rw [nat.add_mod, nat.mul_mod, nat.mod_self, nat.mul_zero, nat.zero_mod,
  nat.zero_add, nat.mod_mod]

lemma nat_mul_add_mod_of_lt {a b c : ℕ} (h : c < b) : (a * b + c) % b = c :=
by rw [nat_mul_add_mod, nat.mod_eq_of_lt h]

lemma nat_exi_mul (x y : ℕ) :
  ∃ (a b : ℕ), x / y = a ∧ x % y = b ∧ x = y * a + b :=
⟨_, _, rfl, rfl, (nat.div_add_mod _ _).symm⟩

lemma shortest_loop_nodup {α : Type}
  {f : α → α} {x : α} {l : list α}
  (h : mem_shortest_loop f x l) :
  l.nodup :=
begin
  cases h with hh₁ hh₂,
  let k := l.length,
  have hk : 0 < k := loop_length_pos hh₁,
  obtain ⟨g, hh⟩ := exi_list_func_of_mem_loop hh₁,
  by_contra h₁,
  rw list_nodup_iff at h₁,
  push_neg at h₁,
  let i := nat.find h₁,
  have hi := nat.find_spec h₁,
  change nat.find h₁ with i at hi,
  let j := nat.find hi,
  have hj := nat.find_spec hi,
  change nat.find hi with j at hj,
  rcases hj with ⟨h₂, h₃, h₄⟩,
  change l.length with k at h₃,
  let d := j - i,
  have hd₁ : 0 < d := tsub_pos_of_lt h₂,
  have hd₂ : d < k := nat_sub_lt_of_lt h₃,
  let x' := some x,
  have h₆ := h₂.trans h₃,
  have h₇ := le_of_lt h₆,
  have hi0 : i = 0,
  { by_contra hi₁,
    have h₅ : l.nth 0 = l.nth d,
    { calc l.nth 0 = l.nth ((i + (k - i)) % k) :
          by rw [nat_add_sub h₇, nat.mod_self]
        ... = (g^[i + (k - i)]) x' : by rw hh
        ... = (g^[k - i]) ((g^[i]) x') : by rw iter_add
        ... = (g^[k - i]) (l.nth i) : by rw [←hh, nat.mod_eq_of_lt h₆]
        ... = (g^[k - i]) (l.nth j) : by rw h₄
        ... = (g^[k - i]) ((g^[j]) x') : by rw [←hh, nat.mod_eq_of_lt h₃]
        ... = (g^[j + (k - i)]) x' : by rw iter_add
        ... = l.nth ((j + (k - i)) % k) : by rw hh
        ... = l.nth ((d + k) % k) :
          by rw [←nat.add_sub_assoc h₇, nat.sub_add_comm (le_of_lt h₂)]
        ... = l.nth (d % k) : by rw nat.add_mod_right
        ... = l.nth d : by rw nat.mod_eq_of_lt hd₂ },
    have h₈ := nat_find_spec_lt h₁ _ (nat.pos_of_ne_zero hi₁),
    push_neg at h₈,
    exact h₈ _ hd₁ hd₂ h₅ },
  have hjd : j = d := by { change _ = j - i, rw hi0, refl },
  have hx0 : l.nth 0 = x' := by { rw [←nat.zero_mod k, hh], refl },
  have hxd : l.nth d = x' := by rw [←hx0, ←hjd, ←hi0, h₄],
  have hmd : ∀ (m : ℕ), l.nth ((d * m) % k) = l.nth 0,
  { intro m,
    rw [hh, hx0],
    apply iter_mul_eq_of_eq,
    rwa [←hh, nat.mod_eq_of_lt hd₂] },
  let l' := l.take d,
  have hlen : l'.length = d,
  { rw list.length_take, exact min_eq_left (le_of_lt hd₂) },
  specialize hh₂ l' _,
  { intro m,
    obtain ⟨a, b, ha, hb, hab⟩ := nat_exi_mul m d,
    have hbd : b < d := by { rw ←hb, exact nat.mod_lt _ hd₁ },
    have hbk := hbd.trans hd₂,
    rw [hlen, hb, list.nth_take hbd, ←nat.mod_eq_of_lt hbk, ←hh₁, hab],
    symmetry,
    change l.length with k,
    rw [hh, iter_add, ←hh, hmd, hh, hx0] },
  contrapose! hh₂,
  rwa hlen,
end

lemma exi_mem_shortest_loop_of_mem_loop {α : Type}
  {f : α → α} {x : α} {l : list α}
  (h : mem_loop f x l) :
  ∃ (l' : list α), mem_shortest_loop f x l' :=
begin
  have h₁ : ∃ (n : ℕ) (l : list α), l.length = n ∧ mem_loop f x l,
  { exact ⟨_, _, rfl, h⟩ },
  let n := nat.find h₁,
  obtain ⟨l, h₂, h₃⟩ := nat.find_spec h₁,
  use [l, h₃],
  rintro l' h₄,
  rw h₂,
  by_contra' h₅,
  have h₆ := nat_find_spec_lt h₁ _ h₅,
  push_neg at h₆,
  exact h₆ _ rfl h₄,
end

lemma exi_mem_loop_nodup_of_mem_loop {α : Type}
  {f : α → α} {x : α} {l : list α}
  (h : mem_loop f x l) :
  ∃ (l' : list α), l'.nodup ∧ mem_loop f x l' :=
begin
  obtain ⟨l', h₁⟩ := exi_mem_shortest_loop_of_mem_loop h,
  exact ⟨_, shortest_loop_nodup h₁, h₁.1⟩,
end

lemma list_length_eq_card_to_finset_of_nodup {α : Type} {l : list α}
  (h : l.nodup) : l.length = l.to_finset.card :=
by rw [list.card_to_finset, list.dedup_eq_self.mpr h]

lemma list_length_le_fintype_card_of_nodup {α : Type} [fintype α] {l : list α}
  (h : l.nodup) : l.length ≤ fintype.card α :=
begin
  rw [fintype.card, list_length_eq_card_to_finset_of_nodup h],
  apply finset.card_le_univ,
end

lemma mem_loop_length_le_of_mem_loop {α : Type} [fintype α]
  {f : α → α} {x : α} {l : list α} {n : ℕ}
  (h : mem_loop f x l) :
  ∃ (l' : list α), l'.length ≤ fintype.card α ∧ mem_loop f x l' :=
begin
  obtain ⟨l', h₁, h₂⟩ := exi_mem_loop_nodup_of_mem_loop h,
  exact ⟨_, list_length_le_fintype_card_of_nodup h₁, h₂⟩,
end

lemma list_nth_cons_of_pos {α : Type} {l : list α} {x : α} {n : ℕ}
  (h : 0 < n) : (x :: l).nth n = l.nth (n - 1) :=
begin
  cases n,
  { cases h },
  { rw list.nth, refl },
end

lemma list_length_snoc {α : Type} {l : list α} {x : α} :
  (l ++ [x]).length = l.length + 1 :=
by rw [list.length_append, list.length_singleton]

lemma list_dedup_singleton {α : Type} {x : α} : [x].dedup = [x] := rfl

lemma list_length_dedup_le {α : Type} {l : list α} :
  l.dedup.length ≤ l.length :=
begin
  induction' l,
  { refl },
  { by_cases h : hd ∈ l,
    { rw list.dedup_cons_of_mem h,
      exact ih.trans (le_of_lt (lt_add_one _)) },
    { simp_rw [list.dedup_cons_of_not_mem h, list.length_cons,
      nat.succ_le_succ_iff, ih] }},
end

lemma list_length_dedup_eq_card_to_finset {α : Type} {l : list α} :
  l.dedup.length = l.to_finset.card :=
begin
  induction' l,
  { refl },
  { rw list.to_finset_cons,
    by_cases h : hd ∈ l,
    { rwa [list.dedup_cons_of_mem h,
      finset.insert_eq_of_mem (list.mem_to_finset.mpr h)] },
    { rw [list.dedup_cons_of_not_mem h, list.length_cons,
      finset.card_insert_of_not_mem _, ih],
      contrapose! h,
      exact list.mem_to_finset.mp h }},
end

lemma list_length_dedup_append_le {α : Type} {l₁ l₂ : list α} :
  ((l₁ ++ l₂).dedup).length ≤ l₁.dedup.length + l₂.dedup.length :=
begin
  simp_rw [list_length_dedup_eq_card_to_finset, list.to_finset_append],
  apply finset.card_union_le,
end

lemma list_dedup_dup_cons {α : Type} {l : list α} {x : α} :
  (x :: x :: l).dedup = (x :: l).dedup :=
begin
  rw [list.dedup, list.pw_filter_cons_of_neg],
  push_neg,
  refine ⟨_, _, rfl⟩,
  rw [←list.dedup, list.mem_dedup],
  apply list.mem_cons_self,
end

lemma list_length_dedup_cons_le_of_mem {α : Type} {l : list α} {x : α}
  (h : x ∈ l) : (x :: l).dedup.length ≤ l.length :=
begin
  rw [list_length_dedup_eq_card_to_finset, list.to_finset_cons,
    finset.card_insert_of_mem (list.mem_to_finset.mpr h)],
  apply list.to_finset_card_le,
end

lemma list_eq_append {α : Type} {l : list α} {i : ℕ}
  (h : i < l.length) : l = l.take i ++ l.drop i :=
by rw list.take_append_drop

lemma list_eq_tail_of_cons_eq {α : Type} {l₁ l₂ : list α} {x : α}
  (h : x :: l₁ = l₂) : l₁ = l₂.tail :=
begin
  cases l₂ with y l₂,
  { cases h },
  { rw list.cons.inj_eq at h, exact h.2 },
end

lemma list_length_dedup_lt_of_dup {α : Type} {l : list α}
  (h : ¬l.nodup) : l.dedup.length < l.length :=
begin
  rw list_nodup_iff at h,
  push_neg at h,
  rcases h with ⟨i, j, hi, hj, h⟩,
  have hh := hi.trans hj,
  rw [list_eq_append hh, list.length_append],
  apply lt_of_le_of_lt list_length_dedup_append_le,
  apply add_lt_add_of_le_of_lt list_length_dedup_le,
  cases h₁ : l.drop i with x l',
  { rw list.drop_eq_nil_iff_le at h₁,
    contrapose! h₁,
    exact hh },
  { symmetry' at h₁,
    have h₂ : l.nth i = some x,
    { change i with i + 0,
      rw [←list.nth_drop, ←h₁],
      refl },
    rw [list.length_cons, nat.lt_succ_iff],
    apply list_length_dedup_cons_le_of_mem,
    rw list.mem_iff_nth,
    use j - i - 1,
    obtain ⟨j, rfl⟩ := nat.exists_eq_add_of_lt hi,
    rw (_ : _ - _ = j), swap,
    { rw [add_assoc, add_comm], simp_rw nat.add_sub_cancel },
    replace h₁ := list_eq_tail_of_cons_eq h₁,
    rw list.tail_drop at h₁,
    subst h₁,
    rw [←h₂, h, list.nth_drop],
    congr' 1,
    linarith },
end

lemma list_dedup_length_eq_length_iff {α : Type} {l : list α} :
  l.dedup.length = l.length ↔ l.nodup :=
begin
  split; intro h,
  { contrapose! h,
    exact ne_of_lt (list_length_dedup_lt_of_dup h) },
  { rw list.dedup_eq_self.mpr h },
end

lemma mk_list_length {α : Type} {f : ℕ → α} {n : ℕ} :
  (mk_list f n).length = n :=
begin
  induction n with n ih,
  { refl },
  { rw [mk_list, list_length_snoc, ih] },
end

lemma list_nth_snoc_right {α : Type} {l : list α} {x : α} :
  (l ++ [x]).nth l.length = some x :=
by { rw [list.nth_append_right (le_refl _), nat.sub_self], refl }

lemma mk_list_nth {α : Type} {f : ℕ → α} {n i : ℕ}
  (h : i < n) : (mk_list f n).nth i = some (f i) :=
begin
  induction n with n ih generalizing i,
  { cases h },
  { have hn := (@mk_list_length _ f n).symm,
    rw mk_list,
    rw [nat.lt_succ_iff, le_iff_eq_or_lt] at h,
    cases h,
    { subst i,
      nth_rewrite 2 hn,
      rw list_nth_snoc_right },
    { have h₁ := h,
      rw hn at h₁,
      rw list.nth_append h₁,
      exact ih h }},
end

lemma card_mk_finset_eq_iff {α : Type} {f : ℕ → α} {n : ℕ} :
  (mk_finset f n).card = n ↔ ∀ (i j : ℕ), i < j → j < n → f i ≠ f j :=
begin
  rw [mk_finset, list.card_to_finset],
  nth_rewrite 1 ←@mk_list_length _ f n,
  simp_rw [list_dedup_length_eq_length_iff, list_nodup_iff, mk_list_length],
  rw forall_congr, intro i, rw forall_congr, intro j,
  rw forall_congr, intro hi, rw forall_congr, intro hj,
  rw [mk_list_nth (hi.trans hj), mk_list_nth hj, not_iff_not, option.some.inj_eq],
end

lemma card_mk_finset_eq_of_iter_add_ne {α : Type}
  {f : α → α} {x : α} {n : ℕ}
  (h : ∀ (m : ℕ), 0 < m → m ≤ n → (f^[n + m]) x ≠ (f^[n]) x) :
  (mk_finset (λ (i : ℕ), (f^[i]) x) n).card = n :=
begin
  rw card_mk_finset_eq_iff,
  rintro i j hi hj,
  by_contra' h₁,
  let d := j - i,
  have h₁ : ∀ (m : ℕ), (f^[i + d * m]) x = (f^[i]) x,
  { intro m,
    apply iter_add_mul_eq_of_add_eq,
    change d with j - i,
    rw [nat_add_sub (le_of_lt hi), h₁] },
  have hh := le_of_lt (hi.trans hj),
  obtain ⟨k, hn⟩ := nat.exists_eq_add_of_le hh,
  obtain ⟨a, b, ha, hb, rfl⟩ := nat_exi_mul k d,
  have h₃ : (f^[n]) x = (f^[i + b]) x,
  { rw [hn, ←add_assoc, iter_add, h₁, ←iter_add] },
  have h₄ : (f^[n + d]) x = (f^[i + b]) x,
  { rw [hn, (by linarith : i + (d * a + b) + d = i + d * (a + 1) + b),
    iter_add, h₁, ←iter_add] },
  specialize h d,
  rw [h₃, h₄] at h,
  exact h (tsub_pos_of_lt hi) (le_of_lt (nat_sub_lt_of_lt hj)) rfl,
end

lemma exi_iter_add_eq {α : Type} [fintype α]
  {f : α → α} {x : α} {n : ℕ}
  (h : n = fintype.card α) :
  ∃ (m : ℕ), 0 < m ∧ m ≤ n ∧ (f^[n + m]) x = (f^[n]) x :=
begin
  by_contra' h₁,
  have h₂ := card_mk_finset_eq_of_iter_add_ne h₁,
  rw [h, finset.card_eq_iff_eq_univ] at h₂,
  symmetry' at h,
  have h₃ := finset.mem_univ (f^[n] x),
  rw [←h₂, mem_mk_finset, h] at h₃,
  rcases h₃ with ⟨k, h₃, h₄⟩,
  symmetry' at h₄,
  contrapose! h₁, clear h₁,
  use [n - k, tsub_pos_of_lt h₃, nat.sub_le n k],
  rwa [iter_add, h₄, ←iter_add, nat_add_sub (le_of_lt h₃)],
end

lemma exi_iter_eq {α : Type} [fintype α] :
  ∃ (a b : ℕ), a < b ∧ ∀ {f : α → α}, (f^[a]) = (f^[b]) :=
begin
  let n := fintype.card α,
  use [n, n + n.factorial],
  fsplit,
  { exact lt_add_of_pos_right _ (nat.factorial_pos _) },
  { intro f,
    funext x,
    symmetry,
    obtain ⟨m, hm₁, hm₂, h₁⟩ := @exi_iter_add_eq α _ f x n rfl,
    obtain ⟨a, ha⟩ := nat.dvd_factorial hm₁ hm₂,
    rw [ha, iter_add_mul_eq_of_add_eq h₁] },
end

lemma fin_exi_iter_eq {n : ℕ} :
  ∃ (a b : ℕ), a < b ∧ ∀ {f : fin n → fin n}, (f^[a]) = (f^[b]) :=
exi_iter_eq


/-
Copyright (c) 2021 Yury G. Kudryashov. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Yury G. Kudryashov
-/
import measure_theory.group.action
import measure_theory.group.pointwise
import measure_theory.integral.set_integral

/-!
# Fundamental domain of a group action

A set `s` is said to be a *fundamental domain* of an action of a group `G` on a measurable space `α`
with respect to a measure `μ` if

* `s` is a measurable set;

* the sets `g • s` over all `g : G` cover almost all points of the whole space;

* the sets `g • s`, are pairwise a.e. disjoint, i.e., `μ (g₁ • s ∩ g₂ • s) = 0` whenever `g₁ ≠ g₂`;
  we require this for `g₂ = 1` in the definition, then deduce it for any two `g₁ ≠ g₂`.

In this file we prove that in case of a countable group `G` and a measure preserving action, any two
fundamental domains have the same measure, and for a `G`-invariant function, its integrals over any
two fundamental domains are equal to each other.

We also generate additive versions of all theorems in this file using the `to_additive` attribute.
-/

open_locale ennreal pointwise topological_space nnreal ennreal measure_theory
open measure_theory measure_theory.measure set function topological_space

namespace measure_theory

/-- A measurable set `s` is a *fundamental domain* for an additive action of an additive group `G`
on a measurable space `α` with respect to a measure `α` if the sets `g +ᵥ s`, `g : G`, are pairwise
a.e. disjoint and cover the whole space. -/
@[protect_proj] structure is_add_fundamental_domain (G : Type*) {α : Type*} [has_zero G]
  [has_vadd G α] [measurable_space α] (s : set α) (μ : measure α . volume_tac) : Prop :=
(measurable_set : measurable_set s)
(ae_covers : ∀ᵐ x ∂μ, ∃ g : G, g +ᵥ x ∈ s)
(ae_disjoint : ∀ g ≠ (0 : G), μ ((g +ᵥ s) ∩ s) = 0)

/-- A measurable set `s` is a *fundamental domain* for an action of a group `G` on a measurable
space `α` with respect to a measure `α` if the sets `g • s`, `g : G`, are pairwise a.e. disjoint and
cover the whole space. -/
@[protect_proj, to_additive is_add_fundamental_domain]
structure is_fundamental_domain (G : Type*) {α : Type*} [has_one G] [has_scalar G α]
  [measurable_space α] (s : set α) (μ : measure α . volume_tac) : Prop :=
(measurable_set : measurable_set s)
(ae_covers : ∀ᵐ x ∂μ, ∃ g : G, g • x ∈ s)
(ae_disjoint : ∀ g ≠ (1 : G), μ ((g • s) ∩ s) = 0)

namespace is_fundamental_domain

variables {G α E : Type*} [group G] [mul_action G α] [measurable_space α]
  [normed_group E] {s t : set α} {μ : measure α}

@[to_additive] lemma Union_smul_ae_eq (h : is_fundamental_domain G s μ) :
  (⋃ g : G, g • s) =ᵐ[μ] univ :=
filter.eventually_eq_univ.2 $ h.ae_covers.mono $
  λ x ⟨g, hg⟩, mem_Union.2 ⟨g⁻¹, _, hg, inv_smul_smul _ _⟩

@[to_additive] lemma mono (h : is_fundamental_domain G s μ) {ν : measure α} (hle : ν ≪ μ) :
  is_fundamental_domain G s ν :=
⟨h.1, hle h.2, λ g hg, hle (h.3 g hg)⟩

variables [measurable_space G] [has_measurable_smul G α]

@[to_additive]
lemma measurable_set_smul (h : is_fundamental_domain G s μ) (g : G) : measurable_set (g • s) :=
h.measurable_set.const_smul g

variables [smul_invariant_measure G α μ]

@[to_additive] lemma pairwise_ae_disjoint (h : is_fundamental_domain G s μ) :
  pairwise (λ g₁ g₂ : G, μ (g₁ • s ∩ g₂ • s) = 0) :=
λ g₁ g₂ hne,
calc μ (g₁ • s ∩ g₂ • s) = μ (g₂ • ((g₂⁻¹ * g₁) • s ∩ s)) :
  by rw [smul_set_inter, ← mul_smul, mul_inv_cancel_left]
... = μ ((g₂⁻¹ * g₁) • s ∩ s) : measure_smul_set _ _ _
... = 0 : h.ae_disjoint _ $ mt inv_mul_eq_one.1 hne.symm

variables [encodable G] {ν : measure α}

@[to_additive] lemma sum_restrict_of_ac (h : is_fundamental_domain G s μ) (hν : ν ≪ μ) :
  sum (λ g : G, ν.restrict (g • s)) = ν :=
by rw [← restrict_Union_ae (h.pairwise_ae_disjoint.mono $ λ i j h, hν h) h.measurable_set_smul,
  restrict_congr_set (hν h.Union_smul_ae_eq), restrict_univ]

@[to_additive] lemma lintegral_eq_tsum_of_ac (h : is_fundamental_domain G s μ) (hν : ν ≪ μ)
  (f : α → ℝ≥0∞) : ∫⁻ x, f x ∂ν = ∑' g : G, ∫⁻ x in g • s, f x ∂ν :=
by rw [← lintegral_sum_measure, h.sum_restrict_of_ac hν]

@[to_additive] lemma set_lintegral_eq_tsum' (h : is_fundamental_domain G s μ) (f : α → ℝ≥0∞)
  (t : set α) : ∫⁻ x in t, f x ∂μ = ∑' g : G, ∫⁻ x in t ∩ g • s, f x ∂μ :=
calc ∫⁻ x in t, f x ∂μ = ∑' g : G, ∫⁻ x in g • s, f x ∂(μ.restrict t) :
  h.lintegral_eq_tsum_of_ac restrict_le_self.absolutely_continuous _
... = ∑' g : G, ∫⁻ x in t ∩ g • s, f x ∂μ :
  by simp only [restrict_restrict, h.measurable_set_smul, inter_comm]

@[to_additive] lemma set_lintegral_eq_tsum (h : is_fundamental_domain G s μ) (f : α → ℝ≥0∞)
  (t : set α) :
  ∫⁻ x in t, f x ∂μ = ∑' g : G, ∫⁻ x in g • t ∩ s, f (g⁻¹ • x) ∂μ :=
calc ∫⁻ x in t, f x ∂μ = ∑' g : G, ∫⁻ x in t ∩ g • s, f x ∂μ :
  h.set_lintegral_eq_tsum' f t
... = ∑' g : G, ∫⁻ x in t ∩ g⁻¹ • s, f x ∂μ : ((equiv.inv G).tsum_eq _).symm
... = ∑' g : G, ∫⁻ x in g⁻¹ • (g • t ∩ s), f (x) ∂μ :
  by simp only [smul_set_inter, inv_smul_smul]
... = ∑' g : G, ∫⁻ x in g • t ∩ s, f (g⁻¹ • x) ∂μ :
  tsum_congr $ λ g, ((measure_preserving_smul g⁻¹ μ).set_lintegral_comp_emb
    (measurable_embedding_const_smul _) _ _).symm

@[to_additive] lemma measure_eq_tsum_of_ac (h : is_fundamental_domain G s μ) (hν : ν ≪ μ)
  (t : set α) :
  ν t = ∑' g : G, ν (t ∩ g • s) :=
by simpa only [set_lintegral_one, pi.one_def, measure.restrict_apply (h.measurable_set_smul _),
  inter_comm]
  using h.lintegral_eq_tsum_of_ac (measure.restrict_le_self.absolutely_continuous.trans hν) 1

@[to_additive] lemma measure_eq_tsum' (h : is_fundamental_domain G s μ) (t : set α) :
  μ t = ∑' g : G, μ (t ∩ g • s) :=
h.measure_eq_tsum_of_ac absolutely_continuous.rfl t

@[to_additive] lemma measure_eq_tsum (h : is_fundamental_domain G s μ) (t : set α) :
  μ t = ∑' g : G, μ (g • t ∩ s) :=
by simpa only [set_lintegral_one] using h.set_lintegral_eq_tsum (λ _, 1) t

@[to_additive] protected lemma set_lintegral_eq (hs : is_fundamental_domain G s μ)
  (ht : is_fundamental_domain G t μ) (f : α → ℝ≥0∞) (hf : ∀ (g : G) x, f (g • x) = f x) :
  ∫⁻ x in s, f x ∂μ = ∫⁻ x in t, f x ∂μ :=
calc ∫⁻ x in s, f x ∂μ = ∑' g : G, ∫⁻ x in s ∩ g • t, f x ∂μ :
  ht.set_lintegral_eq_tsum' _ _
... = ∑' g : G, ∫⁻ x in g • t ∩ s, f (g⁻¹ • x) ∂μ :
  by simp only [hf, inter_comm]
... = ∫⁻ x in t, f x ∂μ :
  (hs.set_lintegral_eq_tsum _ _).symm

/-- If `s` and `t` are two fundamental domains of the same action, then their measures are equal. -/
@[to_additive] protected lemma measure_eq (hs : is_fundamental_domain G s μ)
  (ht : is_fundamental_domain G t μ) : μ s = μ t :=
by simpa only [set_lintegral_one] using hs.set_lintegral_eq ht (λ _, 1) (λ _ _, rfl)

@[to_additive] protected lemma ae_measurable_on_iff {β : Type*} [measurable_space β]
  (hs : is_fundamental_domain G s μ) (ht : is_fundamental_domain G t μ) {f : α → β}
  (hf : ∀ (g : G) x, f (g • x) = f x) :
  ae_measurable f (μ.restrict s) ↔ ae_measurable f (μ.restrict t) :=
calc ae_measurable f (μ.restrict s)
    ↔ ae_measurable f (measure.sum $ λ g : G, (μ.restrict (g • t ∩ s))) :
  by simp only [← restrict_restrict (ht.measurable_set_smul _),
    ht.sum_restrict_of_ac restrict_le_self.absolutely_continuous]
... ↔ ∀ g : G, ae_measurable f (μ.restrict (g • (g⁻¹ • s ∩ t))) :
  by simp only [smul_set_inter, inter_comm, smul_inv_smul, ae_measurable_sum_measure_iff]
... ↔ ∀ g : G, ae_measurable f (μ.restrict (g⁻¹ • (g⁻¹⁻¹ • s ∩ t))) : inv_surjective.forall
... ↔ ∀ g : G, ae_measurable f (μ.restrict (g⁻¹ • (g • s ∩ t))) : by simp only [inv_inv]
... ↔ ∀ g : G, ae_measurable f (μ.restrict (g • s ∩ t)) :
  begin
    refine forall_congr (λ g, _),
    have he : measurable_embedding ((•) g⁻¹ : α → α) := measurable_embedding_const_smul _,
    rw [← image_smul,
      ← ((measure_preserving_smul g⁻¹ μ).restrict_image_emb he _).ae_measurable_comp_iff he],
    simp only [(∘), hf]
  end
... ↔ ae_measurable f (μ.restrict t) :
  by simp only [← ae_measurable_sum_measure_iff, ← restrict_restrict (hs.measurable_set_smul _),
    hs.sum_restrict_of_ac restrict_le_self.absolutely_continuous]

@[to_additive] protected lemma has_finite_integral_on_iff (hs : is_fundamental_domain G s μ)
  (ht : is_fundamental_domain G t μ) {f : α → E} (hf : ∀ (g : G) x, f (g • x) = f x) :
  has_finite_integral f (μ.restrict s) ↔ has_finite_integral f (μ.restrict t) :=
begin
  dunfold has_finite_integral,
  rw hs.set_lintegral_eq ht,
  intros g x, rw hf
end

variables [measurable_space E]

@[to_additive] protected lemma integrable_on_iff (hs : is_fundamental_domain G s μ)
  (ht : is_fundamental_domain G t μ) {f : α → E} (hf : ∀ (g : G) x, f (g • x) = f x) :
  integrable_on f s μ ↔ integrable_on f t μ :=
and_congr (hs.ae_measurable_on_iff ht hf) (hs.has_finite_integral_on_iff ht hf)

variables [normed_space ℝ E] [borel_space E] [complete_space E] [second_countable_topology E]

@[to_additive] protected lemma set_integral_eq (hs : is_fundamental_domain G s μ)
  (ht : is_fundamental_domain G t μ) {f : α → E} (hf : ∀ (g : G) x, f (g • x) = f x) :
  ∫ x in s, f x ∂μ = ∫ x in t, f x ∂μ :=
begin
  by_cases hfs : integrable_on f s μ,
  { have hft : integrable_on f t μ, by rwa ht.integrable_on_iff hs hf,
    have hac : ∀ {u}, μ.restrict u ≪ μ := λ u, restrict_le_self.absolutely_continuous,
    calc ∫ x in s, f x ∂μ = ∫ x in ⋃ g : G, g • t, f x ∂(μ.restrict s) :
      by rw [restrict_congr_set (hac ht.Union_smul_ae_eq), restrict_univ]
    ... = ∑' g : G, ∫ x in g • t, f x ∂(μ.restrict s) :
      integral_Union_of_null_inter ht.measurable_set_smul
        (ht.pairwise_ae_disjoint.mono $ λ i j h, hac h) hfs.integrable.integrable_on
    ... = ∑' g : G, ∫ x in s ∩ g • t, f x ∂μ :
      by simp only [restrict_restrict (ht.measurable_set_smul _), inter_comm]
    ... = ∑' g : G, ∫ x in s ∩ g⁻¹ • t, f x ∂μ : ((equiv.inv G).tsum_eq _).symm
    ... = ∑' g : G, ∫ x in g⁻¹ • (g • s ∩ t), f x ∂μ :
      by simp only [smul_set_inter, inv_smul_smul]
    ... = ∑' g : G, ∫ x in g • s ∩ t, f (g⁻¹ • x) ∂μ :
      tsum_congr $ λ g, (measure_preserving_smul g⁻¹ μ).set_integral_image_emb
        (measurable_embedding_const_smul _) _ _
    ... = ∑' g : G, ∫ x in g • s, f x ∂(μ.restrict t) :
      by simp only [hf, restrict_restrict (hs.measurable_set_smul _)]
    ... = ∫ x in ⋃ g : G, g • s, f x ∂(μ.restrict t) :
      (integral_Union_of_null_inter hs.measurable_set_smul
        (hs.pairwise_ae_disjoint.mono $ λ i j h, hac h) hft.integrable.integrable_on).symm
    ... = ∫ x in t, f x ∂μ :
      by rw [restrict_congr_set (hac hs.Union_smul_ae_eq), restrict_univ] },
  { rw [integral_undef hfs, integral_undef],
    rwa [hs.integrable_on_iff ht hf] at hfs }
end

end is_fundamental_domain

end measure_theory


/-
Copyright (c) 2018 Mario Carneiro. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Mario Carneiro
-/
import data.list.count
import data.list.lex
import data.list.sublists
import data.set.pairwise

/-!
# Pairwise relations on a list

This file provides basic results about `list.pairwise` and `list.pw_filter` (definitions are in
`data.list.defs`).
`pairwise r [a 0, ..., a (n - 1)]` means `∀ i j, i < j → r (a i) (a j)`. For example,
`pairwise (≠) l` means that all elements of `l` are distinct, and `pairwise (<) l` means that `l`
is strictly increasing.
`pw_filter r l` is the list obtained by iteratively adding each element of `l` that doesn't break
the pairwiseness of the list we have so far. It thus yields `l'` a maximal sublist of `l` such that
`pairwise r l'`.

## Tags

sorted, nodup
-/

open nat function

namespace list
variables {α β : Type*} {R S T: α → α → Prop} {a : α} {l : list α}

mk_iff_of_inductive_prop list.pairwise list.pairwise_iff

/-! ### Pairwise -/

lemma rel_of_pairwise_cons (p : (a :: l).pairwise R) : ∀ {a'}, a' ∈ l → R a a' :=
(pairwise_cons.1 p).1

lemma pairwise.of_cons (p : (a :: l).pairwise R) : pairwise R l := (pairwise_cons.1 p).2

theorem pairwise.tail : ∀ {l : list α} (p : pairwise R l), pairwise R l.tail
| [] h := h
| (a :: l) h := h.of_cons

theorem pairwise.drop : ∀ {l : list α} {n : ℕ}, list.pairwise R l → list.pairwise R (l.drop n)
| _ 0 h := h
| [] (n + 1) h := list.pairwise.nil
| (a :: l) (n + 1) h := pairwise.drop (pairwise_cons.mp h).right

theorem pairwise.imp_of_mem {S : α → α → Prop} {l : list α}
  (H : ∀ {a b}, a ∈ l → b ∈ l → R a b → S a b) (p : pairwise R l) : pairwise S l :=
begin
  induction p with a l r p IH generalizing H; constructor,
  { exact ball.imp_right
      (λ x h, H (mem_cons_self _ _) (mem_cons_of_mem _ h)) r },
  { exact IH (λ a b m m', H
      (mem_cons_of_mem _ m) (mem_cons_of_mem _ m')) }
end

lemma pairwise.imp (H : ∀ a b, R a b → S a b) : pairwise R l → pairwise S l :=
pairwise.imp_of_mem (λ a b _ _, H a b)

lemma pairwise_and_iff : l.pairwise (λ a b, R a b ∧ S a b) ↔ l.pairwise R ∧ l.pairwise S :=
⟨λ h, ⟨h.imp (λ a b h, h.1), h.imp (λ a b h, h.2)⟩,
 λ ⟨hR, hS⟩, begin
  clear_, induction hR with a l R1 R2 IH;
  simp only [pairwise.nil, pairwise_cons] at *,
  exact ⟨λ b bl, ⟨R1 b bl, hS.1 b bl⟩, IH hS.2⟩
 end⟩

lemma pairwise.and (hR : l.pairwise R) (hS : l.pairwise S) : l.pairwise (λ a b, R a b ∧ S a b) :=
pairwise_and_iff.2 ⟨hR, hS⟩

lemma pairwise.imp₂ (H : ∀ a b, R a b → S a b → T a b) (hR : l.pairwise R) (hS : l.pairwise S) :
  l.pairwise T :=
(hR.and hS).imp $ λ a b, and.rec (H a b)

theorem pairwise.iff_of_mem {S : α → α → Prop} {l : list α}
  (H : ∀ {a b}, a ∈ l → b ∈ l → (R a b ↔ S a b)) : pairwise R l ↔ pairwise S l :=
⟨pairwise.imp_of_mem (λ a b m m', (H m m').1),
 pairwise.imp_of_mem (λ a b m m', (H m m').2)⟩

theorem pairwise.iff {S : α → α → Prop}
  (H : ∀ a b, R a b ↔ S a b) {l : list α} : pairwise R l ↔ pairwise S l :=
pairwise.iff_of_mem (λ a b _ _, H a b)

theorem pairwise_of_forall {l : list α} (H : ∀ x y, R x y) : pairwise R l :=
by induction l; [exact pairwise.nil,
simp only [*, pairwise_cons, forall_2_true_iff, and_true]]

theorem pairwise.and_mem {l : list α} :
  pairwise R l ↔ pairwise (λ x y, x ∈ l ∧ y ∈ l ∧ R x y) l :=
pairwise.iff_of_mem (by simp only [true_and, iff_self, forall_2_true_iff] {contextual := tt})

theorem pairwise.imp_mem {l : list α} :
  pairwise R l ↔ pairwise (λ x y, x ∈ l → y ∈ l → R x y) l :=
pairwise.iff_of_mem
  (by simp only [forall_prop_of_true, iff_self, forall_2_true_iff] {contextual := tt})

protected lemma pairwise.sublist : Π {l₁ l₂ : list α}, l₁ <+ l₂ → pairwise R l₂ → pairwise R l₁
| ._ ._ sublist.slnil h := h
| ._ ._ (sublist.cons l₁ l₂ a s) (pairwise.cons i h) := h.sublist s
| ._ ._ (sublist.cons2 l₁ l₂ a s) (pairwise.cons i h) :=
  (h.sublist s).cons (ball.imp_left s.subset i)

lemma pairwise.forall_of_forall (H : symmetric R) (H₁ : ∀ x ∈ l, R x x) (H₂ : l.pairwise R) :
  ∀ ⦃x⦄, x ∈ l → ∀ ⦃y⦄, y ∈ l → R x y :=
begin
  induction l with a l IH, { exact forall_mem_nil _ },
  cases forall_mem_cons.1 H₁ with H₁₁ H₁₂,
  cases pairwise_cons.1 H₂ with H₂₁ H₂₂,
  rintro x (rfl | hx) y (rfl | hy),
  exacts [H₁₁, H₂₁ _ hy, H (H₂₁ _ hx), IH H₁₂ H₂₂ hx hy]
end

lemma pairwise.forall (hR : symmetric R) (hl : l.pairwise R) :
  ∀ ⦃a⦄, a ∈ l → ∀ ⦃b⦄, b ∈ l → a ≠ b → R a b :=
pairwise.forall_of_forall
  (λ a b h hne, hR (h hne.symm))
  (λ _ _ h, (h rfl).elim)
  (hl.imp $ λ _ _ h _, h)

lemma pairwise.set_pairwise (hl : pairwise R l) (hr : symmetric R) : {x | x ∈ l}.pairwise R :=
hl.forall hr

theorem pairwise_singleton (R) (a : α) : pairwise R [a] :=
by simp only [pairwise_cons, mem_singleton, forall_prop_of_false (not_mem_nil _), forall_true_iff,
  pairwise.nil, and_true]

theorem pairwise_pair {a b : α} : pairwise R [a, b] ↔ R a b :=
by simp only [pairwise_cons, mem_singleton, forall_eq, forall_prop_of_false (not_mem_nil _),
  forall_true_iff, pairwise.nil, and_true]

theorem pairwise_append {l₁ l₂ : list α} : pairwise R (l₁++l₂) ↔
  pairwise R l₁ ∧ pairwise R l₂ ∧ ∀ x ∈ l₁, ∀ y ∈ l₂, R x y :=
by induction l₁ with x l₁ IH; [simp only [list.pairwise.nil, forall_prop_of_false (not_mem_nil _),
  forall_true_iff, and_true, true_and, nil_append],
simp only [cons_append, pairwise_cons, forall_mem_append, IH, forall_mem_cons, forall_and_distrib,
  and_assoc, and.left_comm]]

theorem pairwise_append_comm (s : symmetric R) {l₁ l₂ : list α} :
  pairwise R (l₁++l₂) ↔ pairwise R (l₂++l₁) :=
have ∀ l₁ l₂ : list α,
  (∀ (x : α), x ∈ l₁ → ∀ (y : α), y ∈ l₂ → R x y) →
  (∀ (x : α), x ∈ l₂ → ∀ (y : α), y ∈ l₁ → R x y),
from λ l₁ l₂ a x xm y ym, s (a y ym x xm),
by simp only [pairwise_append, and.left_comm]; rw iff.intro (this l₁ l₂) (this l₂ l₁)

theorem pairwise_middle (s : symmetric R) {a : α} {l₁ l₂ : list α} :
  pairwise R (l₁ ++ a :: l₂) ↔ pairwise R (a :: (l₁++l₂)) :=
show pairwise R (l₁ ++ ([a] ++ l₂)) ↔ pairwise R ([a] ++ l₁ ++ l₂),
by rw [← append_assoc, pairwise_append, @pairwise_append _ _ ([a] ++ l₁), pairwise_append_comm s];
   simp only [mem_append, or_comm]

theorem pairwise_map (f : β → α) :
  ∀ {l : list β}, pairwise R (map f l) ↔ pairwise (λ a b : β, R (f a) (f b)) l
| []     := by simp only [map, pairwise.nil]
| (b :: l) :=
  have (∀ a b', b' ∈ l → f b' = a → R (f b) a) ↔ ∀ (b' : β), b' ∈ l → R (f b) (f b'), from
  forall_swap.trans $ forall_congr $ λ a, forall_swap.trans $ by simp only [forall_eq'],
  by simp only [map, pairwise_cons, mem_map, exists_imp_distrib, and_imp, this, pairwise_map]

lemma pairwise.of_map {S : β → β → Prop} (f : α → β) (H : ∀ a b : α, S (f a) (f b) → R a b)
  (p : pairwise S (map f l)) : pairwise R l :=
((pairwise_map f).1 p).imp H

lemma pairwise.map {S : β → β → Prop} (f : α → β) (H : ∀ a b : α, R a b → S (f a) (f b))
  (p : pairwise R l) : pairwise S (map f l) :=
(pairwise_map f).2 $ p.imp H

theorem pairwise_filter_map (f : β → option α) {l : list β} :
  pairwise R (filter_map f l) ↔ pairwise (λ a a' : β, ∀ (b ∈ f a) (b' ∈ f a'), R b b') l :=
let S (a a' : β) := ∀ (b ∈ f a) (b' ∈ f a'), R b b' in
begin
  simp only [option.mem_def], induction l with a l IH,
  { simp only [filter_map, pairwise.nil] },
  cases e : f a with b,
  { rw [filter_map_cons_none _ _ e, IH, pairwise_cons],
    simp only [e, forall_prop_of_false not_false, forall_3_true_iff, true_and] },
  rw [filter_map_cons_some _ _ _ e],
  simp only [pairwise_cons, mem_filter_map, exists_imp_distrib, and_imp, IH, e, forall_eq'],
  show (∀ (a' : α) (x : β), x ∈ l → f x = some a' → R b a') ∧ pairwise S l ↔
        (∀ (a' : β), a' ∈ l → ∀ (b' : α), f a' = some b' → R b b') ∧ pairwise S l,
  from and_congr ⟨λ h b mb a ma, h a b mb ma, λ h a b mb ma, h b mb a ma⟩ iff.rfl
end

theorem pairwise.filter_map {S : β → β → Prop} (f : α → option β)
  (H : ∀ (a a' : α), R a a' → ∀ (b ∈ f a) (b' ∈ f a'), S b b') {l : list α}
  (p : pairwise R l) : pairwise S (filter_map f l) :=
(pairwise_filter_map _).2 $ p.imp H

theorem pairwise_filter (p : α → Prop) [decidable_pred p] {l : list α} :
  pairwise R (filter p l) ↔ pairwise (λ x y, p x → p y → R x y) l :=
begin
  rw [← filter_map_eq_filter, pairwise_filter_map],
  apply pairwise.iff, intros, simp only [option.mem_def, option.guard_eq_some, and_imp, forall_eq'],
end

lemma pairwise.filter (p : α → Prop) [decidable_pred p] : pairwise R l → pairwise R (filter p l) :=
pairwise.sublist (filter_sublist _)

theorem pairwise_pmap {p : β → Prop} {f : Π b, p b → α} {l : list β} (h : ∀ x ∈ l, p x) :
  pairwise R (l.pmap f h) ↔
    pairwise (λ b₁ b₂, ∀ (h₁ : p b₁) (h₂ : p b₂), R (f b₁ h₁) (f b₂ h₂)) l :=
begin
  induction l with a l ihl, { simp },
  obtain ⟨ha, hl⟩ : p a ∧ ∀ b, b ∈ l → p b, by simpa using h,
  simp only [ihl hl, pairwise_cons, bex_imp_distrib, pmap, and.congr_left_iff, mem_pmap],
  refine λ _, ⟨λ H b hb hpa hpb, H _ _ hb rfl, _⟩,
  rintro H _ b hb rfl,
  exact H b hb _ _
end

theorem pairwise_join {L : list (list α)} : pairwise R (join L) ↔
  (∀ l ∈ L, pairwise R l) ∧ pairwise (λ l₁ l₂, ∀ (x ∈ l₁) (y ∈ l₂), R x y) L :=
begin
  induction L with l L IH,
  {simp only [join, pairwise.nil, forall_prop_of_false (not_mem_nil _), forall_const, and_self]},
  have : (∀ (x : α), x ∈ l → ∀ (y : α) (x_1 : list α), x_1 ∈ L → y ∈ x_1 → R x y) ↔
          ∀ (a' : list α), a' ∈ L → ∀ (x : α), x ∈ l → ∀ (y : α), y ∈ a' → R x y :=
    ⟨λ h a b c d e, h c d e a b, λ h c d e a b, h a b c d e⟩,
  simp only [join, pairwise_append, IH, mem_join, exists_imp_distrib, and_imp, this,
    forall_mem_cons, pairwise_cons],
  simp only [and_assoc, and_comm, and.left_comm],
end

lemma pairwise_bind {R : β → β → Prop} {l : list α} {f : α → list β} :
  list.pairwise R (l.bind f) ↔
    (∀ a ∈ l, pairwise R (f a)) ∧ pairwise (λ a₁ a₂, ∀ (x ∈ f a₁) (y ∈ f a₂), R x y) l :=
by simp [list.bind, list.pairwise_join, list.mem_map, list.pairwise_map]

@[simp] theorem pairwise_reverse : ∀ {R} {l : list α},
  pairwise R (reverse l) ↔ pairwise (λ x y, R y x) l :=
suffices ∀ {R l}, @pairwise α R l → pairwise (λ x y, R y x) (reverse l),
from λ R l, ⟨λ p, reverse_reverse l ▸ this p, this⟩,
λ R l p, by induction p with a l h p IH;
  [apply pairwise.nil, simpa only [reverse_cons, pairwise_append, IH,
    pairwise_cons, forall_prop_of_false (not_mem_nil _), forall_true_iff,
    pairwise.nil, mem_reverse, mem_singleton, forall_eq, true_and] using h]

lemma pairwise_of_reflexive_on_dupl_of_forall_ne [decidable_eq α] {l : list α} {r : α → α → Prop}
  (hr : ∀ a, 1 < count a l → r a a)
  (h : ∀ (a ∈ l) (b ∈ l), a ≠ b → r a b) : l.pairwise r :=
begin
  induction l with hd tl IH,
  { simp },
  { rw list.pairwise_cons,
    split,
    { intros x hx,
      by_cases H : hd = x,
      { rw H,
        refine hr _ _,
        simpa [count_cons, H, nat.succ_lt_succ_iff, count_pos] using hx },
      { exact h hd (mem_cons_self _ _) x (mem_cons_of_mem _ hx) H } },
    { refine IH _ _,
      { intros x hx,
        refine hr _ _,
        rw count_cons,
        split_ifs,
        { exact hx.trans (nat.lt_succ_self _) },
        { exact hx } },
      { intros x hx y hy,
        exact h x (mem_cons_of_mem _ hx) y (mem_cons_of_mem _ hy) } } }
end

lemma pairwise_of_forall_mem_list {l : list α} {r : α → α → Prop} (h : ∀ (a ∈ l) (b ∈ l), r a b) :
  l.pairwise r :=
begin
  classical,
  refine pairwise_of_reflexive_on_dupl_of_forall_ne (λ a ha', _) (λ a ha b hb _, h a ha b hb),
  have ha := list.one_le_count_iff_mem.1 ha'.le,
  exact h a ha a ha
end

lemma pairwise_of_reflexive_of_forall_ne {l : list α} {r : α → α → Prop}
  (hr : reflexive r) (h : ∀ (a ∈ l) (b ∈ l), a ≠ b → r a b) : l.pairwise r :=
by { classical, exact pairwise_of_reflexive_on_dupl_of_forall_ne (λ _ _, hr _) h }

theorem pairwise_iff_nth_le {R} : ∀ {l : list α},
  pairwise R l ↔ ∀ i j (h₁ : j < length l) (h₂ : i < j),
    R (nth_le l i (lt_trans h₂ h₁)) (nth_le l j h₁)
| [] := by simp only [pairwise.nil, true_iff]; exact λ i j h, (nat.not_lt_zero j).elim h
| (a :: l) := begin
  rw [pairwise_cons, pairwise_iff_nth_le],
  refine ⟨λ H i j h₁ h₂, _, λ H, ⟨λ a' m, _,
    λ i j h₁ h₂, H _ _ (succ_lt_succ h₁) (succ_lt_succ h₂)⟩⟩,
  { cases j with j, {exact (nat.not_lt_zero _).elim h₂},
    cases i with i,
    { exact H.1 _ (nth_le_mem l _ _) },
    { exact H.2 _ _ (lt_of_succ_lt_succ h₁) (lt_of_succ_lt_succ h₂) } },
  { rcases nth_le_of_mem m with ⟨n, h, rfl⟩,
    exact H _ _ (succ_lt_succ h) (succ_pos _) }
end

theorem pairwise.sublists' {R} : ∀ {l : list α}, pairwise R l →
  pairwise (lex (swap R)) (sublists' l)
| _ pairwise.nil := pairwise_singleton _ _
| _ (@pairwise.cons _ _ a l H₁ H₂) :=
  begin
    simp only [sublists'_cons, pairwise_append, pairwise_map, mem_sublists', mem_map,
      exists_imp_distrib, and_imp],
    refine ⟨H₂.sublists', H₂.sublists'.imp (λ l₁ l₂, lex.cons), _⟩,
    intros l₁ sl₁ x l₂ sl₂ e, subst e,
    cases l₁ with b l₁, {constructor},
    exact lex.rel (H₁ _ $ sl₁.subset $ mem_cons_self _ _)
  end

theorem pairwise_sublists {R} {l : list α} (H : pairwise R l) :
  pairwise (λ l₁ l₂, lex R (reverse l₁) (reverse l₂)) (sublists l) :=
by { have := (pairwise_reverse.2 H).sublists', rwa [sublists'_reverse, pairwise_map] at this }

lemma pairwise_repeat {α : Type*} {r : α → α → Prop} {x : α} (hx : r x x) :
  ∀ (n : ℕ), pairwise r (repeat x n)
| 0 := by simp
| (n+1) := by simp [hx, mem_repeat, pairwise_repeat n]

/-! ### Pairwise filtering -/

variable [decidable_rel R]

@[simp] theorem pw_filter_nil : pw_filter R [] = [] := rfl

@[simp] theorem pw_filter_cons_of_pos {a : α} {l : list α} (h : ∀ b ∈ pw_filter R l, R a b) :
  pw_filter R (a :: l) = a :: pw_filter R l := if_pos h

@[simp] theorem pw_filter_cons_of_neg {a : α} {l : list α} (h : ¬ ∀ b ∈ pw_filter R l, R a b) :
  pw_filter R (a :: l) = pw_filter R l := if_neg h

theorem pw_filter_map (f : β → α) :
  Π (l : list β), pw_filter R (map f l) = map f (pw_filter (λ x y, R (f x) (f y)) l)
| [] := rfl
| (x :: xs) :=
  if h : ∀ b ∈ pw_filter R (map f xs), R (f x) b
    then have h' : ∀ (b : β), b ∈ pw_filter (λ (x y : β), R (f x) (f y)) xs → R (f x) (f b),
           from λ b hb, h _ (by rw [pw_filter_map]; apply mem_map_of_mem _ hb),
         by rw [map,pw_filter_cons_of_pos h,pw_filter_cons_of_pos h',pw_filter_map,map]
    else have h' : ¬∀ (b : β), b ∈ pw_filter (λ (x y : β), R (f x) (f y)) xs → R (f x) (f b),
           from λ hh, h $ λ a ha,
           by { rw [pw_filter_map,mem_map] at ha, rcases ha with ⟨b,hb₀,hb₁⟩,
                subst a, exact hh _ hb₀, },
         by rw [map,pw_filter_cons_of_neg h,pw_filter_cons_of_neg h',pw_filter_map]

theorem pw_filter_sublist : ∀ (l : list α), pw_filter R l <+ l
| []     := nil_sublist _
| (x :: l) := begin
  by_cases (∀ y ∈ pw_filter R l, R x y),
  { rw [pw_filter_cons_of_pos h],
    exact (pw_filter_sublist l).cons_cons _ },
  { rw [pw_filter_cons_of_neg h],
    exact sublist_cons_of_sublist _ (pw_filter_sublist l) },
end

theorem pw_filter_subset (l : list α) : pw_filter R l ⊆ l :=
(pw_filter_sublist _).subset

theorem pairwise_pw_filter : ∀ (l : list α), pairwise R (pw_filter R l)
| []     := pairwise.nil
| (x :: l) := begin
  by_cases (∀ y ∈ pw_filter R l, R x y),
  { rw [pw_filter_cons_of_pos h],
    exact pairwise_cons.2 ⟨h, pairwise_pw_filter l⟩ },
  { rw [pw_filter_cons_of_neg h],
    exact pairwise_pw_filter l },
end

theorem pw_filter_eq_self {l : list α} : pw_filter R l = l ↔ pairwise R l :=
⟨λ e, e ▸ pairwise_pw_filter l, λ p, begin
  induction l with x l IH, {refl},
  cases pairwise_cons.1 p with al p,
  rw [pw_filter_cons_of_pos (ball.imp_left (pw_filter_subset l) al), IH p],
end⟩

alias pw_filter_eq_self ↔ _ list.pairwise.pw_filter

attribute [protected] pairwise.pw_filter

@[simp] lemma pw_filter_idempotent : pw_filter R (pw_filter R l) = pw_filter R l :=
(pairwise_pw_filter l).pw_filter

theorem forall_mem_pw_filter (neg_trans : ∀ {x y z}, R x z → R x y ∨ R y z)
  (a : α) (l : list α) : (∀ b ∈ pw_filter R l, R a b) ↔ (∀ b ∈ l, R a b) :=
⟨begin
  induction l with x l IH, { exact λ _ _, false.elim },
  simp only [forall_mem_cons],
  by_cases (∀ y ∈ pw_filter R l, R x y); dsimp at h,
  { simp only [pw_filter_cons_of_pos h, forall_mem_cons, and_imp],
    exact λ r H, ⟨r, IH H⟩ },
  { rw [pw_filter_cons_of_neg h],
    refine λ H, ⟨_, IH H⟩,
    cases e : find (λ y, ¬ R x y) (pw_filter R l) with k,
    { refine h.elim (ball.imp_right _ (find_eq_none.1 e)),
      exact λ y _, not_not.1 },
    { have := find_some e,
      exact (neg_trans (H k (find_mem e))).resolve_right this } }
end, ball.imp_left (pw_filter_subset l)⟩

end list