/-
Copyright (c) 2022 Sébastien Gouëzel. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Sébastien Gouëzel
-/
import probability.variance
import measure_theory.function.uniform_integrable

/-!
# Identically distributed random variables

Two random variables defined on two (possibly different) probability spaces but taking value in
the same space are *identically distributed* if their distributions (i.e., the image probability
measures on the target space) coincide. We define this concept and establish its basic properties
in this file.

## Main definitions and results

* `ident_distrib f g μ ν` registers that the image of `μ` under `f` coincides with the image of `ν`
  under `g` (and that `f` and `g` are almost everywhere measurable, as otherwise the image measures
  don't make sense). The measures can be kept implicit as in `ident_distrib f g` if the spaces
  are registered as measure spaces.
* `ident_distrib.comp`: being identically distributed is stable under composition with measurable
  maps.

There are two main kind of lemmas, under the assumption that `f` and `g` are identically
distributed: lemmas saying that two quantities computed for `f` and `g` are the same, and lemmas
saying that if `f` has some property then `g` also has it. The first kind is registered as
`ident_distrib.foo_eq`, the second one as `ident_distrib.foo_snd` (in the latter case, to deduce
a property of `f` from one of `g`, use `h.symm.foo_snd` where `h : ident_distrib f g μ ν`). For
instance:

* `ident_distrib.measure_mem_eq`: if `f` and `g` are identically distributed, then the probabilities
  that they belong to a given measurable set are the same.
* `ident_distrib.integral_eq`: if `f` and `g` are identically distributed, then their integrals
  are the same.
* `ident_distrib.variance_eq`: if `f` and `g` are identically distributed, then their variances
  are the same.

* `ident_distrib.ae_strongly_measurable_snd`: if `f` and `g` are identically distributed and `f`
  is almost everywhere strongly measurable, then so is `g`.
* `ident_distrib.mem_ℒp_snd`: if `f` and `g` are identically distributed and `f`
  belongs to `ℒp`, then so does `g`.

We also register several dot notation shortcuts for convenience.
For instance, if `h : ident_distrib f g μ ν`, then `h.sq` states that `f^2` and `g^2` are
identically distributed, and `h.norm` states that `‖f‖` and `‖g‖` are identically distributed, and
so on.
-/

open measure_theory filter finset

noncomputable theory

open_locale topology big_operators measure_theory ennreal nnreal

variables {α β γ δ : Type*} [measurable_space α] [measurable_space β]
  [measurable_space γ] [measurable_space δ]

namespace probability_theory

/-- Two functions defined on two (possibly different) measure spaces are identically distributed if
their image measures coincide. This only makes sense when the functions are ae measurable
(as otherwise the image measures are not defined), so we require this as well in the definition. -/
structure ident_distrib
  (f : α → γ) (g : β → γ) (μ : measure α . volume_tac) (ν : measure β . volume_tac) : Prop :=
(ae_measurable_fst : ae_measurable f μ)
(ae_measurable_snd : ae_measurable g ν)
(map_eq : measure.map f μ = measure.map g ν)

namespace ident_distrib

open topological_space

variables {μ : measure α} {ν : measure β} {f : α → γ} {g : β → γ}

protected lemma refl (hf : ae_measurable f μ) :
  ident_distrib f f μ μ :=
{ ae_measurable_fst := hf,
  ae_measurable_snd := hf,
  map_eq := rfl }

protected lemma symm (h : ident_distrib f g μ ν) : ident_distrib g f ν μ :=
{ ae_measurable_fst := h.ae_measurable_snd,
  ae_measurable_snd := h.ae_measurable_fst,
  map_eq := h.map_eq.symm }

protected lemma trans {ρ : measure δ} {h : δ → γ}
  (h₁ : ident_distrib f g μ ν) (h₂ : ident_distrib g h ν ρ) : ident_distrib f h μ ρ :=
{ ae_measurable_fst := h₁.ae_measurable_fst,
  ae_measurable_snd := h₂.ae_measurable_snd,
  map_eq := h₁.map_eq.trans h₂.map_eq }

protected lemma comp_of_ae_measurable {u : γ → δ} (h : ident_distrib f g μ ν)
  (hu : ae_measurable u (measure.map f μ)) :
  ident_distrib (u ∘ f) (u ∘ g) μ ν :=
{ ae_measurable_fst := hu.comp_ae_measurable h.ae_measurable_fst,
  ae_measurable_snd :=
    by { rw h.map_eq at hu, exact hu.comp_ae_measurable h.ae_measurable_snd },
  map_eq :=
  begin
    rw [← ae_measurable.map_map_of_ae_measurable hu h.ae_measurable_fst,
      ← ae_measurable.map_map_of_ae_measurable _ h.ae_measurable_snd, h.map_eq],
    rwa ← h.map_eq,
  end }

protected lemma comp {u : γ → δ} (h : ident_distrib f g μ ν) (hu : measurable u) :
  ident_distrib (u ∘ f) (u ∘ g) μ ν :=
h.comp_of_ae_measurable hu.ae_measurable

protected lemma of_ae_eq {g : α → γ} (hf : ae_measurable f μ) (heq : f =ᵐ[μ] g) :
  ident_distrib f g μ μ :=
{ ae_measurable_fst := hf,
  ae_measurable_snd := hf.congr heq,
  map_eq := measure.map_congr heq }

lemma measure_mem_eq (h : ident_distrib f g μ ν) {s : set γ} (hs : measurable_set s) :
  μ (f ⁻¹' s) = ν (g ⁻¹' s) :=
by rw [← measure.map_apply_of_ae_measurable h.ae_measurable_fst hs,
  ← measure.map_apply_of_ae_measurable h.ae_measurable_snd hs, h.map_eq]

alias measure_mem_eq ← measure_preimage_eq

lemma ae_snd (h : ident_distrib f g μ ν) {p : γ → Prop}
  (pmeas : measurable_set {x | p x}) (hp : ∀ᵐ x ∂μ, p (f x)) :
   ∀ᵐ x ∂ν, p (g x) :=
begin
  apply (ae_map_iff h.ae_measurable_snd pmeas).1,
  rw ← h.map_eq,
  exact (ae_map_iff h.ae_measurable_fst pmeas).2 hp,
end

lemma ae_mem_snd (h : ident_distrib f g μ ν) {t : set γ}
  (tmeas : measurable_set t) (ht : ∀ᵐ x ∂μ, f x ∈ t) :
   ∀ᵐ x ∂ν, g x ∈ t :=
h.ae_snd tmeas ht

/-- In a second countable topology, the first function in an identically distributed pair is a.e.
strongly measurable. So is the second function, but use `h.symm.ae_strongly_measurable_fst` as
`h.ae_strongly_measurable_snd` has a different meaning.-/

/-- If `f` and `g` are identically distributed and `f` is a.e. strongly measurable, so is `g`. -/
lemma ae_strongly_measurable_snd [topological_space γ] [metrizable_space γ] [borel_space γ]
  (h : ident_distrib f g μ ν) (hf : ae_strongly_measurable f μ) :
  ae_strongly_measurable g ν :=
begin
  refine ae_strongly_measurable_iff_ae_measurable_separable.2 ⟨h.ae_measurable_snd, _⟩,
  rcases (ae_strongly_measurable_iff_ae_measurable_separable.1 hf).2 with ⟨t, t_sep, ht⟩,
  refine ⟨closure t, t_sep.closure, _⟩,
  apply h.ae_mem_snd is_closed_closure.measurable_set,
  filter_upwards [ht] with x hx using subset_closure hx,
end

lemma ae_strongly_measurable_iff [topological_space γ] [metrizable_space γ] [borel_space γ]
  (h : ident_distrib f g μ ν) :
  ae_strongly_measurable f μ ↔ ae_strongly_measurable g ν :=
⟨λ hf, h.ae_strongly_measurable_snd hf, λ hg, h.symm.ae_strongly_measurable_snd hg⟩

lemma ess_sup_eq [conditionally_complete_linear_order γ] [topological_space γ]
  [opens_measurable_space γ] [order_closed_topology γ] (h : ident_distrib f g μ ν) :
  ess_sup f μ = ess_sup g ν :=
begin
  have I : ∀ a, μ {x : α | a < f x} = ν {x : β | a < g x} :=
    λ a, h.measure_mem_eq measurable_set_Ioi,
  simp_rw [ess_sup_eq_Inf, I],
end

lemma lintegral_eq {f : α → ℝ≥0∞} {g : β → ℝ≥0∞} (h : ident_distrib f g μ ν) :
  ∫⁻ x, f x ∂μ = ∫⁻ x, g x ∂ν :=
begin
  change ∫⁻ x, id (f x) ∂μ = ∫⁻ x, id (g x) ∂ν,
  rw [← lintegral_map' ae_measurable_id h.ae_measurable_fst,
      ← lintegral_map' ae_measurable_id h.ae_measurable_snd, h.map_eq],
end

lemma integral_eq [normed_add_comm_group γ] [normed_space ℝ γ] [complete_space γ] [borel_space γ]
  (h : ident_distrib f g μ ν) : ∫ x, f x ∂μ = ∫ x, g x ∂ν :=
begin
  by_cases hf : ae_strongly_measurable f μ,
  { have A : ae_strongly_measurable id (measure.map f μ),
    { rw ae_strongly_measurable_iff_ae_measurable_separable,
      rcases (ae_strongly_measurable_iff_ae_measurable_separable.1 hf).2 with ⟨t, t_sep, ht⟩,
      refine ⟨ae_measurable_id, ⟨closure t, t_sep.closure, _⟩⟩,
      rw ae_map_iff h.ae_measurable_fst,
      { filter_upwards [ht] with x hx using subset_closure hx },
      { exact is_closed_closure.measurable_set } },
    change ∫ x, id (f x) ∂μ = ∫ x, id (g x) ∂ν,
    rw [← integral_map h.ae_measurable_fst A],
    rw h.map_eq at A,
    rw [← integral_map h.ae_measurable_snd A, h.map_eq] },
  { rw integral_non_ae_strongly_measurable hf,
    rw h.ae_strongly_measurable_iff at hf,
    rw integral_non_ae_strongly_measurable hf }
end

lemma snorm_eq [normed_add_comm_group γ] [opens_measurable_space γ] (h : ident_distrib f g μ ν)
  (p : ℝ≥0∞) :
  snorm f p μ = snorm g p ν :=
begin
  by_cases h0 : p = 0,
  { simp [h0], },
  by_cases h_top : p = ∞,
  { simp only [h_top, snorm, snorm_ess_sup, ennreal.top_ne_zero, eq_self_iff_true, if_true,
      if_false],
    apply ess_sup_eq,
    exact h.comp (measurable_coe_nnreal_ennreal.comp measurable_nnnorm) },
  simp only [snorm_eq_snorm' h0 h_top, snorm', one_div],
  congr' 1,
  apply lintegral_eq,
  exact h.comp
    (measurable.pow_const (measurable_coe_nnreal_ennreal.comp measurable_nnnorm) p.to_real),
end

lemma mem_ℒp_snd [normed_add_comm_group γ] [borel_space γ]
  {p : ℝ≥0∞} (h : ident_distrib f g μ ν) (hf : mem_ℒp f p μ) :
  mem_ℒp g p ν :=
begin
  refine ⟨h.ae_strongly_measurable_snd hf.ae_strongly_measurable, _⟩,
  rw ← h.snorm_eq,
  exact hf.2
end

lemma mem_ℒp_iff [normed_add_comm_group γ] [borel_space γ] {p : ℝ≥0∞} (h : ident_distrib f g μ ν) :
  mem_ℒp f p μ ↔ mem_ℒp g p ν :=
⟨λ hf, h.mem_ℒp_snd hf, λ hg, h.symm.mem_ℒp_snd hg⟩

lemma integrable_snd [normed_add_comm_group γ] [borel_space γ] (h : ident_distrib f g μ ν)
  (hf : integrable f μ) : integrable g ν :=
begin
  rw ← mem_ℒp_one_iff_integrable at hf ⊢,
  exact h.mem_ℒp_snd hf
end

lemma integrable_iff [normed_add_comm_group γ] [borel_space γ] (h : ident_distrib f g μ ν) :
  integrable f μ ↔ integrable g ν :=
⟨λ hf, h.integrable_snd hf, λ hg, h.symm.integrable_snd hg⟩

protected lemma norm [normed_add_comm_group γ] [borel_space γ] (h : ident_distrib f g μ ν) :
  ident_distrib (λ x, ‖f x‖) (λ x, ‖g x‖) μ ν :=
h.comp measurable_norm

protected lemma nnnorm [normed_add_comm_group γ] [borel_space γ] (h : ident_distrib f g μ ν) :
  ident_distrib (λ x, ‖f x‖₊) (λ x, ‖g x‖₊) μ ν :=
h.comp measurable_nnnorm

protected lemma pow [has_pow γ ℕ] [has_measurable_pow γ ℕ] (h : ident_distrib f g μ ν) {n : ℕ} :
  ident_distrib (λ x, (f x) ^ n) (λ x, (g x) ^ n) μ ν :=
h.comp (measurable_id.pow_const n)

protected lemma sq [has_pow γ ℕ] [has_measurable_pow γ ℕ] (h : ident_distrib f g μ ν) :
  ident_distrib (λ x, (f x) ^ 2) (λ x, (g x) ^ 2) μ ν :=
h.comp (measurable_id.pow_const 2)

protected lemma coe_nnreal_ennreal {f : α → ℝ≥0} {g : β → ℝ≥0} (h : ident_distrib f g μ ν) :
  ident_distrib (λ x, (f x : ℝ≥0∞)) (λ x, (g x : ℝ≥0∞)) μ ν :=
h.comp measurable_coe_nnreal_ennreal

@[to_additive]
lemma mul_const [has_mul γ] [has_measurable_mul γ] (h : ident_distrib f g μ ν) (c : γ) :
  ident_distrib (λ x, f x * c) (λ x, g x * c) μ ν :=
h.comp (measurable_mul_const c)

@[to_additive]
lemma const_mul [has_mul γ] [has_measurable_mul γ] (h : ident_distrib f g μ ν) (c : γ) :
  ident_distrib (λ x, c * f x) (λ x, c * g x) μ ν :=
h.comp (measurable_const_mul c)

@[to_additive]
lemma div_const [has_div γ] [has_measurable_div γ] (h : ident_distrib f g μ ν) (c : γ) :
  ident_distrib (λ x, f x / c) (λ x, g x / c) μ ν :=
h.comp (has_measurable_div.measurable_div_const c)

@[to_additive]
lemma const_div [has_div γ] [has_measurable_div γ] (h : ident_distrib f g μ ν) (c : γ) :
  ident_distrib (λ x, c / f x) (λ x, c / g x) μ ν :=
h.comp (has_measurable_div.measurable_const_div c)

lemma evariance_eq {f : α → ℝ} {g : β → ℝ} (h : ident_distrib f g μ ν) :
  evariance f μ = evariance g ν :=
begin
  convert (h.sub_const (∫ x, f x ∂μ)).nnnorm.coe_nnreal_ennreal.sq.lintegral_eq,
  rw h.integral_eq,
  refl
end

lemma variance_eq {f : α → ℝ} {g : β → ℝ} (h : ident_distrib f g μ ν) :
  variance f μ = variance g ν :=
by { rw [variance, h.evariance_eq], refl, }

end ident_distrib

section uniform_integrable

open topological_space

variables {E : Type*} [measurable_space E] [normed_add_comm_group E] [borel_space E]
  [second_countable_topology E] {μ : measure α} [is_finite_measure μ]

/-- This lemma is superceded by `mem_ℒp.uniform_integrable_of_ident_distrib` which only require
`ae_strongly_measurable`. -/
lemma mem_ℒp.uniform_integrable_of_ident_distrib_aux {ι : Type*} {f : ι → α → E}
  {j : ι} {p : ℝ≥0∞} (hp : 1 ≤ p) (hp' : p ≠ ∞)
  (hℒp : mem_ℒp (f j) p μ) (hfmeas : ∀ i, strongly_measurable (f i))
  (hf : ∀ i, ident_distrib (f i) (f j) μ μ) :
  uniform_integrable f p μ :=
begin
  refine uniform_integrable_of' hp hp' hfmeas (λ ε hε, _),
  by_cases hι : nonempty ι,
  swap, { exact ⟨0, λ i, false.elim (hι $ nonempty.intro i)⟩ },
  obtain ⟨C, hC₁, hC₂⟩ := hℒp.snorm_indicator_norm_ge_pos_le μ (hfmeas _) hε,
  have hmeas : ∀ i, measurable_set {x | (⟨C, hC₁.le⟩ : ℝ≥0) ≤ ‖f i x‖₊} :=
    λ i, measurable_set_le measurable_const (hfmeas _).measurable.nnnorm,
  refine ⟨⟨C, hC₁.le⟩, λ i, le_trans (le_of_eq _) hC₂⟩,
  have : {x : α | (⟨C, hC₁.le⟩ : ℝ≥0) ≤ ‖f i x‖₊}.indicator (f i) =
    (λ x : E, if (⟨C, hC₁.le⟩ : ℝ≥0) ≤ ‖x‖₊ then x else 0) ∘ (f i),
  { ext x,
    simp only [set.indicator, set.mem_set_of_eq] },
  simp_rw [coe_nnnorm, this],
  rw [← snorm_map_measure _ (hf i).ae_measurable_fst, (hf i).map_eq,
    snorm_map_measure _ (hf j).ae_measurable_fst],
  { refl },
  all_goals { exact ae_strongly_measurable_id.indicator
      (measurable_set_le measurable_const measurable_nnnorm) },
end

/-- A sequence of identically distributed Lᵖ functions is p-uniformly integrable. -/
lemma mem_ℒp.uniform_integrable_of_ident_distrib {ι : Type*} {f : ι → α → E}
  {j : ι} {p : ℝ≥0∞} (hp : 1 ≤ p) (hp' : p ≠ ∞)
  (hℒp : mem_ℒp (f j) p μ) (hf : ∀ i, ident_distrib (f i) (f j) μ μ) :
  uniform_integrable f p μ :=
begin
  have hfmeas : ∀ i, ae_strongly_measurable (f i) μ :=
    λ i, (hf i).ae_strongly_measurable_iff.2 hℒp.1,
  set g : ι → α → E := λ i, (hfmeas i).some,
  have hgmeas : ∀ i, strongly_measurable (g i) := λ i, (Exists.some_spec $ hfmeas i).1,
  have hgeq : ∀ i, g i =ᵐ[μ] f i := λ i, (Exists.some_spec $ hfmeas i).2.symm,
  have hgℒp : mem_ℒp (g j) p μ := hℒp.ae_eq (hgeq j).symm,
  exact uniform_integrable.ae_eq (mem_ℒp.uniform_integrable_of_ident_distrib_aux hp hp'
    hgℒp hgmeas $
    λ i, (ident_distrib.of_ae_eq (hgmeas i).ae_measurable (hgeq i)).trans ((hf i).trans
      $ ident_distrib.of_ae_eq (hfmeas j).ae_measurable (hgeq j).symm)) hgeq,
end

end uniform_integrable

end probability_theory


import tactic

def square {A B : Type*} (R : A → B → Prop) : Prop :=
∀ x₁ x₂ y₁ y₂, R x₁ y₁ → R x₂ y₁ → R x₂ y₂ → R x₁ y₂

structure edge (X Y : Type) : Type :=
( R : X → Y → Prop )
( square : square R )

namespace edge

variables {X Y : Type}

def le : edge X Y → edge X Y → Prop :=
λ e₁ e₂, ∃ (f : X → X) (g : Y → Y), ∀ x y, e₁.R (f x) y ↔ e₂.R x (g y)

instance : preorder (edge X Y) :=
{ le := le,
  le_refl := λ _, ⟨id, id, λ _ _, iff.rfl⟩,
  le_trans := λ a b c ⟨f₁, g₁, h₁⟩ ⟨f₂, g₂, h₂⟩,
    ⟨f₁ ∘ f₂, g₂ ∘ g₁, λ x y, (h₁ _ _).trans $ h₂ _ _⟩ }

def of_fun (f : X → Y) : edge X Y :=
{ R := λ x y, f x = y,
  square := λ _ _ _ _, by cc }

lemma maximal_of_fun (f : X → Y) (E : edge X Y) (h : of_fun f ≤ E) :
  E ≤ of_fun f :=
begin
  rcases h with ⟨a, b, h⟩,

  refine ⟨a, b, _⟩,
  dsimp [of_fun] at *,

end

end edge


import tactic
open classical
local attribute [instance] prop_decidable

structure gamestate (α : Type) :=
-- α represents the type of squares on the chessboard
(left : α → α → Prop)
(white_turn : Prop)
(K : α → Prop)  -- Is the White king on this square?
(k : α → Prop)  -- ...    Black ...
(left_nonrefl : ∀ x y, left x y → x ≠ y)
(left_trans : ∀ x y z, left x y ∧ left y z → left x z)
(square_one_piece_K : ∀ x, K x → ¬ k x)
(square_one_piece_k : ∀ x, k x → ¬ K x)

variables {α : Type} (G : gamestate α)

def adjleft (x y : α) := G.left x y ∧ (∀ z, ¬ G.left x z ∧ ¬ G.left z y)

-- `can'_<color> x y` iff a piece on `x` can
-- 1. reach `y`
-- *or*
-- 2. capture a different-colored piece on `y`
-- *or*
-- 3. protect a same-colored piece on `y`
def can'_white (x y : α) := G.K x ∧ (adjleft G x y ∨ adjleft G y x)
def can'_black (x y : α) := G.k x ∧ (adjleft G x y ∨ adjleft G y x)
def can' (x y : α) := (G.white_turn → can'_white G x y) ∧ (¬ G.white_turn → can'_black G x y)

-- `can_<color> x y` iff only 1 and 2 from above hold
def can_white (x y : α) := G.K x ∧ ¬ G.K y ∧ (adjleft G x y ∨ adjleft G y x)
def can_black (x y : α) := G.k x ∧ ¬ G.k y ∧ (adjleft G x y ∨ adjleft G y x)
def can (x y : α) := (G.white_turn → can_white G x y) ∧ (¬ G.white_turn → can_black G x y)

def checked_white := ∃ (x y : α), G.K y ∧ can_black G x y
def checked_black := ∃ (x y : α), G.k y ∧ can_white G x y
def checked := (G.white_turn → checked_white G) ∧ (¬ G.white_turn → checked_black G)
def checking := (G.white_turn → checked_black G) ∧ (¬ G.white_turn → checked_white G)

def move (x y : α) (h : can G x y) : gamestate α :=
{ left := G.left,
  white_turn := ¬ G.white_turn,
  -- Piece on source square always disappears on next move
  -- Piece on target square only present if it was moved from
  -- source square
  K := λ z, ite (z = x) false
    (ite (z = y) (G.K x) (G.K z)),
  k := λ z, ite (z = x) false
    (ite (z = y) (G.k x) (G.k z)),
  left_nonrefl := G.left_nonrefl,
  left_trans := G.left_trans,
  -- Mindless case bashing lol
  square_one_piece_K := begin
    intros z h1,
    by_contra h2,
    by_cases h3 : z = x,
      exfalso, rwa (if_pos h3) at h1,
    by_cases h4 : z = y;
    rw (if_neg h3) at h1,
    { rw (if_pos h4) at h1,
      rw [if_neg h3, if_pos h4] at h2,
      exact (G.square_one_piece_K x h1) h2 },
    rw (if_neg h4) at h1,
    rw [if_neg h3, if_neg h4] at h2,
    exact (G.square_one_piece_K z h1) h2
  end,
  square_one_piece_k := begin
    intros z h1,
    by_contra h2,
    by_cases h3 : z = x,
      exfalso, rwa (if_pos h3) at h1,
    by_cases h4 : z = y;
    rw (if_neg h3) at h1,
    { rw (if_pos h4) at h1,
      rw [if_neg h3, if_pos h4] at h2,
      exact (G.square_one_piece_k x h1) h2 },
    rw (if_neg h4) at h1,
    rw [if_neg h3, if_neg h4] at h2,
    exact (G.square_one_piece_k z h1) h2
  end }

-- legal moves don't leave the player in check
def legal (x y : α) (h : can G x y) := ¬ checking (move G x y h)
def got_can := ∃ (x y : α), can G x y
def got_legal := ∃ (x y : α) {h : can G x y}, legal G x y h
def stalemated := ¬ checked G ∧ (¬ got_can G ∨ ¬ got_legal G)
def checkmated := checked G ∧ (¬ got_can G ∨ ¬ got_legal G)

def winning : ℕ → gamestate α → Prop
| 0 := λ G, ¬ G.white_turn ∧ checkmated G
| (k+1) := λ G, ¬ stalemated G ∧ got_can G ∧
  (¬ G.white_turn → ∀ (x y : α) {h : can G x y}, legal G x y h ∧ winning k (move G x y h)) ∧
  (G.white_turn → ∃ (x y : α) (h : can G x y), legal G x y h ∧ winning k (move G x y h))

def losing : ℕ → gamestate α → Prop
| 0 := λ G, G.white_turn ∧ checkmated G
| (k+1) := λ G, ¬ stalemated G ∧ got_can G ∧
  (G.white_turn → ∀ (x y : α) {h : can G x y}, legal G x y h ∧ losing k (move G x y h)) ∧
  (¬ G.white_turn → ∃ (x y : α) (h : can G x y), legal G x y h ∧ losing k (move G x y h))

def draw := ∀ (k : ℕ), ¬ winning k G ∧ ¬ losing k G

-- Some basic results
-- When there is only one White/Black king on the board
lemma left_of_adjleft {x y : α} (h : adjleft G x y) : G.left x y := h.left
lemma check_of_checkmate (h : checkmated G) : checked G := h.left

def one_white_piece (x : α) := G.K x ∧ (∀ (z : α), G.K z → z = x)
def one_black_piece (x : α) := G.k x ∧ (∀ (z : α), G.k z → z = x)

lemma adj_of_can {x y : α} (hcan : can G x y) : adjleft G x y ∨ adjleft G y x := begin
  unfold can at hcan,
  by_cases hwhite : G.white_turn,
  { have h1 := hcan.left hwhite,
    unfold can_white at h1,
    exact h1.right.right },
  have h1 := hcan.right hwhite,
  unfold can_black at h1,
  exact h1.right.right,
end

lemma neq_of_adj {x y : α} (h : adjleft G x y ∨ adjleft G y x) : x ≠ y := begin
  cases h,
    exact G.left_nonrefl _ _ h.left,
  exact ne_comm.mp (G.left_nonrefl _ _ h.left),
end

lemma neq_of_can {x y : α} (hcan : can G x y) : x ≠ y := neq_of_adj G (adj_of_can G hcan)

lemma K_of_move {x y : α} (hK : G.K x) (hcan : can G x y) :
  (move G x y hcan).K y := begin
  unfold move, dsimp,
  rwa [if_neg _, if_pos _],
    refl,
  exact ne_comm.mp (neq_of_can G hcan),
end

lemma k_of_move {x y : α} (hk : G.k x) (hcan : can G x y) :
  (move G x y hcan).k y := begin
  unfold move, dsimp,
  rwa [if_neg _, if_pos _],
    refl,
  exact ne_comm.mp (neq_of_can G hcan),
end

lemma K_of_move_2 {x y z : α} (hK : G.K x) (hk : G.k z) (hcan : can G x y)
  (hxz : x ≠ z) (hyz : y ≠ z) : (move G x y hcan).k z := begin
  unfold move, dsimp,
  rwa [if_neg (ne_comm.mp hyz), if_neg (ne_comm.mp hxz)],
end

lemma k_of_move_2 {x y z : α} (hk : G.k x) (hK : G.K z) (hcan : can G x y)
  (hxz : x ≠ z) (hyz : y ≠ z) : (move G x y hcan).K z := begin
  unfold move, dsimp,
  rwa [if_neg (ne_comm.mp hyz), if_neg (ne_comm.mp hxz)],
end

-- Making a move preserves the number of pieces of your color
lemma one_white_piece_preserved_1 {x y : α} (hone : one_white_piece G x) (hcan : can G x y) :
  one_white_piece (move G x y hcan) y := begin
  unfold one_white_piece,
  split,
    exact K_of_move G hone.left hcan,
  intros z hz,
  unfold move at hz, dsimp at hz,
  have hzx : z ≠ x := λ h, by rwa (if_pos h) at hz,
  by_contra h,
  rw [if_neg hzx, if_neg h] at hz,
  exact hzx (hone.right z hz),
end

lemma one_black_piece_preserved_1 {x y : α} (hone : one_black_piece G x) (hcan : can G x y) :
  one_black_piece (move G x y hcan) y := begin
  unfold one_black_piece,
  split,
    exact k_of_move G hone.left hcan,
  intros z hz,
  unfold move at hz, dsimp at hz,
  have hzx : z ≠ x := λ h, by rwa (if_pos h) at hz,
  by_contra h,
  rw [if_neg hzx, if_neg h] at hz,
  exact hzx (hone.right z hz),
end

-- Non-capturing moves by the opponent preserve the number of pieces of your color
lemma one_white_piece_preserved_2 {x y z : α} (hblack : ¬ G.white_turn) (hone : one_white_piece G z)
  (hcan : can G x y) (hyz : y ≠ z) :
  one_white_piece (move G x y hcan) z := begin
  unfold one_white_piece,
  split,
  { unfold move, dsimp,
    by_cases hxz : x = z,
    { subst hxz,
      rw (if_pos rfl),
      have hkx := (hcan.right hblack).left,
      exact G.square_one_piece_K x hone.left hkx },
    rw [if_neg (ne_comm.mp hxz), if_neg (ne_comm.mp hyz)],
    exact hone.left },
  intros w hw,
  unfold move at hw, dsimp at hw,
  rw [if_neg _, if_neg _] at hw,
  exact hone.right w hw,
  { by_contra h1,
    rw (if_pos h1) at hw,
    have h2 := (hcan.right hblack).left,
    exact G.square_one_piece_K x hw h2 },
  by_contra h1,
  rwa (if_pos h1) at hw,
end

lemma one_black_piece_preserved_2 {x y z : α} (hwhite : G.white_turn) (hone : one_black_piece G z)
  (hcan : can G x y) (hyz : y ≠ z) :
  one_black_piece (move G x y hcan) z := begin
  unfold one_black_piece,
  split,
  { unfold move, dsimp,
    by_cases hxz : x = z,
    { subst hxz,
      rw (if_pos rfl),
      have hkx := (hcan.left hwhite).left,
      exact G.square_one_piece_k x hone.left hkx },
    rw [if_neg (ne_comm.mp hxz), if_neg (ne_comm.mp hyz)],
    exact hone.left },
  intros w hw,
  unfold move at hw, dsimp at hw,
  rw [if_neg _, if_neg _] at hw,
  exact hone.right w hw,
  { by_contra h1,
    rw (if_pos h1) at hw,
    have h2 := (hcan.left hwhite).left,
    exact G.square_one_piece_k x hw h2 },
  by_contra h1,
  rwa (if_pos h1) at hw,
end

lemma adj_of_move {x y : α} (hcan : can G x y) : adjleft G x y ∨ adjleft G y x := begin
  by_cases hwhite : G.white_turn,
    exact (hcan.left hwhite).right.right,
  exact (hcan.right hwhite).right.right,
end

-- Define a `KvK position` to be a position with only one non-adjacent White and Black king
-- I show that KvK positions are draws
def KvK := ∃ (x y : α), one_white_piece G x ∧ one_black_piece G y ∧ ¬ adjleft G x y ∧ ¬ adjleft G y x

-- 1. A KvK position is a check for neither player
lemma KvK_no_check (h : KvK G) : ¬ checked G :=
begin
  unfold checked,
  simp only [not_and_distrib, not_not, not_imp],
  by_cases hturn : G.white_turn,
  { left, split,
      assumption,
    unfold checked_white,
    simp only [not_exists, not_and_distrib],
    intros y x,

    by_cases hK : G.K x, swap,
      left, assumption,
    right,
    unfold can_black,
    simp only [not_and_distrib, not_not, not_or_distrib],

    by_cases hk : G.k y, swap,
      left, assumption,
    right, right,
    rcases h with ⟨x', y', hx', hy', hnotadj⟩,
    rw and_comm at hnotadj,
    convert hnotadj,
    repeat { exact hy'.right y hk <|> exact hx'.right x hK } },

  -- The same thing
  right, split,
    assumption,
  unfold checked_black,
  simp only [not_exists, not_and_distrib],
  intros x y,

  by_cases hk : G.k y, swap,
    left, assumption,
  right,
  unfold can_white,
  simp only [not_and_distrib, not_not, not_or_distrib],

  by_cases hK : G.K x, swap,
    left, assumption,
  right, right,
  rcases h with ⟨x', y', hx', hy', hnotadj⟩,
  convert hnotadj,
  repeat { exact hy'.right y hk <|> exact hx'.right x hK },
end

-- 2. Legal moves preserve KvK positions
lemma KvK_preserved {x y : α} (hG : KvK G) (hcan : can G x y) (hlegal : legal G x y hcan) :
  KvK (move G x y hcan) :=
begin
  rcases hG with ⟨x1, x2, hx1, hx2, hnotadj⟩,
  unfold KvK,
  by_cases hwhite : G.white_turn,
  { have : x = x1 := hx1.right x (hcan.left hwhite).left,
    subst this,

    have hy_x2 : y ≠ x2 := begin
      by_contra h, subst h,
      apply not_or_distrib.mpr hnotadj,
      exact adj_of_move G hcan,
    end,

    use [y, x2],
    split,
    { apply one_white_piece_preserved_1,
      convert hx1 },
    split,
    { apply one_black_piece_preserved_2,
      repeat { assumption } },

    let G' := move G x y hcan,
    -- Expanding the monstrous expression out
    rename hlegal h1,
    unfold legal checking checked_white checked_black can_white can_black at h1,
    simp only [not_and_distrib, not_imp, not_not] at h1,
    cases h1,
      exact false.elim (not_not.mpr hwhite h1.left),
    replace h1 := h1.right,
    simp only [not_exists, not_and_distrib, not_not, not_or_distrib] at h1,
    replace h1 := h1 x2 y,
    cases h1,
      exact false.elim (h1 (K_of_move G hx1.left hcan)),
    cases h1,
    { refine false.elim (h1 (K_of_move_2 G hx1.left hx2.left hcan _ hy_x2)),
      by_contra h2,
      subst h2,
      exact (G.square_one_piece_K x hx1.left) hx2.left },
    cases h1,
    { refine false.elim ((G'.square_one_piece_K y _) h1),
      apply K_of_move G hx1.left },
    rwa and_comm },

  -- EXACT SAME THING
  have : x = x2 := hx2.right x (hcan.right hwhite).left,
  subst this,

  have hy_x2 : y ≠ x1 := begin
    by_contra h, subst h,
    apply not_or_distrib.mpr hnotadj,
    rw or_comm,
    exact adj_of_move G hcan,
  end,

  use [x1, y],
  split,
  { apply one_white_piece_preserved_2,
    repeat { assumption } },
  split,
  { apply one_black_piece_preserved_1,
    assumption },

  let G' := move G x y hcan,
  have : G'.white_turn := hwhite,
  -- Expanding the monstrous expression out
  rename hlegal h1,
  unfold legal checking checked_white checked_black can_white can_black at h1,
  simp only [not_and_distrib, not_imp, not_not] at h1,
  cases h1, swap,
    exact false.elim (h1.left this),
  replace h1 := h1.right,
  simp only [not_exists, not_and_distrib, not_not, not_or_distrib] at h1,
  replace h1 := h1 x1 y,
  cases h1,
    exact false.elim (h1 (k_of_move G hx2.left hcan)),
  cases h1,
  { refine false.elim (h1 (k_of_move_2 G hx2.left hx1.left hcan _ hy_x2)),
    by_contra h2,
    subst h2,
    exact (G.square_one_piece_K x hx1.left) hx2.left },
  cases h1,
  { refine false.elim ((G'.square_one_piece_k y _) h1),
    apply k_of_move G hx2.left },
  assumption,
end

-- The main result
theorem KvK_draw (h : KvK G) : draw G := begin
  unfold draw, intro k, revert G,
  induction k with k hk; intros G hG,
  { split,
    { unfold winning,
      rw [not_and_distrib, not_not],
      right,
      exact (λ h, (KvK_no_check G hG) (check_of_checkmate G h)) },
    unfold losing,
    rw not_and_distrib,
    right,
    exact (λ h, (KvK_no_check G hG) (check_of_checkmate G h)) },

  split,
  { unfold winning,
    simp only [not_and_distrib, not_not, not_imp, not_forall, not_exists],
    by_cases h1 : stalemated G,
      left, assumption,
    right,

    by_cases h2 : G.white_turn,
    { right, right,
      use h2,
      intros x y hcan,
      by_cases h3 : legal G x y _, swap,
        left, assumption,
      right,
      let G' := move G x y _,
      exact (hk G' (KvK_preserved G hG hcan h3)).left },

    by_cases h3 : got_can G, swap,
      left, assumption,
    right, left,
    rcases h3 with ⟨x, y, hxy⟩,
    use [h2, x, y, hxy],

    by_cases h4 : legal G x y _, swap,
      left, assumption,
    right,
    let G' := move G x y _,
    exact (hk G' (KvK_preserved G hG hxy h4)).left, },

  -- The exact same thing but replace `winning` with `losing`
  unfold losing,
  simp only [not_and_distrib, not_not, not_imp, not_forall, not_exists],
  by_cases h1 : stalemated G,
    left, assumption,
  right,

  by_cases h2 : G.white_turn, swap,
  { right, right,
    use h2,
    intros x y hcan,
    by_cases h3 : legal G x y _, swap,
      left, assumption,
    right,
    let G' := move G x y _,
    exact (hk G' (KvK_preserved G hG hcan h3)).right },

  by_cases h3 : got_can G, swap,
    left, assumption,
  right, left,
  rcases h3 with ⟨x, y, hxy⟩,
  use [h2, x, y, hxy],

  by_cases h4 : legal G x y _, swap,
    left, assumption,
  right,
  let G' := move G x y _,
  exact (hk G' (KvK_preserved G hG hxy h4)).right
end


constants p q : Prop

theorem t1 : p → q → p := λ hp : p, λ hq : q, hp


import SciLean.Quot.Basic

namespace SciLean.Quot'

  class QForm {α} (S : Rel α) where
    RedForm  : α → Prop
    NormForm : α → Prop
    norm_red : ∀ x, NormForm x → RedForm x
    norm_eq  : ∀ x y, S x y → NormForm x → NormForm y → x = y

  open QForm

  class IsQHomR (S : Rel α) (R : Rel β) [QForm S] [QForm R] (f : α → β) extends IsQHom S R f where
    preserve_red : ∀ x : α, RedForm S x → RedForm R (f x)

  class IsQHomN (S : Rel α) (R : Rel β) [QForm S] [QForm R] (f : α → β) extends IsQHomR S R f where
    preserve_norm : ∀ x : α, NormForm S x → NormForm R (f x)

  ---

  class QReduce {α} (S : Rel α) [QForm S] where
    reduce : α → α
    is_reduce : ∀ x, RedForm S (reduce x)
    eq_reduce : ∀ x, ⟦x, S⟧ = ⟦reduce x⟧
    preserve_norm : ∀ x, NormForm S x → NormForm S (reduce x)

  class Reduce (α) where
    reduce : α → α
    id_reduce : ∀ x : α, reduce x = x

  ---

  class QNormalize {α} (S : Rel α) [QForm S] where
    normalize : α → α
    is_normalize : ∀ x, NormForm S (normalize x)
    eq_normalize : ∀ x, ⟦x, S⟧ = ⟦normalize x⟧

  class Normalize (α) where
    normalize : α → α
    id_normalize : ∀ x : α, normalize x = x

  ---

  -- This just tags `Repr` in which form they are
  inductive QRepr {α} (S : Rel α) [QForm S] where
    | raw  (x : α) : QRepr S
    | red  (x : α) (h : RedForm S x)  : QRepr S
    | norm (x : α) (h : NormForm S x) : QRepr S

  namespace QRepr

    variable {α} {S : Rel α} [QForm S]

    def repr (x : QRepr S) : α :=
      match x with
      | raw  x   => x
      | red  x _ => x
      | norm x _ => x

    @[simp]
    theorem raw_repr (x : α) : (raw x : QRepr S).repr = x := by simp[repr] done

    @[simp]
    theorem red_repr (x : α) (h : RedForm S x) : (red x h : QRepr S).repr = x := by simp[repr] done

    @[simp]
    theorem norm_repr (x : α) (h : NormForm S x) : (norm x h : QRepr S).repr = x := by simp[repr] done

    def isReduced (x : QRepr S) : Bool :=
      match x with
      | raw x => false
      | _ => true

    def isNormalized (x : QRepr S) : Bool :=
      match x with
      | norm x _ => true
      | _ => false

    -- variable {Repr' } {R'  : Repr'  → Repr'  → Prop} [Symbolic R']
    -- variable {Repr''} {R'' : Repr'' → Repr'' → Prop} [Symbolic R'']

    -- def lift (f : Repr → Repr') (x : QRepr R) : QRepr R' := raw (f x.repr)

    -- def lift₂ (f : Repr → Repr' → Repr'') (x : QRepr R) (x' : QRepr R') : QRepr R'' :=
    --   raw (f x.repr x'.repr)

    -- def liftHom (f : Repr → Repr') (h : SHom R R' f) (x : QRepr R) : QRepr R' :=
    --   match x with
    --   | raw x => raw (f x)
    --   | red  x h' => red  (f x) (h.preserve_red x h')
    --   | norm x h' => norm (f x) (h.preserve_norm x h')

    -- @[simp]
    -- theorem lift_hom_repr (f : Repr → Repr') (h : SHom R R' f) (x : QRepr R)
    --   : (liftHom f h x).repr = f x.repr
    --   :=
    --   by induction x
    --      repeat simp[liftHom]
    --      done

    -- def liftHom₂ (f : Repr → Repr' → Repr'') (h : SHom₂ R R' R'' f)
    --   (x : QRepr R) (y : QRepr R') : QRepr R'' :=
    --   match x, y with
    --   | red x hx,  red y hy  => red  (f x y) (h.preserve_red  x y hx hy)
    --   | norm x hx, norm y hy => norm (f x y) (h.preserve_norm x y hx hy)
    --   | x, y => raw (f x.repr y.repr)

    def reduce (x : QRepr S) [QReduce S] : QRepr S :=
      match x with
      | raw x => red (QReduce.reduce S x) (QReduce.is_reduce x)
      | x => x

    def normalize (x : QRepr S) [QNormalize S] : QRepr S :=
      match x with
      | raw x   => norm (QNormalize.normalize S x) (QNormalize.is_normalize x)
      | red x _ => norm (QNormalize.normalize S x) (QNormalize.is_normalize x)
      | x => x

  end QRepr

end Quot'

open Quot' in
def Quot' {α} (S : Rel α) [QForm S]
  := Quot (λ x y : QRepr S => S x.repr y.repr)

namespace Quot'

  variable {α} {S : Rel α} [QForm S]

  -- Normalized representant is unique, follows from `QForm.norm_eq`
  def nrepr [QNormalize S] : Quot' S → α := Quot.lift (λ x => x.normalize.repr) sorry

  noncomputable
  def srepr (x : Quot' S) : QRepr S := x.repr

  noncomputable
  def repr (x : Quot' S) : α := x.srepr.repr

  variable (x : Quot' S)

  #check x.repr
  #check x.srepr

end Quot'

  -- TODO:
  ---  QNormalize -> Normalize
  ---  QNormalize -> DecidableEq


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

! This file was ported from Lean 3 source module tactic.by_contra
! leanprover-community/mathlib commit 770703645cbd2f8d0e96743527f9ca57e7b9b63d
! Please do not edit these lines, except to modify the commit id
! if you have ported upstream changes.
-/
import Mathbin.Tactic.Core
import Mathbin.Tactic.PushNeg

/-!
# by_contra'

`by_contra'` is a tactic for proving propositions by contradiction.
It is similar to `by_contra` except that it also uses `push_neg` to normalize negations.
-/

namespace Tactic

namespace Interactive

/- ./././Mathport/Syntax/Translate/Tactic/Mathlib/Core.lean:38:34: unsupported: setup_tactic_parser -/
/- ./././Mathport/Syntax/Translate/Expr.lean:207:4: warning: unsupported notation `parser.optional -/
/- ./././Mathport/Syntax/Translate/Expr.lean:207:4: warning: unsupported notation `parser.optional -/
/-- If the target of the main goal is a proposition `p`,
`by_contra'` reduces the goal to proving `false` using the additional hypothesis `h : ¬ p`.
`by_contra' h` can be used to name the hypothesis `h : ¬ p`.
The hypothesis `¬ p` will be negation normalized using `push_neg`.
For instance, `¬ a < b` will be changed to `b ≤ a`.
`by_contra' h : q` will normalize negations in `¬ p`, normalize negations in `q`,
and then check that the two normalized forms are equal.
The resulting hypothesis is the pre-normalized form, `q`.

If the name `h` is not explicitly provided, then `this` will be used as name.

This tactic uses classical reasoning.
It is a variant on the tactic `by_contra` (`tactic.interactive.by_contra`).

Examples:

```lean
example : 1 < 2 :=
begin
  by_contra' h,
  -- h : 2 ≤ 1 ⊢ false
end

example : 1 < 2 :=
begin
  by_contra' h : ¬ 1 < 2,
  -- h : ¬ 1 < 2 ⊢ false
end
```
-/
unsafe def by_contra' (h : parse (parser.optional ident))
    (t : parse (parser.optional (tk ":" *> texpr))) : tactic Unit := do
  let h := h.getD `this
  let tgt ← target
  mk_mapp `classical.by_contradiction [some tgt] >>= tactic.eapply
  let h₁ ← tactic.intro h
  let t' ← infer_type h₁
  let-- negation-normalize `t'` to the expression `e'` and get a proof `pr'` of `t' = e'`
    (e', pr')
    ← push_neg.normalize_negations t' <|> refl_conv t'
  match t with
    | none => () <$ replace_hyp h₁ e' pr'
    | some t => do
      let t ← to_expr ``(($(t) : Prop))
      let-- negation-normalize `t` to the expression `e` and get a proof `pr` of `t = e`
        (e, pr)
        ← push_neg.normalize_negations t <|> refl_conv t
      unify e e'
      () <$ (mk_eq_symm pr >>= mk_eq_trans pr' >>= replace_hyp h₁ t)
#align tactic.interactive.by_contra' tactic.interactive.by_contra'

add_tactic_doc
  { Name := "by_contra'"
    category := DocCategory.tactic
    declNames := [`tactic.interactive.by_contra']
    tags := ["logic"] }

end Interactive

end Tactic