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

! This file was ported from Lean 3 source module algebra.continued_fractions.computation.correctness_terminating
! leanprover-community/mathlib commit d6814c584384ddf2825ff038e868451a7c956f31
! Please do not edit these lines, except to modify the commit id
! if you have ported upstream changes.
-/
import Mathbin.Algebra.ContinuedFractions.Computation.Translations
import Mathbin.Algebra.ContinuedFractions.TerminatedStable
import Mathbin.Algebra.ContinuedFractions.ContinuantsRecurrence
import Mathbin.Order.Filter.AtTopBot
import Mathbin.Tactic.FieldSimp

/-!
# Correctness of Terminating Continued Fraction Computations (`generalized_continued_fraction.of`)

## Summary

We show the correctness of the
algorithm computing continued fractions (`generalized_continued_fraction.of`) in case of termination
in the following sense:

At every step `n : ℕ`, we can obtain the value `v` by adding a specific residual term to the last
denominator of the fraction described by `(generalized_continued_fraction.of v).convergents' n`.
The residual term will be zero exactly when the continued fraction terminated; otherwise, the
residual term will be given by the fractional part stored in
`generalized_continued_fraction.int_fract_pair.stream v n`.

For an example, refer to
`generalized_continued_fraction.comp_exact_value_correctness_of_stream_eq_some` and for more
information about the computation process, refer to `algebra.continued_fraction.computation.basic`.

## Main definitions

- `generalized_continued_fraction.comp_exact_value` can be used to compute the exact value
  approximated by the continued fraction `generalized_continued_fraction.of v` by adding a residual
  term as described in the summary.

## Main Theorems

- `generalized_continued_fraction.comp_exact_value_correctness_of_stream_eq_some` shows that
  `generalized_continued_fraction.comp_exact_value` indeed returns the value `v` when given the
  convergent and fractional part as described in the summary.
- `generalized_continued_fraction.of_correctness_of_terminated_at` shows the equality
  `v = (generalized_continued_fraction.of v).convergents n` if `generalized_continued_fraction.of v`
  terminated at position `n`.
-/

namespace GeneralizedContinuedFraction

open GeneralizedContinuedFraction (of)

variable {K : Type _} [LinearOrderedField K] {v : K} {n : ℕ}

/-- Given two continuants `pconts` and `conts` and a value `fr`, this function returns
- `conts.a / conts.b` if `fr = 0`
- `exact_conts.a / exact_conts.b` where `exact_conts = next_continuants 1 fr⁻¹ pconts conts`
  otherwise.

This function can be used to compute the exact value approxmated by a continued fraction
`generalized_continued_fraction.of v` as described in lemma
`comp_exact_value_correctness_of_stream_eq_some`.
-/
protected def compExactValue (pconts conts : Pair K) (fr : K) : K :=
  if-- if the fractional part is zero, we exactly approximated the value by the last continuants
        fr =
        0 then
    conts.a / conts.b
  else-- otherwise, we have to include the fractional part in a final continuants step.
    let exact_conts := nextContinuants 1 fr⁻¹ pconts conts
    exact_conts.a / exact_conts.b
#align generalized_continued_fraction.comp_exact_value GeneralizedContinuedFraction.compExactValue

variable [FloorRing K]

/-- Just a computational lemma we need for the next main proof. -/
protected theorem comp_exact_value_correctness_of_stream_eq_some_aux_comp {a : K} (b c : K)
    (fract_a_ne_zero : Int.fract a ≠ 0) :
    ((⌊a⌋ : K) * b + c) / Int.fract a + b = (b * a + c) / Int.fract a :=
  by
  field_simp [fract_a_ne_zero]
  rw [Int.fract]
  ring
#align generalized_continued_fraction.comp_exact_value_correctness_of_stream_eq_some_aux_comp GeneralizedContinuedFraction.comp_exact_value_correctness_of_stream_eq_some_aux_comp

open
  GeneralizedContinuedFraction (compExactValue comp_exact_value_correctness_of_stream_eq_some_aux_comp)

/-- Shows the correctness of `comp_exact_value` in case the continued fraction
`generalized_continued_fraction.of v` did not terminate at position `n`. That is, we obtain the
value `v` if we pass the two successive (auxiliary) continuants at positions `n` and `n + 1` as well
as the fractional part at `int_fract_pair.stream n` to `comp_exact_value`.

The correctness might be seen more readily if one uses `convergents'` to evaluate the continued
fraction. Here is an example to illustrate the idea:

Let `(v : ℚ) := 3.4`. We have
- `generalized_continued_fraction.int_fract_pair.stream v 0 = some ⟨3, 0.4⟩`, and
- `generalized_continued_fraction.int_fract_pair.stream v 1 = some ⟨2, 0.5⟩`.
Now `(generalized_continued_fraction.of v).convergents' 1 = 3 + 1/2`, and our fractional term at
position `2` is `0.5`. We hence have `v = 3 + 1/(2 + 0.5) = 3 + 1/2.5 = 3.4`. This computation
corresponds exactly to the one using the recurrence equation in `comp_exact_value`.
-/
theorem compExactValue_correctness_of_stream_eq_some :
    ∀ {ifp_n : IntFractPair K},
      IntFractPair.stream v n = some ifp_n →
        v = compExactValue ((of v).continuantsAux n) ((of v).continuantsAux <| n + 1) ifp_n.fr :=
  by
  let g := of v
  induction' n with n IH
  · intro ifp_zero stream_zero_eq
    -- nat.zero
    have : int_fract_pair.of v = ifp_zero :=
      by
      have : int_fract_pair.stream v 0 = some (int_fract_pair.of v) := rfl
      simpa only [this] using stream_zero_eq
    cases this
    cases' Decidable.em (Int.fract v = 0) with fract_eq_zero fract_ne_zero
    -- int.fract v = 0; we must then have `v = ⌊v⌋`
    · suffices v = ⌊v⌋ by simpa [continuants_aux, fract_eq_zero, comp_exact_value]
      calc
        v = Int.fract v + ⌊v⌋ := by rw [Int.fract_add_floor]
        _ = ⌊v⌋ := by simp [fract_eq_zero]

    -- int.fract v ≠ 0; the claim then easily follows by unfolding a single computation step
    ·
      field_simp [continuants_aux, next_continuants, next_numerator, next_denominator,
        of_h_eq_floor, comp_exact_value, fract_ne_zero]
  · intro ifp_succ_n succ_nth_stream_eq
    -- nat.succ
    obtain ⟨ifp_n, nth_stream_eq, nth_fract_ne_zero, -⟩ :
      ∃ ifp_n,
        int_fract_pair.stream v n = some ifp_n ∧
          ifp_n.fr ≠ 0 ∧ int_fract_pair.of ifp_n.fr⁻¹ = ifp_succ_n
    exact int_fract_pair.succ_nth_stream_eq_some_iff.elim_left succ_nth_stream_eq
    -- introduce some notation
    let conts := g.continuants_aux (n + 2)
    set pconts := g.continuants_aux (n + 1) with pconts_eq
    set ppconts := g.continuants_aux n with ppconts_eq
    cases' Decidable.em (ifp_succ_n.fr = 0) with ifp_succ_n_fr_eq_zero ifp_succ_n_fr_ne_zero
    -- ifp_succ_n.fr = 0
    · suffices v = conts.a / conts.b by simpa [comp_exact_value, ifp_succ_n_fr_eq_zero]
      -- use the IH and the fact that ifp_n.fr⁻¹ = ⌊ifp_n.fr⁻¹⌋ to prove this case
      obtain ⟨ifp_n', nth_stream_eq', ifp_n_fract_inv_eq_floor⟩ :
        ∃ ifp_n, int_fract_pair.stream v n = some ifp_n ∧ ifp_n.fr⁻¹ = ⌊ifp_n.fr⁻¹⌋
      exact
        int_fract_pair.exists_succ_nth_stream_of_fr_zero succ_nth_stream_eq ifp_succ_n_fr_eq_zero
      have : ifp_n' = ifp_n := by injection Eq.trans nth_stream_eq'.symm nth_stream_eq
      cases this
      have s_nth_eq : g.s.nth n = some ⟨1, ⌊ifp_n.fr⁻¹⌋⟩ :=
        nth_of_eq_some_of_nth_int_fract_pair_stream_fr_ne_zero nth_stream_eq nth_fract_ne_zero
      rw [← ifp_n_fract_inv_eq_floor] at s_nth_eq
      suffices v = comp_exact_value ppconts pconts ifp_n.fr by
        simpa [conts, continuants_aux, s_nth_eq, comp_exact_value, nth_fract_ne_zero] using this
      exact IH nth_stream_eq
    -- ifp_succ_n.fr ≠ 0
    · -- use the IH to show that the following equality suffices
      suffices
        comp_exact_value ppconts pconts ifp_n.fr = comp_exact_value pconts conts ifp_succ_n.fr
        by
        have : v = comp_exact_value ppconts pconts ifp_n.fr := IH nth_stream_eq
        conv_lhs => rw [this]
        assumption
      -- get the correspondence between ifp_n and ifp_succ_n
      obtain ⟨ifp_n', nth_stream_eq', ifp_n_fract_ne_zero, ⟨refl⟩⟩ :
        ∃ ifp_n,
          int_fract_pair.stream v n = some ifp_n ∧
            ifp_n.fr ≠ 0 ∧ int_fract_pair.of ifp_n.fr⁻¹ = ifp_succ_n
      exact int_fract_pair.succ_nth_stream_eq_some_iff.elim_left succ_nth_stream_eq
      have : ifp_n' = ifp_n := by injection Eq.trans nth_stream_eq'.symm nth_stream_eq
      cases this
      -- get the correspondence between ifp_n and g.s.nth n
      have s_nth_eq : g.s.nth n = some ⟨1, (⌊ifp_n.fr⁻¹⌋ : K)⟩ :=
        nth_of_eq_some_of_nth_int_fract_pair_stream_fr_ne_zero nth_stream_eq ifp_n_fract_ne_zero
      -- the claim now follows by unfolding the definitions and tedious calculations
      -- some shorthand notation
      let ppA := ppconts.a
      let ppB := ppconts.b
      let pA := pconts.a
      let pB := pconts.b
      have :
        comp_exact_value ppconts pconts ifp_n.fr =
          (ppA + ifp_n.fr⁻¹ * pA) / (ppB + ifp_n.fr⁻¹ * pB) :=
        by
        -- unfold comp_exact_value and the convergent computation once
        field_simp [ifp_n_fract_ne_zero, comp_exact_value, next_continuants, next_numerator,
          next_denominator]
        ac_rfl
      rw [this]
      -- two calculations needed to show the claim
      have tmp_calc :=
        comp_exact_value_correctness_of_stream_eq_some_aux_comp pA ppA ifp_succ_n_fr_ne_zero
      have tmp_calc' :=
        comp_exact_value_correctness_of_stream_eq_some_aux_comp pB ppB ifp_succ_n_fr_ne_zero
      rw [inv_eq_one_div] at tmp_calc tmp_calc'
      have : Int.fract (1 / ifp_n.fr) ≠ 0 := by simpa using ifp_succ_n_fr_ne_zero
      -- now unfold the recurrence one step and simplify both sides to arrive at the conclusion
      field_simp [conts, comp_exact_value, continuants_aux_recurrence s_nth_eq ppconts_eq pconts_eq,
        next_continuants, next_numerator, next_denominator, this, tmp_calc, tmp_calc']
      ac_rfl
#align generalized_continued_fraction.comp_exact_value_correctness_of_stream_eq_some GeneralizedContinuedFraction.compExactValue_correctness_of_stream_eq_some

open GeneralizedContinuedFraction (of_terminatedAt_n_iff_succ_nth_intFractPair_stream_eq_none)

/-- The convergent of `generalized_continued_fraction.of v` at step `n - 1` is exactly `v` if the
`int_fract_pair.stream` of the corresponding continued fraction terminated at step `n`. -/
theorem of_correctness_of_nth_stream_eq_none (nth_stream_eq_none : IntFractPair.stream v n = none) :
    v = (of v).convergents (n - 1) := by
  induction' n with n IH
  case zero => contradiction
  -- int_fract_pair.stream v 0 ≠ none
  case succ =>
    rename' nth_stream_eq_none => succ_nth_stream_eq_none
    let g := of v
    change v = g.convergents n
    have :
      int_fract_pair.stream v n = none ∨ ∃ ifp, int_fract_pair.stream v n = some ifp ∧ ifp.fr = 0 :=
      int_fract_pair.succ_nth_stream_eq_none_iff.elim_left succ_nth_stream_eq_none
    rcases this with (⟨nth_stream_eq_none⟩ | ⟨ifp_n, nth_stream_eq, nth_stream_fr_eq_zero⟩)
    · cases' n with n'
      · contradiction
      -- int_fract_pair.stream v 0 ≠ none
      · have : g.terminated_at n' :=
          of_terminated_at_n_iff_succ_nth_int_fract_pair_stream_eq_none.elim_right
            nth_stream_eq_none
        have : g.convergents (n' + 1) = g.convergents n' :=
          convergents_stable_of_terminated n'.le_succ this
        rw [this]
        exact IH nth_stream_eq_none
    ·
      simpa [nth_stream_fr_eq_zero, comp_exact_value] using
        comp_exact_value_correctness_of_stream_eq_some nth_stream_eq
#align generalized_continued_fraction.of_correctness_of_nth_stream_eq_none GeneralizedContinuedFraction.of_correctness_of_nth_stream_eq_none

/-- If `generalized_continued_fraction.of v` terminated at step `n`, then the `n`th convergent is
exactly `v`.
-/
theorem of_correctness_of_terminatedAt (terminated_at_n : (of v).TerminatedAt n) :
    v = (of v).convergents n :=
  have : IntFractPair.stream v (n + 1) = none :=
    of_terminatedAt_n_iff_succ_nth_intFractPair_stream_eq_none.left terminated_at_n
  of_correctness_of_nth_stream_eq_none this
#align generalized_continued_fraction.of_correctness_of_terminated_at GeneralizedContinuedFraction.of_correctness_of_terminatedAt

/-- If `generalized_continued_fraction.of v` terminates, then there is `n : ℕ` such that the `n`th
convergent is exactly `v`.
-/
theorem of_correctness_of_terminates (terminates : (of v).Terminates) :
    ∃ n : ℕ, v = (of v).convergents n :=
  Exists.elim terminates fun n terminated_at_n =>
    Exists.intro n (of_correctness_of_terminatedAt terminated_at_n)
#align generalized_continued_fraction.of_correctness_of_terminates GeneralizedContinuedFraction.of_correctness_of_terminates

open Filter

/-- If `generalized_continued_fraction.of v` terminates, then its convergents will eventually always
be `v`.
-/
theorem of_correctness_atTop_of_terminates (terminates : (of v).Terminates) :
    ∀ᶠ n in atTop, v = (of v).convergents n :=
  by
  rw [eventually_at_top]
  obtain ⟨n, terminated_at_n⟩ : ∃ n, (of v).TerminatedAt n
  exact terminates
  use n
  intro m m_geq_n
  rw [convergents_stable_of_terminated m_geq_n terminated_at_n]
  exact of_correctness_of_terminated_at terminated_at_n
#align generalized_continued_fraction.of_correctness_at_top_of_terminates GeneralizedContinuedFraction.of_correctness_atTop_of_terminates

end GeneralizedContinuedFraction


import filter_world.definition --hide

open set --hide
namespace filters --hide

/-
# Level 1: The principal filter of a subset
-/

def principal' {X : Type} (s : set X) := {t | s ⊆ t}

/- Lemma
The collection of subsets defined before have a filter structure.
-/
lemma principal_is_filter {X : Type} (s : set X) : is_filter (principal' s):=
begin
  fconstructor,
  {
    exact subset_univ s
  },
  {
    intros A B hA hAB,
    exact subset.trans hA hAB
  },
  {
    intros A B hA hB,
    exact subset_inter hA hB
  }

end

localized "notation `P` := principal" in filters -- hide

end filters --hide


/-
Copyright (c) 2020 Johan Commelin. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Johan Commelin, Robert Y. Lewis
-/
import Mathlib.PrePort
import Mathlib.Lean3Lib.init.default
import Mathlib.algebra.invertible
import Mathlib.data.mv_polynomial.variables
import Mathlib.data.mv_polynomial.comm_ring
import Mathlib.data.mv_polynomial.expand
import Mathlib.data.zmod.basic
import Mathlib.PostPort

universes u_1 u_2

namespace Mathlib

/-!
# Witt polynomials

To endow `witt_vector p R` with a ring structure,
we need to study the so-called Witt polynomials.

Fix a base value `p : ℕ`.
The `p`-adic Witt polynomials are an infinite family of polynomials
indexed by a natural number `n`, taking values in an arbitrary ring `R`.
The variables of these polynomials are represented by natural numbers.
The variable set of the `n`th Witt polynomial contains at most `n+1` elements `{0, ..., n}`,
with exactly these variables when `R` has characteristic `0`.

These polynomials are used to define the addition and multiplication operators
on the type of Witt vectors. (While this type itself is not complicated,
the ring operations are what make it interesting.)

When the base `p` is invertible in `R`, the `p`-adic Witt polynomials
form a basis for `mv_polynomial ℕ R`, equivalent to the standard basis.

## Main declarations

* `witt_polynomial p R n`: the `n`-th Witt polynomial, viewed as polynomial over the ring `R`
* `X_in_terms_of_W p R n`: if `p` is invertible, the polynomial `X n` is contained in the subalgebra
  generated by the Witt polynomials. `X_in_terms_of_W p R n` is the explicit polynomial,
  which upon being bound to the Witt polynomials yields `X n`.
* `bind₁_witt_polynomial_X_in_terms_of_W`: the proof of the claim that
  `bind₁ (X_in_terms_of_W p R) (W_ R n) = X n`
* `bind₁_X_in_terms_of_W_witt_polynomial`: the converse of the above statement

## Notation

In this file we use the following notation

* `p` is a natural number, typically assumed to be prime.
* `R` and `S` are commutative rings
* `W n` (and `W_ R n` when the ring needs to be explicit) denotes the `n`th Witt polynomial

-/

/-- `witt_polynomial p R n` is the `n`-th Witt polynomial
with respect to a prime `p` with coefficients in a commutative ring `R`.
It is defined as:

`∑_{i ≤ n} p^i X_i^{p^{n-i}} ∈ R[X_0, X_1, X_2, …]`. -/
def witt_polynomial (p : ℕ) (R : Type u_1) [comm_ring R] (n : ℕ) : mv_polynomial ℕ R :=
  finset.sum (finset.range (n + 1))
    fun (i : ℕ) => mv_polynomial.monomial (finsupp.single i (p ^ (n - i))) (↑p ^ i)

theorem witt_polynomial_eq_sum_C_mul_X_pow (p : ℕ) (R : Type u_1) [comm_ring R] (n : ℕ) :
    witt_polynomial p R n =
        finset.sum (finset.range (n + 1))
          fun (i : ℕ) => coe_fn mv_polynomial.C (↑p ^ i) * mv_polynomial.X i ^ p ^ (n - i) :=
  sorry

/-! We set up notation locally to this file, to keep statements short and comprehensible.
This allows us to simply write `W n` or `W_ ℤ n`. -/

-- Notation with ring of coefficients explicit

-- Notation with ring of coefficients implicit

/- The first observation is that the Witt polynomial doesn't really depend on the coefficient ring.
If we map the coefficients through a ring homomorphism, we obtain the corresponding Witt polynomial
over the target ring. -/

@[simp] theorem map_witt_polynomial (p : ℕ) {R : Type u_1} [comm_ring R] {S : Type u_2}
    [comm_ring S] (f : R →+* S) (n : ℕ) :
    coe_fn (mv_polynomial.map f) (witt_polynomial p R n) = witt_polynomial p S n :=
  sorry

@[simp] theorem constant_coeff_witt_polynomial (p : ℕ) (R : Type u_1) [comm_ring R]
    [hp : fact (nat.prime p)] (n : ℕ) :
    coe_fn mv_polynomial.constant_coeff (witt_polynomial p R n) = 0 :=
  sorry

@[simp] theorem witt_polynomial_zero (p : ℕ) (R : Type u_1) [comm_ring R] :
    witt_polynomial p R 0 = mv_polynomial.X 0 :=
  sorry

@[simp] theorem witt_polynomial_one (p : ℕ) (R : Type u_1) [comm_ring R] :
    witt_polynomial p R 1 = coe_fn mv_polynomial.C ↑p * mv_polynomial.X 1 + mv_polynomial.X 0 ^ p :=
  sorry

theorem aeval_witt_polynomial (p : ℕ) (R : Type u_1) [comm_ring R] {A : Type u_2} [comm_ring A]
    [algebra R A] (f : ℕ → A) (n : ℕ) :
    coe_fn (mv_polynomial.aeval f) (witt_polynomial p R n) =
        finset.sum (finset.range (n + 1)) fun (i : ℕ) => ↑p ^ i * f i ^ p ^ (n - i) :=
  sorry

/--
Over the ring `zmod (p^(n+1))`, we produce the `n+1`st Witt polynomial
by expanding the `n`th witt polynomial by `p`.
-/
@[simp] theorem witt_polynomial_zmod_self (p : ℕ) (n : ℕ) :
    witt_polynomial p (zmod (p ^ (n + 1))) (n + 1) =
        coe_fn (mv_polynomial.expand p) (witt_polynomial p (zmod (p ^ (n + 1))) n) :=
  sorry

-- in fact, `0 < p` would be sufficient

theorem witt_polynomial_vars (p : ℕ) (R : Type u_1) [comm_ring R] [hp : fact (nat.prime p)]
    [char_zero R] (n : ℕ) : mv_polynomial.vars (witt_polynomial p R n) = finset.range (n + 1) :=
  sorry

theorem witt_polynomial_vars_subset (p : ℕ) (R : Type u_1) [comm_ring R] [hp : fact (nat.prime p)]
    (n : ℕ) : mv_polynomial.vars (witt_polynomial p R n) ⊆ finset.range (n + 1) :=
  sorry

/-!

## Witt polynomials as a basis of the polynomial algebra

If `p` is invertible in `R`, then the Witt polynomials form a basis
of the polynomial algebra `mv_polynomial ℕ R`.
The polynomials `X_in_terms_of_W` give the coordinate transformation in the backwards direction.
-/

/-- The `X_in_terms_of_W p R n` is the polynomial on the basis of Witt polynomials
that corresponds to the ordinary `X n`. -/
def X_in_terms_of_W (p : ℕ) (R : Type u_1) [comm_ring R] [invertible ↑p] : ℕ → mv_polynomial ℕ R :=
  sorry

theorem X_in_terms_of_W_eq (p : ℕ) (R : Type u_1) [comm_ring R] [invertible ↑p] {n : ℕ} :
    X_in_terms_of_W p R n =
        (mv_polynomial.X n -
            finset.sum (finset.range n)
              fun (i : ℕ) =>
                coe_fn mv_polynomial.C (↑p ^ i) * X_in_terms_of_W p R i ^ p ^ (n - i)) *
          coe_fn mv_polynomial.C (⅟ ^ n) :=
  sorry

@[simp] theorem constant_coeff_X_in_terms_of_W (p : ℕ) (R : Type u_1) [comm_ring R]
    [hp : fact (nat.prime p)] [invertible ↑p] (n : ℕ) :
    coe_fn mv_polynomial.constant_coeff (X_in_terms_of_W p R n) = 0 :=
  sorry

@[simp] theorem X_in_terms_of_W_zero (p : ℕ) (R : Type u_1) [comm_ring R] [invertible ↑p] :
    X_in_terms_of_W p R 0 = mv_polynomial.X 0 :=
  sorry

theorem X_in_terms_of_W_vars_aux (p : ℕ) [hp : fact (nat.prime p)] (n : ℕ) :
    n ∈ mv_polynomial.vars (X_in_terms_of_W p ℚ n) ∧
        mv_polynomial.vars (X_in_terms_of_W p ℚ n) ⊆ finset.range (n + 1) :=
  sorry

theorem X_in_terms_of_W_vars_subset (p : ℕ) [hp : fact (nat.prime p)] (n : ℕ) :
    mv_polynomial.vars (X_in_terms_of_W p ℚ n) ⊆ finset.range (n + 1) :=
  and.right (X_in_terms_of_W_vars_aux p n)

theorem X_in_terms_of_W_aux (p : ℕ) (R : Type u_1) [comm_ring R] [invertible ↑p] (n : ℕ) :
    X_in_terms_of_W p R n * coe_fn mv_polynomial.C (↑p ^ n) =
        mv_polynomial.X n -
          finset.sum (finset.range n)
            fun (i : ℕ) => coe_fn mv_polynomial.C (↑p ^ i) * X_in_terms_of_W p R i ^ p ^ (n - i) :=
  sorry

@[simp] theorem bind₁_X_in_terms_of_W_witt_polynomial (p : ℕ) (R : Type u_1) [comm_ring R]
    [invertible ↑p] (k : ℕ) :
    coe_fn (mv_polynomial.bind₁ (X_in_terms_of_W p R)) (witt_polynomial p R k) =
        mv_polynomial.X k :=
  sorry

@[simp] theorem bind₁_witt_polynomial_X_in_terms_of_W (p : ℕ) (R : Type u_1) [comm_ring R]
    [invertible ↑p] (n : ℕ) :
    coe_fn (mv_polynomial.bind₁ (witt_polynomial p R)) (X_in_terms_of_W p R n) =
        mv_polynomial.X n :=
  sorry

end Mathlib


import algebra.field
import algebra.char_zero
import algebra.char_p
import gtm106.weierstrass_equation.basic
import gtm106.weierstrass_equation.linear_change_of_variable
import myhelper.char
import tactic

namespace weierstrass_equation

/--
An automorphism of an elliptic curve is a linear change of variable
which changes it to itself.
-/
@[ext]
structure automorphism {K : Type*} [field K] (E : weierstrass_equation K) :=
mk :: (C : linear_change_of_variable K) (h : C.change_curve E = E)

namespace automorphism

@[simp]
lemma preserve_curve {K : Type*} [field K] {E : weierstrass_equation K}
(C : automorphism E) : C.C.change_curve E = E := C.h

def identity {K : Type*} [field K] (E : weierstrass_equation K) : automorphism E
:= ⟨ @linear_change_of_variable.identity K _,
  @linear_change_of_variable.change_curve.id K _ E ⟩

def composite {K : Type*} [field K] {E : weierstrass_equation K}
(C C' : automorphism E) : automorphism E
:= ⟨ C.C.composite C'.C, by rw [linear_change_of_variable.change_curve.comp, C'.h, C.h] ⟩

def inverse {K : Type*} [field K] {E : weierstrass_equation K}
(C : automorphism E) : automorphism E
:= ⟨ C.C.inverse, by {
  have h := C.h,
  apply_fun C.C.inverse.change_curve at h,
  rw [← linear_change_of_variable.change_curve.comp,
    linear_change_of_variable.inv_comp,
    linear_change_of_variable.change_curve.id] at h,
  exact h.symm,
} ⟩

instance to_group {K : Type*} [field K] {E : weierstrass_equation K}
: group (automorphism E)
:= ⟨ composite,
  (λ C C' C'', by {
    simp only [has_mul.mul, mul_one_class.mul,
      composite, linear_change_of_variable.comp_assoc],
  }), identity E,
  (λ C, by {
    simp only [has_mul.mul, mul_one_class.mul, has_one.one,
      identity, composite, linear_change_of_variable.id_comp, ext_iff],
  }),
  (λ C, by {
    simp only [has_mul.mul, mul_one_class.mul, has_one.one,
      identity, composite, linear_change_of_variable.comp_id, ext_iff],
  }), inverse,
  (λ C C', C.composite (C'.inverse)), by {
    intros _ _, simp only [has_mul.mul, mul_one_class.mul],
  }, (λ C, by {
    simp only [has_mul.mul, has_inv.inv, mul_one_class.mul, monoid.mul,
      has_one.one, mul_one_class.one, monoid.one,
      identity, composite, inverse, linear_change_of_variable.inv_comp],
  }) ⟩

/--
The automorphism which sends P to -P.
-/
def involution {K : Type*} [field K] (E : weierstrass_equation K)
: automorphism E
:= ⟨ ⟨ -1, 0, -E.a1, -E.a3, by simp ⟩, by {
  simp [linear_change_of_variable.change_curve, weierstrass_equation.ext_iff, zero_pow],
  split, { ring, },
  split, { ring, },
  split, { ring, },
  split, { ring, },
  ring,
} ⟩

@[simp]
lemma involution.is_involution {K : Type*} [field K] (E : weierstrass_equation K)
: (involution E).composite (involution E) = identity E :=
begin
  simp [involution, composite, identity,
    linear_change_of_variable.composite,
    linear_change_of_variable.identity],
end

lemma involution.non_trivial {K : Type*} [field K] (E : weierstrass_equation K)
(h : ring_char K = 2 → E.non_singular')
: involution E ≠ identity E :=
begin
  by_cases hchar2 : ring_char K = 2, {
    simp [involution, identity,
      linear_change_of_variable.identity],
    by_cases ha1 : E.a1 = 0, {
      by_cases ha3 : E.a3 = 0, {
        exfalso,
        replace h := h hchar2,
        simp [non_singular', disc, b2, b4, b6, b8, ha1, ha3, zero_pow] at h,
        ring_char2 at h,
        exact h,
      },
      simp [ha3],
    },
    simp [ha1],
  },
  replace h := prime_neq_char_is_non_zero K 2 (by norm_num) hchar2,
  norm_cast at h,
  replace h : (1:K) ≠ -1 := by {
    intro h0,
    apply_fun has_add.add 1 at h0,
    norm_num at h0,
  },
  simp [involution, identity,
    linear_change_of_variable.identity, h.symm],
end

end automorphism

end weierstrass_equation


variable U: Type
variables R S: U -> Prop
variable j: U

example (P1 : R(j))
        (P2 : forall x,(R(x)->S(x)))
        : S(j):=

show S j, from (show R(j)->S(j), from P2 j) P1.


import Hw10
import Sets.Basic
import Functions.Basic
import Lean.Elab.Print
import Lean.Elab.Command

open Set
open Func

variable (α β γ : Type)
variable (f : α → β) (g : β → γ)
variable (X Y : Set α) (U V : Set β)

theorem desiredType1 (h : U ⊆ V) : f ⁻¹ U ⊆ f ⁻¹ V := by
  intro a h'
  have : f a ∈ V := h (f a) h'
  exact this

theorem desiredType2 (h₁ : α ≅ β) (h₂ : β ≅ γ) : α ≅ γ := by
  have ⟨f,u⟩ := h₁
  have ⟨g,v⟩ := h₂
  have l : Bijective (g ∘ f) := by
    have (inj : Injective (g ∘ f)) := inj_comp u.left v.left
    have (surj : Surjective (g ∘ f)) := surj_comp u.right v.right
    exact ⟨inj,surj⟩
  exact ⟨g ∘ f,l⟩

theorem desiredType3 (h : Surjective f) : HasRightInv f := by
  let g : β → α := by
    intro b
    have : ∃ a, f a = b := h b
    have (a : α) := Classical.choose this
    exact a
  have (l : f ∘ g = id) := by
    apply funext
    intro b
    have u : g b = Classical.choose (h b) := by rfl
    have v : f (Classical.choose (h b)) = b := Classical.choose_spec (h b)
    calc
      f (g b) = f (Classical.choose (h b))  := by rw [u]
      _       = b                           := by rw [v]
  exact ⟨g,l⟩

theorem desiredType4 (f : α → β) (g : β → γ) (d : LeftInverse f) (e : LeftInverse g) :
  (d.to_fun ∘ e.to_fun) ∘ (g ∘ f) = id := sorry

theorem desiredType5 (h : α ≅ β) : β ≅ α := sorry

open Lean
open Lean.Meta
open Lean.Elab.Command

def n : String := "4"

def problem : String := "problem"++n

def desired : String := "desiredType"++n

def collectAxiomsOf (constName : Name) : MetaM (List String) := do
  let env ← getEnv
  let (_, s) := ((CollectAxioms.collect constName).run env).run {}
  let a := s.axioms.toList.map toString
  return a

#eval isDefEq (Expr.const desired []) (Expr.const problem [])
#eval collectAxiomsOf problem


import guidelines.definitions
import guidelines.protocol
import guidelines.requirements
import data.finset.basic

variables {sys_state_t pid_t ballot_t value_t : Type}
          [linear_order ballot_t] [decidable_eq pid_t]

-- The first variant says that if two values are chosen at the same state, then they must be the
-- same value.
def safety (proto : protocol sys_state_t) (defs : paxos_defs sys_state_t pid_t ballot_t value_t)
  := proto.invariant (λ state, (∀ v v', defs.chosen state v → defs.chosen state v' → v = v'))

-- The second variant says that if a value is chosen at one state and another value is chosen at a
-- later state, then both must be the same value.
def safety_v2 (proto : protocol sys_state_t) (defs : paxos_defs sys_state_t pid_t ballot_t value_t)
  := proto.invariant (λ s, (∀ s' v v',
                        proto.reachable_from s s' → defs.chosen s v → defs.chosen s' v' → v = v'))

variables {proto : protocol sys_state_t} {defs : paxos_defs sys_state_t pid_t ballot_t value_t}

lemma proposed_higher_than_chosen_has_same_val
  (reqs_sat : requirements proto defs) : proto.invariant (λ state,
    ∀ b v,
      defs.chosen_ballot state b → defs.proposed state b v →
      ∀ (b' > b) v', defs.proposed state b' v' → v = v') :=
begin
suffices fact : proto.invariant
  (λ state, ∀ b v,
    defs.choosable state b → defs.proposed state b v →
      ∀ (b' > b) v', defs.proposed state b' v' → v = v'),
by {
  intros state state_r b v cond,
  exact fact state state_r b v (defs.chosen_imp_choosable cond)
},
rw protocol.prove_invariant,
split,
{ intros s s_init b v __ proposed_s_b_v,
  exfalso, exact reqs_sat.none_proposed_at_init s b v s_init proposed_s_b_v },
intros u u_reachable w inv_at_u u_n_w b v b_choosable
  b_v_proposed_at_w b' b'_gt_b v' b'_v'_proposed_at_w,

have b_choosable_at_u : defs.choosable u b, by {
  rcases b_choosable with ⟨q, q_quorum, all_q_voted_or_may_vote⟩,
  use [q, q_quorum],
  intros voter voter_in_q, specialize all_q_voted_or_may_vote voter voter_in_q,
  cases all_q_voted_or_may_vote with voted_in_w curr_in_w_le_b,
  { exact reqs_sat.new_votes_ge_curr_ballot voter b w u u_reachable u_n_w voted_in_w },
  right, exact le_trans (reqs_sat.curr_increases voter w u u_reachable u_n_w) curr_in_w_le_b
},

specialize inv_at_u b v b_choosable_at_u,

rcases reqs_sat.at_most_one_proposal_per_step w u u_reachable u_n_w with ⟨bp, vp, hyp⟩,
cases hyp b' v' b'_v'_proposed_at_w,
{ have b_v_proposed : defs.proposed u b v, by {
    rcases reqs_sat.at_most_one_proposal_per_step w u u_reachable u_n_w with ⟨b_p, v_p, fact⟩,
    cases fact b' v' b'_v'_proposed_at_w with fact_prime fact_prime,
    { clear fact,
      rcases reachable_implies_reachable_in_proto_with_intervals_recorded defs proto u u_reachable
        with ⟨lift_u, lift_u_reachable, lift_u_is_lift⟩,
      have key := reqs_sat.majority_have_upper_interval_if_proposed b' v' lift_u lift_u_reachable,
      rw lift_u_is_lift at key,
      specialize key fact_prime,
      rcases key with ⟨q, promised, q_quorum, all_quorum_promised, rest⟩, clear rest,
      rcases b_choosable_at_u with ⟨q', q'_quorum, all_q'_may_vote⟩,
      rcases reqs_sat.quorums_intersect q q' q_quorum q'_quorum with ⟨a, a_in_both⟩,
      rw finset.mem_inter at a_in_both, cases a_in_both with a_promised a_may_vote,
      specialize all_quorum_promised a a_promised,
      specialize all_q'_may_vote a a_may_vote,
      cases all_q'_may_vote with h impossible,
      { rcases reqs_sat.voted_imp_proposed a b u u_reachable h with ⟨v'', hv''⟩,
        have vals_eq := reqs_sat.proposals_unique b v v'' w
          (by { cases u_reachable with k hk, exact ⟨k.succ, u, hk, u_n_w⟩}) b_v_proposed_at_w
          (reqs_sat.proposed_stable b v'' u w hv'' u_n_w),
        rw vals_eq, exact hv'' },
      rw ← lift_u_is_lift at impossible,
      have := le_trans
        (reqs_sat.all_upper_le_curr a lift_u lift_u_reachable
           {upper := b', lower := promised a} all_quorum_promised b' (by refl))
        impossible,
      exact absurd this (not_le_of_lt b'_gt_b) },
    cases fact b v b_v_proposed_at_w with fact_orig fact_orig,
    { exact fact_orig },
    exact absurd (eq.trans fact_orig.left (eq.symm fact_prime.left)) (ne_of_lt b'_gt_b) },
  exact inv_at_u b_v_proposed b' b'_gt_b v' h },
rw ← h.left at hyp, rw ← h.right at hyp, clear h bp vp,

have w_reachable : proto.reachable w,
by { rcases u_reachable with ⟨k, hk⟩, exact ⟨k.succ, u, hk, u_n_w⟩ },

rcases reachable_implies_reachable_in_proto_with_intervals_recorded defs proto w w_reachable
      with ⟨lift_w, lift_w_reachable, lift_w_is_lift⟩,

have key := reqs_sat.majority_have_upper_interval_if_proposed b' v' lift_w lift_w_reachable,
rw lift_w_is_lift at key,
specialize key b'_v'_proposed_at_w,
rcases key with ⟨q, promised, q_quorum, promised_is_lower_endpoint,
                    promised_lt_b', v'_is_max_val⟩,
rcases b_choosable with ⟨q', q'_quorum, q'_can_vote⟩,
rcases reqs_sat.quorums_intersect q q' q_quorum q'_quorum with ⟨a, a_in_both⟩,
rw finset.mem_inter at a_in_both,
cases a_in_both with a_promised a_voted,
specialize q'_can_vote a a_voted, clear a_voted q_quorum q'_quorum,
have a_voted : defs.voted w a b, by {
  cases q'_can_vote,
  { exact q'_can_vote },
  have key := reqs_sat.all_upper_le_curr a lift_w lift_w_reachable
    {upper := b', lower := promised a} (promised_is_lower_endpoint a a_promised) b' (by refl),
  rw lift_w_is_lift at key,
  exact absurd (le_trans key q'_can_vote) (not_le_of_lt b'_gt_b)
}, clear q'_can_vote q',

have key := reqs_sat.none_voted_in_interval a b lift_w lift_w_reachable {upper := b', lower := promised a} (promised_is_lower_endpoint a a_promised),
rw lift_w_is_lift at key,
specialize key a_voted,
cases key, swap,
{ exact absurd b'_gt_b (not_lt_of_le key) },
rcases key with ⟨prop_a, prop_a_is_lower, prop_a_bal_ge_b⟩,
unfold interval.lower at prop_a_is_lower,

cases v'_is_max_val with impossible,
{ specialize impossible a a_promised, rw prop_a_is_lower at impossible, injection impossible },

rcases v'_is_max_val
  with ⟨max, max_in_quorum, p_max, p_max_is_prop_for_max, p_max_highest_bal, p_max_v_is_v'⟩,
specialize p_max_highest_bal a a_promised prop_a prop_a_is_lower,
specialize promised_lt_b' max max_in_quorum p_max p_max_is_prop_for_max,

have p_max_proposed_at_w : defs.proposed w p_max.b p_max.v, by {
  specialize promised_is_lower_endpoint max max_in_quorum,
  rw p_max_is_prop_for_max at promised_is_lower_endpoint,
  have := reqs_sat.all_lower_proposed max lift_w lift_w_reachable {upper := b', lower := some p_max} promised_is_lower_endpoint p_max (by refl),
  rw lift_w_is_lift at this, exact this
},

cases le_iff_lt_or_eq.mp (le_trans prop_a_bal_ge_b p_max_highest_bal) with is_lt is_eq, swap,
{ rw ← is_eq at p_max_proposed_at_w,
  have := reqs_sat.proposals_unique b v p_max.v w w_reachable b_v_proposed_at_w p_max_proposed_at_w,
  exact eq.trans this p_max_v_is_v' },

specialize inv_at_u
  (by { cases (hyp b v b_v_proposed_at_w) , { exact h }, exact absurd h.left (ne_of_lt b'_gt_b) }),
specialize inv_at_u p_max.b is_lt p_max.v,
specialize inv_at_u
  (by { cases (hyp p_max.b p_max.v p_max_proposed_at_w), { exact h }, exact absurd h.left (ne_of_lt promised_lt_b') }),

exact eq.trans inv_at_u p_max_v_is_v'
end

theorem requirements_give_safety : requirements proto defs → safety proto defs :=
begin
intro reqs_sat,
intros s reach_s v v' v_chosen v'_chosen,
rcases v_chosen with ⟨b, b_chosen, b_v_prop⟩,
rcases v'_chosen with ⟨b', b'_chosen, b'_v'_prop⟩,
cases lt_trichotomy b b' with is_lt is_eq_or_is_lt,
{ exact proposed_higher_than_chosen_has_same_val reqs_sat s reach_s b v b_chosen b_v_prop b' is_lt v' b'_v'_prop },
cases is_eq_or_is_lt with is_eq is_lt,
{ apply reqs_sat.proposals_unique b v v' s reach_s b_v_prop,
  rw is_eq, exact b'_v'_prop },
exact eq.symm (proposed_higher_than_chosen_has_same_val reqs_sat s reach_s b' v' b'_chosen b'_v'_prop b is_lt v b_v_prop)
end

theorem requirements_give_safety_v2 : requirements proto defs → safety_v2 proto defs :=
begin
intro reqs_sat,
intros s s_reachable s' v v' s'_reachable_from_s v_chosen_at_s v'_chosen_at_s',
have v_chosen_at_s' : defs.chosen s' v
  := proto.stability_applies_to_reachable_from (λ s, defs.chosen s v)
                                               (reqs_sat.chosen_stable v) s s' s'_reachable_from_s v_chosen_at_s,
have s'_reachable : proto.reachable s' := proto.reachable_from_reachable_is_reachable s s' s_reachable s'_reachable_from_s,
exact requirements_give_safety reqs_sat s' s'_reachable v v' v_chosen_at_s' v'_chosen_at_s',
end


/-
Copyright (c) 2020 Bryan Gin-ge Chen. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Bryan Gin-ge Chen, Kevin Lacker
-/
import Mathlib.PrePort
import Mathlib.Lean3Lib.init.default
import Mathlib.tactic.ring
import Mathlib.PostPort

universes u_1

namespace Mathlib

/-!
# Identities

This file contains some "named" commutative ring identities.
-/

/--
Brahmagupta-Fibonacci identity or Diophantus identity, see
<https://en.wikipedia.org/wiki/Brahmagupta%E2%80%93Fibonacci_identity>.

This sign choice here corresponds to the signs obtained by multiplying two complex numbers.
-/
theorem pow_two_add_pow_two_mul_pow_two_add_pow_two {R : Type u_1} [comm_ring R] {x₁ : R} {x₂ : R} {y₁ : R} {y₂ : R} : (x₁ ^ bit0 1 + x₂ ^ bit0 1) * (y₁ ^ bit0 1 + y₂ ^ bit0 1) = (x₁ * y₁ - x₂ * y₂) ^ bit0 1 + (x₁ * y₂ + x₂ * y₁) ^ bit0 1 := sorry

/--
Brahmagupta's identity, see <https://en.wikipedia.org/wiki/Brahmagupta%27s_identity>
-/
theorem pow_two_add_mul_pow_two_mul_pow_two_add_mul_pow_two {R : Type u_1} [comm_ring R] {x₁ : R} {x₂ : R} {y₁ : R} {y₂ : R} {n : R} : (x₁ ^ bit0 1 + n * x₂ ^ bit0 1) * (y₁ ^ bit0 1 + n * y₂ ^ bit0 1) =
  (x₁ * y₁ - n * x₂ * y₂) ^ bit0 1 + n * (x₁ * y₂ + x₂ * y₁) ^ bit0 1 := sorry

/--
Sophie Germain's identity, see <https://www.cut-the-knot.org/blue/SophieGermainIdentity.shtml>.
-/
theorem pow_four_add_four_mul_pow_four {R : Type u_1} [comm_ring R] {a : R} {b : R} : a ^ bit0 (bit0 1) + bit0 (bit0 1) * b ^ bit0 (bit0 1) =
  ((a - b) ^ bit0 1 + b ^ bit0 1) * ((a + b) ^ bit0 1 + b ^ bit0 1) := sorry

/--
Sophie Germain's identity, see <https://www.cut-the-knot.org/blue/SophieGermainIdentity.shtml>.
-/
theorem pow_four_add_four_mul_pow_four' {R : Type u_1} [comm_ring R] {a : R} {b : R} : a ^ bit0 (bit0 1) + bit0 (bit0 1) * b ^ bit0 (bit0 1) =
  (a ^ bit0 1 - bit0 1 * a * b + bit0 1 * b ^ bit0 1) * (a ^ bit0 1 + bit0 1 * a * b + bit0 1 * b ^ bit0 1) := sorry

/--
Euler's four-square identity, see <https://en.wikipedia.org/wiki/Euler%27s_four-square_identity>.

This sign choice here corresponds to the signs obtained by multiplying two quaternions.
-/
theorem sum_four_sq_mul_sum_four_sq {R : Type u_1} [comm_ring R] {x₁ : R} {x₂ : R} {x₃ : R} {x₄ : R} {y₁ : R} {y₂ : R} {y₃ : R} {y₄ : R} : (x₁ ^ bit0 1 + x₂ ^ bit0 1 + x₃ ^ bit0 1 + x₄ ^ bit0 1) * (y₁ ^ bit0 1 + y₂ ^ bit0 1 + y₃ ^ bit0 1 + y₄ ^ bit0 1) =
  (x₁ * y₁ - x₂ * y₂ - x₃ * y₃ - x₄ * y₄) ^ bit0 1 + (x₁ * y₂ + x₂ * y₁ + x₃ * y₄ - x₄ * y₃) ^ bit0 1 +
      (x₁ * y₃ - x₂ * y₄ + x₃ * y₁ + x₄ * y₂) ^ bit0 1 +
    (x₁ * y₄ + x₂ * y₃ - x₃ * y₂ + x₄ * y₁) ^ bit0 1 := sorry

/--
Degen's eight squares identity, see <https://en.wikipedia.org/wiki/Degen%27s_eight-square_identity>.

This sign choice here corresponds to the signs obtained by multiplying two octonions.
-/
theorem sum_eight_sq_mul_sum_eight_sq {R : Type u_1} [comm_ring R] {x₁ : R} {x₂ : R} {x₃ : R} {x₄ : R} {x₅ : R} {x₆ : R} {x₇ : R} {x₈ : R} {y₁ : R} {y₂ : R} {y₃ : R} {y₄ : R} {y₅ : R} {y₆ : R} {y₇ : R} {y₈ : R} : (x₁ ^ bit0 1 + x₂ ^ bit0 1 + x₃ ^ bit0 1 + x₄ ^ bit0 1 + x₅ ^ bit0 1 + x₆ ^ bit0 1 + x₇ ^ bit0 1 + x₈ ^ bit0 1) *
    (y₁ ^ bit0 1 + y₂ ^ bit0 1 + y₃ ^ bit0 1 + y₄ ^ bit0 1 + y₅ ^ bit0 1 + y₆ ^ bit0 1 + y₇ ^ bit0 1 + y₈ ^ bit0 1) =
  (x₁ * y₁ - x₂ * y₂ - x₃ * y₃ - x₄ * y₄ - x₅ * y₅ - x₆ * y₆ - x₇ * y₇ - x₈ * y₈) ^ bit0 1 +
                (x₁ * y₂ + x₂ * y₁ + x₃ * y₄ - x₄ * y₃ + x₅ * y₆ - x₆ * y₅ - x₇ * y₈ + x₈ * y₇) ^ bit0 1 +
              (x₁ * y₃ - x₂ * y₄ + x₃ * y₁ + x₄ * y₂ + x₅ * y₇ + x₆ * y₈ - x₇ * y₅ - x₈ * y₆) ^ bit0 1 +
            (x₁ * y₄ + x₂ * y₃ - x₃ * y₂ + x₄ * y₁ + x₅ * y₈ - x₆ * y₇ + x₇ * y₆ - x₈ * y₅) ^ bit0 1 +
          (x₁ * y₅ - x₂ * y₆ - x₃ * y₇ - x₄ * y₈ + x₅ * y₁ + x₆ * y₂ + x₇ * y₃ + x₈ * y₄) ^ bit0 1 +
        (x₁ * y₆ + x₂ * y₅ - x₃ * y₈ + x₄ * y₇ - x₅ * y₂ + x₆ * y₁ - x₇ * y₄ + x₈ * y₃) ^ bit0 1 +
      (x₁ * y₇ + x₂ * y₈ + x₃ * y₅ - x₄ * y₆ - x₅ * y₃ + x₆ * y₄ + x₇ * y₁ - x₈ * y₂) ^ bit0 1 +
    (x₁ * y₈ - x₂ * y₇ + x₃ * y₆ + x₄ * y₅ - x₅ * y₄ - x₆ * y₃ + x₇ * y₂ + x₈ * y₁) ^ bit0 1 := sorry


import algebra.order

universe u
variables {α : Type u}
variables [decidable_linear_order α]

lemma cmp_eq_eq (a b : α)
: cmp a b = ordering.eq = (a = b) :=
by { simp [cmp,cmp_using_eq_eq], rw ← le_antisymm_iff, cc }


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

! This file was ported from Lean 3 source module topology.algebra.constructions
! leanprover-community/mathlib commit c10e724be91096453ee3db13862b9fb9a992fef2
! Please do not edit these lines, except to modify the commit id
! if you have ported upstream changes.
-/
import Mathlib.Topology.Homeomorph

/-!
# Topological space structure on the opposite monoid and on the units group

In this file we define `TopologicalSpace` structure on `Mᵐᵒᵖ`, `Mᵃᵒᵖ`, `Mˣ`, and `add_units M`.
This file does not import definitions of a topological monoid and/or a continuous multiplicative
action, so we postpone the proofs of `HasContinuousMul Mᵐᵒᵖ` etc till we have these definitions.

## Tags

topological space, opposite monoid, units
-/

variable {M X : Type _}

open Filter Topology

namespace MulOpposite

/-- Put the same topological space structure on the opposite monoid as on the original space. -/
@[to_additive "Put the same topological space structure on the opposite monoid as on the original
space."]
instance [TopologicalSpace M] : TopologicalSpace Mᵐᵒᵖ :=
  TopologicalSpace.induced (unop : Mᵐᵒᵖ → M) ‹_›

variable [TopologicalSpace M]

@[to_additive (attr := continuity)]
theorem continuous_unop : Continuous (unop : Mᵐᵒᵖ → M) :=
  continuous_induced_dom
#align mul_opposite.continuous_unop MulOpposite.continuous_unop
#align add_opposite.continuous_unop AddOpposite.continuous_unop

@[to_additive (attr := continuity)]
theorem continuous_op : Continuous (op : M → Mᵐᵒᵖ) :=
  continuous_induced_rng.2 continuous_id
#align mul_opposite.continuous_op MulOpposite.continuous_op
#align add_opposite.continuous_op AddOpposite.continuous_op

/-- `MulOpposite.op` as a homeomorphism. -/
@[to_additive (attr := simps!) "`AddOpposite.op` as a homeomorphism."]
def opHomeomorph : M ≃ₜ Mᵐᵒᵖ where
  toEquiv := opEquiv
  continuous_toFun := continuous_op
  continuous_invFun := continuous_unop
#align mul_opposite.op_homeomorph MulOpposite.opHomeomorph
#align add_opposite.op_homeomorph AddOpposite.opHomeomorph

@[to_additive]
instance [T2Space M] : T2Space Mᵐᵒᵖ :=
  opHomeomorph.symm.embedding.t2Space

@[to_additive (attr := simp)]
theorem map_op_nhds (x : M) : map (op : M → Mᵐᵒᵖ) (𝓝 x) = 𝓝 (op x) :=
  opHomeomorph.map_nhds_eq x
#align mul_opposite.map_op_nhds MulOpposite.map_op_nhds
#align add_opposite.map_op_nhds AddOpposite.map_op_nhds

@[to_additive (attr := simp)]
theorem map_unop_nhds (x : Mᵐᵒᵖ) : map (unop : Mᵐᵒᵖ → M) (𝓝 x) = 𝓝 (unop x) :=
  opHomeomorph.symm.map_nhds_eq x
#align mul_opposite.map_unop_nhds MulOpposite.map_unop_nhds
#align add_opposite.map_unop_nhds AddOpposite.map_unop_nhds

@[to_additive (attr := simp)]
theorem comap_op_nhds (x : Mᵐᵒᵖ) : comap (op : M → Mᵐᵒᵖ) (𝓝 x) = 𝓝 (unop x) :=
  opHomeomorph.comap_nhds_eq x
#align mul_opposite.comap_op_nhds MulOpposite.comap_op_nhds
#align add_opposite.comap_op_nhds AddOpposite.comap_op_nhds

@[to_additive (attr := simp)]
theorem comap_unop_nhds (x : M) : comap (unop : Mᵐᵒᵖ → M) (𝓝 x) = 𝓝 (op x) :=
  opHomeomorph.symm.comap_nhds_eq x
#align mul_opposite.comap_unop_nhds MulOpposite.comap_unop_nhds
#align add_opposite.comap_unop_nhds AddOpposite.comap_unop_nhds

end MulOpposite

namespace Units

open MulOpposite

variable [TopologicalSpace M] [Monoid M] [TopologicalSpace X]

/-- The units of a monoid are equipped with a topology, via the embedding into `M × M`. -/
@[to_additive "The additive units of a monoid are equipped with a topology, via the embedding into
`M × M`."]
instance : TopologicalSpace Mˣ :=
  TopologicalSpace.induced (embedProduct M) inferInstance

@[to_additive]

@[to_additive]
theorem embedding_embedProduct : Embedding (embedProduct M) :=
  ⟨inducing_embedProduct, embedProduct_injective M⟩
#align units.embedding_embed_product Units.embedding_embedProduct
#align add_units.embedding_embed_product AddUnits.embedding_embedProduct

@[to_additive] lemma topology_eq_inf :
    instTopologicalSpaceUnits =
      .induced (val : Mˣ → M) ‹_› ⊓ .induced (fun u ↦ ↑u⁻¹ : Mˣ → M) ‹_› := by
  simp only [inducing_embedProduct.1, instTopologicalSpaceProd, induced_inf,
    instTopologicalSpaceMulOpposite, induced_compose]; rfl
#align units.topology_eq_inf Units.topology_eq_inf
#align add_units.topology_eq_inf AddUnits.topology_eq_inf

/-- An auxiliary lemma that can be used to prove that coercion `Mˣ → M` is a topological embedding.
Use `Units.embedding_val₀`, `Units.embedding_val`, or `toUnits_homeomorph` instead. -/
@[to_additive "An auxiliary lemma that can be used to prove that coercion `AddUnits M → M` is a
topological embedding. Use `AddUnits.embedding_val` or `toAddUnits_homeomorph` instead."]
lemma embedding_val_mk {M : Type _} [DivisionMonoid M] [TopologicalSpace M]
    (h : ContinuousOn Inv.inv {x : M | IsUnit x}) : Embedding (val : Mˣ → M) := by
  refine ⟨⟨?_⟩, ext⟩
  rw [topology_eq_inf, inf_eq_left, ← continuous_iff_le_induced,
    @continuous_iff_continuousAt _ _ (.induced _ _)]
  intros u s hs
  simp only [val_inv_eq_inv_val, nhds_induced, Filter.mem_map] at hs ⊢
  exact ⟨_, mem_inf_principal.1 (h u u.isUnit hs), fun u' hu' ↦ hu' u'.isUnit⟩
#align units.embedding_coe_mk Units.embedding_val_mk
#align add_units.embedding_coe_mk AddUnits.embedding_val_mk

@[to_additive]
theorem continuous_embedProduct : Continuous (embedProduct M) :=
  continuous_induced_dom
#align units.continuous_embed_product Units.continuous_embedProduct
#align add_units.continuous_embed_product AddUnits.continuous_embedProduct

@[to_additive]
theorem continuous_val : Continuous ((↑) : Mˣ → M) :=
  (@continuous_embedProduct M _ _).fst
#align units.continuous_coe Units.continuous_val
#align add_units.continuous_coe AddUnits.continuous_val

@[to_additive]
protected theorem continuous_iff {f : X → Mˣ} :
    Continuous f ↔ Continuous (val ∘ f) ∧ Continuous (fun x => ↑(f x)⁻¹ : X → M) := by
  simp only [inducing_embedProduct.continuous_iff, embedProduct_apply, (· ∘ ·),
    continuous_prod_mk, opHomeomorph.symm.inducing.continuous_iff, opHomeomorph_symm_apply,
    unop_op]
#align units.continuous_iff Units.continuous_iff
#align add_units.continuous_iff AddUnits.continuous_iff

@[to_additive]
theorem continuous_coe_inv : Continuous (fun u => ↑u⁻¹ : Mˣ → M) :=
  (Units.continuous_iff.1 continuous_id).2
#align units.continuous_coe_inv Units.continuous_coe_inv
#align add_units.continuous_coe_neg AddUnits.continuous_coe_neg

end Units


/-
Copyright (c) 2020 Simon Hudon. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Simon Hudon
-/
import control.monad.basic
import data.part
import order.preorder_hom
import tactic.monotonicity
import tactic.wlog

/-!
# Omega Complete Partial Orders

An omega-complete partial order is a partial order with a supremum
operation on increasing sequences indexed by natural numbers (which we
call `ωSup`). In this sense, it is strictly weaker than join complete
semi-lattices as only ω-sized totally ordered sets have a supremum.

The concept of an omega-complete partial order (ωCPO) is useful for the
formalization of the semantics of programming languages. Its notion of
supremum helps define the meaning of recursive procedures.

## Main definitions

 * class `omega_complete_partial_order`
 * `ite`, `map`, `bind`, `seq` as continuous morphisms

## Instances of `omega_complete_partial_order`

 * `part`
 * every `complete_lattice`
 * pi-types
 * product types
 * `monotone_hom`
 * `continuous_hom` (with notation →𝒄)
   * an instance of `omega_complete_partial_order (α →𝒄 β)`
 * `continuous_hom.of_fun`
 * `continuous_hom.of_mono`
 * continuous functions:
   * `id`
   * `ite`
   * `const`
   * `part.bind`
   * `part.map`
   * `part.seq`

## References

 * [Chain-complete posets and directed sets with applications][markowsky1976]
 * [Recursive definitions of partial functions and their computations][cadiou1972]
 * [Semantics of Programming Languages: Structures and Techniques][gunter1992]
-/

universes u v

local attribute [-simp] part.bind_eq_bind part.map_eq_map
open_locale classical

namespace preorder_hom

variables (α : Type*) (β : Type*) {γ : Type*} {φ : Type*}
variables [preorder α] [preorder β] [preorder γ] [preorder φ]

variables {β γ}

variables {α} {α' : Type*} {β' : Type*} [preorder α'] [preorder β']

/-- `part.bind` as a monotone function -/
@[simps]
def bind {β γ} (f : α →ₘ part β) (g : α →ₘ β → part γ) : α →ₘ part γ :=
{ to_fun := λ x, f x >>= g x,
  monotone' :=
  begin
    intros x y h a,
    simp only [and_imp, exists_prop, part.bind_eq_bind, part.mem_bind_iff,
               exists_imp_distrib],
    intros b hb ha,
    refine ⟨b, f.monotone h _ hb, g.monotone h _ _ ha⟩,
  end }

end preorder_hom

namespace omega_complete_partial_order

/-- A chain is a monotone sequence.

See the definition on page 114 of [gunter1992]. -/
def chain (α : Type u) [preorder α] :=
ℕ →ₘ α

namespace chain

variables {α : Type u} {β : Type v} {γ : Type*}
variables [preorder α] [preorder β] [preorder γ]

instance : has_coe_to_fun (chain α) (λ _, ℕ → α) := preorder_hom.has_coe_to_fun

instance [inhabited α] : inhabited (chain α) :=
⟨ ⟨ λ _, default _, λ _ _ _, le_refl _ ⟩ ⟩

instance : has_mem α (chain α) :=
⟨λa (c : ℕ →ₘ α), ∃ i, a = c i⟩

variables (c c' : chain α)
variables (f : α →ₘ β)
variables (g : β →ₘ γ)

instance : has_le (chain α) :=
{ le := λ x y, ∀ i, ∃ j, x i ≤ y j }

/-- `map` function for `chain` -/
@[simps {fully_applied := ff}] def map : chain β :=
f.comp c

variables {f}

lemma mem_map (x : α) : x ∈ c → f x ∈ chain.map c f :=
λ ⟨i,h⟩, ⟨i, h.symm ▸ rfl⟩

lemma exists_of_mem_map {b : β} : b ∈ c.map f → ∃ a, a ∈ c ∧ f a = b :=
λ ⟨i,h⟩, ⟨c i, ⟨i, rfl⟩, h.symm⟩

lemma mem_map_iff {b : β} : b ∈ c.map f ↔ ∃ a, a ∈ c ∧ f a = b :=
⟨ exists_of_mem_map _, λ h, by { rcases h with ⟨w,h,h'⟩, subst b, apply mem_map c _ h, } ⟩

@[simp]
lemma map_id : c.map preorder_hom.id = c :=
preorder_hom.comp_id _

lemma map_comp : (c.map f).map g = c.map (g.comp f) := rfl

@[mono]
lemma map_le_map {g : α →ₘ β} (h : f ≤ g) : c.map f ≤ c.map g :=
λ i, by simp [mem_map_iff]; intros; existsi i; apply h

/-- `chain.zip` pairs up the elements of two chains that have the same index -/
@[simps]
def zip (c₀ : chain α) (c₁ : chain β) : chain (α × β) :=
preorder_hom.prod c₀ c₁

end chain

end omega_complete_partial_order

open omega_complete_partial_order

section prio
set_option extends_priority 50

/-- An omega-complete partial order is a partial order with a supremum
operation on increasing sequences indexed by natural numbers (which we
call `ωSup`). In this sense, it is strictly weaker than join complete
semi-lattices as only ω-sized totally ordered sets have a supremum.

See the definition on page 114 of [gunter1992]. -/
class omega_complete_partial_order (α : Type*) extends partial_order α :=
(ωSup     : chain α → α)
(le_ωSup  : ∀(c:chain α), ∀ i, c i ≤ ωSup c)
(ωSup_le  : ∀(c:chain α) x, (∀ i, c i ≤ x) → ωSup c ≤ x)

end prio

namespace omega_complete_partial_order
variables {α : Type u} {β : Type v} {γ : Type*}
variables [omega_complete_partial_order α]

/-- Transfer a `omega_complete_partial_order` on `β` to a `omega_complete_partial_order` on `α`
using a strictly monotone function `f : β →ₘ α`, a definition of ωSup and a proof that `f` is
continuous with regard to the provided `ωSup` and the ωCPO on `α`. -/
@[reducible]
protected def lift [partial_order β] (f : β →ₘ α)
  (ωSup₀ : chain β → β)
  (h : ∀ x y, f x ≤ f y → x ≤ y)
  (h' : ∀ c, f (ωSup₀ c) = ωSup (c.map f)) : omega_complete_partial_order β :=
{ ωSup := ωSup₀,
  ωSup_le := λ c x hx, h _ _ (by rw h'; apply ωSup_le; intro; apply f.monotone (hx i)),
  le_ωSup := λ c i, h _ _ (by rw h'; apply le_ωSup (c.map f)) }

lemma le_ωSup_of_le {c : chain α} {x : α} (i : ℕ) (h : x ≤ c i) : x ≤ ωSup c :=
le_trans h (le_ωSup c _)

lemma ωSup_total {c : chain α} {x : α} (h : ∀ i, c i ≤ x ∨ x ≤ c i) : ωSup c ≤ x ∨ x ≤ ωSup c :=
classical.by_cases
  (assume : ∀ i, c i ≤ x, or.inl (ωSup_le _ _ this))
  (assume : ¬ ∀ i, c i ≤ x,
    have ∃ i, ¬ c i ≤ x,
      by simp only [not_forall] at this ⊢; assumption,
    let ⟨i, hx⟩ := this in
    have x ≤ c i, from (h i).resolve_left hx,
    or.inr $ le_ωSup_of_le _ this)

@[mono]
lemma ωSup_le_ωSup_of_le {c₀ c₁ : chain α} (h : c₀ ≤ c₁) : ωSup c₀ ≤ ωSup c₁ :=
ωSup_le _ _ $
λ i, Exists.rec_on (h i) $
λ j h, le_trans h (le_ωSup _ _)

lemma ωSup_le_iff (c : chain α) (x : α) : ωSup c ≤ x ↔ (∀ i, c i ≤ x) :=
begin
  split; intros,
  { transitivity ωSup c,
    exact le_ωSup _ _, assumption },
  exact ωSup_le _ _ ‹_›,
end

/-- A subset `p : α → Prop` of the type closed under `ωSup` induces an
`omega_complete_partial_order` on the subtype `{a : α // p a}`. -/
def subtype {α : Type*} [omega_complete_partial_order α] (p : α → Prop)
  (hp : ∀ (c : chain α), (∀ i ∈ c, p i) → p (ωSup c)) :
  omega_complete_partial_order (subtype p) :=
omega_complete_partial_order.lift
  (preorder_hom.subtype.val p)
  (λ c, ⟨ωSup _, hp (c.map (preorder_hom.subtype.val p)) (λ i ⟨n, q⟩, q.symm ▸ (c n).2)⟩)
  (λ x y h, h)
  (λ c, rfl)

section continuity
open chain

variables [omega_complete_partial_order β]
variables [omega_complete_partial_order γ]

/-- A monotone function `f : α →ₘ β` is continuous if it distributes over ωSup.

In order to distinguish it from the (more commonly used) continuity from topology
(see topology/basic.lean), the present definition is often referred to as
"Scott-continuity" (referring to Dana Scott). It corresponds to continuity
in Scott topological spaces (not defined here). -/
def continuous (f : α →ₘ β) : Prop :=
∀ c : chain α, f (ωSup c) = ωSup (c.map f)

/-- `continuous' f` asserts that `f` is both monotone and continuous. -/
def continuous' (f : α → β) : Prop :=
∃ hf : monotone f, continuous ⟨f, hf⟩

lemma continuous'.to_monotone {f : α → β} (hf : continuous' f) : monotone f := hf.fst

lemma continuous.of_bundled (f : α → β) (hf : monotone f)
  (hf' : continuous ⟨f, hf⟩) : continuous' f := ⟨hf, hf'⟩

lemma continuous.of_bundled' (f : α →ₘ β) (hf' : continuous f) : continuous' f :=
⟨f.mono, hf'⟩

lemma continuous'.to_bundled (f : α → β) (hf : continuous' f) :
  continuous ⟨f, hf.to_monotone⟩ := hf.snd

@[simp, norm_cast] lemma continuous'_coe : ∀ {f : α →ₘ β}, continuous' f ↔ continuous f
| ⟨f, hf⟩ := ⟨λ ⟨hf', hc⟩, hc, λ hc, ⟨hf, hc⟩⟩

variables (f : α →ₘ β) (g : β →ₘ γ)

lemma continuous_id : continuous (@preorder_hom.id α _) :=
by intro; rw c.map_id; refl

lemma continuous_comp (hfc : continuous f) (hgc : continuous g) : continuous (g.comp f):=
begin
  dsimp [continuous] at *, intro,
  rw [hfc,hgc,chain.map_comp]
end

lemma id_continuous' : continuous' (@id α) :=
continuous_id.of_bundled' _

lemma continuous_const (x : β) : continuous (preorder_hom.const α x) :=
λ c, eq_of_forall_ge_iff $ λ z, by simp [ωSup_le_iff]

lemma const_continuous' (x: β) : continuous' (function.const α x) :=
continuous.of_bundled' (preorder_hom.const α x) (continuous_const x)

end continuity

end omega_complete_partial_order

namespace part

variables {α : Type u} {β : Type v} {γ : Type*}
open omega_complete_partial_order

lemma eq_of_chain {c : chain (part α)} {a b : α} (ha : some a ∈ c) (hb : some b ∈ c) : a = b :=
begin
  cases ha with i ha, replace ha := ha.symm,
  cases hb with j hb, replace hb := hb.symm,
  wlog h : i ≤ j := le_total i j using [a b i j, b a j i],
  rw [eq_some_iff] at ha hb,
  have := c.monotone h _ ha, apply mem_unique this hb
end

/-- The (noncomputable) `ωSup` definition for the `ω`-CPO structure on `part α`. -/
protected noncomputable def ωSup (c : chain (part α)) : part α :=
if h : ∃a, some a ∈ c then some (classical.some h) else none

lemma ωSup_eq_some {c : chain (part α)} {a : α} (h : some a ∈ c) : part.ωSup c = some a :=
have ∃a, some a ∈ c, from ⟨a, h⟩,
have a' : some (classical.some this) ∈ c, from classical.some_spec this,
calc part.ωSup c = some (classical.some this) : dif_pos this
                ... = some a : congr_arg _ (eq_of_chain a' h)

lemma ωSup_eq_none {c : chain (part α)} (h : ¬∃a, some a ∈ c) : part.ωSup c = none :=
dif_neg h

lemma mem_chain_of_mem_ωSup {c : chain (part α)} {a : α} (h : a ∈ part.ωSup c) : some a ∈ c :=
begin
  simp [part.ωSup] at h, split_ifs at h,
  { have h' := classical.some_spec h_1,
    rw ← eq_some_iff at h, rw ← h, exact h' },
  { rcases h with ⟨ ⟨ ⟩ ⟩ }
end

noncomputable instance omega_complete_partial_order : omega_complete_partial_order (part α) :=
{ ωSup    := part.ωSup,
  le_ωSup := λ c i, by { intros x hx, rw ← eq_some_iff at hx ⊢,
                         rw [ωSup_eq_some, ← hx], rw ← hx, exact ⟨i,rfl⟩ },
  ωSup_le := by { rintros c x hx a ha, replace ha := mem_chain_of_mem_ωSup ha,
                  cases ha with i ha, apply hx i, rw ← ha, apply mem_some } }

section inst

lemma mem_ωSup (x : α) (c : chain (part α)) : x ∈ ωSup c ↔ some x ∈ c :=
begin
  simp [omega_complete_partial_order.ωSup,part.ωSup],
  split,
  { split_ifs, swap, rintro ⟨⟨⟩⟩,
    intro h', have hh := classical.some_spec h,
    simp at h', subst x, exact hh },
  { intro h,
    have h' : ∃ (a : α), some a ∈ c := ⟨_,h⟩,
    rw dif_pos h', have hh := classical.some_spec h',
    rw eq_of_chain hh h, simp }
end

end inst

end part

namespace pi

variables {α : Type*} {β : α → Type*} {γ : Type*}

open omega_complete_partial_order omega_complete_partial_order.chain

instance [∀a, omega_complete_partial_order (β a)] : omega_complete_partial_order (Πa, β a) :=
{ ωSup    := λc a, ωSup (c.map (pi.eval_preorder_hom a)),
  ωSup_le := assume c f hf a, ωSup_le _ _ $ by { rintro i, apply hf },
  le_ωSup := assume c i x, le_ωSup_of_le _ $ le_refl _ }

namespace omega_complete_partial_order

variables [∀ x, omega_complete_partial_order $ β x]
variables [omega_complete_partial_order γ]

lemma flip₁_continuous'
  (f : ∀ x : α, γ → β x) (a : α) (hf : continuous' (λ x y, f y x)) :
  continuous' (f a) :=
continuous.of_bundled _
  (λ x y h, hf.to_monotone h a)
  (λ c, congr_fun (hf.to_bundled _ c) a)

lemma flip₂_continuous'
  (f : γ → Π x, β x) (hf : ∀ x, continuous' (λ g, f g x)) : continuous' f :=
continuous.of_bundled _
  (λ x y h a, (hf a).to_monotone h)
  (by intro c; ext a; apply (hf a).to_bundled _ c)

end omega_complete_partial_order

end pi

namespace prod

open omega_complete_partial_order
variables {α : Type*} {β : Type*} {γ : Type*}
variables [omega_complete_partial_order α]
variables [omega_complete_partial_order β]
variables [omega_complete_partial_order γ]

/-- The supremum of a chain in the product `ω`-CPO. -/
@[simps]
protected def ωSup (c : chain (α × β)) : α × β :=
(ωSup (c.map preorder_hom.fst), ωSup (c.map preorder_hom.snd))

@[simps ωSup_fst ωSup_snd]
instance : omega_complete_partial_order (α × β) :=
{ ωSup := prod.ωSup,
  ωSup_le := λ c ⟨x,x'⟩ h, ⟨ωSup_le _ _ $ λ i, (h i).1, ωSup_le _ _ $ λ i, (h i).2⟩,
  le_ωSup := λ c i,
    ⟨le_ωSup (c.map preorder_hom.fst) i, le_ωSup (c.map preorder_hom.snd) i⟩ }

end prod

namespace complete_lattice
variables (α : Type u)

/-- Any complete lattice has an `ω`-CPO structure where the countable supremum is a special case
of arbitrary suprema. -/

@[priority 100] -- see Note [lower instance priority]
instance [complete_lattice α] : omega_complete_partial_order α :=
{ ωSup    := λc, ⨆ i, c i,
  ωSup_le := λ ⟨c, _⟩ s hs, by simp only [supr_le_iff, preorder_hom.coe_fun_mk] at ⊢ hs;
    intros i; apply hs i,
  le_ωSup := assume ⟨c, _⟩ i, by simp only [preorder_hom.coe_fun_mk]; apply le_supr_of_le i; refl }

variables {α} {β : Type v} [omega_complete_partial_order α] [complete_lattice β]
open omega_complete_partial_order

lemma inf_continuous [is_total β (≤)] (f g : α →ₘ β) (hf : continuous f) (hg : continuous g) :
  continuous (f ⊓ g) :=
begin
  intro c,
  apply eq_of_forall_ge_iff, intro z,
  simp only [inf_le_iff, hf c, hg c, ωSup_le_iff, ←forall_or_distrib_left, ←forall_or_distrib_right,
             function.comp_app, chain.map_coe, preorder_hom.has_inf_inf_coe],
  split,
  { introv h, apply h },
  { intros h i j,
    apply or.imp _ _ (h (max i j)); apply le_trans; mono*; try { exact le_rfl },
    { apply le_max_left },
    { apply le_max_right }, },
end

lemma Sup_continuous (s : set $ α →ₘ β) (hs : ∀ f ∈ s, continuous f) :
  continuous (Sup s) :=
begin
  intro c, apply eq_of_forall_ge_iff, intro z,
  suffices : (∀ (f ∈ s) n, (f : _) (c n) ≤ z) ↔ (∀ n (f ∈ s), (f : _) (c n) ≤ z),
    by simpa [ωSup_le_iff, hs _ _ _] { contextual := tt },
  exact ⟨λ H n f hf, H f hf n, λ H f hf n, H n f hf⟩
end

lemma supr_continuous {ι : Sort*} {f : ι → α →ₘ β} (h : ∀ i, continuous (f i)) :
  continuous (⨆ i, f i) :=
Sup_continuous _ $ set.forall_range_iff.2 h

theorem Sup_continuous' (s : set (α → β)) (hc : ∀ f ∈ s, continuous' f) :
  continuous' (Sup s) :=
begin
  lift s to set (α →ₘ β) using λ f hf, (hc f hf).to_monotone,
  simp only [set.ball_image_iff, continuous'_coe] at hc,
  rw [Sup_image],
  norm_cast,
  exact supr_continuous (λ f, supr_continuous (λ hf, hc f hf)),
end

lemma sup_continuous {f g : α →ₘ β} (hf : continuous f) (hg : continuous g) :
  continuous (f ⊔ g) :=
begin
  rw ← Sup_pair, apply Sup_continuous,
  rintro f (rfl|rfl|_); assumption
end

lemma top_continuous :
  continuous (⊤ : α →ₘ β) :=
begin
  intro c, apply eq_of_forall_ge_iff, intro z,
  simp only [ωSup_le_iff, forall_const, chain.map_coe, (∘), function.const,
             preorder_hom.has_top_top, preorder_hom.const_coe_coe],
end

lemma bot_continuous :
  continuous (⊥ : α →ₘ β) :=
begin
  rw ← Sup_empty,
  exact Sup_continuous _ (λ f hf, hf.elim),
end

end complete_lattice

namespace omega_complete_partial_order

variables {α : Type u} {α' : Type*} {β : Type v} {β' : Type*} {γ : Type*} {φ : Type*}

variables [omega_complete_partial_order α] [omega_complete_partial_order β]
variables [omega_complete_partial_order γ] [omega_complete_partial_order φ]
variables [omega_complete_partial_order α'] [omega_complete_partial_order β']

namespace preorder_hom

/-- The `ωSup` operator for monotone functions. -/
@[simps]
protected def ωSup (c : chain (α →ₘ β)) : α →ₘ β :=
{ to_fun := λ a, ωSup (c.map (preorder_hom.apply a)),
  monotone' := λ x y h, ωSup_le_ωSup_of_le (chain.map_le_map _ $ λ a, a.monotone h) }

@[simps ωSup_coe]
instance omega_complete_partial_order : omega_complete_partial_order (α →ₘ β) :=
omega_complete_partial_order.lift preorder_hom.coe_fn_hom preorder_hom.ωSup
  (λ x y h, h) (λ c, rfl)

end preorder_hom

section
variables (α β)

/-- A monotone function on `ω`-continuous partial orders is said to be continuous
if for every chain `c : chain α`, `f (⊔ i, c i) = ⊔ i, f (c i)`.
This is just the bundled version of `preorder_hom.continuous`. -/
structure continuous_hom extends preorder_hom α β :=
(cont : continuous (preorder_hom.mk to_fun monotone'))

attribute [nolint doc_blame] continuous_hom.to_preorder_hom

infixr ` →𝒄 `:25 := continuous_hom -- Input: \r\MIc

instance : has_coe_to_fun (α →𝒄 β) (λ _, α → β) := ⟨λ f, f.to_preorder_hom.to_fun⟩

instance : has_coe (α →𝒄 β) (α →ₘ β) :=
{ coe :=  continuous_hom.to_preorder_hom }

instance : partial_order (α →𝒄 β) :=
partial_order.lift (λ f, f.to_preorder_hom.to_fun) $ by rintro ⟨⟨⟩⟩ ⟨⟨⟩⟩ h; congr; exact h

/-- See Note [custom simps projection]. We need to specify this projection explicitly in this case,
  because it is a composition of multiple projections. -/
def continuous_hom.simps.apply (h : α →𝒄 β) : α → β := h

initialize_simps_projections continuous_hom
  (to_preorder_hom_to_fun → apply, -to_preorder_hom)

end

namespace continuous_hom

theorem congr_fun {f g : α →𝒄 β} (h : f = g) (x : α) : f x = g x :=
congr_arg (λ h : α →𝒄 β, h x) h

theorem congr_arg (f : α →𝒄 β) {x y : α} (h : x = y) : f x = f y :=
congr_arg (λ x : α, f x) h

protected lemma monotone (f : α →𝒄 β) : monotone f := f.monotone'

@[mono] lemma apply_mono {f g : α →𝒄 β} {x y : α} (h₁ : f ≤ g) (h₂ : x ≤ y) : f x ≤ g y :=
preorder_hom.apply_mono (show (f : α →ₘ β) ≤ g, from h₁) h₂

lemma ite_continuous' {p : Prop} [hp : decidable p] (f g : α → β)
  (hf : continuous' f) (hg : continuous' g) : continuous' (λ x, if p then f x else g x) :=
by split_ifs; simp *

lemma ωSup_bind {β γ : Type v} (c : chain α) (f : α →ₘ part β) (g : α →ₘ β → part γ) :
  ωSup (c.map (f.bind g)) = ωSup (c.map f) >>= ωSup (c.map g) :=
begin
  apply eq_of_forall_ge_iff, intro x,
  simp only [ωSup_le_iff, part.bind_le, chain.mem_map_iff, and_imp, preorder_hom.bind_coe,
    exists_imp_distrib],
  split; intro h''',
  { intros b hb, apply ωSup_le _ _ _,
    rintros i y hy, simp only [part.mem_ωSup] at hb,
    rcases hb with ⟨j,hb⟩, replace hb := hb.symm,
    simp only [part.eq_some_iff, chain.map_coe, function.comp_app, preorder_hom.apply_coe]
      at hy hb,
    replace hb : b ∈ f (c (max i j))   := f.mono (c.mono (le_max_right i j)) _ hb,
    replace hy : y ∈ g (c (max i j)) b := g.mono (c.mono (le_max_left i j)) _ _ hy,
    apply h''' (max i j),
    simp only [exists_prop, part.bind_eq_bind, part.mem_bind_iff, chain.map_coe,
               function.comp_app, preorder_hom.bind_coe],
    exact ⟨_,hb,hy⟩, },
  { intros i, intros y hy,
    simp only [exists_prop, part.bind_eq_bind, part.mem_bind_iff, chain.map_coe,
               function.comp_app, preorder_hom.bind_coe] at hy,
    rcases hy with ⟨b,hb₀,hb₁⟩,
    apply h''' b _,
    { apply le_ωSup (c.map g) _ _ _ hb₁ },
    { apply le_ωSup (c.map f) i _ hb₀ } },
end

lemma bind_continuous' {β γ : Type v} (f : α → part β) (g : α → β → part γ) :
  continuous' f → continuous' g →
  continuous' (λ x, f x >>= g x)
| ⟨hf,hf'⟩ ⟨hg,hg'⟩ :=
continuous.of_bundled' (preorder_hom.bind ⟨f,hf⟩ ⟨g,hg⟩)
  (by intro c; rw [ωSup_bind, ← hf', ← hg']; refl)

lemma map_continuous' {β γ : Type v} (f : β → γ) (g : α → part β)
  (hg : continuous' g) :
  continuous' (λ x, f <$> g x) :=
by simp only [map_eq_bind_pure_comp];
   apply bind_continuous' _ _ hg;
   apply const_continuous'

lemma seq_continuous' {β γ : Type v} (f : α → part (β → γ)) (g : α → part β)
  (hf : continuous' f) (hg : continuous' g) :
  continuous' (λ x, f x <*> g x) :=
by simp only [seq_eq_bind_map];
   apply bind_continuous' _ _ hf;
   apply pi.omega_complete_partial_order.flip₂_continuous'; intro;
   apply map_continuous' _ _ hg

lemma continuous (F : α →𝒄 β) (C : chain α) : F (ωSup C) = ωSup (C.map F) :=
continuous_hom.cont _ _

/-- Construct a continuous function from a bare function, a continuous function, and a proof that
they are equal. -/
@[simps, reducible]
def of_fun (f : α → β) (g : α →𝒄 β) (h : f = g) : α →𝒄 β :=
by refine {to_preorder_hom := {to_fun := f, ..}, ..}; subst h; rcases g with ⟨⟨⟩⟩; assumption

/-- Construct a continuous function from a monotone function with a proof of continuity. -/
@[simps, reducible]
def of_mono (f : α →ₘ β) (h : ∀ c : chain α, f (ωSup c) = ωSup (c.map f)) : α →𝒄 β :=
{ to_fun := f,
  monotone' := f.monotone,
  cont := h }

/-- The identity as a continuous function. -/
@[simps]
def id : α →𝒄 α :=
of_mono preorder_hom.id continuous_id

/-- The composition of continuous functions. -/
@[simps]
def comp (f : β →𝒄 γ) (g : α →𝒄 β) : α →𝒄 γ :=
of_mono (preorder_hom.comp (↑f) (↑g)) (continuous_comp _ _ g.cont f.cont)

@[ext]
protected lemma ext (f g : α →𝒄 β) (h : ∀ x, f x = g x) : f = g :=
by cases f; cases g; congr; ext; apply h

protected lemma coe_inj (f g : α →𝒄 β) (h : (f : α → β) = g) : f = g :=
continuous_hom.ext _ _ $ _root_.congr_fun h

@[simp]
lemma comp_id (f : β →𝒄 γ) : f.comp id = f := by ext; refl

@[simp]
lemma id_comp (f : β →𝒄 γ) : id.comp f = f := by ext; refl

@[simp]
lemma comp_assoc (f : γ →𝒄 φ) (g : β →𝒄 γ) (h : α →𝒄 β) : f.comp (g.comp h) = (f.comp g).comp h :=
by ext; refl

@[simp]
lemma coe_apply (a : α) (f : α →𝒄 β) : (f : α →ₘ β) a = f a := rfl

/-- `function.const` is a continuous function. -/
def const (x : β) : α →𝒄 β :=
of_mono (preorder_hom.const _ x) (continuous_const x)

@[simp] theorem const_apply (f : β) (a : α) : const f a = f := rfl

instance [inhabited β] : inhabited (α →𝒄 β) :=
⟨ const (default β) ⟩

namespace prod

/-- The application of continuous functions as a monotone function.

(It would make sense to make it a continuous function, but we are currently constructing a
`omega_complete_partial_order` instance for `α →𝒄 β`, and we cannot use it as the domain or image
of a continuous function before we do.) -/
@[simps]
def apply : (α →𝒄 β) × α →ₘ β :=
{ to_fun := λ f, f.1 f.2,
  monotone' := λ x y h, by dsimp; transitivity y.fst x.snd; [apply h.1, apply y.1.monotone h.2] }

end prod

/-- The map from continuous functions to monotone functions is itself a monotone function. -/
@[simps]
def to_mono : (α →𝒄 β) →ₘ (α →ₘ β) :=
{ to_fun := λ f, f,
  monotone' := λ x y h, h }

/-- When proving that a chain of applications is below a bound `z`, it suffices to consider the
functions and values being selected from the same index in the chains.

This lemma is more specific than necessary, i.e. `c₀` only needs to be a
chain of monotone functions, but it is only used with continuous functions. -/
@[simp]
lemma forall_forall_merge (c₀ : chain (α →𝒄 β)) (c₁ : chain α) (z : β) :
  (∀ (i j : ℕ), (c₀ i) (c₁ j) ≤ z) ↔ ∀ (i : ℕ), (c₀ i) (c₁ i) ≤ z :=
begin
  split; introv h,
  { apply h },
  { apply le_trans _ (h (max i j)),
    transitivity c₀ i (c₁ (max i j)),
    { apply (c₀ i).monotone, apply c₁.monotone, apply le_max_right },
    { apply c₀.monotone, apply le_max_left } }
end

@[simp]
lemma forall_forall_merge' (c₀ : chain (α →𝒄 β)) (c₁ : chain α) (z : β) :
  (∀ (j i : ℕ), (c₀ i) (c₁ j) ≤ z) ↔ ∀ (i : ℕ), (c₀ i) (c₁ i) ≤ z :=
by rw [forall_swap,forall_forall_merge]

/-- The `ωSup` operator for continuous functions, which takes the pointwise countable supremum
of the functions in the `ω`-chain. -/
@[simps]
protected def ωSup (c : chain (α →𝒄 β)) : α →𝒄 β :=
continuous_hom.of_mono (ωSup $ c.map to_mono)
begin
  intro c',
  apply eq_of_forall_ge_iff, intro z,
  simp only [ωSup_le_iff, (c _).continuous, chain.map_coe, preorder_hom.apply_coe,
    to_mono_coe, coe_apply, preorder_hom.omega_complete_partial_order_ωSup_coe,
    forall_forall_merge, forall_forall_merge', (∘), function.eval],
end

@[simps ωSup]
instance : omega_complete_partial_order (α →𝒄 β) :=
omega_complete_partial_order.lift continuous_hom.to_mono continuous_hom.ωSup
  (λ x y h, h) (λ c, rfl)

lemma ωSup_def (c : chain (α →𝒄 β)) (x : α) : ωSup c x = continuous_hom.ωSup c x := rfl

lemma ωSup_ωSup (c₀ : chain (α →𝒄 β)) (c₁ : chain α) :
  ωSup c₀ (ωSup c₁) = ωSup (continuous_hom.prod.apply.comp $ c₀.zip c₁) :=
begin
  apply eq_of_forall_ge_iff, intro z,
  simp only [ωSup_le_iff, (c₀ _).continuous, chain.map_coe, to_mono_coe, coe_apply,
    preorder_hom.omega_complete_partial_order_ωSup_coe, ωSup_def, forall_forall_merge,
    chain.zip_coe, preorder_hom.prod_map_coe, preorder_hom.diag_coe, prod.map_mk,
    preorder_hom.apply_coe, function.comp_app, prod.apply_coe,
    preorder_hom.comp_coe, ωSup_apply, function.eval],
end

/-- A family of continuous functions yields a continuous family of functions. -/
@[simps]
def flip {α : Type*} (f : α → β →𝒄 γ) : β →𝒄 α → γ :=
{ to_fun := λ x y, f y x,
  monotone' := λ x y h a, (f a).monotone h,
  cont := by intro; ext; change f x _ = _; rw [(f x).continuous ]; refl, }

/-- `part.bind` as a continuous function. -/
@[simps { rhs_md := reducible }]
noncomputable def bind {β γ : Type v}
  (f : α →𝒄 part β) (g : α →𝒄 β → part γ) : α →𝒄 part γ :=
of_mono (preorder_hom.bind (↑f) (↑g)) $ λ c, begin
  rw [preorder_hom.bind, ← preorder_hom.bind, ωSup_bind, ← f.continuous, ← g.continuous],
  refl
end

/-- `part.map` as a continuous function. -/
@[simps {rhs_md := reducible}]
noncomputable def map {β γ : Type v} (f : β → γ) (g : α →𝒄 part β) : α →𝒄 part γ :=
of_fun (λ x, f <$> g x) (bind g (const (pure ∘ f))) $
by ext; simp only [map_eq_bind_pure_comp, bind_apply, preorder_hom.bind_coe, const_apply,
  preorder_hom.const_coe_coe, coe_apply]

/-- `part.seq` as a continuous function. -/
@[simps {rhs_md := reducible}]
noncomputable def seq {β γ : Type v} (f : α →𝒄 part (β → γ)) (g : α →𝒄 part β) :
  α →𝒄 part γ :=
of_fun (λ x, f x <*> g x) (bind f $ (flip $ _root_.flip map g))
  (by ext; simp only [seq_eq_bind_map, flip, part.bind_eq_bind, map_apply, part.mem_bind_iff,
                      bind_apply, preorder_hom.bind_coe, coe_apply, flip_apply]; refl)

end continuous_hom

end omega_complete_partial_order


import set_theory.game.pgame
import tactic.abel

open pgame

open_locale pgame

universes u v

namespace game

instance pgame.setoid : setoid pgame.{u} :=
⟨(≈), equiv_refl, @pgame.equiv.symm, @pgame.equiv.trans⟩

abbreviation game : Type (u+1) := quotient pgame.setoid.{u}

instance : add_comm_group game :=
{ zero := ⟦0⟧,
  neg := quotient.lift (λ x, ⟦-x⟧) (λ x₁ x₂ h, quotient.sound ((@neg_equiv_neg_iff x₁ x₂).mpr h)),
  add := quotient.lift₂ (λ x y : pgame, ⟦x + y⟧)
    (λ x₁ y₁ x₂ y₂ hx hy, quotient.sound (add_congr hx hy)),
  add_zero := by { rintro ⟨x⟩, exact quotient.sound (add_zero_equiv x) },
  zero_add := by { rintro ⟨x⟩, exact quotient.sound (zero_add_equiv x) },
  add_assoc := by { rintros ⟨x⟩ ⟨y⟩ ⟨z⟩, exact quotient.sound add_assoc_equiv },
  add_left_neg := by { rintro ⟨x⟩, exact quotient.sound (add_left_neg_equiv x), },
  add_comm := by { rintros ⟨x⟩ ⟨y⟩, exact quotient.sound add_comm_equiv } }

instance : has_one game := ⟨⟦1⟧⟩
instance : inhabited game := ⟨0⟩

instance : partial_order game :=
{ le := quotient.lift₂ (λ x y, x ≤ y) (λ x₁ y₁ x₂ y₂ hx hy, propext (le_congr hx hy)),
  le_refl := by { rintro ⟨x⟩, exact le_refl x },
  le_trans := by { rintros ⟨x⟩ ⟨y⟩ ⟨z⟩, exact @le_trans _ _ x y z },
  le_antisymm := by { rintros ⟨x⟩ ⟨y⟩ h₁ h₂, exact quotient.sound ⟨h₁, h₂⟩ } }

def lf : game → game → Prop :=
quotient.lift₂ lf (λ x₁ y₁ x₂ y₂ hx hy, propext (lf_congr hx hy))

local infix ` ⧏ `:50 := lf

@[simp] theorem not_le : ∀ {x y : game}, ¬ x ≤ y ↔ y ⧏ x :=
by { rintro ⟨x⟩ ⟨y⟩, exact pgame.not_le }

@[simp] theorem not_lf : ∀ {x y : game}, ¬ x ⧏ y ↔ y ≤ x :=
by { rintro ⟨x⟩ ⟨y⟩, exact not_lf }

instance : is_trichotomous game (⧏) :=
⟨by { rintro ⟨x⟩ ⟨y⟩, change _ ∨ ⟦x⟧ = ⟦y⟧ ∨ _, rw quotient.eq, exact lf_or_equiv_or_gf x y }⟩

theorem _root_.pgame.le_iff_game_le {x y : pgame} : x ≤ y ↔ ⟦x⟧ ≤ ⟦y⟧ := iff.rfl
theorem _root_.pgame.lf_iff_game_lf {x y : pgame} : pgame.lf x y ↔ ⟦x⟧ ⧏ ⟦y⟧ := iff.rfl
theorem _root_.pgame.lt_iff_game_lt {x y : pgame} : x < y ↔ ⟦x⟧ < ⟦y⟧ := iff.rfl
theorem _root_.pgame.equiv_iff_game_eq {x y : pgame} : x ≈ y ↔ ⟦x⟧ = ⟦y⟧ :=
(@quotient.eq _ _ x y).symm

def fuzzy : game → game → Prop :=
quotient.lift₂ fuzzy (λ x₁ y₁ x₂ y₂ hx hy, propext (fuzzy_congr hx hy))

local infix ` ∥ `:50 := fuzzy

theorem _root_.pgame.fuzzy_iff_game_fuzzy {x y : pgame} : pgame.fuzzy x y ↔ ⟦x⟧ ∥ ⟦y⟧ := iff.rfl

instance covariant_class_add_le : covariant_class game game (+) (≤) :=
⟨by { rintro ⟨x⟩ ⟨y⟩ ⟨z⟩ h, exact @add_le_add_left _ _ _ _ y z h x }⟩

instance covariant_class_swap_add_le : covariant_class game game (function.swap (+)) (≤) :=
⟨by { rintro ⟨x⟩ ⟨y⟩ ⟨z⟩ h, exact @add_le_add_right _ _ _ _ y z h x }⟩

instance covariant_class_add_lt : covariant_class game game (+) (<) :=
⟨by { rintro ⟨x⟩ ⟨y⟩ ⟨z⟩ h, exact @add_lt_add_left _ _ _ _ y z h x }⟩

instance covariant_class_swap_add_lt : covariant_class game game (function.swap (+)) (<) :=
⟨by { rintro ⟨x⟩ ⟨y⟩ ⟨z⟩ h, exact @add_lt_add_right _ _ _ _ y z h x }⟩

theorem add_lf_add_right : ∀ {y z : game} (h : y ⧏ z) (x), y + x ⧏ z + x :=
by { rintro ⟨y⟩ ⟨z⟩ h ⟨x⟩, apply add_lf_add_right h }

theorem add_lf_add_left : ∀ {y z : game} (h : y ⧏ z) (x), x + y ⧏ x + z :=
by { rintro ⟨y⟩ ⟨z⟩ h ⟨x⟩, apply add_lf_add_left h }

instance ordered_add_comm_group : ordered_add_comm_group game :=
{ add_le_add_left := @add_le_add_left _ _ _ game.covariant_class_add_le,
  ..game.add_comm_group,
  ..game.partial_order }

end game

namespace pgame

@[simp] lemma quot_neg (x : pgame) : ⟦-x⟧ = -⟦x⟧ := rfl

@[simp] lemma quot_add (x y : pgame) : ⟦x + y⟧ = ⟦x⟧ + ⟦y⟧ := rfl

@[simp] lemma quot_sub (x y : pgame) : ⟦x - y⟧ = ⟦x⟧ - ⟦y⟧ := rfl

theorem quot_eq_of_mk_quot_eq {x y : pgame}
  (L : x.left_moves ≃ y.left_moves) (R : x.right_moves ≃ y.right_moves)
  (hl : ∀ (i : x.left_moves), ⟦x.move_left i⟧ = ⟦y.move_left (L i)⟧)
  (hr : ∀ (j : y.right_moves), ⟦x.move_right (R.symm j)⟧ = ⟦y.move_right j⟧) :
  ⟦x⟧ = ⟦y⟧ :=
begin
  simp only [quotient.eq] at hl hr,
  exact quotient.sound (equiv_of_mk_equiv L R hl hr)
end

def mul : pgame → pgame → pgame
| x@⟨xl, xr, xL, xR⟩ y@⟨yl, yr, yL, yR⟩ :=
⟨xl × yl ⊕ xr × yr, xl × yr ⊕ xr × yl,
 @sum.rec _ _ (λ _, pgame)
    (@prod.rec _ _ (λ _, pgame) (λ i₁ i₂, mul (xL i₁) y + mul x (yL i₂) - mul (xL i₁) (yL i₂)))
    (@prod.rec _ _ (λ _, pgame) (λ j₁ j₂, mul (xR j₁) y + mul x (yR j₂) - mul (xR j₁) (yR j₂))),
 @sum.rec _ _ (λ _, pgame)
    (@prod.rec _ _ (λ _, pgame) (λ i j, mul (xL i) y + mul x (yR j) - mul (xL i) (yR j)))
    (@prod.rec _ _ (λ _, pgame) (λ j i, mul (xR j) y + mul x (yL i) - mul (xR j) (yL i)))⟩
using_well_founded { dec_tac := pgame_wf_tac }

instance : has_mul pgame.{u} :=
⟨λ x y, begin
  induction x with xl xr xL xR IHxl IHxr generalizing y,
  induction y with yl yr yL yR IHyl IHyr,
  have y := mk yl yr yL yR,
  refine ⟨xl × yl ⊕ xr × yr, xl × yr ⊕ xr × yl, _, _⟩; rintro (⟨i, j⟩ | ⟨i, j⟩),
  { exact IHxl i y + IHyl j - IHxl i (yL j) },
  { exact IHxr i y + IHyr j - IHxr i (yR j) },
  { exact IHxl i y + IHyr j - IHxl i (yR j) },
  { exact IHxr i y + IHyl j - IHxr i (yL j) }
end⟩

example {x y : pgame} : x * y = mul x y :=
begin
  induction x with xl xr xL xR IHxl IHxr generalizing y,
  induction y with yl yr yL yR IHyl IHyr,
  dsimp only [(*)],
  unfold mul,
  congr,
  all_goals
  { ext,
    change _ * _ + mk _ _ _ _ * _ - _ * _ = _,
    congr; simp [IHxl, IHxr, IHyl, IHyr] }
end

theorem left_moves_mul : ∀ (x y : pgame.{u}), (x * y).left_moves
  = (x.left_moves × y.left_moves ⊕ x.right_moves × y.right_moves)
| ⟨_, _, _, _⟩ ⟨_, _, _, _⟩ := rfl

theorem right_moves_mul : ∀ (x y : pgame.{u}), (x * y).right_moves
  = (x.left_moves × y.right_moves ⊕ x.right_moves × y.left_moves)
| ⟨_, _, _, _⟩ ⟨_, _, _, _⟩ := rfl

def to_left_moves_mul {x y : pgame} :
  x.left_moves × y.left_moves ⊕ x.right_moves × y.right_moves ≃ (x * y).left_moves :=
equiv.cast (left_moves_mul x y).symm

def to_right_moves_mul {x y : pgame} :
  x.left_moves × y.right_moves ⊕ x.right_moves × y.left_moves ≃ (x * y).right_moves :=
equiv.cast (right_moves_mul x y).symm

@[simp] lemma mk_mul_move_left_inl {xl xr yl yr} {xL xR yL yR} {i j} :
  (mk xl xr xL xR * mk yl yr yL yR).move_left (sum.inl (i, j))
  = xL i * (mk yl yr yL yR) + (mk xl xr xL xR) * yL j - xL i * yL j :=
rfl

@[simp] lemma mul_move_left_inl {x y : pgame} {i j} :
   (x * y).move_left (to_left_moves_mul (sum.inl (i, j)))
   = x.move_left i * y + x * y.move_left j - x.move_left i * y.move_left j :=
by { cases x, cases y, refl }

@[simp] lemma mk_mul_move_left_inr {xl xr yl yr} {xL xR yL yR} {i j} :
  (mk xl xr xL xR * mk yl yr yL yR).move_left (sum.inr (i, j))
  = xR i * (mk yl yr yL yR) + (mk xl xr xL xR) * yR j - xR i * yR j :=
rfl

@[simp] lemma mul_move_left_inr {x y : pgame} {i j} :
   (x * y).move_left (to_left_moves_mul (sum.inr (i, j)))
   = x.move_right i * y + x * y.move_right j - x.move_right i * y.move_right j :=
by { cases x, cases y, refl }

@[simp] lemma mk_mul_move_right_inl {xl xr yl yr} {xL xR yL yR} {i j} :
  (mk xl xr xL xR * mk yl yr yL yR).move_right (sum.inl (i, j))
  = xL i * (mk yl yr yL yR) + (mk xl xr xL xR) * yR j - xL i * yR j :=
rfl

@[simp] lemma mul_move_right_inl {x y : pgame} {i j} :
   (x * y).move_right (to_right_moves_mul (sum.inl (i, j)))
   = x.move_left i * y + x * y.move_right j - x.move_left i * y.move_right j :=
by { cases x, cases y, refl }

@[simp] lemma mk_mul_move_right_inr {xl xr yl yr} {xL xR yL yR} {i j} :
  (mk xl xr xL xR * mk yl yr yL yR).move_right (sum.inr (i, j))
  = xR i * (mk yl yr yL yR) + (mk xl xr xL xR) * yL j - xR i * yL j :=
rfl

@[simp] lemma mul_move_right_inr {x y : pgame} {i j} :
   (x * y).move_right (to_right_moves_mul (sum.inr (i, j)))
   = x.move_right i * y + x * y.move_left j - x.move_right i * y.move_left j :=
by { cases x, cases y, refl }

lemma left_moves_mul_cases {x y : pgame} (k) {P : (x * y).left_moves → Prop}
  (hl : ∀ ix iy, P $ to_left_moves_mul (sum.inl ⟨ix, iy⟩))
  (hr : ∀ jx jy, P $ to_left_moves_mul (sum.inr ⟨jx, jy⟩)) : P k :=
begin
  rw ←to_left_moves_mul.apply_symm_apply k,
  rcases to_left_moves_mul.symm k with ⟨ix, iy⟩ | ⟨jx, jy⟩,
  { apply hl },
  { apply hr }
end

lemma right_moves_mul_cases {x y : pgame} (k) {P : (x * y).right_moves → Prop}
  (hl : ∀ i j, P $ to_right_moves_mul (sum.inl ⟨i, j⟩))
  (hr : ∀ j i, P $ to_right_moves_mul (sum.inr ⟨j, i⟩)) : P k :=
begin
  rw ←to_right_moves_mul.apply_symm_apply k,
  rcases to_right_moves_mul.symm k with ⟨i, j⟩ | ⟨j, i⟩,
  { apply hl },
  { apply hr }
end

theorem quot_mul_comm : Π (x y : pgame.{u}), ⟦x * y⟧ = ⟦y * x⟧
| (mk xl xr xL xR) (mk yl yr yL yR) :=
begin
  refine quot_eq_of_mk_quot_eq
    (equiv.sum_congr (equiv.prod_comm _ _) (equiv.prod_comm _ _))
    ((equiv.sum_comm _ _).trans (equiv.sum_congr (equiv.prod_comm _ _) (equiv.prod_comm _ _))) _ _;
  all_goals { rintro (⟨i, j⟩ | ⟨i, j⟩); dsimp; rw [quot_mul_comm, quot_mul_comm (mk xl xr xL xR)] },
  { rw [quot_mul_comm (xL i), add_comm] },
  { rw [quot_mul_comm (xR i), add_comm] },
  { rw [quot_mul_comm (xR j), add_comm] },
  { rw [quot_mul_comm (xL j), add_comm] }
end
using_well_founded { dec_tac := pgame_wf_tac }

theorem mul_comm_equiv (x y : pgame) : x * y ≈ y * x :=
quotient.exact $ quot_mul_comm _ _

instance is_empty_mul_zero_left_moves (x : pgame.{u}) : is_empty (x * 0).left_moves :=
by { cases x, apply sum.is_empty }
instance is_empty_mul_zero_right_moves (x : pgame.{u}) : is_empty (x * 0).right_moves :=
by { cases x, apply sum.is_empty }
instance is_empty_zero_mul_left_moves (x : pgame.{u}) : is_empty (0 * x).left_moves :=
by { cases x, apply sum.is_empty }
instance is_empty_zero_mul_right_moves (x : pgame.{u}) : is_empty (0 * x).right_moves :=
by { cases x, apply sum.is_empty }

def mul_zero_relabelling (x : pgame) : x * 0 ≡r 0 := relabelling.is_empty _

theorem mul_zero_equiv (x : pgame) : x * 0 ≈ 0 := (mul_zero_relabelling x).equiv

@[simp] theorem quot_mul_zero (x : pgame) : ⟦x * 0⟧ = ⟦0⟧ :=
@quotient.sound _ _ (x * 0) _ x.mul_zero_equiv

def zero_mul_relabelling (x : pgame) : 0 * x ≡r 0 := relabelling.is_empty _

theorem zero_mul_equiv (x : pgame) : 0 * x ≈ 0 := (zero_mul_relabelling x).equiv

@[simp] theorem quot_zero_mul (x : pgame) : ⟦0 * x⟧ = ⟦0⟧ :=
@quotient.sound _ _ (0 * x) _ x.zero_mul_equiv

@[simp] theorem quot_neg_mul : ∀ (x y : pgame), ⟦-x * y⟧ = -⟦x * y⟧
| (mk xl xr xL xR) (mk yl yr yL yR) :=
begin
  let x := mk xl xr xL xR,
  let y := mk yl yr yL yR,
  refine quot_eq_of_mk_quot_eq _ _ _ _,
  any_goals
  { fsplit; rintro (⟨_, _⟩ | ⟨_, _⟩);
    solve_by_elim [sum.inl, sum.inr, prod.mk] { max_depth := 4 } },
  all_goals
  { rintro (⟨_, _⟩ | ⟨_, _⟩),
    all_goals
    { change ⟦-_ * y + (-x) * _ - (-_) * _⟧ = ⟦-(_ * y + x * _ - _ * _)⟧,
      simp only [quot_add, quot_sub, quot_neg_mul],
      simp, abel } }
end
using_well_founded { dec_tac := pgame_wf_tac }

@[simp] theorem quot_mul_neg (x y : pgame) : ⟦x * -y⟧ = -⟦x * y⟧ :=
by rw [quot_mul_comm, quot_neg_mul, quot_mul_comm]

@[simp] theorem quot_left_distrib : ∀ (x y z : pgame), ⟦x * (y + z)⟧ = ⟦x * y⟧ + ⟦x * z⟧
| (mk xl xr xL xR) (mk yl yr yL yR) (mk zl zr zL zR) :=
begin
  let x := mk xl xr xL xR,
  let y := mk yl yr yL yR,
  let z := mk zl zr zL zR,
  refine quot_eq_of_mk_quot_eq _ _ _ _,
  { fsplit,
    { rintro (⟨_, _ | _⟩ | ⟨_, _ | _⟩);
      solve_by_elim [sum.inl, sum.inr, prod.mk] { max_depth := 5 } },
    { rintro (⟨⟨_, _⟩ | ⟨_, _⟩⟩ | ⟨_, _⟩ | ⟨_, _⟩);
      solve_by_elim [sum.inl, sum.inr, prod.mk] { max_depth := 5 } },
    { rintro (⟨_, _ | _⟩ | ⟨_, _ | _⟩); refl },
    { rintro (⟨⟨_, _⟩ | ⟨_, _⟩⟩ | ⟨_, _⟩ | ⟨_, _⟩); refl } },
  { fsplit,
    { rintro (⟨_, _ | _⟩ | ⟨_, _ | _⟩);
      solve_by_elim [sum.inl, sum.inr, prod.mk] { max_depth := 5 } },
    { rintro (⟨⟨_, _⟩ | ⟨_, _⟩⟩ | ⟨_, _⟩ | ⟨_, _⟩);
      solve_by_elim [sum.inl, sum.inr, prod.mk] { max_depth := 5 } },
    { rintro (⟨_, _ | _⟩ | ⟨_, _ | _⟩); refl },
    { rintro (⟨⟨_, _⟩ | ⟨_, _⟩⟩ | ⟨_, _⟩ | ⟨_, _⟩); refl } },
  { rintro (⟨i, j | k⟩ | ⟨i, j | k⟩),
    { change ⟦xL i * (y + z) + x * (yL j + z) - xL i * (yL j + z)⟧
             = ⟦xL i * y + x * yL j - xL i * yL j + x * z⟧,
      simp [quot_left_distrib], abel },
    { change ⟦xL i * (y + z) + x * (y + zL k) - xL i * (y + zL k)⟧
             = ⟦x * y + (xL i * z + x * zL k - xL i * zL k)⟧,
      simp [quot_left_distrib], abel },
    { change ⟦xR i * (y + z) + x * (yR j + z) - xR i * (yR j + z)⟧
             = ⟦xR i * y + x * yR j - xR i * yR j + x * z⟧,
      simp [quot_left_distrib], abel },
    { change ⟦xR i * (y + z) + x * (y + zR k) - xR i * (y + zR k)⟧
             = ⟦x * y + (xR i * z + x * zR k - xR i * zR k)⟧,
      simp [quot_left_distrib], abel } },
  { rintro (⟨⟨i, j⟩ | ⟨i, j⟩⟩ | ⟨i, k⟩ | ⟨i, k⟩),
    { change ⟦xL i * (y + z) + x * (yR j + z) - xL i * (yR j + z)⟧
             = ⟦xL i * y + x * yR j - xL i * yR j + x * z⟧,
      simp [quot_left_distrib], abel },
    { change ⟦xR i * (y + z) + x * (yL j + z) - xR i * (yL j + z)⟧
             = ⟦xR i * y + x * yL j - xR i * yL j + x * z⟧,
      simp [quot_left_distrib], abel },
    { change ⟦xL i * (y + z) + x * (y + zR k) - xL i * (y + zR k)⟧
             = ⟦x * y + (xL i * z + x * zR k - xL i * zR k)⟧,
      simp [quot_left_distrib], abel },
    { change ⟦xR i * (y + z) + x * (y + zL k) - xR i * (y + zL k)⟧
             = ⟦x * y + (xR i * z + x * zL k - xR i * zL k)⟧,
      simp [quot_left_distrib], abel } }
end
using_well_founded { dec_tac := pgame_wf_tac }

theorem left_distrib_equiv (x y z : pgame) : x * (y + z) ≈ x * y + x * z :=
quotient.exact $ quot_left_distrib _ _ _

@[simp] theorem quot_left_distrib_sub (x y z : pgame) : ⟦x * (y - z)⟧ = ⟦x * y⟧ - ⟦x * z⟧ :=
by { change  ⟦x * (y + -z)⟧ = ⟦x * y⟧ + -⟦x * z⟧, rw [quot_left_distrib, quot_mul_neg] }

@[simp] theorem quot_right_distrib (x y z : pgame) : ⟦(x + y) * z⟧ = ⟦x * z⟧ + ⟦y * z⟧ :=
by simp only [quot_mul_comm, quot_left_distrib]

theorem right_distrib_equiv (x y z : pgame) : (x + y) * z ≈ x * z + y * z :=
quotient.exact $ quot_right_distrib _ _ _

@[simp] theorem quot_right_distrib_sub (x y z : pgame) : ⟦(y - z) * x⟧ = ⟦y * x⟧ - ⟦z * x⟧ :=
by { change ⟦(y + -z) * x⟧ = ⟦y * x⟧ + -⟦z * x⟧, rw [quot_right_distrib, quot_neg_mul] }

@[simp] theorem quot_mul_one : ∀ (x : pgame), ⟦x * 1⟧ = ⟦x⟧
| (mk xl xr xL xR) :=
begin
  let x := mk xl xr xL xR,
  refine quot_eq_of_mk_quot_eq _ _ _ _,
  { fsplit,
    { rintro (⟨_, ⟨⟩⟩ | ⟨_, ⟨⟩⟩), assumption },
    { rintro i, exact sum.inl (i, punit.star) },
    { rintro (⟨_, ⟨⟩⟩ | ⟨_, ⟨⟩⟩), refl },
    { rintro i, refl } },
  { fsplit,
    { rintro (⟨_, ⟨⟩⟩ | ⟨_, ⟨⟩⟩), assumption },
    { rintro i, exact sum.inr (i, punit.star) },
    { rintro (⟨_, ⟨⟩⟩ | ⟨_, ⟨⟩⟩), refl },
    { rintro i, refl } },
  { rintro (⟨i, ⟨⟩⟩ | ⟨_, ⟨⟩⟩),
    change ⟦xL i * 1 + x * 0 - xL i * 0⟧ = ⟦xL i⟧,
    simp [quot_mul_one] },
  { rintro i,
    change ⟦xR i * 1 + x * 0 - xR i * 0⟧ = ⟦xR i⟧,
    simp [quot_mul_one] }
end

theorem mul_one_equiv (x : pgame) : x * 1 ≈ x := quotient.exact $ quot_mul_one _

@[simp] theorem quot_one_mul (x : pgame) : ⟦1 * x⟧ = ⟦x⟧ :=
by rw [quot_mul_comm, quot_mul_one x]

theorem one_mul_equiv (x : pgame) : 1 * x ≈ x := quotient.exact $ quot_one_mul _

theorem quot_mul_assoc : ∀ (x y z : pgame), ⟦x * y * z⟧ = ⟦x * (y * z)⟧
| (mk xl xr xL xR) (mk yl yr yL yR) (mk zl zr zL zR) :=
begin
  let x := mk xl xr xL xR,
  let y := mk yl yr yL yR,
  let z := mk zl zr zL zR,
  refine quot_eq_of_mk_quot_eq _ _ _ _,
  { fsplit,
    { rintro (⟨⟨_, _⟩ | ⟨_, _⟩, _⟩ | ⟨⟨_, _⟩ | ⟨_, _⟩, _⟩);
      solve_by_elim [sum.inl, sum.inr, prod.mk] { max_depth := 7 } },
    { rintro (⟨_, ⟨_, _⟩ | ⟨_, _⟩⟩ | ⟨_,⟨_, _⟩ | ⟨_, _⟩⟩);
      solve_by_elim [sum.inl, sum.inr, prod.mk] { max_depth := 7 } },
    { rintro (⟨⟨_, _⟩ | ⟨_, _⟩, _⟩ | ⟨⟨_,_⟩ | ⟨_, _⟩,_⟩); refl },
    { rintro (⟨_, ⟨_, _⟩ | ⟨_, _⟩⟩ | ⟨_,⟨_, _⟩ | ⟨_, _⟩⟩); refl } },
  { fsplit,
    { rintro (⟨⟨_, _⟩ | ⟨_, _⟩, _⟩ | ⟨⟨_, _⟩ | ⟨_, _⟩,_⟩);
      solve_by_elim [sum.inl, sum.inr, prod.mk] { max_depth := 7 } },
    { rintro (⟨_, ⟨_, _⟩ | ⟨_, _⟩⟩ | ⟨_, ⟨_, _⟩ | ⟨_, _⟩⟩);
      solve_by_elim [sum.inl, sum.inr, prod.mk] { max_depth := 7 } },
    { rintro (⟨⟨_, _⟩ | ⟨_, _⟩, _⟩ | ⟨⟨_, _⟩ | ⟨_, _⟩,_⟩); refl },
    { rintro (⟨_, ⟨_, _⟩ | ⟨_, _⟩⟩ | ⟨_, ⟨_, _⟩ | ⟨_, _⟩⟩); refl } },
  all_goals
  { try { rintro (⟨⟨_, _⟩ | ⟨_, _⟩, _⟩ | ⟨⟨_, _⟩ | ⟨_, _⟩, _⟩) },
    try { rintro (⟨_, ⟨_, _⟩ | ⟨_, _⟩⟩ | ⟨_, ⟨_, _⟩ | ⟨_, _⟩⟩) },
    all_goals
    { change ⟦(_ * y + x * _ - _ * _) * z + (x * y) * _
               - (_ * y + x * _ - _ * _) * _⟧
             = ⟦_ * (y * z) + x * (_ * z + y * _ - _ * _)
               - _ * (_ * z + y * _ - _ * _)⟧,
      simp [quot_mul_assoc], abel } },
end
using_well_founded { dec_tac := pgame_wf_tac }

theorem mul_assoc_equiv (x y z : pgame) : x * y * z ≈ x * (y * z) :=
quotient.exact $ quot_mul_assoc _ _ _

section

parameters {l r : Type u}

inductive inv_ty (l r : Type u) : bool → Type u
| zero : inv_ty ff
| left₁ : r → inv_ty ff → inv_ty ff
| left₂ : l → inv_ty tt → inv_ty ff
| right₁ : l → inv_ty ff → inv_ty tt
| right₂ : r → inv_ty tt → inv_ty tt

mutual inductive inv_ty_ff, inv_ty_tt (l r : Type u)
with inv_ty_ff : Type u
| zero : inv_ty_ff
| left₁ : r → inv_ty_ff → inv_ty_ff
| left₂ : l → inv_ty_tt → inv_ty_ff
with inv_ty_tt : Type u
| right₁ : l → inv_ty_ff → inv_ty_tt
| right₂ : r → inv_ty_tt → inv_ty_tt

def inv_ty' : bool → Type u
| ff := inv_ty_ff
| tt := inv_ty_tt

def inv_ty'.sizeof : (Σ' b, inv_ty' b) → ℕ
| ⟨ff, x⟩ := @sizeof inv_ty_ff _ x
| ⟨tt, x⟩ := @sizeof inv_ty_tt _ x

meta def inv_ty'.rel_tac : expr → list expr → tactic unit :=
λ _ _, `[exact ⟨_, measure_wf inv_ty'.sizeof⟩]

@[simp] def inv_ty'.rec {C : Π b, inv_ty' b → Sort v}
  (hz : C ff inv_ty_ff.zero)
  (hl₁ : Π {j x}, C ff x → C ff (inv_ty_ff.left₁ j x))
  (hl₂ : Π {i x}, C tt x → C ff (inv_ty_ff.left₂ i x))
  (hr₁ : Π {i x}, C ff x → C tt (inv_ty_tt.right₁ i x))
  (hr₂ : Π {j x}, C tt x → C tt (inv_ty_tt.right₂ j x))
  : Π {b} x, C b x
| ff inv_ty_ff.zero := hz
| ff (inv_ty_ff.left₁ _ x) := hl₁ (@inv_ty'.rec ff x)
| ff (inv_ty_ff.left₂ _ x) := hl₂ (@inv_ty'.rec tt x)
| tt (inv_ty_tt.right₁ _ x) := hr₁ (@inv_ty'.rec ff x)
| tt (inv_ty_tt.right₂ _ x) := hr₂ (@inv_ty'.rec tt x)
using_well_founded { rel_tac := inv_ty'.rel_tac }

@[simp] def f_aux : Π {b}, inv_ty b → inv_ty' b
| _ inv_ty.zero := inv_ty_ff.zero
| _ (inv_ty.left₁ j x) := inv_ty_ff.left₁ j (f_aux x)
| _ (inv_ty.left₂ i x) := inv_ty_ff.left₂ i (f_aux x)
| _ (inv_ty.right₁ i x) := inv_ty_tt.right₁ i (f_aux x)
| _ (inv_ty.right₂ j x) := inv_ty_tt.right₂ j (f_aux x)

@[simp] def f : (Σ b, inv_ty b) → Σ b, inv_ty' b
| ⟨_, x⟩ := ⟨_, f_aux x⟩

@[simp] def f_inv_aux : Π b, inv_ty' b → inv_ty b
| ff inv_ty_ff.zero := inv_ty.zero
| ff (inv_ty_ff.left₁ j x) := inv_ty.left₁ j (f_inv_aux ff x)
| ff (inv_ty_ff.left₂ i x) := inv_ty.left₂ i (f_inv_aux tt x)
| tt (inv_ty_tt.right₁ i x) := inv_ty.right₁ i (f_inv_aux ff x)
| tt (inv_ty_tt.right₂ j x) := inv_ty.right₂ j (f_inv_aux tt x)
using_well_founded { rel_tac := inv_ty'.rel_tac }

@[simp] def f_inv : (Σ b, inv_ty' b) → Σ b, inv_ty b
| ⟨_, x⟩ := ⟨_, f_inv_aux _ x⟩

example : (Σ b, inv_ty b) ≃ Σ b, inv_ty' b :=
by refine ⟨f, f_inv, _, _⟩; rintro ⟨_, x⟩; induction x; simp * at *

end

instance (l r : Type u) [is_empty l] [is_empty r] : is_empty (inv_ty l r tt) :=
⟨by rintro (_|_|_|a|a); exact is_empty_elim a⟩

instance (l r : Type u) : inhabited (inv_ty l r ff) := ⟨inv_ty.zero⟩

instance unique_inv_ty (l r : Type u) [is_empty l] [is_empty r] : unique (inv_ty l r ff) :=
⟨_, by { rintro (_|a|a), refl, all_goals { exact is_empty_elim a } }⟩

def inv_val {l r} (L : l → pgame) (R : r → pgame)
  (IHl : l → pgame) (IHr : r → pgame) : ∀ {b}, inv_ty l r b → pgame
| _ inv_ty.zero := 0
| _ (inv_ty.left₁ j x) := (1 + (R j - mk l r L R) * inv_val x) * IHr j
| _ (inv_ty.left₂ i x) := (1 + (L i - mk l r L R) * inv_val x) * IHl i
| _ (inv_ty.right₁ i x) := (1 + (L i - mk l r L R) * inv_val x) * IHl i
| _ (inv_ty.right₂ j x) := (1 + (R j - mk l r L R) * inv_val x) * IHr j

@[simp] theorem inv_val_is_empty {l r b} (L R IHl IHr) (x : inv_ty l r b)
  [is_empty l] [is_empty r] : inv_val L R IHl IHr x = 0 :=
by { cases x with a _ a _ a _ a, refl, all_goals { exact is_empty_elim a } }

def inv' : pgame → pgame
| ⟨l, r, L, R⟩ :=
  let l' := {i // 0 < L i},
      L' : l' → pgame := λ i, L i.1,
      IHl' : l' → pgame := λ i, inv' (L i.1),
      IHr := λ i, inv' (R i) in
  ⟨inv_ty l' r ff, inv_ty l' r tt,
    inv_val L' R IHl' IHr, inv_val L' R IHl' IHr⟩

def inv'' : pgame → pgame
| ⟨l, r, L, R⟩ := begin
  let l' := {i // 0 < L i},
  let L' := λ i : l', L i.1,
  let IHl' := λ i : l', inv'' (L i.1),
  let IHr := λ j, inv'' (R j),
  exact ⟨inv_ty l' r ff, inv_ty l' r tt, inv_val L' R IHl' IHr, inv_val L' R IHl' IHr⟩
end

example : inv' = inv'' :=
begin
  ext x,
  induction x with _ _ _ _ IHl _,
  dsimp only [inv'],
  congr; ext; solve_by_elim [λ i, IHl (subtype.val i)]
end

def inv''' (x : pgame) : pgame :=
begin
  induction x with l r L R IHl IHr,
  let l' := {i // 0 < L i},
  let L' := λ i : l', L i.1,
  let IHl' := λ i : l', IHl i.1,
  exact ⟨inv_ty l' r ff, inv_ty l' r tt, inv_val L' R IHl' IHr, inv_val L' R IHl' IHr⟩
end

example : inv' = inv''' :=
begin
  ext x,
  induction x with _ _ _ _ IHl _,
  dsimp only [inv'],
  congr; ext; solve_by_elim [λ i, IHl (subtype.val i)]
end

theorem zero_lf_inv' : ∀ (x : pgame), 0 ⧏ inv' x
| ⟨xl, xr, xL, xR⟩ := by { convert lf_mk _ _ inv_ty.zero, refl }

def inv'_zero : inv' 0 ≡r 1 :=
begin
  change mk _ _ _ _ ≡r 1,
  refine ⟨_, _, λ i, _, is_empty_elim⟩,
  { dsimp, apply equiv.equiv_punit },
  { dsimp, apply equiv.equiv_pempty },
  { simp }
end

theorem inv'_zero_equiv : inv' 0 ≈ 1 := inv'_zero.equiv

def inv'_one : inv' 1 ≡r (1 : pgame.{u}) :=
begin
  change mk _ _ _ _ ≡r 1,
  haveI : is_empty {i : punit.{u+1} // (0 : pgame.{u}) < 0},
  { rw lt_self_iff_false, apply_instance },
  refine ⟨_, _, λ i, _, is_empty_elim⟩,
  { dsimp, apply equiv.equiv_punit },
  { dsimp, apply equiv.equiv_pempty },
  { simp }
end

theorem inv'_one_equiv : inv' 1 ≈ 1 := inv'_one.equiv

noncomputable instance : has_inv pgame :=
⟨by { classical, exact λ x, if x ≈ 0 then 0 else if 0 < x then inv' x else -inv' (-x) }⟩

noncomputable instance : has_div pgame := ⟨λ x y, x * y⁻¹⟩

theorem inv_eq_of_equiv_zero {x : pgame} (h : x ≈ 0) : x⁻¹ = 0 := if_pos h

@[simp] theorem inv_zero : (0 : pgame)⁻¹ = 0 :=
inv_eq_of_equiv_zero (equiv_refl _)

theorem inv_eq_of_pos {x : pgame} (h : 0 < x) : x⁻¹ = inv' x :=
(if_neg h.lf.not_equiv').trans (if_pos h)

theorem inv_eq_of_lf_zero {x : pgame} (h : x ⧏ 0) : x⁻¹ = -inv' (-x) :=
(if_neg h.not_equiv).trans (if_neg h.not_gt)

def inv_one : 1⁻¹ ≡r 1 :=
by { rw inv_eq_of_pos zero_lt_one, exact inv'_one }

theorem inv_one_equiv : 1⁻¹ ≈ 1 := inv_one.equiv

end pgame