/-
Copyright (c) 2019 Mario Carneiro. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Reid Barton, Mario Carneiro, Isabel Longbottom, Scott Morrison
-/
import logic.embedding
import data.nat.cast
import data.fin

/-!
# Combinatorial (pre-)games.

The basic theory of combinatorial games, following Conway's book `On Numbers and Games`. We
construct "pregames", define an ordering and arithmetic operations on them, then show that the
operations descend to "games", defined via the equivalence relation `p ≈ q ↔ p ≤ q ∧ q ≤ p`.

The surreal numbers will be built as a quotient of a subtype of pregames.

A pregame (`pgame` below) is axiomatised via an inductive type, whose sole constructor takes two
types (thought of as indexing the the possible moves for the players Left and Right), and a pair of
functions out of these types to `pgame` (thought of as describing the resulting game after making a
move).

Combinatorial games themselves, as a quotient of pregames, are constructed in `game.lean`.

## Conway induction

By construction, the induction principle for pregames is exactly "Conway induction". That is, to
prove some predicate `pgame → Prop` holds for all pregames, it suffices to prove that for every
pregame `g`, if the predicate holds for every game resulting from making a move, then it also holds
for `g`.

While it is often convenient to work "by induction" on pregames, in some situations this becomes
awkward, so we also define accessor functions `left_moves`, `right_moves`, `move_left` and
`move_right`. There is a relation `subsequent p q`, saying that `p` can be reached by playing some
non-empty sequence of moves starting from `q`, an instance `well_founded subsequent`, and a local
tactic `pgame_wf_tac` which is helpful for discharging proof obligations in inductive proofs relying
on this relation.

## Order properties

Pregames have both a `≤` and a `<` relation, which are related in quite a subtle way. In particular,
it is worth noting that in Lean's (perhaps unfortunate?) definition of a `preorder`, we have
`lt_iff_le_not_le : ∀ a b : α, a < b ↔ (a ≤ b ∧ ¬ b ≤ a)`, but this is _not_ satisfied by the usual
`≤` and `<` relations on pregames. (It is satisfied once we restrict to the surreal numbers.) In
particular, `<` is not transitive; there is an example below showing `0 < star ∧ star < 0`.

We do have
```
theorem not_le {x y : pgame} : ¬ x ≤ y ↔ y < x := ...
theorem not_lt {x y : pgame} : ¬ x < y ↔ y ≤ x := ...
```

The statement `0 ≤ x` means that Left has a good response to any move by Right; in particular, the
theorem `zero_le` below states
```
0 ≤ x ↔ ∀ j : x.right_moves, ∃ i : (x.move_right j).left_moves, 0 ≤ (x.move_right j).move_left i
```
On the other hand the statement `0 < x` means that Left has a good move right now; in particular the
theorem `zero_lt` below states
```
0 < x ↔ ∃ i : left_moves x, ∀ j : right_moves (x.move_left i), 0 < (x.move_left i).move_right j
```

The theorems `le_def`, `lt_def`, give a recursive characterisation of each relation, in terms of
themselves two moves later. The theorems `le_def_lt` and `lt_def_lt` give recursive
characterisations of each relation in terms of the other relation one move later.

We define an equivalence relation `equiv p q ↔ p ≤ q ∧ q ≤ p`. Later, games will be defined as the
quotient by this relation.

## Algebraic structures

We next turn to defining the operations necessary to make games into a commutative additive group.
Addition is defined for $x = \{xL | xR\}$ and $y = \{yL | yR\}$ by $x + y = \{xL + y, x + yL | xR +
y, x + yR\}$. Negation is defined by $\{xL | xR\} = \{-xR | -xL\}$.

The order structures interact in the expected way with addition, so we have
```
theorem le_iff_sub_nonneg {x y : pgame} : x ≤ y ↔ 0 ≤ y - x := sorry
theorem lt_iff_sub_pos {x y : pgame} : x < y ↔ 0 < y - x := sorry
```

We show that these operations respect the equivalence relation, and hence descend to games. At the
level of games, these operations satisfy all the laws of a commutative group. To prove the necessary
equivalence relations at the level of pregames, we introduce the notion of a `relabelling` of a
game, and show, for example, that there is a relabelling between `x + (y + z)` and `(x + y) + z`.

## Future work
* The theory of dominated and reversible positions, and unique normal form for short games.
* Analysis of basic domineering positions.
* Hex.
* Temperature.
* The development of surreal numbers, based on this development of combinatorial games, is still
  quite incomplete.

## References

The material here is all drawn from
* [Conway, *On numbers and games*][conway2001]

An interested reader may like to formalise some of the material from
* [Andreas Blass, *A game semantics for linear logic*][MR1167694]
* [André Joyal, *Remarques sur la théorie des jeux à deux personnes*][joyal1997]
-/

universes u

/-- The type of pre-games, before we have quotiented
  by extensionality. In ZFC, a combinatorial game is constructed from
  two sets of combinatorial games that have been constructed at an earlier
  stage. To do this in type theory, we say that a pre-game is built
  inductively from two families of pre-games indexed over any type
  in Type u. The resulting type `pgame.{u}` lives in `Type (u+1)`,
  reflecting that it is a proper class in ZFC. -/
inductive pgame : Type (u+1)
| mk : ∀ α β : Type u, (α → pgame) → (β → pgame) → pgame

namespace pgame

/--
Construct a pre-game from list of pre-games describing the available moves for Left and Right.
-/
-- TODO provide some API describing the interaction with
-- `left_moves`, `right_moves`, `move_left` and `move_right` below.
-- TODO define this at the level of games, as well, and perhaps also for finsets of games.
def of_lists (L R : list pgame.{0}) : pgame.{0} :=
pgame.mk (fin L.length) (fin R.length) (λ i, L.nth_le i i.is_lt) (λ j, R.nth_le j.val j.is_lt)

/-- The indexing type for allowable moves by Left. -/
def left_moves : pgame → Type u
| (mk l _ _ _) := l
/-- The indexing type for allowable moves by Right. -/
def right_moves : pgame → Type u
| (mk _ r _ _) := r

/-- The new game after Left makes an allowed move. -/
def move_left : Π (g : pgame), left_moves g → pgame
| (mk l _ L _) i := L i
/-- The new game after Right makes an allowed move. -/
def move_right : Π (g : pgame), right_moves g → pgame
| (mk _ r _ R) j := R j

@[simp] lemma left_moves_mk {xl xr xL xR} : (⟨xl, xr, xL, xR⟩ : pgame).left_moves = xl := rfl
@[simp] lemma move_left_mk {xl xr xL xR i} : (⟨xl, xr, xL, xR⟩ : pgame).move_left i = xL i := rfl
@[simp] lemma right_moves_mk {xl xr xL xR} : (⟨xl, xr, xL, xR⟩ : pgame).right_moves = xr := rfl
@[simp] lemma move_right_mk {xl xr xL xR j} : (⟨xl, xr, xL, xR⟩ : pgame).move_right j = xR j := rfl

/-- `subsequent p q` says that `p` can be obtained by playing
  some nonempty sequence of moves from `q`. -/
inductive subsequent : pgame → pgame → Prop
| left : Π (x : pgame) (i : x.left_moves), subsequent (x.move_left i) x
| right : Π (x : pgame) (j : x.right_moves), subsequent (x.move_right j) x
| trans : Π (x y z : pgame), subsequent x y → subsequent y z → subsequent x z

theorem wf_subsequent : well_founded subsequent :=
⟨λ x, begin
  induction x with l r L R IHl IHr,
  refine ⟨_, λ y h, _⟩,
  generalize_hyp e : mk l r L R = x at h,
  induction h with _ i _ j a b _ h1 h2 IH1 IH2; subst e,
  { apply IHl },
  { apply IHr },
  { exact acc.inv (IH2 rfl) h1 }
end⟩

instance : has_well_founded pgame :=
{ r := subsequent,
  wf := wf_subsequent }

/-- A move by Left produces a subsequent game. (For use in pgame_wf_tac.) -/
lemma subsequent.left_move {xl xr} {xL : xl → pgame} {xR : xr → pgame} {i : xl} :
  subsequent (xL i) (mk xl xr xL xR) :=
subsequent.left (mk xl xr xL xR) i
/-- A move by Right produces a subsequent game. (For use in pgame_wf_tac.) -/
lemma subsequent.right_move {xl xr} {xL : xl → pgame} {xR : xr → pgame} {j : xr} :
  subsequent (xR j) (mk xl xr xL xR) :=
subsequent.right (mk xl xr xL xR) j

/-- A local tactic for proving well-foundedness of recursive definitions involving pregames. -/
meta def pgame_wf_tac :=
`[solve_by_elim
  [psigma.lex.left, psigma.lex.right,
   subsequent.left_move, subsequent.right_move,
   subsequent.left, subsequent.right, subsequent.trans]
  { max_depth := 6 }]

/-- The pre-game `zero` is defined by `0 = { | }`. -/
instance : has_zero pgame := ⟨⟨pempty, pempty, pempty.elim, pempty.elim⟩⟩

@[simp] lemma zero_left_moves : (0 : pgame).left_moves = pempty := rfl
@[simp] lemma zero_right_moves : (0 : pgame).right_moves = pempty := rfl

instance : inhabited pgame := ⟨0⟩

/-- The pre-game `one` is defined by `1 = { 0 | }`. -/
instance : has_one pgame := ⟨⟨punit, pempty, λ _, 0, pempty.elim⟩⟩

@[simp] lemma one_left_moves : (1 : pgame).left_moves = punit := rfl
@[simp] lemma one_move_left : (1 : pgame).move_left punit.star = 0 := rfl
@[simp] lemma one_right_moves : (1 : pgame).right_moves = pempty := rfl

/-- Define simultaneously by mutual induction the `<=` and `<`
  relation on pre-games. The ZFC definition says that `x = {xL | xR}`
  is less or equal to `y = {yL | yR}` if `∀ x₁ ∈ xL, x₁ < y`
  and `∀ y₂ ∈ yR, x < y₂`, where `x < y` is the same as `¬ y <= x`.
  This is a tricky induction because it only decreases one side at
  a time, and it also swaps the arguments in the definition of `<`.
  The solution is to define `x < y` and `x <= y` simultaneously. -/
def le_lt : Π (x y : pgame), Prop × Prop
| (mk xl xr xL xR) (mk yl yr yL yR) :=
  -- the orderings of the clauses here are carefully chosen so that
  --   and.left/or.inl refer to moves by Left, and
  --   and.right/or.inr refer to moves by Right.
((∀ i : xl, (le_lt (xL i) ⟨yl, yr, yL, yR⟩).2) ∧ (∀ j : yr, (le_lt ⟨xl, xr, xL, xR⟩ (yR j)).2),
  (∃ i : yl, (le_lt ⟨xl, xr, xL, xR⟩ (yL i)).1) ∨ (∃ j : xr, (le_lt (xR j) ⟨yl, yr, yL, yR⟩).1))
using_well_founded { dec_tac := pgame_wf_tac }

instance : has_le pgame := ⟨λ x y, (le_lt x y).1⟩
instance : has_lt pgame := ⟨λ x y, (le_lt x y).2⟩

/-- Definition of `x ≤ y` on pre-games built using the constructor. -/
@[simp] theorem mk_le_mk {xl xr xL xR yl yr yL yR} :
  (⟨xl, xr, xL, xR⟩ : pgame) ≤ ⟨yl, yr, yL, yR⟩ ↔
  (∀ i, xL i < ⟨yl, yr, yL, yR⟩) ∧
  (∀ j, (⟨xl, xr, xL, xR⟩ : pgame) < yR j) :=
show (le_lt _ _).1 ↔ _, by { rw le_lt, refl }

/-- Definition of `x ≤ y` on pre-games, in terms of `<` -/
theorem le_def_lt {x y : pgame} : x ≤ y ↔
  (∀ i : x.left_moves, x.move_left i < y) ∧
  (∀ j : y.right_moves, x < y.move_right j) :=
by { cases x, cases y, rw mk_le_mk, refl }

/-- Definition of `x < y` on pre-games built using the constructor. -/
@[simp] theorem mk_lt_mk {xl xr xL xR yl yr yL yR} :
  (⟨xl, xr, xL, xR⟩ : pgame) < ⟨yl, yr, yL, yR⟩ ↔
  (∃ i, (⟨xl, xr, xL, xR⟩ : pgame) ≤ yL i) ∨
  (∃ j, xR j ≤ ⟨yl, yr, yL, yR⟩) :=
show (le_lt _ _).2 ↔ _, by { rw le_lt, refl }

/-- Definition of `x < y` on pre-games, in terms of `≤` -/
theorem lt_def_le {x y : pgame} : x < y ↔
  (∃ i : y.left_moves, x ≤ y.move_left i) ∨
  (∃ j : x.right_moves, x.move_right j ≤ y) :=
by { cases x, cases y, rw mk_lt_mk, refl }

/-- The definition of `x ≤ y` on pre-games, in terms of `≤` two moves later. -/
theorem le_def {x y : pgame} : x ≤ y ↔
  (∀ i : x.left_moves,
   (∃ i' : y.left_moves, x.move_left i ≤ y.move_left i') ∨
   (∃ j : (x.move_left i).right_moves, (x.move_left i).move_right j ≤ y)) ∧
  (∀ j : y.right_moves,
   (∃ i : (y.move_right j).left_moves, x ≤ (y.move_right j).move_left i) ∨
   (∃ j' : x.right_moves, x.move_right j' ≤ y.move_right j)) :=
begin
  rw [le_def_lt],
  conv { to_lhs, simp only [lt_def_le] },
end

/-- The definition of `x < y` on pre-games, in terms of `<` two moves later. -/
theorem lt_def {x y : pgame} : x < y ↔
  (∃ i : y.left_moves,
    (∀ i' : x.left_moves, x.move_left i' < y.move_left i) ∧
    (∀ j : (y.move_left i).right_moves, x < (y.move_left i).move_right j)) ∨
  (∃ j : x.right_moves,
    (∀ i : (x.move_right j).left_moves, (x.move_right j).move_left i < y) ∧
    (∀ j' : y.right_moves, x.move_right j < y.move_right j')) :=
begin
  rw [lt_def_le],
  conv { to_lhs, simp only [le_def_lt] },
end

/-- The definition of `x ≤ 0` on pre-games, in terms of `≤ 0` two moves later. -/
theorem le_zero {x : pgame} : x ≤ 0 ↔
  ∀ i : x.left_moves, ∃ j : (x.move_left i).right_moves, (x.move_left i).move_right j ≤ 0 :=
begin
  rw le_def,
  dsimp,
  simp [forall_pempty, exists_pempty]
end

/-- The definition of `0 ≤ x` on pre-games, in terms of `0 ≤` two moves later. -/
theorem zero_le {x : pgame} : 0 ≤ x ↔
  ∀ j : x.right_moves, ∃ i : (x.move_right j).left_moves, 0 ≤ (x.move_right j).move_left i :=
begin
  rw le_def,
  dsimp,
  simp [forall_pempty, exists_pempty]
end

/-- The definition of `x < 0` on pre-games, in terms of `< 0` two moves later. -/
theorem lt_zero {x : pgame} : x < 0 ↔
  ∃ j : x.right_moves, ∀ i : (x.move_right j).left_moves, (x.move_right j).move_left i < 0 :=
begin
  rw lt_def,
  dsimp,
  simp [forall_pempty, exists_pempty]
end

/-- The definition of `0 < x` on pre-games, in terms of `< x` two moves later. -/
theorem zero_lt {x : pgame} : 0 < x ↔
  ∃ i : x.left_moves, ∀ j : (x.move_left i).right_moves, 0 < (x.move_left i).move_right j :=
begin
  rw lt_def,
  dsimp,
  simp [forall_pempty, exists_pempty]
end

/-- Given a right-player-wins game, provide a response to any move by left. -/
noncomputable def right_response {x : pgame} (h : x ≤ 0) (i : x.left_moves) :
  (x.move_left i).right_moves :=
classical.some $ (le_zero.1 h) i

/-- Show that the response for right provided by `right_response`
    preserves the right-player-wins condition. -/
lemma right_response_spec {x : pgame} (h : x ≤ 0) (i : x.left_moves) :
  (x.move_left i).move_right (right_response h i) ≤ 0 :=
classical.some_spec $ (le_zero.1 h) i

/-- Given a left-player-wins game, provide a response to any move by right. -/
noncomputable def left_response {x : pgame} (h : 0 ≤ x) (j : x.right_moves) :
  (x.move_right j).left_moves :=
classical.some $ (zero_le.1 h) j

/-- Show that the response for left provided by `left_response`
    preserves the left-player-wins condition. -/
lemma left_response_spec {x : pgame} (h : 0 ≤ x) (j : x.right_moves) :
  0 ≤ (x.move_right j).move_left (left_response h j) :=
classical.some_spec $ (zero_le.1 h) j

theorem lt_of_le_mk {xl xr xL xR y i} :
  (⟨xl, xr, xL, xR⟩ : pgame) ≤ y → xL i < y :=
by { cases y, rw mk_le_mk, tauto }

theorem lt_of_mk_le {x : pgame} {yl yr yL yR i} :
  x ≤ ⟨yl, yr, yL, yR⟩ → x < yR i :=
by { cases x, rw mk_le_mk, tauto }

theorem mk_lt_of_le {xl xr xL xR y i} :
  (by exact xR i ≤ y) → (⟨xl, xr, xL, xR⟩ : pgame) < y :=
by { cases y, rw mk_lt_mk, tauto }

theorem lt_mk_of_le {x : pgame} {yl yr yL yR i} :
  (by exact x ≤ yL i) → x < ⟨yl, yr, yL, yR⟩ :=
by { cases x, rw mk_lt_mk, exact λ h, or.inl ⟨_, h⟩ }

theorem not_le_lt {x y : pgame} :
  (¬ x ≤ y ↔ y < x) ∧ (¬ x < y ↔ y ≤ x) :=
begin
  induction x with xl xr xL xR IHxl IHxr generalizing y,
  induction y with yl yr yL yR IHyl IHyr,
  classical,
  simp only [mk_le_mk, mk_lt_mk,
    not_and_distrib, not_or_distrib, not_forall, not_exists,
    and_comm, or_comm, IHxl, IHxr, IHyl, IHyr, iff_self, and_self]
end

theorem not_le {x y : pgame} : ¬ x ≤ y ↔ y < x := not_le_lt.1
theorem not_lt {x y : pgame} : ¬ x < y ↔ y ≤ x := not_le_lt.2

@[refl] theorem le_refl : ∀ x : pgame, x ≤ x
| ⟨l, r, L, R⟩ := by rw mk_le_mk; exact
⟨λ i, lt_mk_of_le (le_refl _), λ i, mk_lt_of_le (le_refl _)⟩

theorem lt_irrefl (x : pgame) : ¬ x < x :=
not_lt.2 (le_refl _)

theorem ne_of_lt : ∀ {x y : pgame}, x < y → x ≠ y
| x _ h rfl := lt_irrefl x h

theorem le_trans_aux
  {xl xr} {xL : xl → pgame} {xR : xr → pgame}
  {yl yr} {yL : yl → pgame} {yR : yr → pgame}
  {zl zr} {zL : zl → pgame} {zR : zr → pgame}
  (h₁ : ∀ i, mk yl yr yL yR ≤ mk zl zr zL zR → mk zl zr zL zR ≤ xL i → mk yl yr yL yR ≤ xL i)
  (h₂ : ∀ i, zR i ≤ mk xl xr xL xR → mk xl xr xL xR ≤ mk yl yr yL yR → zR i ≤ mk yl yr yL yR) :
  mk xl xr xL xR ≤ mk yl yr yL yR →
  mk yl yr yL yR ≤ mk zl zr zL zR →
  mk xl xr xL xR ≤ mk zl zr zL zR :=
by simp only [mk_le_mk] at *; exact
λ ⟨xLy, xyR⟩ ⟨yLz, yzR⟩, ⟨
  λ i, not_le.1 (λ h, not_lt.2 (h₁ _ ⟨yLz, yzR⟩ h) (xLy _)),
  λ i, not_le.1 (λ h, not_lt.2 (h₂ _ h ⟨xLy, xyR⟩) (yzR _))⟩

@[trans] theorem le_trans {x y z : pgame} : x ≤ y → y ≤ z → x ≤ z :=
suffices ∀ {x y z : pgame},
  (x ≤ y → y ≤ z → x ≤ z) ∧ (y ≤ z → z ≤ x → y ≤ x) ∧ (z ≤ x → x ≤ y → z ≤ y),
from this.1, begin
  clear x y z, intros,
  induction x with xl xr xL xR IHxl IHxr generalizing y z,
  induction y with yl yr yL yR IHyl IHyr generalizing z,
  induction z with zl zr zL zR IHzl IHzr,
  exact ⟨
    le_trans_aux (λ i, (IHxl _).2.1) (λ i, (IHzr _).2.2),
    le_trans_aux (λ i, (IHyl _).2.2) (λ i, (IHxr _).1),
    le_trans_aux (λ i, (IHzl _).1) (λ i, (IHyr _).2.1)⟩,
end

@[trans] theorem lt_of_le_of_lt {x y z : pgame} (hxy : x ≤ y) (hyz : y < z) : x < z :=
begin
  rw ←not_le at ⊢ hyz,
  exact mt (λ H, le_trans H hxy) hyz
end

@[trans] theorem lt_of_lt_of_le {x y z : pgame} (hxy : x < y) (hyz : y ≤ z) : x < z :=
begin
  rw ←not_le at ⊢ hxy,
  exact mt (λ H, le_trans hyz H) hxy
end

/-- Define the equivalence relation on pre-games. Two pre-games
  `x`, `y` are equivalent if `x ≤ y` and `y ≤ x`. -/
def equiv (x y : pgame) : Prop := x ≤ y ∧ y ≤ x

local infix ` ≈ ` := pgame.equiv

@[refl, simp] theorem equiv_refl (x) : x ≈ x := ⟨le_refl _, le_refl _⟩
@[symm] theorem equiv_symm {x y} : x ≈ y → y ≈ x | ⟨xy, yx⟩ := ⟨yx, xy⟩
@[trans] theorem equiv_trans {x y z} : x ≈ y → y ≈ z → x ≈ z
| ⟨xy, yx⟩ ⟨yz, zy⟩ := ⟨le_trans xy yz, le_trans zy yx⟩

theorem lt_of_lt_of_equiv {x y z} (h₁ : x < y) (h₂ : y ≈ z) : x < z := lt_of_lt_of_le h₁ h₂.1
theorem le_of_le_of_equiv {x y z} (h₁ : x ≤ y) (h₂ : y ≈ z) : x ≤ z := le_trans h₁ h₂.1
theorem lt_of_equiv_of_lt {x y z} (h₁ : x ≈ y) (h₂ : y < z) : x < z := lt_of_le_of_lt h₁.1 h₂
theorem le_of_equiv_of_le {x y z} (h₁ : x ≈ y) (h₂ : y ≤ z) : x ≤ z := le_trans h₁.1 h₂

theorem le_congr {x₁ y₁ x₂ y₂} : x₁ ≈ x₂ → y₁ ≈ y₂ → (x₁ ≤ y₁ ↔ x₂ ≤ y₂)
| ⟨x12, x21⟩ ⟨y12, y21⟩ := ⟨λ h, le_trans x21 (le_trans h y12), λ h, le_trans x12 (le_trans h y21)⟩

theorem lt_congr {x₁ y₁ x₂ y₂} (hx : x₁ ≈ x₂) (hy : y₁ ≈ y₂) : x₁ < y₁ ↔ x₂ < y₂ :=
not_le.symm.trans $ (not_congr (le_congr hy hx)).trans not_le

theorem equiv_congr_left {y₁ y₂} : y₁ ≈ y₂ ↔ ∀ x₁, x₁ ≈ y₁ ↔ x₁ ≈ y₂ :=
⟨λ h x₁, ⟨λ h', equiv_trans h' h, λ h', equiv_trans h' (equiv_symm h)⟩,
 λ h, (h y₁).1 $ equiv_refl _⟩

theorem equiv_congr_right {x₁ x₂} : x₁ ≈ x₂ ↔ ∀ y₁, x₁ ≈ y₁ ↔ x₂ ≈ y₁ :=
⟨λ h y₁, ⟨λ h', equiv_trans (equiv_symm h) h', λ h', equiv_trans h h'⟩,
 λ h, (h x₂).2 $ equiv_refl _⟩

/-- `restricted x y` says that Left always has no more moves in `x` than in `y`,
     and Right always has no more moves in `y` than in `x` -/
inductive restricted : pgame.{u} → pgame.{u} → Type (u+1)
| mk : Π {x y : pgame} (L : x.left_moves → y.left_moves) (R : y.right_moves → x.right_moves),
         (∀ (i : x.left_moves), restricted (x.move_left i) (y.move_left (L i))) →
         (∀ (j : y.right_moves), restricted (x.move_right (R j)) (y.move_right j)) → restricted x y

/-- The identity restriction. -/
@[refl] def restricted.refl : Π (x : pgame), restricted x x
| (mk xl xr xL xR) :=
  restricted.mk
    id id
    (λ i, restricted.refl _) (λ j, restricted.refl _)
using_well_founded { dec_tac := pgame_wf_tac }

-- TODO trans for restricted

theorem restricted.le : Π {x y : pgame} (r : restricted x y), x ≤ y
| (mk xl xr xL xR) (mk yl yr yL yR)
  (restricted.mk L_embedding R_embedding L_restriction R_restriction) :=
begin
  rw le_def,
  exact
    ⟨λ i, or.inl ⟨L_embedding i, (L_restriction i).le⟩,
     λ i, or.inr ⟨R_embedding i, (R_restriction i).le⟩⟩
end

/--
`relabelling x y` says that `x` and `y` are really the same game, just dressed up differently.
Specifically, there is a bijection between the moves for Left in `x` and in `y`, and similarly
for Right, and under these bijections we inductively have `relabelling`s for the consequent games.
-/
inductive relabelling : pgame.{u} → pgame.{u} → Type (u+1)
| mk : Π {x y : pgame} (L : x.left_moves ≃ y.left_moves) (R : x.right_moves ≃ y.right_moves),
         (∀ (i : x.left_moves), relabelling (x.move_left i) (y.move_left (L i))) →
         (∀ (j : y.right_moves), relabelling (x.move_right (R.symm j)) (y.move_right j)) →
       relabelling x y

/-- If `x` is a relabelling of `y`, then Left and Right have the same moves in either game,
    so `x` is a restriction of `y`. -/
def relabelling.restricted: Π {x y : pgame} (r : relabelling x y), restricted x y
| (mk xl xr xL xR) (mk yl yr yL yR) (relabelling.mk L_equiv R_equiv L_relabelling R_relabelling) :=
restricted.mk L_equiv.to_embedding R_equiv.symm.to_embedding
  (λ i, (L_relabelling i).restricted)
  (λ j, (R_relabelling j).restricted)

-- It's not the case that `restricted x y → restricted y x → relabelling x y`,
-- but if we insisted that the maps in a restriction were injective, then one
-- could use Schröder-Bernstein for do this.

/-- The identity relabelling. -/
@[refl] def relabelling.refl : Π (x : pgame), relabelling x x
| (mk xl xr xL xR) :=
  relabelling.mk (equiv.refl _) (equiv.refl _)
    (λ i, relabelling.refl _) (λ j, relabelling.refl _)
using_well_founded { dec_tac := pgame_wf_tac }

/-- Reverse a relabelling. -/
@[symm] def relabelling.symm : Π {x y : pgame}, relabelling x y → relabelling y x
| (mk xl xr xL xR) (mk yl yr yL yR) (relabelling.mk L_equiv R_equiv L_relabelling R_relabelling) :=
begin
  refine relabelling.mk L_equiv.symm R_equiv.symm _ _,
  { intro i, simpa using (L_relabelling (L_equiv.symm i)).symm },
  { intro j, simpa using (R_relabelling (R_equiv j)).symm }
end

/-- Transitivity of relabelling -/
@[trans] def relabelling.trans :
  Π {x y z : pgame}, relabelling x y → relabelling y z → relabelling x z
| (mk xl xr xL xR) (mk yl yr yL yR) (mk zl zr zL zR)
  (relabelling.mk L_equiv₁ R_equiv₁ L_relabelling₁ R_relabelling₁)
  (relabelling.mk L_equiv₂ R_equiv₂ L_relabelling₂ R_relabelling₂) :=
begin
  refine relabelling.mk (L_equiv₁.trans L_equiv₂) (R_equiv₁.trans R_equiv₂) _ _,
  { intro i, simpa using (L_relabelling₁ _).trans (L_relabelling₂ _) },
  { intro j, simpa using (R_relabelling₁ _).trans (R_relabelling₂ _) },
end

theorem relabelling.le {x y : pgame} (r : relabelling x y) : x ≤ y :=
r.restricted.le

/-- A relabelling lets us prove equivalence of games. -/
theorem relabelling.equiv {x y : pgame} (r : relabelling x y) : x ≈ y :=
⟨r.le, r.symm.le⟩

instance {x y : pgame} : has_coe (relabelling x y) (x ≈ y) := ⟨relabelling.equiv⟩

/-- Replace the types indexing the next moves for Left and Right by equivalent types. -/
def relabel {x : pgame} {xl' xr'} (el : x.left_moves ≃ xl') (er : x.right_moves ≃ xr') :=
pgame.mk xl' xr' (λ i, x.move_left (el.symm i)) (λ j, x.move_right (er.symm j))

@[simp] lemma relabel_move_left' {x : pgame} {xl' xr'}
  (el : x.left_moves ≃ xl') (er : x.right_moves ≃ xr') (i : xl') :
  move_left (relabel el er) i = x.move_left (el.symm i) :=
rfl
@[simp] lemma relabel_move_left {x : pgame} {xl' xr'}
  (el : x.left_moves ≃ xl') (er : x.right_moves ≃ xr') (i : x.left_moves) :
  move_left (relabel el er) (el i) = x.move_left i :=
by simp

@[simp] lemma relabel_move_right' {x : pgame} {xl' xr'}
  (el : x.left_moves ≃ xl') (er : x.right_moves ≃ xr') (j : xr') :
  move_right (relabel el er) j = x.move_right (er.symm j) :=
rfl
@[simp] lemma relabel_move_right {x : pgame} {xl' xr'}
  (el : x.left_moves ≃ xl') (er : x.right_moves ≃ xr') (j : x.right_moves) :
  move_right (relabel el er) (er j) = x.move_right j :=
by simp

/-- The game obtained by relabelling the next moves is a relabelling of the original game. -/
def relabel_relabelling {x : pgame} {xl' xr'} (el : x.left_moves ≃ xl') (er : x.right_moves ≃ xr') :
  relabelling x (relabel el er) :=
relabelling.mk el er (λ i, by simp) (λ j, by simp)

/-- The negation of `{L | R}` is `{-R | -L}`. -/
def neg : pgame → pgame
| ⟨l, r, L, R⟩ := ⟨r, l, λ i, neg (R i), λ i, neg (L i)⟩

instance : has_neg pgame := ⟨neg⟩

@[simp] lemma neg_def {xl xr xL xR} : -(mk xl xr xL xR) = mk xr xl (λ j, -(xR j)) (λ i, -(xL i)) :=
rfl

@[simp] theorem neg_neg : Π {x : pgame}, -(-x) = x
| (mk xl xr xL xR) :=
begin
  dsimp [has_neg.neg, neg],
  congr; funext i; apply neg_neg
end

@[simp] theorem neg_zero : -(0 : pgame) = 0 :=
begin
  dsimp [has_zero.zero, has_neg.neg, neg],
  congr; funext i; cases i
end

/-- An explicit equivalence between the moves for Left in `-x` and the moves for Right in `x`. -/
-- This equivalence is useful to avoid having to use `cases` unnecessarily.
def left_moves_neg (x : pgame) : (-x).left_moves ≃ x.right_moves :=
by { cases x, refl }

/-- An explicit equivalence between the moves for Right in `-x` and the moves for Left in `x`. -/
def right_moves_neg (x : pgame) : (-x).right_moves ≃ x.left_moves :=
by { cases x, refl }

@[simp] lemma move_right_left_moves_neg {x : pgame} (i : left_moves (-x)) :
  move_right x ((left_moves_neg x) i) = -(move_left (-x) i) :=
begin
  induction x,
  exact neg_neg.symm
end
@[simp] lemma move_left_left_moves_neg_symm {x : pgame} (i : right_moves x) :
  move_left (-x) ((left_moves_neg x).symm i) = -(move_right x i) :=
by { cases x, refl }
@[simp] lemma move_left_right_moves_neg {x : pgame} (i : right_moves (-x)) :
  move_left x ((right_moves_neg x) i) = -(move_right (-x) i) :=
begin
  induction x,
  exact neg_neg.symm
end
@[simp] lemma move_right_right_moves_neg_symm {x : pgame} (i : left_moves x) :
  move_right (-x) ((right_moves_neg x).symm i) = -(move_left x i) :=
by { cases x, refl }

/-- If `x` has the same moves as `y`, then `-x` has the sames moves as `-y`. -/
def relabelling.neg_congr : ∀ {x y : pgame}, x.relabelling y → (-x).relabelling (-y)
| (mk xl xr xL xR) (mk yl yr yL yR) ⟨L_equiv, R_equiv, L_relabelling, R_relabelling⟩ :=
  ⟨R_equiv, L_equiv,
    λ i, relabelling.neg_congr (by simpa using R_relabelling (R_equiv i)),
    λ i, relabelling.neg_congr (by simpa using L_relabelling (L_equiv.symm i))⟩

theorem le_iff_neg_ge : Π {x y : pgame}, x ≤ y ↔ -y ≤ -x
| (mk xl xr xL xR) (mk yl yr yL yR) :=
begin
  rw [le_def],
  rw [le_def],
  dsimp [neg],
  split,
  { intro h,
    split,
    { intro i, have t := h.right i, cases t,
      { right, cases t,
        use (@right_moves_neg (yR i)).symm t_w, convert le_iff_neg_ge.1 t_h, simp },
      { left, cases t,
        use t_w, exact le_iff_neg_ge.1 t_h, } },
    { intro j, have t := h.left j, cases t,
      { right, cases t,
        use t_w, exact le_iff_neg_ge.1 t_h, },
      { left, cases t,
        use (@left_moves_neg (xL j)).symm t_w, convert le_iff_neg_ge.1 t_h, simp, } } },
  { intro h,
    split,
    { intro i, have t := h.right i, cases t,
      { right, cases t,
        use (@left_moves_neg (xL i)) t_w, convert le_iff_neg_ge.2 _, convert t_h, simp, },
      { left, cases t,
        use t_w, exact le_iff_neg_ge.2 t_h, } },
    { intro j, have t := h.left j, cases t,
      { right, cases t,
        use t_w, exact le_iff_neg_ge.2 t_h, },
      { left, cases t,
        use (@right_moves_neg (yR j)) t_w, convert le_iff_neg_ge.2 _, convert t_h, simp } } },
end
using_well_founded { dec_tac := pgame_wf_tac }

theorem neg_congr {x y : pgame} (h : x ≈ y) : -x ≈ -y :=
⟨le_iff_neg_ge.1 h.2, le_iff_neg_ge.1 h.1⟩

theorem lt_iff_neg_gt : Π {x y : pgame}, x < y ↔ -y < -x :=
begin
  classical,
  intros,
  rw [←not_le, ←not_le, not_iff_not],
  apply le_iff_neg_ge
end

theorem zero_le_iff_neg_le_zero {x : pgame} : 0 ≤ x ↔ -x ≤ 0 :=
begin
  convert le_iff_neg_ge,
  rw neg_zero
end

theorem le_zero_iff_zero_le_neg {x : pgame} : x ≤ 0 ↔ 0 ≤ -x :=
begin
  convert le_iff_neg_ge,
  rw neg_zero
end

/-- The sum of `x = {xL | xR}` and `y = {yL | yR}` is `{xL + y, x + yL | xR + y, x + yR}`. -/
def add (x y : pgame) : pgame :=
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, sum.rec _ _, sum.rec _ _⟩,
  { exact λ i, IHxl i y },
  { exact λ i, IHyl i },
  { exact λ i, IHxr i y },
  { exact λ i, IHyr i }
end

instance : has_add pgame := ⟨add⟩

/-- `x + 0` has exactly the same moves as `x`. -/
def add_zero_relabelling : Π (x : pgame.{u}), relabelling (x + 0) x
| (mk xl xr xL xR) :=
begin
  refine ⟨equiv.sum_pempty xl, equiv.sum_pempty xr, _, _⟩,
  { rintro (⟨i⟩|⟨⟨⟩⟩),
    apply add_zero_relabelling, },
  { rintro j,
    apply add_zero_relabelling, }
end

/-- `x + 0` is equivalent to `x`. -/
lemma add_zero_equiv (x : pgame.{u}) : x + 0 ≈ x :=
(add_zero_relabelling x).equiv

/-- `0 + x` has exactly the same moves as `x`. -/
def zero_add_relabelling : Π (x : pgame.{u}), relabelling (0 + x) x
| (mk xl xr xL xR) :=
begin
  refine ⟨equiv.pempty_sum xl, equiv.pempty_sum xr, _, _⟩,
  { rintro (⟨⟨⟩⟩|⟨i⟩),
    apply zero_add_relabelling, },
  { rintro j,
    apply zero_add_relabelling, }
end

/-- `0 + x` is equivalent to `x`. -/
lemma zero_add_equiv (x : pgame.{u}) : 0 + x ≈ x :=
(zero_add_relabelling x).equiv

/-- An explicit equivalence between the moves for Left in `x + y` and the type-theory sum
    of the moves for Left in `x` and in `y`. -/
def left_moves_add (x y : pgame) : (x + y).left_moves ≃ x.left_moves ⊕ y.left_moves :=
by { cases x, cases y, refl, }

/-- An explicit equivalence between the moves for Right in `x + y` and the type-theory sum
    of the moves for Right in `x` and in `y`. -/
def right_moves_add (x y : pgame) : (x + y).right_moves ≃ x.right_moves ⊕ y.right_moves :=
by { cases x, cases y, refl, }

@[simp] lemma mk_add_move_left_inl {xl xr yl yr} {xL xR yL yR} {i} :
  (mk xl xr xL xR + mk yl yr yL yR).move_left (sum.inl i) =
    (mk xl xr xL xR).move_left i + (mk yl yr yL yR) :=
rfl
@[simp] lemma add_move_left_inl {x y : pgame} {i} :
  (x + y).move_left ((@left_moves_add x y).symm (sum.inl i)) = x.move_left i + y :=
by { cases x, cases y, refl, }

@[simp] lemma mk_add_move_right_inl {xl xr yl yr} {xL xR yL yR} {i} :
  (mk xl xr xL xR + mk yl yr yL yR).move_right (sum.inl i) =
    (mk xl xr xL xR).move_right i + (mk yl yr yL yR) :=
rfl
@[simp] lemma add_move_right_inl {x y : pgame} {i} :
  (x + y).move_right ((@right_moves_add x y).symm (sum.inl i)) = x.move_right i + y :=
by { cases x, cases y, refl, }

@[simp] lemma mk_add_move_left_inr {xl xr yl yr} {xL xR yL yR} {i} :
  (mk xl xr xL xR + mk yl yr yL yR).move_left (sum.inr i) =
    (mk xl xr xL xR) + (mk yl yr yL yR).move_left i :=
rfl
@[simp] lemma add_move_left_inr {x y : pgame} {i : y.left_moves} :
  (x + y).move_left ((@left_moves_add x y).symm (sum.inr i)) = x + y.move_left i :=
by { cases x, cases y, refl, }

@[simp] lemma mk_add_move_right_inr {xl xr yl yr} {xL xR yL yR} {i} :
  (mk xl xr xL xR + mk yl yr yL yR).move_right (sum.inr i) =
    (mk xl xr xL xR) + (mk yl yr yL yR).move_right i :=
rfl
@[simp] lemma add_move_right_inr {x y : pgame} {i} :
  (x + y).move_right ((@right_moves_add x y).symm (sum.inr i)) = x + y.move_right i :=
by { cases x, cases y, refl, }

/-- If `w` has the same moves as `x` and `y` has the same moves as `z`,
then `w + y` has the same moves as `x + z`. -/
def relabelling.add_congr : ∀ {w x y z : pgame.{u}},
  w.relabelling x → y.relabelling z → (w + y).relabelling (x + z)
| (mk wl wr wL wR) (mk xl xr xL xR) (mk yl yr yL yR) (mk zl zr zL zR)
  ⟨L_equiv₁, R_equiv₁, L_relabelling₁, R_relabelling₁⟩
  ⟨L_equiv₂, R_equiv₂, L_relabelling₂, R_relabelling₂⟩ :=
begin
  refine ⟨equiv.sum_congr L_equiv₁ L_equiv₂, equiv.sum_congr R_equiv₁ R_equiv₂, _, _⟩,
  { rintro (i|j),
    { exact relabelling.add_congr
        (L_relabelling₁ i)
        (⟨L_equiv₂, R_equiv₂, L_relabelling₂, R_relabelling₂⟩) },
    { exact relabelling.add_congr
        (⟨L_equiv₁, R_equiv₁, L_relabelling₁, R_relabelling₁⟩)
        (L_relabelling₂ j) }},
  { rintro (i|j),
    { exact relabelling.add_congr
        (R_relabelling₁ i)
        (⟨L_equiv₂, R_equiv₂, L_relabelling₂, R_relabelling₂⟩) },
    { exact relabelling.add_congr
        (⟨L_equiv₁, R_equiv₁, L_relabelling₁, R_relabelling₁⟩)
        (R_relabelling₂ j) }}
end
using_well_founded { dec_tac := pgame_wf_tac }

instance : has_sub pgame := ⟨λ x y, x + -y⟩

/-- If `w` has the same moves as `x` and `y` has the same moves as `z`,
then `w - y` has the same moves as `x - z`. -/
def relabelling.sub_congr {w x y z : pgame}
  (h₁ : w.relabelling x) (h₂ : y.relabelling z) : (w - y).relabelling (x - z) :=
h₁.add_congr h₂.neg_congr

/-- `-(x+y)` has exactly the same moves as `-x + -y`. -/
def neg_add_relabelling : Π (x y : pgame), relabelling (-(x + y)) (-x + -y)
| (mk xl xr xL xR) (mk yl yr yL yR) :=
⟨equiv.refl _, equiv.refl _,
 λ j, sum.cases_on j
   (λ j, neg_add_relabelling (xR j) (mk yl yr yL yR))
   (λ j, neg_add_relabelling (mk xl xr xL xR) (yR j)),
 λ i, sum.cases_on i
   (λ i, neg_add_relabelling (xL i) (mk yl yr yL yR))
   (λ i, neg_add_relabelling (mk xl xr xL xR) (yL i))⟩
using_well_founded { dec_tac := pgame_wf_tac }

theorem neg_add_le {x y : pgame} : -(x + y) ≤ -x + -y :=
(neg_add_relabelling x y).le

/-- `x+y` has exactly the same moves as `y+x`. -/
def add_comm_relabelling : Π (x y : pgame.{u}), relabelling (x + y) (y + x)
| (mk xl xr xL xR) (mk yl yr yL yR) :=
begin
  refine ⟨equiv.sum_comm _ _, equiv.sum_comm _ _, _, _⟩;
  rintros (_|_);
  { simp [left_moves_add, right_moves_add], apply add_comm_relabelling }
end
using_well_founded { dec_tac := pgame_wf_tac }

theorem add_comm_le {x y : pgame} : x + y ≤ y + x :=
(add_comm_relabelling x y).le

theorem add_comm_equiv {x y : pgame} : x + y ≈ y + x :=
(add_comm_relabelling x y).equiv

/-- `(x + y) + z` has exactly the same moves as `x + (y + z)`. -/
def add_assoc_relabelling : Π (x y z : pgame.{u}), relabelling ((x + y) + z) (x + (y + z))
| (mk xl xr xL xR) (mk yl yr yL yR) (mk zl zr zL zR) :=
begin
  refine ⟨equiv.sum_assoc _ _ _, equiv.sum_assoc _ _ _, _, _⟩,
  { rintro (⟨i|i⟩|i),
    { apply add_assoc_relabelling, },
    { change relabelling
        (mk xl xr xL xR + yL i + mk zl zr zL zR) (mk xl xr xL xR + (yL i + mk zl zr zL zR)),
      apply add_assoc_relabelling, },
    { change relabelling
        (mk xl xr xL xR + mk yl yr yL yR + zL i) (mk xl xr xL xR + (mk yl yr yL yR + zL i)),
      apply add_assoc_relabelling, } },
  { rintro (j|⟨j|j⟩),
    { apply add_assoc_relabelling, },
    { change relabelling
        (mk xl xr xL xR + yR j + mk zl zr zL zR) (mk xl xr xL xR + (yR j + mk zl zr zL zR)),
      apply add_assoc_relabelling, },
    { change relabelling
        (mk xl xr xL xR + mk yl yr yL yR + zR j) (mk xl xr xL xR + (mk yl yr yL yR + zR j)),
      apply add_assoc_relabelling, } },
end
using_well_founded { dec_tac := pgame_wf_tac }

theorem add_assoc_equiv {x y z : pgame} : (x + y) + z ≈ x + (y + z) :=
(add_assoc_relabelling x y z).equiv

theorem add_le_add_right : Π {x y z : pgame} (h : x ≤ y), x + z ≤ y + z
| (mk xl xr xL xR) (mk yl yr yL yR) (mk zl zr zL zR) :=
begin
  intros h,
  rw le_def,
  split,
  { -- if Left plays first
    intros i,
    change xl ⊕ zl at i,
    cases i,
    { -- either they play in x
      rw le_def at h,
      cases h,
      have t := h_left i,
      rcases t with ⟨i', ih⟩ | ⟨j, jh⟩,
      { left,
        refine ⟨(left_moves_add _ _).inv_fun (sum.inl i'), _⟩,
        exact add_le_add_right ih, },
      { right,
        refine ⟨(right_moves_add _ _).inv_fun (sum.inl j), _⟩,
        convert add_le_add_right jh,
        apply add_move_right_inl },
      },
    { -- or play in z
      left,
      refine ⟨(left_moves_add _ _).inv_fun (sum.inr i), _⟩,
      exact add_le_add_right h, }, },
  { -- if Right plays first
    intros j,
    change yr ⊕ zr at j,
    cases j,
    { -- either they play in y
      rw le_def at h,
      cases h,
      have t := h_right j,
      rcases t with ⟨i, ih⟩ | ⟨j', jh⟩,
      { left,
        refine ⟨(left_moves_add _ _).inv_fun (sum.inl i), _⟩,
        convert add_le_add_right ih,
        apply add_move_left_inl },
      { right,
        refine ⟨(right_moves_add _ _).inv_fun (sum.inl j'), _⟩,
        exact add_le_add_right jh } },
    { -- or play in z
      right,
      refine ⟨(right_moves_add _ _).inv_fun (sum.inr j), _⟩,
      exact add_le_add_right h } }
end
using_well_founded { dec_tac := pgame_wf_tac }

theorem add_le_add_left {x y z : pgame} (h : y ≤ z) : x + y ≤ x + z :=
calc x + y ≤ y + x : add_comm_le
     ... ≤ z + x : add_le_add_right h
     ... ≤ x + z : add_comm_le

theorem add_congr {w x y z : pgame} (h₁ : w ≈ x) (h₂ : y ≈ z) : w + y ≈ x + z :=
⟨calc w + y ≤ w + z : add_le_add_left h₂.1
        ... ≤ x + z : add_le_add_right h₁.1,
 calc x + z ≤ x + y : add_le_add_left h₂.2
        ... ≤ w + y : add_le_add_right h₁.2⟩

theorem add_left_neg_le_zero : Π {x : pgame}, (-x) + x ≤ 0
| ⟨xl, xr, xL, xR⟩ :=
begin
  rw [le_def],
  split,
  { intro i,
    change xr ⊕ xl at i,
    cases i,
    { -- If Left played in -x, Right responds with the same move in x.
      right,
      refine ⟨(right_moves_add _ _).inv_fun (sum.inr i), _⟩,
      convert @add_left_neg_le_zero (xR i),
      exact add_move_right_inr },
    { -- If Left in x, Right responds with the same move in -x.
      right,
      dsimp,
      refine ⟨(right_moves_add _ _).inv_fun (sum.inl i), _⟩,
      convert @add_left_neg_le_zero (xL i),
      exact add_move_right_inl }, },
  { rintro ⟨⟩, }
end
using_well_founded { dec_tac := pgame_wf_tac }

theorem zero_le_add_left_neg : Π {x : pgame}, 0 ≤ (-x) + x :=
begin
  intro x,
  rw [le_iff_neg_ge, neg_zero],
  exact le_trans neg_add_le add_left_neg_le_zero
end

theorem add_left_neg_equiv {x : pgame} : (-x) + x ≈ 0 :=
⟨add_left_neg_le_zero, zero_le_add_left_neg⟩

theorem add_right_neg_le_zero {x : pgame} : x + (-x) ≤ 0 :=
calc x + (-x) ≤ (-x) + x : add_comm_le
     ... ≤ 0 : add_left_neg_le_zero

theorem zero_le_add_right_neg {x : pgame} : 0 ≤ x + (-x) :=
calc 0 ≤ (-x) + x : zero_le_add_left_neg
     ... ≤ x + (-x) : add_comm_le

theorem add_lt_add_right {x y z : pgame} (h : x < y) : x + z < y + z :=
suffices y + z ≤ x + z → y ≤ x, by { rw ←not_le at ⊢ h, exact mt this h },
assume w,
calc y ≤ y + 0            : (add_zero_relabelling _).symm.le
     ... ≤ y + (z + -z)   : add_le_add_left zero_le_add_right_neg
     ... ≤ (y + z) + (-z) : (add_assoc_relabelling _ _ _).symm.le
     ... ≤ (x + z) + (-z) : add_le_add_right w
     ... ≤ x + (z + -z)   : (add_assoc_relabelling _ _ _).le
     ... ≤ x + 0          : add_le_add_left add_right_neg_le_zero
     ... ≤ x              : (add_zero_relabelling _).le

theorem add_lt_add_left {x y z : pgame} (h : y < z) : x + y < x + z :=
calc x + y ≤ y + x : add_comm_le
     ... < z + x   : add_lt_add_right h
     ... ≤ x + z   : add_comm_le

theorem le_iff_sub_nonneg {x y : pgame} : x ≤ y ↔ 0 ≤ y - x :=
⟨λ h, le_trans zero_le_add_right_neg (add_le_add_right h),
 λ h,
  calc x ≤ 0 + x : (zero_add_relabelling x).symm.le
     ... ≤ (y - x) + x : add_le_add_right h
     ... ≤ y + (-x + x) : (add_assoc_relabelling _ _ _).le
     ... ≤ y + 0 : add_le_add_left (add_left_neg_le_zero)
     ... ≤ y : (add_zero_relabelling y).le⟩
theorem lt_iff_sub_pos {x y : pgame} : x < y ↔ 0 < y - x :=
⟨λ h, lt_of_le_of_lt zero_le_add_right_neg (add_lt_add_right h),
 λ h,
  calc x ≤ 0 + x : (zero_add_relabelling x).symm.le
     ... < (y - x) + x : add_lt_add_right h
     ... ≤ y + (-x + x) : (add_assoc_relabelling _ _ _).le
     ... ≤ y + 0 : add_le_add_left (add_left_neg_le_zero)
     ... ≤ y : (add_zero_relabelling y).le⟩

/-- The pre-game `star`, which is fuzzy/confused with zero. -/
def star : pgame := pgame.of_lists [0] [0]

theorem star_lt_zero : star < 0 :=
by rw lt_def; exact
or.inr ⟨⟨0, zero_lt_one⟩, (by split; rintros ⟨⟩)⟩

theorem zero_lt_star : 0 < star :=
by rw lt_def; exact
or.inl ⟨⟨0, zero_lt_one⟩, (by split; rintros ⟨⟩)⟩

/-- The pre-game `ω`. (In fact all ordinals have game and surreal representatives.) -/
def omega : pgame := ⟨ulift ℕ, pempty, λ n, ↑n.1, pempty.elim⟩

end pgame


import Mathlib.Logic.Denumerable

inductive ConsExp : Type
  | nat : Nat → ConsExp
  | cons : ConsExp → ConsExp → ConsExp

def ConsExp.encode : ConsExp → Nat
  | nat n => 2 * n
  | cons f g => 2 * Nat.mkpair f.encode g.encode + 1

def ConsExp.decode (n : ℕ) : ConsExp :=
  match hn : Nat.boddDiv2 n with
  | (false, m) => nat m
  | (true, m) =>
    match hm : Nat.unpair m with
    | (f, g) =>
      -- Some proofs to show termination:
      have hn' : 1 ≤ n := by
        cases n
        · simp at hn
        · simp [Nat.succ_eq_add_one]
      have : m < n := by
        have := congr_arg Prod.snd hn
        simp at this
        cases this
        apply Nat.binaryRec_decreasing
        rwa [Nat.one_le_iff_ne_zero] at hn'
      have : f < n := by
        apply Nat.lt_of_le_of_lt _ this
        have := congr_arg Prod.fst hm
        simp at this
        cases this
        cases m
        · simp
        next m =>
          apply (Nat.unpair_lt _).le
          simp [Nat.succ_eq_add_one]
      have : g < n := by
        have := congr_arg Prod.snd hm
        simp at this
        cases this
        have := Nat.unpair_right_le m
        apply Nat.lt_of_le_of_lt this
        assumption
      -- With those out of the way:
      cons (decode f) (decode g)
termination_by _ => n

theorem ConsExp.decode_encode (c : ConsExp) : ConsExp.decode c.encode = c := by
  induction c
  · rw [encode, decode]
    split
    next h =>
      simp [Nat.div2_val] at h
      simp [*]
    next h => simp at h
  next hf hg =>
    rw [encode, decode]
    split
    next h => simp at h
    next h =>
      simp [Nat.div2_val] at h
      cases h
      simp [*]

instance : Encodable ConsExp where
  encode := ConsExp.encode
  decode := fun v => some (ConsExp.decode v)
  encodek := fun a => by simp [ConsExp.decode_encode]


import tactic data.set.basic data.setoid.basic
set_option trace.simplify.rewrite true

#print partial_order
#print setoid
#print quotient
#print subtype
#print set

@[class] structure closure_op (Ω : Type _) (p : partial_order(Ω)):=
(co : Ω → Ω)
(co_extensive : ∀(X : Ω), X ≤ co(X))
(co_monotonic : ∀(X Y : Ω), (X ≤ Y) → (co(X) ≤ co(Y)))
(co_idempotent: ∀(X : Ω), co(co(X)) = co(X))

--Ejemplo: Saturación de una relación de equivalencia
@[instance] def set.partial_order (Ω : Type _): partial_order (set (Ω)) :=
{
  le := (⊆),
  lt := (⊂),
  le_refl := @set.subset.rfl (Ω),
  le_trans := @set.subset.trans (Ω),
  lt_iff_le_not_le :=
    begin
      assume A B,
      simp *,
      refl
    end,
  le_antisymm := @set.subset.antisymm (Ω)
}

def sat_fun {Ω : Type _} {Φ : setoid (Ω)} : set (Ω) → set (Ω) :=
λ L, (λ y, ∃ ( x ∈ L ), x ≈ y)

namespace sat_fun

lemma is_extensive {Ω : Type _} {Φ : setoid (Ω)}:
 ∀(L : set Ω), L ⊆ @sat_fun (Ω) (Φ) (L) :=
begin
  assume L,
  assume x,
  assume x_in_L,
  fconstructor,
  {
    exact x
  },
  {
    tauto
  }
end

lemma is_monotonic {Ω : Type _} {Φ : setoid (Ω)}:
∀(L M : set(Ω)), (L ⊆ M) → (@sat_fun (Ω) (Φ) (L) ⊆ @sat_fun (Ω) (Φ) (M)) :=
begin
  assume L M,
  assume L_subset_M,
  assume y,
  assume h1,
  cases h1,
  fconstructor,
  {
    exact h1_w
  },
  {
    tauto
  }
end

lemma is_idempotent {Ω : Type _} {Φ : setoid (Ω)}:
∀(L : set Ω), @sat_fun (Ω) (Φ) (@sat_fun (Ω) (Φ) (L)) = @sat_fun (Ω) (Φ) (L) :=
begin
  assume L,
  ext1,
  split,
  {
    assume h1,
    cases h1,
    cases h1_h,
    cases h1_h_w,
    fconstructor,
    {
      exact h1_h_w_w
    },
    {
      simp at *,
      cases h1_h_w_h,
      apply and.intro,
      {
        exact h1_h_w_h_left
      },
      {
        exact setoid.trans h1_h_w_h_right h1_h_h
      }
    }
  },
  {
    have h1: sat_fun (L) ⊆ sat_fun (sat_fun (L)), from
    begin
      exact @sat_fun.is_extensive (Ω) (Φ) (sat_fun L),
      exact Φ
    end,
    tauto
  }
end

@[instance] def co {Ω : Type _} {Φ : setoid (Ω)} : closure_op (set(Ω)) (set.partial_order Ω):=
{
  co := @sat_fun (Ω) (Φ),
  co_extensive := sat_fun.is_extensive,
  co_monotonic := sat_fun.is_monotonic,
  co_idempotent := sat_fun.is_idempotent
}

end sat_fun

lemma remark_2_25 {Ω : Type _} {Φ : setoid (Ω)} {L: set (Ω)}:
  @sat_fun (Ω) (Φ) (L) = quotient.mk ⁻¹' (quotient.mk '' (L)) :=
begin
  ext1,
  split,

-- (-->)
  {
    assume h1,
    cases h1 with x' h1,
    simp at *,
    fconstructor,
    {
      exact x'
    },
    {
      exact h1
    }
  },

-- (<--)
  {
    assume h1,
    cases h1 with x' h1,
    simp at *,
    fconstructor,
    {
      exact x'
    },
    {
      simp at *,
      exact h1
    }
  }
end

--Operador saturación y relaciones
lemma lemma_2_26 {Ω : Type _} (Φ Ψ : setoid (Ω)) :
Φ ≤ Ψ ↔ ∀ (L : set(Ω)), @sat_fun (Ω) (Φ) (@sat_fun (Ω) (Ψ) (L)) = @sat_fun (Ω) (Ψ) (L) :=
begin
  rw setoid.le_def,
  split,

-- (-->)
  {
    assume h1,
    assume L,
    apply set.subset.antisymm,

    --(⊆)
    {
      assume z,
      assume h2,
      cases h2 with a h2,
      cases h2 with h2 h3,
      have h4 : Ψ.rel a z, by exact h1 h3,
      cases h2 with b h2,
      fconstructor,
      {
        exact b
      },
      {
        cases h2 with h5 h6,
        have h2 : Ψ.rel b z, by exact setoid.trans' Ψ h6 h4,
        fconstructor,
        {
          exact h5
        },
        {
          exact h2
        }
      }
    },

    --(⊇)
    {
      exact sat_fun.is_extensive (sat_fun L),
    }
  },
  {
    assume h1,
    assume x0 y0,
    assume h2,
    have h3 : sat_fun (sat_fun {x0}) = sat_fun {x0}, from
      begin
        exact h1 {x0}
      end,
    have h4 : {x0} ⊆ @sat_fun Ω Ψ {x0}, from
      begin
        exact sat_fun.is_extensive {x0}
      end,
    have h5 : @sat_fun Ω Φ {x0} ⊆ @sat_fun Ω Φ (@sat_fun Ω Ψ {x0}), from
      begin
        exact sat_fun.is_monotonic {x0} (@sat_fun Ω Ψ {x0}) h4
      end,
    have h6 : @sat_fun Ω Φ {x0} ⊆ @sat_fun Ω Ψ {x0}, from
      begin
        rw (eq.symm h3),
        exact h5
      end,
    have h7 : y0 ∈ @sat_fun Ω Φ {x0}, from
      begin
        rw sat_fun,
        simp at *,
        exact h2
      end,
    have h8 : y0 ∈ @sat_fun Ω Ψ {x0}, from
      begin
        exact h6 h7
      end,
    rw sat_fun at h8,
    simp at h8,
    exact h8
  }
end


/-
The at-least-k boolean function.

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

import data.list.basic
import cnf.literal
import cnf.assignment
import cnf.clause
import cardinality.distinct
import cardinality.amk

variables {V : Type*} [decidable_eq V] [inhabited V]

open assignment
open clause
open list
open nat
open distinct
open amk

def alk (k : nat) (l : list bool) : bool := l.count tt ≥ k

namespace alk

protected def eval (k : nat) (τ : assignment V) (l : list (literal V)) : bool :=
  alk k (l.map (literal.eval τ))

@[simp] theorem eval_zero : ∀ (τ : assignment V) (l : list (literal V)),
  alk.eval 0 τ l = tt :=
assume τ l, by simp only [alk.eval, alk, ge_iff_le, zero_le, to_bool_true_eq_tt]

@[simp] theorem eval_nil_ff_iff_pos {k : nat} :
  ∀ τ, (alk.eval k τ ([] : list (literal V)) = ff ↔ k > 0) :=
assume τ, by simp [alk.eval, alk, pos_iff_ne_zero]

@[simp] theorem eval_nil_tt_iff_zero {k : nat} :
  ∀ τ, (alk.eval k τ ([] : list (literal V)) = tt ↔ k = 0) :=
assume τ, by simp [alk.eval, alk]

variables {k : nat} {τ : assignment V} {lit : literal V} {l : list (literal V)}

theorem eval_cons_pos : lit.eval τ = tt →
  ∀ l, alk.eval (k + 1) τ (lit :: l) = alk.eval k τ l :=
assume hlit l, by simp [alk.eval, alk, hlit, succ_le_succ_iff]

theorem eval_cons_neg : lit.eval τ = ff →
  ∀ l, alk.eval k τ (lit :: l) = alk.eval k τ l :=
assume hlit l, by simp [alk.eval, alk, hlit]

theorem eval_take_tail_pos {i : nat} (Hi : i < length l) :
  (l.nth_le i Hi).eval τ = tt →
  alk.eval (k + 1) τ (l.take (i + 1)) = alk.eval k τ (l.take i) :=
begin
  intro hl,
  induction i with i ih generalizing l k,
  { rw nth_le_zero at hl,
    simp [take_one_of_ne_nil (ne_nil_of_length_pos Hi), hl, alk.eval, alk] },
  { rcases exists_cons_of_ne_nil (ne_nil_of_length_pos (pos_of_gt Hi)) with ⟨l₁, ls, rfl⟩,
    rw nth_le at hl,
    cases h₁ : l₁.eval τ,
    { simp only [take, eval_cons_neg h₁, ih (succ_lt_succ_iff.mp Hi) hl] },
    { cases k,
      { simp [alk.eval, alk, h₁, succ_le_succ_iff] },
      { simp [take, eval_cons_pos h₁],
        exact ih (succ_lt_succ_iff.mp Hi) hl } } }
end

theorem eval_take_tail_neg {i : nat} (Hi : i < length l) :
  (l.nth_le i Hi).eval τ = ff →
  alk.eval k τ (l.take (i + 1)) = alk.eval k τ (l.take i) :=
begin
  intro hl,
  induction i with i ih generalizing l k,
  { rw nth_le_zero at hl,
    simp [take_one_of_ne_nil (ne_nil_of_length_pos Hi), hl, alk.eval, alk] },
  { rcases exists_cons_of_ne_nil (ne_nil_of_length_pos (pos_of_gt Hi)) with ⟨l₁, ls, rfl⟩,
    rw nth_le at hl,
    cases h₁ : l₁.eval τ,
    { simp [take, eval_cons_neg h₁, ih (succ_le_succ_iff.mp Hi) hl] },
    { cases k,
      { simp [take, alk.eval, alk] },
      { simp [take, eval_cons_pos h₁,ih (succ_le_succ_iff.mp Hi) hl] } } }
end

theorem amo_take_of_tt {i : nat} (Hi : i < length l) :
  (l.nth_le i Hi).eval τ = tt → alk.eval 1 τ (l.take (i + 1)) = tt :=
assume ht, eval_zero τ l ▸ eval_take_tail_pos Hi ht

theorem alo_take_tail {i : nat} (Hi : i < length l) :
  alk.eval 1 τ (l.take (i + 1)) = tt →
  ((l.nth_le i Hi).eval τ = tt ∨ alk.eval 1 τ (l.take i) = tt) :=
begin
  intro hlk,
  cases hl : (l.nth_le i Hi).eval τ,
  { rw eval_take_tail_neg Hi hl at hlk,
    exact or.inr hlk },
  { exact or.inl rfl }
end

theorem eval_tt_of_ge_of_eval_tt {k₁ k₂ : nat} : k₁ ≥ k₂ →
  alk.eval k₁ τ l = tt → alk.eval k₂ τ l = tt :=
begin
  simp only [alk.eval, alk, ge_iff_le, to_bool_iff],
  intros hk h₁,
  exact le_trans hk h₁
end

theorem eval_tt_of_sublist_of_eval_tt {l₁ l₂ : list (literal V)} :
  l₁ <+ l₂ → alk.eval k τ l₁ = tt → alk.eval k τ l₂ = tt :=
begin
  simp [alk.eval, alk],
  intros hls h₁,
  exact le_trans h₁ (sublist.count_le (sublist.map (literal.eval τ) hls) tt)
end

theorem amk_alk_take {k : nat} {l : list (literal V)} {i : nat} :
  i ≤ length l → ∀ {τ : assignment V}, alk.eval k τ (l.take i) = tt →
  amk.eval k τ l = tt → amk.eval 0 τ (l.drop i) = tt :=
begin
  intros hi τ htake hamk,
  induction l with l₁ ls ih generalizing k i,
  { simp only [drop_eq_nil_of_le, length, zero_le, amk.eval_nil] },
  { cases i,
    { simp at htake, subst htake,
      rw drop,
      exact hamk },
    { cases k,
      { exact eval_drop hamk _ },
      { rw [length, succ_le_succ_iff] at hi,
        cases hl₁ : (l₁.eval τ),
        { rw [take, eval_cons_neg hl₁] at htake,
          rw amk.eval_cons_neg hl₁ at hamk,
          exact ih hi htake hamk },
        { rw [take, eval_cons_pos hl₁] at htake,
          rw amk.eval_cons_pos hl₁ at hamk,
          exact ih hi htake hamk } } } }
end

theorem amk_eval_eq_alk_succ_eval (k : nat) (τ : assignment V) (l : list (literal V)) :
  amk.eval k τ l = !(alk.eval (k + 1) τ l) :=
begin
  induction l with l₁ ls ih generalizing k,
  { apply symm, simp },
  { cases h₁ : l₁.eval τ,
    { rw [amk.eval_cons_neg h₁, alk.eval_cons_neg h₁],
      exact ih k },
    { cases k,
      { rw [amk.eval_cons_pos_zero h₁, alk.eval_cons_pos h₁, eval_zero],
        exact bool.bnot_tt.symm },
      { rw [amk.eval_cons_pos h₁, alk.eval_cons_pos h₁],
        exact ih k } } }
end

theorem alk_split {k : nat} {l : list (literal V)} {τ : assignment V} :
  alk.eval (k + 1) τ l = tt → ∃ {i : nat} (Hi : i < length l),
  amk.eval 0 τ (l.take (i - 1)) = tt ∧ (l.nth_le i Hi).eval τ = tt ∧
  alk.eval k τ (l.drop (i + 1)) = tt :=
begin
  intro halk,
  induction l with l₁ ls ih generalizing k,
  { simp at halk |-, assumption },
  { cases h₁ : l₁.eval τ,
    { rw eval_cons_neg h₁ at halk,
      rcases ih halk with ⟨i, Hi, htake, he, hdrop⟩,
      use i + 1,
      simp [Hi, hdrop],
      cases i,
      { simpa },
      { simp at htake, simpa [amk.eval_cons_neg h₁, htake] } },
    { rw eval_cons_pos h₁ at halk, use 0, simpa [h₁] } }
end

theorem alk_of_amk_of_gt {j : nat} {l : list (literal V)} {τ : assignment V} :
  amk.eval j τ l = tt → ∀ {k}, j < k → alk.eval k τ l = ff :=
begin
  induction l with l₁ ls ih generalizing j,
  { simp, intros k hk, exact pos_of_gt hk },
  { intros hmk k hk,
    cases j,
    { have ihred := ih (amz_of_amz_cons hmk) hk,
      rw amz_eval_tt_iff_forall_eval_ff at hmk,
      rw eval_cons_neg (hmk l₁ (mem_cons_self _ _)),
      exact ihred },
    { cases hl₁ : l₁.eval τ,
      { rw amk.eval_cons_neg hl₁ at hmk,
        rw eval_cons_neg hl₁,
        exact ih hmk hk },
      { cases k with k,
        { linarith },
        { rw amk.eval_cons_pos hl₁ at hmk,
          rw eval_cons_pos hl₁,
          exact ih hmk (succ_lt_succ_iff.mp hk) } } } }
end

/-
theorem alk_or_amk_pred_of_amk {k : nat} {l : list (literal V)} {τ : assignment V} :
  amk.eval (k + 1) τ l = tt → alk.eval (k + 1) τ l = tt ∨ amk.eval k τ l = tt :=
begin
  sorry
end
-/

end alk


/-
Copyright (c) 2022 Yaël Dillies, Bhavik Mehta. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Yaël Dillies, Bhavik Mehta
-/
import algebra.big_operators.order
import algebra.module.basic
import combinatorics.simple_graph.density

/-!
# Energy of a partition

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

This file defines the energy of a partition.

The energy is the auxiliary quantity that drives the induction process in the proof of Szemerédi's
Regularity Lemma. As long as we do not have a suitable equipartition, we will find a new one that
has an energy greater than the previous one plus some fixed constant.
-/

open finset
open_locale big_operators

variables {α : Type*} [decidable_eq α] {s : finset α} (P : finpartition s) (G : simple_graph α)
  [decidable_rel G.adj]

namespace finpartition

/-- The energy of a partition, also known as index. Auxiliary quantity for Szemerédi's regularity
lemma.  -/
def energy : ℚ := (∑ uv in P.parts.off_diag, G.edge_density uv.1 uv.2 ^ 2) / P.parts.card ^ 2

lemma energy_nonneg : 0 ≤ P.energy G :=
div_nonneg (finset.sum_nonneg $ λ _ _, sq_nonneg _) $ sq_nonneg _

lemma energy_le_one : P.energy G ≤ 1 :=
div_le_of_nonneg_of_le_mul (sq_nonneg _) zero_le_one $
  calc ∑ uv in P.parts.off_diag, G.edge_density uv.1 uv.2^2
        ≤ P.parts.off_diag.card • 1
        : sum_le_card_nsmul _ _ 1 $ λ uv _, (sq_le_one_iff $ G.edge_density_nonneg _ _).2 $
            G.edge_density_le_one _ _
    ... = P.parts.off_diag.card : nat.smul_one_eq_coe _
    ... ≤ _ : by { rw [off_diag_card, one_mul, ←nat.cast_pow, nat.cast_le, sq], exact tsub_le_self }

end finpartition


/-
Copyright (c) 2022 Mario Carneiro. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Mario Carneiro
-/
import Std.Data.RBMap.Alter
import Std.Data.Nat.Lemmas
import Std.Data.List.Lemmas

/-!
# Additional lemmas for Red-black trees
-/

namespace Std
namespace RBNode
open RBColor

attribute [simp] fold foldl foldr Any forM foldlM Ordered

section depth

/--
`O(n)`. `depth t` is the maximum number of nodes on any path to a leaf.
It is an upper bound on most tree operations.
-/
def depth : RBNode α → Nat
  | nil => 0
  | node _ a _ b => max a.depth b.depth + 1

theorem size_lt_depth : ∀ t : RBNode α, t.size < 2 ^ t.depth
  | .nil => (by decide : 0 < 1)
  | .node _ a _ b => by
    rw [size, depth, Nat.add_right_comm, Nat.pow_succ, Nat.mul_two]
    refine Nat.add_le_add
      (Nat.lt_of_lt_of_le a.size_lt_depth ?_) (Nat.lt_of_lt_of_le b.size_lt_depth ?_)
    · exact Nat.pow_le_pow_of_le_right (by decide) (Nat.le_max_left ..)
    · exact Nat.pow_le_pow_of_le_right (by decide) (Nat.le_max_right ..)

/--
`depthLB c n` is the best upper bound on the depth of any balanced red-black tree
with root colored `c` and black-height `n`.
-/
def depthLB : RBColor → Nat → Nat
  | red, n => n + 1
  | black, n => n

theorem depthLB_le : ∀ c n, n ≤ depthLB c n
  | red, _ => Nat.le_succ _
  | black, _ => Nat.le_refl _

/--
`depthUB c n` is the best upper bound on the depth of any balanced red-black tree
with root colored `c` and black-height `n`.
-/
def depthUB : RBColor → Nat → Nat
  | red, n => 2 * n + 1
  | black, n => 2 * n

theorem depthUB_le : ∀ c n, depthUB c n ≤ 2 * n + 1
  | red, _ => Nat.le_refl _
  | black, _ => Nat.le_succ _

theorem depthUB_le_two_depthLB : ∀ c n, depthUB c n ≤ 2 * depthLB c n
  | red, _ => Nat.le_succ _
  | black, _ => Nat.le_refl _

theorem Balanced.depth_le : @Balanced α t c n → t.depth ≤ depthUB c n
  | .nil => Nat.le_refl _
  | .red hl hr => Nat.succ_le_succ <| Nat.max_le.2 ⟨hl.depth_le, hr.depth_le⟩
  | .black hl hr => Nat.succ_le_succ <| Nat.max_le.2
    ⟨Nat.le_trans hl.depth_le (depthUB_le ..), Nat.le_trans hr.depth_le (depthUB_le ..)⟩

theorem Balanced.le_size : @Balanced α t c n → 2 ^ depthLB c n ≤ t.size + 1
  | .nil => Nat.le_refl _
  | .red hl hr => by
    rw [size, Nat.add_right_comm (size _), Nat.add_assoc, depthLB, Nat.pow_succ, Nat.mul_two]
    exact Nat.add_le_add hl.le_size hr.le_size
  | .black hl hr => by
    rw [size, Nat.add_right_comm (size _), Nat.add_assoc, depthLB, Nat.pow_succ, Nat.mul_two]
    refine Nat.add_le_add (Nat.le_trans ?_ hl.le_size) (Nat.le_trans ?_ hr.le_size) <;>
      exact Nat.pow_le_pow_of_le_right (by decide) (depthLB_le ..)

theorem Balanced.depth_bound (h : @Balanced α t c n) : t.depth ≤ 2 * (t.size + 1).log2 :=
  Nat.le_trans h.depth_le <| Nat.le_trans (depthUB_le_two_depthLB ..) <|
    Nat.mul_le_mul_left _ <| (Nat.le_log2 (Nat.succ_ne_zero _)).2 h.le_size

/--
A well formed tree has `t.depth ∈ O(log t.size)`, that is, it is well balanced.
This justifies the `O(log n)` bounds on most searching operations of `RBSet`.
-/
theorem WF.depth_bound {t : RBNode α} (h : t.WF cmp) : t.depth ≤ 2 * (t.size + 1).log2 :=
  let ⟨_, _, h⟩ := h.out.2; h.depth_bound

end depth

@[simp] theorem mem_nil {x} : ¬x ∈ (.nil : RBNode α) := by simp [(·∈·), EMem]
@[simp] theorem mem_node {y c a x b} :
    y ∈ (.node c a x b : RBNode α) ↔ y = x ∨ y ∈ a ∨ y ∈ b := by simp [(·∈·), EMem]

theorem All_def {t : RBNode α} : t.All p ↔ ∀ x ∈ t, p x := by
  induction t <;> simp [or_imp, forall_and, *]

theorem Any_def {t : RBNode α} : t.Any p ↔ ∃ x ∈ t, p x := by
  induction t <;> simp [or_and_right, exists_or, *]

theorem memP_def : MemP cut t ↔ ∃ x ∈ t, cut x = .eq := Any_def

theorem mem_def : Mem cmp x t ↔ ∃ y ∈ t, cmp x y = .eq := Any_def

/--
A cut is like a homomorphism of orderings: it is a monotonic predicate with respect to `cmp`,
but it can make things that are distinguished by `cmp` equal.
This is sufficient for `find?` to locate an element on which `cut` returns `.eq`,
but there may be other elements, not returned by `find?`, on which `cut` also returns `.eq`.
-/
class IsCut (cmp : α → α → Ordering) (cut : α → Ordering) : Prop where
  /-- The set `{x | cut x = .lt}` is downward-closed. -/
  le_lt_trans [TransCmp cmp] : cmp x y ≠ .gt → cut x = .lt → cut y = .lt
  /-- The set `{x | cut x = .gt}` is upward-closed. -/
  le_gt_trans [TransCmp cmp] : cmp x y ≠ .gt → cut y = .gt → cut x = .gt

theorem IsCut.lt_trans [IsCut cmp cut] [TransCmp cmp]
    (H : cmp x y = .lt) : cut x = .lt → cut y = .lt :=
  IsCut.le_lt_trans <| TransCmp.gt_asymm <| OrientedCmp.cmp_eq_gt.2 H

theorem IsCut.gt_trans [IsCut cmp cut] [TransCmp cmp]
    (H : cmp x y = .lt) : cut y = .gt → cut x = .gt :=
  IsCut.le_gt_trans <| TransCmp.gt_asymm <| OrientedCmp.cmp_eq_gt.2 H

theorem IsCut.congr [IsCut cmp cut] [TransCmp cmp] (H : cmp x y = .eq) : cut x = cut y := by
  cases ey : cut y
  · exact IsCut.le_lt_trans (fun h => nomatch H.symm.trans <| OrientedCmp.cmp_eq_gt.1 h) ey
  · cases ex : cut x
    · exact IsCut.le_lt_trans (fun h => nomatch H.symm.trans h) ex |>.symm.trans ey
    · rfl
    · refine IsCut.le_gt_trans (cmp := cmp) (fun h => ?_) ex |>.symm.trans ey
      cases H.symm.trans <| OrientedCmp.cmp_eq_gt.1 h
  · exact IsCut.le_gt_trans (fun h => nomatch H.symm.trans h) ey

/--
`IsStrictCut` upgrades the `IsCut` property to ensure that at most one element of the tree
can match the cut, and hence `find?` will return the unique such element if one exists.
-/
class IsStrictCut (cmp : α → α → Ordering) (cut : α → Ordering) extends IsCut cmp cut : Prop where
  /-- If `cut = x`, then `cut` and `x` have compare the same with respect to other elements. -/
  exact [TransCmp cmp] : cut x = .eq → cmp x y = cut y

/-- A "representable cut" is one generated by `cmp a` for some `a`. This is always a valid cut. -/
instance (cmp) (a : α) : IsStrictCut cmp (cmp a) where
  le_lt_trans h₁ h₂ := TransCmp.lt_le_trans h₂ h₁
  le_gt_trans h₁ := Decidable.not_imp_not.1 (TransCmp.le_trans · h₁)
  exact h := (TransCmp.cmp_congr_left h).symm

section find?

theorem find?_some_eq_eq {t : RBNode α} : x ∈ t.find? cut → cut x = .eq := by
  induction t <;> simp [find?]; split <;> try assumption
  intro | rfl => assumption

theorem find?_some_mem {t : RBNode α} : x ∈ t.find? cut → x ∈ t := by
  induction t <;> simp [find?]; split <;> simp (config := {contextual := true}) [*]

theorem find?_some_memP {t : RBNode α} (h : x ∈ t.find? cut) : MemP cut t :=
  memP_def.2 ⟨_, find?_some_mem h, find?_some_eq_eq h⟩

theorem Ordered.memP_iff_find? [@TransCmp α cmp] [IsCut cmp cut] (ht : Ordered cmp t) :
    MemP cut t ↔ ∃ x, x ∈ t.find? cut := by
  refine ⟨fun H => ?_, fun ⟨x, h⟩ => find?_some_memP h⟩
  induction t with simp [find?] at H ⊢
  | nil => cases H
  | node _ l _ r ihl ihr =>
    let ⟨lx, xr, hl, hr⟩ := ht
    split
    · next ev =>
      refine ihl hl ?_
      rcases H with ev' | hx | hx
      · cases ev.symm.trans ev'
      · exact hx
      · have ⟨z, hz, ez⟩ := Any_def.1 hx
        cases ez.symm.trans <| IsCut.lt_trans (All_def.1 xr _ hz).1 ev
    · next ev =>
      refine ihr hr ?_
      rcases H with ev' | hx | hx
      · cases ev.symm.trans ev'
      · have ⟨z, hz, ez⟩ := Any_def.1 hx
        cases ez.symm.trans <| IsCut.gt_trans (All_def.1 lx _ hz).1 ev
      · exact hx
    · exact ⟨_, rfl⟩

theorem Ordered.unique [@TransCmp α cmp] (ht : Ordered cmp t)
    (hx : x ∈ t) (hy : y ∈ t) (e : cmp x y = .eq) : x = y := by
  induction t with
  | nil => cases hx
  | node _ l _ r ihl ihr =>
    let ⟨lx, xr, hl, hr⟩ := ht
    rcases hx, hy with ⟨rfl | hx | hx, rfl | hy | hy⟩
    · rfl
    · cases e.symm.trans <| OrientedCmp.cmp_eq_gt.2 (All_def.1 lx _ hy).1
    · cases e.symm.trans (All_def.1 xr _ hy).1
    · cases e.symm.trans (All_def.1 lx _ hx).1
    · exact ihl hl hx hy
    · cases e.symm.trans ((All_def.1 lx _ hx).trans (All_def.1 xr _ hy)).1
    · cases e.symm.trans <| OrientedCmp.cmp_eq_gt.2 (All_def.1 xr _ hx).1
    · cases e.symm.trans <| OrientedCmp.cmp_eq_gt.2
        ((All_def.1 lx _ hy).trans (All_def.1 xr _ hx)).1
    · exact ihr hr hx hy

theorem Ordered.mem_find? [@TransCmp α cmp] [IsStrictCut cmp cut] (ht : Ordered cmp t) :
    x ∈ t.find? cut ↔ x ∈ t ∧ cut x = .eq := by
  refine ⟨fun h => ⟨find?_some_mem h, find?_some_eq_eq h⟩, fun ⟨hx, e⟩ => ?_⟩
  have ⟨y, hy⟩ := ht.memP_iff_find?.1 (memP_def.2 ⟨_, hx, e⟩)
  exact ht.unique hx (find?_some_mem hy) ((IsStrictCut.exact e).trans (find?_some_eq_eq hy)) ▸ hy

end find?

section lowerBound?

/-- The value `x` returned by `lowerBound?` is less or equal to the `cut`. -/
theorem lowerBound?_le' {t : RBNode α} (H : ∀ {x}, x ∈ lb → cut x ≠ .lt) :
    x ∈ t.lowerBound? cut lb → cut x ≠ .lt := by
  induction t generalizing lb with
  | nil => exact H
  | node _ _ _ _ ihl ihr =>
    simp [lowerBound?]; split
    · exact ihl H
    · next hv => exact ihr fun | rfl, e => nomatch hv.symm.trans e
    · next hv => intro | rfl, e => cases hv.symm.trans e

/-- The value `x` returned by `lowerBound?` is less or equal to the `cut`. -/
theorem lowerBound?_le {t : RBNode α} : x ∈ t.lowerBound? cut none → cut x ≠ .lt :=
  lowerBound?_le' (fun.)

theorem All.lowerBound?_lb {t : RBNode α} (hp : t.All p) (H : ∀ {x}, x ∈ lb → p x) :
    x ∈ t.lowerBound? cut lb → p x := by
  induction t generalizing lb with
  | nil => exact H
  | node _ _ _ _ ihl ihr =>
    simp [lowerBound?]; split
    · exact ihl hp.2.1 H
    · exact ihr hp.2.2 fun | rfl => hp.1
    · exact fun | rfl => hp.1

theorem All.lowerBound? {t : RBNode α} (hp : t.All p) : x ∈ t.lowerBound? cut none → p x :=
  hp.lowerBound?_lb (fun.)

theorem lowerBound?_mem_lb {t : RBNode α}
    (h : x ∈ t.lowerBound? cut lb) : x ∈ t ∨ x ∈ lb :=
  All.lowerBound?_lb (p := fun x => x ∈ t ∨ x ∈ lb) (All_def.2 fun _ => .inl) Or.inr h

theorem lowerBound?_mem {t : RBNode α} (h : x ∈ t.lowerBound? cut none) : x ∈ t :=
  (lowerBound?_mem_lb h).resolve_right (fun.)

theorem lowerBound?_of_some {t : RBNode α} : ∃ x, x ∈ t.lowerBound? cut (some y) := by
  simp; induction t generalizing y <;> simp [lowerBound?]; split <;> simp [*]

theorem Ordered.lowerBound?_exists [@TransCmp α cmp] [IsCut cmp cut] (h : Ordered cmp t) :
    (∃ x, x ∈ t.lowerBound? cut none) ↔ ∃ x ∈ t, cut x ≠ .lt := by
  refine ⟨fun ⟨x, hx⟩ => ⟨_, lowerBound?_mem hx, lowerBound?_le hx⟩, fun H => ?_⟩
  obtain ⟨x, hx, e⟩ := H
  induction t generalizing x with
  | nil => cases hx
  | node _ _ _ _ ihl =>
    simp [lowerBound?]; split
    · rcases hx with rfl | hx | hx
      · contradiction
      · exact ihl h.2.2.1 _ hx e
      · next hv => cases e <| IsCut.lt_trans (All_def.1 h.2.1 _ hx).1 hv
    · exact lowerBound?_of_some
    · exact ⟨_, rfl⟩

theorem Ordered.lowerBound?_least_lb [@TransCmp α cmp] [IsCut cmp cut] (h : Ordered cmp t)
    (hlb : ∀ {x}, x ∈ lb → t.All (cmpLT cmp x ·)) :
    x ∈ t.lowerBound? cut lb → y ∈ t → cut x = .gt → cmp x y = .lt → cut y = .lt := by
  induction t generalizing lb with
  | nil => intro.
  | node _ _ _ _ ihl ihr =>
    simp [lowerBound?]; split <;> rename_i hv <;> rintro h₁ (rfl | hy' | hy') hx h₂
    · exact hv
    · exact ihl h.2.2.1 (fun h => (hlb h).2.1) h₁ hy' hx h₂
    · exact IsCut.lt_trans (cut := cut) (cmp := cmp) (All_def.1 h.2.1 _ hy').1 hv
    · rcases lowerBound?_mem_lb h₁ with h₁ | ⟨⟨⟩⟩
      · cases TransCmp.lt_asymm h₂ (All_def.1 h.2.1 _ h₁).1
      · cases TransCmp.lt_asymm h₂ h₂
    · refine (TransCmp.lt_asymm h₂ ?_).elim; have := (All_def.1 h.1 _ hy').1
      rcases lowerBound?_mem_lb h₁ with h₁ | ⟨⟨⟩⟩
      · exact TransCmp.lt_trans this (All_def.1 h.2.1 _ h₁).1
      · exact this
    · exact ihr h.2.2.2 (by rintro _ ⟨⟨⟩⟩; exact h.2.1) h₁ hy' hx h₂
    · cases h₁; cases TransCmp.lt_asymm h₂ h₂
    · cases h₁; cases hx.symm.trans hv
    · cases h₁; cases hx.symm.trans hv

/--
A statement of the least-ness of the result of `lowerBound?`. If `x` is the return value of
`lowerBound?` and it is strictly less than the cut, then any other `y > x` in the tree is in fact
strictly greater than the cut (so there is no exact match, and nothing closer to the cut).
-/
theorem Ordered.lowerBound?_least [@TransCmp α cmp] [IsCut cmp cut] (ht : Ordered cmp t)
    (H : x ∈ t.lowerBound? cut none) (hy : y ∈ t)
    (xy : cmp x y = .lt) (hx : cut x = .gt) : cut y = .lt :=
  ht.lowerBound?_least_lb (by exact fun.) H hy hx xy

theorem Ordered.memP_iff_lowerBound? [@TransCmp α cmp] [IsCut cmp cut] (ht : Ordered cmp t) :
    t.MemP cut ↔ ∃ x ∈ t.lowerBound? cut none, cut x = .eq := by
  refine memP_def.trans ⟨fun ⟨y, hy, ey⟩ => ?_, fun ⟨x, hx, e⟩ => ⟨_, lowerBound?_mem hx, e⟩⟩
  have ⟨x, hx⟩ := ht.lowerBound?_exists.2 ⟨_, hy, fun h => nomatch ey.symm.trans h⟩
  refine ⟨x, hx, ?_⟩; cases ex : cut x
  · cases lowerBound?_le hx ex
  · rfl
  · cases e : cmp x y
    · cases ey.symm.trans <| ht.lowerBound?_least hx hy e ex
    · cases ey.symm.trans <| IsCut.congr e |>.symm.trans ex
    · cases ey.symm.trans <| IsCut.gt_trans (OrientedCmp.cmp_eq_gt.1 e) ex

/-- A stronger version of `lowerBound?_least` that holds when the cut is strict. -/
theorem Ordered.lowerBound?_lt [@TransCmp α cmp] [IsStrictCut cmp cut] (ht : Ordered cmp t)
    (H : x ∈ t.lowerBound? cut none) (hy : y ∈ t) : cmp x y = .lt ↔ cut y = .lt := by
  refine ⟨fun h => ?_, fun h => OrientedCmp.cmp_eq_gt.1 ?_⟩
  · cases e : cut x
    · cases lowerBound?_le H e
    · exact IsStrictCut.exact e |>.symm.trans h
    · exact ht.lowerBound?_least H hy h e
  · by_contra h'; exact lowerBound?_le H <| IsCut.le_lt_trans (cmp := cmp) (cut := cut) h' h

end lowerBound?

section fold

theorem foldr_cons (t : RBNode α) (l) : t.foldr (·::·) l = t.toList ++ l := by
  unfold toList
  induction t generalizing l with
  | nil => rfl
  | node _ a _ b iha ihb => rw [foldr, foldr, iha, iha (_::_), ihb]; simp

@[simp] theorem toList_nil : (.nil : RBNode α).toList = [] := rfl

@[simp] theorem toList_node : (.node c a x b : RBNode α).toList = a.toList ++ x :: b.toList := by
  rw [toList, foldr, foldr_cons]; rfl

@[simp] theorem mem_toList {t : RBNode α} : x ∈ t.toList ↔ x ∈ t := by
  induction t <;> simp [*, or_left_comm]

theorem foldl_eq_foldl_toList {t : RBNode α} : t.foldl f init = t.toList.foldl f init := by
  induction t generalizing init <;> simp [*]

theorem forM_eq_forM_toList [Monad m] [LawfulMonad m] {t : RBNode α} :
    t.forM (m := m) f = t.toList.forM f := by induction t <;> simp [*]

theorem foldlM_eq_foldlM_toList [Monad m] [LawfulMonad m] {t : RBNode α} :
    t.foldlM (m := m) f init = t.toList.foldlM f init := by
  induction t generalizing init <;> simp [*]

theorem forIn_visit_eq_bindList [Monad m] [LawfulMonad m] {t : RBNode α} :
    forIn.visit (m := m) f t init = (ForInStep.yield init).bindList f t.toList := by
  induction t generalizing init <;> simp [*, forIn.visit]

theorem forIn_eq_forIn_toList [Monad m] [LawfulMonad m] {t : RBNode α} :
    forIn (m := m) t init f = forIn t.toList init f := by
  simp [forIn, RBNode.forIn]; rw [List.forIn_eq_bindList, forIn_visit_eq_bindList]

end fold

namespace Stream

attribute [simp] foldl foldr

theorem foldr_cons (t : RBNode.Stream α) (l) : t.foldr (·::·) l = t.toList ++ l := by
  unfold toList; apply Eq.symm; induction t <;> simp [*, foldr, RBNode.foldr_cons]

@[simp] theorem toList_nil : (.nil : RBNode.Stream α).toList = [] := rfl

@[simp] theorem toList_cons :
    (.cons x r s : RBNode.Stream α).toList = x :: r.toList ++ s.toList := by
  rw [toList, toList, foldr, RBNode.foldr_cons]; rfl

theorem foldr_eq_foldr_toList {s : RBNode.Stream α} : s.foldr f init = s.toList.foldr f init := by
  induction s <;> simp [-List.foldr] <;> simp [*, RBNode.foldr_eq_foldr_toList]

theorem foldl_eq_foldl_toList {t : RBNode.Stream α} : t.foldl f init = t.toList.foldl f init := by
  induction t generalizing init <;> simp [-List.foldl] <;> simp [*, RBNode.foldl_eq_foldl_toList]

theorem forIn_eq_forIn_toList [Monad m] [LawfulMonad m] {t : RBNode α} :
    forIn (m := m) t init f = forIn t.toList init f := by
  simp [forIn, RBNode.forIn]; rw [List.forIn_eq_bindList, forIn_visit_eq_bindList]

end Stream

theorem toStream_toList' {t : RBNode α} {s} : (t.toStream s).toList = t.toList ++ s.toList := by
  induction t generalizing s <;> simp [*, toStream]

@[simp] theorem toStream_toList {t : RBNode α} : t.toStream.toList = t.toList := by
  simp [toStream_toList']

theorem Stream.next?_toList {s : RBNode.Stream α} :
    (s.next?.map fun (a, b) => (a, b.toList)) = s.toList.next? := by
  cases s <;> simp [next?, toStream_toList']

theorem ordered_iff {t : RBNode α} :
    t.Ordered cmp ↔ t.toList.Pairwise (cmpLT cmp) := by
  induction t with
  | nil => simp
  | node c l v r ihl ihr =>
    simp [*, List.pairwise_append, Ordered, All_def,
      and_assoc, and_left_comm, and_comm, imp_and, forall_and]
    exact fun _ _ hl hr a ha b hb => (hl _ ha).trans (hr _ hb)

theorem Ordered.toList_sorted {t : RBNode α} : t.Ordered cmp → t.toList.Pairwise (cmpLT cmp) :=
  ordered_iff.1

@[simp] theorem setBlack_toList {t : RBNode α} : t.setBlack.toList = t.toList := by
  cases t <;> simp [setBlack]

@[simp] theorem setRed_toList {t : RBNode α} : t.setRed.toList = t.toList := by
  cases t <;> simp [setRed]

@[simp] theorem balance1_toList {l : RBNode α} {v r} :
    (l.balance1 v r).toList = l.toList ++ v :: r.toList := by
  unfold balance1; split <;> simp

@[simp] theorem balance2_toList {l : RBNode α} {v r} :
    (l.balance2 v r).toList = l.toList ++ v :: r.toList := by
  unfold balance2; split <;> simp

@[simp] theorem balLeft_toList {l : RBNode α} {v r} :
    (l.balLeft v r).toList = l.toList ++ v :: r.toList := by
  unfold balLeft; split <;> simp; split <;> simp

@[simp] theorem balRight_toList {l : RBNode α} {v r} :
    (l.balRight v r).toList = l.toList ++ v :: r.toList := by
  unfold balRight; split <;> simp; split <;> simp

namespace Path

attribute [simp] RootOrdered Ordered

/-- The list of elements to the left of the hole.
(This function is intended for specification purposes only.) -/
@[simp] def listL : Path α → List α
  | .root => []
  | .left _ parent _ _ => parent.listL
  | .right _ l v parent => parent.listL ++ (l.toList ++ [v])

/-- The list of elements to the right of the hole.
(This function is intended for specification purposes only.) -/
@[simp] def listR : Path α → List α
  | .root => []
  | .left _ parent v r => v :: r.toList ++ parent.listR
  | .right _ _ _ parent => parent.listR

/-- Wraps a list of elements with the left and right elements of the path. -/
abbrev withList (p : Path α) (l : List α) : List α := p.listL ++ l ++ p.listR

theorem rootOrdered_iff {p : Path α} (hp : p.Ordered cmp) :
    p.RootOrdered cmp v ↔ (∀ a ∈ p.listL, cmpLT cmp a v) ∧ (∀ a ∈ p.listR, cmpLT cmp v a) := by
  induction p with
    (simp [All_def] at hp; simp [*, and_assoc, and_left_comm, and_comm, or_imp, forall_and])
  | left _ _ x _ ih => exact fun vx _ _ _ ha => vx.trans (hp.2.1 _ ha)
  | right _ _ x _ ih => exact fun xv _ _ _ ha => (hp.2.1 _ ha).trans xv

theorem ordered_iff {p : Path α} :
    p.Ordered cmp ↔ p.listL.Pairwise (cmpLT cmp) ∧ p.listR.Pairwise (cmpLT cmp) ∧
      ∀ x ∈ p.listL, ∀ y ∈ p.listR, cmpLT cmp x y := by
  induction p with
  | root => simp
  | left _ _ x _ ih | right _ _ x _ ih => ?_
  all_goals
    rw [Ordered, and_congr_right_eq fun h => by simp [All_def, rootOrdered_iff h]; rfl]
    simp [List.pairwise_append, or_imp, forall_and, ih, RBNode.ordered_iff]
    -- FIXME: simp [and_assoc, and_left_comm, and_comm] is really slow here
  · exact ⟨
      fun ⟨⟨hL, hR, LR⟩, xr, ⟨Lx, xR⟩, ⟨rL, rR⟩, hr⟩ =>
        ⟨hL, ⟨⟨xr, xR⟩, hr, hR, rR⟩, Lx, fun _ ha _ hb => rL _ hb _ ha, LR⟩,
      fun ⟨hL, ⟨⟨xr, xR⟩, hr, hR, rR⟩, Lx, Lr, LR⟩ =>
        ⟨⟨hL, hR, LR⟩, xr, ⟨Lx, xR⟩, ⟨fun _ ha _ hb => Lr _ hb _ ha, rR⟩, hr⟩⟩
  · exact ⟨
      fun ⟨⟨hL, hR, LR⟩, lx, ⟨Lx, xR⟩, ⟨lL, lR⟩, hl⟩ =>
        ⟨⟨hL, ⟨hl, lx⟩, fun _ ha _ hb => lL _ hb _ ha, Lx⟩, hR, LR, lR, xR⟩,
      fun ⟨⟨hL, ⟨hl, lx⟩, Ll, Lx⟩, hR, LR, lR, xR⟩ =>
       ⟨⟨hL, hR, LR⟩, lx, ⟨Lx, xR⟩, ⟨fun _ ha _ hb => Ll _ hb _ ha, lR⟩, hl⟩⟩

@[simp] theorem fill_toList {p : Path α} : (p.fill t).toList = p.withList t.toList := by
  induction p generalizing t <;> simp [*]

theorem _root_.Std.RBNode.zoom_toList {t : RBNode α} (eq : t.zoom cut = (t', p')) :
    p'.withList t'.toList = t.toList := by rw [← fill_toList, ← zoom_fill eq]; rfl

@[simp] theorem ins_toList {p : Path α} : (p.ins t).toList = p.withList t.toList := by
  match p with
  | .root | .left red .. | .right red .. | .left black .. | .right black .. =>
    simp [ins, ins_toList]

@[simp] theorem insertNew_toList {p : Path α} : (p.insertNew v).toList = p.withList [v] := by
  simp [insertNew]

theorem insert_toList {p : Path α} :
    (p.insert t v).toList = p.withList (t.setRoot v).toList := by
  simp [insert]; split <;> simp [setRoot]


/-
Copyright (c) 2019 Minchao Wu. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Minchao Wu, Chris Hughes, Mantas Bakšys
-/
import data.list.basic
/-!
# Minimum and maximum of lists

## Main definitions

The main definitions are `argmax`, `argmin`, `minimum` and `maximum` for lists.

`argmax f l` returns `some a`, where `a` of `l` that maximises `f a`. If there are `a b` such that
  `f a = f b`, it returns whichever of `a` or `b` comes first in the list.
  `argmax f []` = none`

`minimum l` returns an `with_top α`, the smallest element of `l` for nonempty lists, and `⊤` for
`[]`
-/

namespace list

variables {α β : Type*}

section arg_aux
variables (r : α → α → Prop) [decidable_rel r] {l : list α} {o : option α} {a m : α}

/-- Auxiliary definition for `argmax` and `argmin`. -/
def arg_aux (a : option α) (b : α) : option α :=
option.cases_on a (some b) $ λ c, if r b c then some b else some c

@[simp] lemma foldl_arg_aux_eq_none :
  l.foldl (arg_aux r) o = none ↔ l = [] ∧ o = none :=
list.reverse_rec_on l (by simp) $
  (assume tl hd, by simp [arg_aux];
    cases foldl (arg_aux r) o tl; simp; try {split_ifs}; simp)

private lemma foldl_arg_aux_mem (l) : Π (a m : α),
  m ∈ foldl (arg_aux r) (some a) l → m ∈ a :: l :=
list.reverse_rec_on l (by simp [eq_comm])
  begin
    assume tl hd ih a m,
    simp only [foldl_append, foldl_cons, foldl_nil, arg_aux],
    cases hf : foldl (arg_aux r) (some a) tl,
    { simp {contextual := tt} },
    { dsimp only, split_ifs,
      { simp {contextual := tt} },
      { -- `finish [ih _ _ hf]` closes this goal
        rcases ih _ _ hf with rfl | H,
        { simp only [mem_cons_iff, mem_append, mem_singleton, option.mem_def], tauto },
        { apply λ hm, or.inr (list.mem_append.mpr $ or.inl _),
          exact (option.mem_some_iff.mp hm ▸ H)} } }
  end

@[simp] lemma arg_aux_self (hr₀ : irreflexive r) (a : α) : arg_aux r (some a) a = a :=
if_neg $ hr₀ _

lemma not_of_mem_foldl_arg_aux (hr₀ : irreflexive r) (hr₁ : transitive r) :
  Π {a m : α} {o : option α}, a ∈ l → m ∈ foldl (arg_aux r) o l → ¬ r a m :=
begin
  induction l using list.reverse_rec_on with tl a ih,
  { exact λ _ _ _ h, absurd h $ not_mem_nil _ },
  intros b m o hb ho,
  rw [foldl_append, foldl_cons, foldl_nil, arg_aux] at ho,
  cases hf : foldl (arg_aux r) o tl with c,
  { rw [hf] at ho,
    rw [foldl_arg_aux_eq_none] at hf,
    simp [hf.1, hf.2, *, hr₀ _] at * },
  rw [hf, option.mem_def] at ho,
  dsimp only at ho,
  split_ifs at ho with hac hac; cases mem_append.1 hb with h h; subst ho,
  { exact λ hba, ih h hf (hr₁ hba hac) },
  { simp [*, hr₀ _] at * },
  { exact ih h hf },
  { simp * at * }
end

end arg_aux

section preorder
variables [preorder β] [@decidable_rel β (<)] {f : α → β} {l : list α} {o : option α} {a m : α}

/-- `argmax f l` returns `some a`, where `f a` is maximal among the elements of `l`, in the sense
that there is no `b ∈ l` with `f a < f b`. If `a`, `b` are such that `f a = f b`, it returns
whichever of `a` or `b` comes first in the list. `argmax f []` = none`. -/
def argmax (f : α → β) (l : list α) : option α := l.foldl (arg_aux $ λ b c, f c < f b) none

/-- `argmin f l` returns `some a`, where `f a` is minimal among the elements of `l`, in the sense
that there is no `b ∈ l` with `f b < f a`. If `a`, `b` are such that `f a = f b`, it returns
whichever of `a` or `b` comes first in the list. `argmin f []` = none`. -/
def argmin (f : α → β) (l : list α) := l.foldl (arg_aux $ λ b c, f b < f c) none

@[simp] lemma argmax_nil (f : α → β) : argmax f [] = none := rfl
@[simp] lemma argmin_nil (f : α → β) : argmin f [] = none := rfl

@[simp] lemma argmax_singleton {f : α → β} {a : α} : argmax f [a] = a := rfl
@[simp] lemma argmin_singleton {f : α → β} {a : α} : argmin f [a] = a := rfl

lemma not_lt_of_mem_argmax : a ∈ l → m ∈ argmax f l → ¬ f m < f a :=
not_of_mem_foldl_arg_aux _ (λ _ , lt_irrefl _) $ λ _ _ _, gt_trans

lemma not_lt_of_mem_argmin : a ∈ l → m ∈ argmin f l → ¬ f a < f m :=
not_of_mem_foldl_arg_aux _ (λ _ , lt_irrefl _) $ λ _ _ _, lt_trans

theorem argmax_concat (f : α → β) (a : α) (l : list α) : argmax f (l ++ [a]) =
  option.cases_on (argmax f l) (some a) (λ c, if f c < f a then some a else some c) :=
by rw [argmax, argmax]; simp [arg_aux]

theorem argmin_concat (f : α → β) (a : α) (l : list α) : argmin f (l ++ [a]) =
  option.cases_on (argmin f l) (some a) (λ c, if f a < f c then some a else some c) :=
@argmax_concat _ βᵒᵈ _ _ _ _ _

theorem argmax_mem : Π {l : list α} {m : α}, m ∈ argmax f l → m ∈ l
| [] m       := by simp
| (hd::tl) m := by simpa [argmax, arg_aux] using foldl_arg_aux_mem _ tl hd m

theorem argmin_mem : Π {l : list α} {m : α}, m ∈ argmin f l → m ∈ l := @argmax_mem _ βᵒᵈ _ _ _

@[simp] theorem argmax_eq_none : l.argmax f = none ↔ l = [] := by simp [argmax]
@[simp] theorem argmin_eq_none : l.argmin f = none ↔ l = [] := @argmax_eq_none _ βᵒᵈ _ _ _ _

end preorder

section linear_order
variables [linear_order β] {f : α → β} {l : list α} {o : option α} {a m : α}

theorem le_of_mem_argmax : a ∈ l → m ∈ argmax f l → f a ≤ f m :=
λ ha hm, le_of_not_lt $ not_lt_of_mem_argmax ha hm

theorem le_of_mem_argmin : a ∈ l → m ∈ argmin f l → f m ≤ f a := @le_of_mem_argmax _ βᵒᵈ _ _ _ _ _

theorem argmax_cons (f : α → β) (a : α) (l : list α) : argmax f (a :: l) =
  option.cases_on (argmax f l) (some a) (λ c, if f a < f c then some c else some a) :=
list.reverse_rec_on l rfl $ λ hd tl ih, begin
    rw [← cons_append, argmax_concat, ih, argmax_concat],
    cases h : argmax f hd with m,
    { simp [h] },
    dsimp,
    rw [←apply_ite, ←apply_ite],
    dsimp,
    split_ifs; try { refl },
    { exact absurd (lt_trans ‹f a < f m› ‹_›) ‹_› },
    { cases (‹f a < f tl›.lt_or_lt _).elim ‹_› ‹_› }
  end

theorem argmin_cons (f : α → β) (a : α) (l : list α) : argmin f (a :: l) =
  option.cases_on (argmin f l) (some a) (λ c, if f c < f a then some c else some a) :=
by convert @argmax_cons _ βᵒᵈ _ _ _ _

variables [decidable_eq α]

theorem index_of_argmax : Π {l : list α} {m : α}, m ∈ argmax f l →
  ∀ {a}, a ∈ l → f m ≤ f a → l.index_of m ≤ l.index_of a
| []       m _  _ _  _   := by simp
| (hd::tl) m hm a ha ham := begin
  simp only [index_of_cons, argmax_cons, option.mem_def] at ⊢ hm,
  cases h : argmax f tl,
  { rw h at hm,
    simp * at * },
  rw h at hm,
  dsimp only at hm,
  obtain rfl | ha := ha; split_ifs at hm; subst hm,
  { cases not_le_of_lt ‹_› ‹_› },
  { rw [if_neg, if_neg],
    exact nat.succ_le_succ (index_of_argmax h ha ham),
    { exact ne_of_apply_ne f (lt_of_lt_of_le ‹_› ‹_›).ne' },
    { exact ne_of_apply_ne _ ‹f hd < f val›.ne' } },
  { rw if_pos rfl,
    exact bot_le }
end

theorem index_of_argmin : Π {l : list α} {m : α}, m ∈ argmin f l →
  ∀ {a}, a ∈ l → f a ≤ f m → l.index_of m ≤ l.index_of a :=
@index_of_argmax _ βᵒᵈ _ _ _

theorem mem_argmax_iff :
  m ∈ argmax f l ↔ m ∈ l ∧ (∀ a ∈ l, f a ≤ f m) ∧
    ∀ a ∈ l, f m ≤ f a → l.index_of m ≤ l.index_of a :=
⟨λ hm, ⟨argmax_mem hm, λ a ha, le_of_mem_argmax ha hm, λ _, index_of_argmax hm⟩,
  begin
    rintros ⟨hml, ham, hma⟩,
    cases harg : argmax f l with n,
    { simp * at * },
    { have := le_antisymm (hma n (argmax_mem harg) (le_of_mem_argmax hml harg))
        (index_of_argmax harg hml (ham _ (argmax_mem harg))),
      rw [(index_of_inj hml (argmax_mem harg)).1 this, option.mem_def] }
  end⟩

theorem argmax_eq_some_iff :
  argmax f l = some m ↔ m ∈ l ∧ (∀ a ∈ l, f a ≤ f m) ∧
    ∀ a ∈ l, f m ≤ f a → l.index_of m ≤ l.index_of a := mem_argmax_iff

theorem mem_argmin_iff :
  m ∈ argmin f l ↔ m ∈ l ∧ (∀ a ∈ l, f m ≤ f a) ∧
    ∀ a ∈ l, f a ≤ f m → l.index_of m ≤ l.index_of a :=
@mem_argmax_iff _ βᵒᵈ _ _ _ _ _

theorem argmin_eq_some_iff :
  argmin f l = some m ↔ m ∈ l ∧ (∀ a ∈ l, f m ≤ f a) ∧
    ∀ a ∈ l, f a ≤ f m → l.index_of m ≤ l.index_of a := mem_argmin_iff

end linear_order

section maximum_minimum
section preorder
variables [preorder α] [@decidable_rel α (<)] {l : list α} {a m : α}

/-- `maximum l` returns an `with_bot α`, the largest element of `l` for nonempty lists, and `⊥` for
`[]`  -/
def maximum (l : list α) : with_bot α := argmax id l

/-- `minimum l` returns an `with_top α`, the smallest element of `l` for nonempty lists, and `⊤` for
`[]`  -/
def minimum (l : list α) : with_top α := argmin id l

@[simp] lemma maximum_nil : maximum ([] : list α) = ⊥ := rfl

@[simp] lemma minimum_nil : minimum ([] : list α) = ⊤ := rfl

@[simp] lemma maximum_singleton (a : α) : maximum [a] = a := rfl

@[simp] lemma minimum_singleton (a : α) : minimum [a] = a := rfl

theorem maximum_mem {l : list α} {m : α} : (maximum l : with_top α) = m → m ∈ l := argmax_mem

theorem minimum_mem {l : list α} {m : α} : (minimum l : with_bot α) = m → m ∈ l := argmin_mem

@[simp] theorem maximum_eq_none {l : list α} : l.maximum = none ↔ l = [] := argmax_eq_none

@[simp] theorem minimum_eq_none {l : list α} : l.minimum = none ↔ l = [] := argmin_eq_none

lemma not_lt_maximum_of_mem : a ∈ l → (maximum l : with_bot α) = m → ¬ m < a := not_lt_of_mem_argmax
lemma minimum_not_lt_of_mem : a ∈ l → (minimum l : with_top α) = m → ¬ a < m := not_lt_of_mem_argmin

theorem not_lt_maximum_of_mem' (ha : a ∈ l) : ¬ maximum l < (a : with_bot α) :=
begin
  cases h : l.maximum,
  { simp * at * },
  { simp_rw [with_bot.some_eq_coe, with_bot.coe_lt_coe, not_lt_maximum_of_mem ha h, not_false_iff] }
end

theorem not_lt_minimum_of_mem' (ha : a ∈ l) : ¬ (a : with_top α) < minimum l :=
@not_lt_maximum_of_mem' αᵒᵈ _ _ _ _ ha

end preorder

section linear_order
variables [linear_order α] {l : list α} {a m : α}

theorem maximum_concat (a : α) (l : list α) : maximum (l ++ [a]) = max (maximum l) a :=
begin
  simp only [maximum, argmax_concat, id],
  cases h : argmax id l,
  { exact (max_eq_right bot_le).symm },
  { simp [option.coe_def, max_def, ←not_lt] }
end

lemma le_maximum_of_mem' (ha : a ∈ l) : (a : with_bot α) ≤ maximum l :=
le_of_not_lt $ not_lt_maximum_of_mem' ha

lemma le_minimum_of_mem' (ha : a ∈ l) : minimum l ≤ (a : with_top α) :=
@le_maximum_of_mem' αᵒᵈ _ _ _ ha

theorem minimum_concat (a : α) (l : list α) : minimum (l ++ [a]) = min (minimum l) a :=
@maximum_concat αᵒᵈ _ _ _

theorem maximum_cons (a : α) (l : list α) : maximum (a :: l) = max a (maximum l) :=
list.reverse_rec_on l (by simp [@max_eq_left (with_bot α) _ _ _ bot_le])
  (λ tl hd ih, by rw [← cons_append, maximum_concat, ih, maximum_concat, max_assoc])

theorem minimum_cons (a : α) (l : list α) : minimum (a :: l) = min a (minimum l) :=
@maximum_cons αᵒᵈ _ _ _

lemma maximum_eq_coe_iff : maximum l = m ↔ m ∈ l ∧ ∀ a ∈ l, a ≤ m :=
begin
  unfold_coes,
  simp only [maximum, argmax_eq_some_iff, id],
  split,
  { simp only [true_and, forall_true_iff] {contextual := tt} },
  { simp only [true_and, forall_true_iff] {contextual := tt},
    intros h a hal hma,
    rw [le_antisymm hma (h.2 a hal)] }
end

lemma minimum_eq_coe_iff : minimum l = m ↔ m ∈ l ∧ ∀ a ∈ l, m ≤ a :=
@maximum_eq_coe_iff αᵒᵈ _ _ _

end linear_order
end maximum_minimum

section fold
variables [linear_order α]

section order_bot
variables [order_bot α] {l : list α}

@[simp] lemma foldr_max_of_ne_nil (h : l ≠ []) : ↑(l.foldr max ⊥) = l.maximum :=
begin
  induction l with hd tl IH,
  { contradiction },
  { rw [maximum_cons, foldr, with_bot.coe_max],
    by_cases h : tl = [],
    { simp [h, -with_top.coe_zero] },
    { simp [IH h] } }
end

lemma max_le_of_forall_le (l : list α) (a : α) (h : ∀ x ∈ l, x ≤ a) : l.foldr max ⊥ ≤ a :=
begin
  induction l with y l IH,
  { simp },
  { simpa [h y (mem_cons_self _ _)] using IH (λ x hx, h x $ mem_cons_of_mem _ hx) }
end

lemma le_max_of_le {l : list α} {a x : α} (hx : x ∈ l) (h : a ≤ x) :
  a ≤ l.foldr max ⊥ :=
begin
  induction l with y l IH,
  { exact absurd hx (not_mem_nil _), },
  { obtain rfl | hl := hx,
    simp only [foldr, foldr_cons],
    { exact le_max_of_le_left h, },
    { exact le_max_of_le_right (IH hl) }}
end

end order_bot

section order_top
variables [order_top α] {l : list α}

@[simp] lemma foldr_min_of_ne_nil (h : l ≠ []) : ↑(l.foldr min ⊤) = l.minimum :=
@foldr_max_of_ne_nil αᵒᵈ _ _ _ h

lemma le_min_of_forall_le (l : list α) (a : α) (h : ∀ x ∈ l, a ≤ x) : a ≤ l.foldr min ⊤ :=
@max_le_of_forall_le αᵒᵈ _ _ _ _ h

lemma min_le_of_le (l : list α) (a : α) {x : α} (hx : x ∈ l) (h : x ≤ a) :
  l.foldr min ⊤ ≤ a :=
@le_max_of_le αᵒᵈ _ _ _ _ _ hx h

end order_top
end fold
end list


import tactic -- hide
open function nat -- hide

/-
## The `assumption` tactic

The first tactic that we'll learn is the `assumption` tactic. This can be used
when your goal is exactly one of your hypotheses. In the following example,
there are three hypotheses, namely the fact that $a$ is $3$ (hypothesis `ha`), the
fact that $b$ is $4$ (hypothesis `hb`) and the fact that $c$ is $5$ (hypothesis `hc`).

Since we want to prove that $b=4$, which is one of our hypotheses, we should be able to
win by typing `assumption,` (**don't forget the comma**). Delete the `sorry` and try it.

**Pro tip:** If the hypothesis to be used is called, say `hb`, you can also close the goal
by using `exact hb,` instead. Sometimes it is more efficient to do so, especially if we believe
that assumption should work and we don't know why. The `exact` tactic will give us information
about why that does not work.

-/

/- Symbol:
ℕ : \N
-/

/- Lemma : no-side-bar
If $a$ is $3$ and $b$ is $4$ and $c$ is $5$, then $b$ is $4$.
-/
lemma l0 (a b c : ℕ) (ha : a = 3) (hb : b = 4) (hc : c = 5) : b = 4 :=
begin
  assumption,

end


/-
Copyright (c) 2019 Neil Strickland. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Neil Strickland

 Recall that (fin n) is the type of pairs ⟨i,h⟩, where i is a natural
 number and h is a proof that i < n.  In this file we prove some
 additional facts about these types, which might perhaps be added
 to the standard library at some point.
-/

import data.list data.fintype.basic data.finset.interval data.fin.interval

namespace fin
open fin finset

/- (reflect i) is essentially n - 1 - i -/
def reflect : ∀ {n : ℕ} (i : fin n), fin n
| 0 i := fin.elim0 i
| (n + 1) i := ⟨n - i, nat.lt_succ_of_le (nat.sub_le n i)⟩

@[simp] lemma coe_reflect : ∀ {n : ℕ} (i : fin n), (i.reflect : ℕ) = n - 1 - i
| 0 i := fin.elim0 i
| (n + 1) i := by { change n - i = _, simp }

@[simp] lemma reflect_val {n : ℕ} (i : fin n) : i.reflect.val = n - 1 - i :=
  coe_reflect i

lemma reflect_reflect : ∀ {n : ℕ} (i : fin n), i.reflect.reflect = i
| 0 i := fin.elim0 i
| (n + 1) ⟨i,h⟩ :=
begin
  rw [fin.ext_iff],
  let j := n - i,
  change n - j = i,
  have : n = i + j := (nat.add_sub_of_le (nat.le_of_lt_succ h)).symm,
  rw [this, nat.add_sub_cancel]
end

lemma add_reflect : ∀ {n : ℕ} (i : fin n), (i : ℕ) + (i.reflect : ℕ) + 1 = n
| 0 i := fin.elim0 i
| (n + 1) ⟨i,h⟩ :=
begin
  let j := n - i,
  change i + j + 1 = n + 1,
  rw [(nat.add_sub_of_le (nat.le_of_lt_succ h)).symm]
end

lemma reflect_le : ∀ {n : ℕ} {i j : fin n} (h : i ≤ j), j.reflect ≤ i.reflect
| 0 i _ _ := i.elim0
| (n + 1) ⟨i,hi⟩ ⟨j,hj⟩ hij := nat.sub_le_sub_left n hij

lemma reflect_lt {n : ℕ} {i j : fin n} (h : i < j) : j.reflect < i.reflect :=
begin
  apply lt_of_not_ge, intro hr, replace hr := reflect_le hr,
  rw [reflect_reflect, reflect_reflect] at hr,
  exact not_lt_of_ge hr h
end

/- inc is the inclusion of (fin n) in (fin (n + 1)) -/
def inc {n : ℕ} : fin n → fin n.succ :=
  λ i, ⟨i.val, lt_trans i.is_lt n.lt_succ_self⟩

@[simp] lemma coe_inc {n : ℕ} (i : fin n) : (i.inc : ℕ) = (i : ℕ) := rfl
@[simp] lemma inc_val {n : ℕ} (i : fin n) :  i.inc.val  = i.val := rfl

lemma reflect_inc {n : ℕ} (i : fin n) : i.inc.reflect = i.reflect.succ :=
begin
  cases n, exact fin.elim0 i, apply fin.eq_of_veq,
  change (n + 1) - i = (n - i) + 1,
  exact nat.succ_sub (nat.le_of_lt_succ i.is_lt)
end

lemma reflect_succ {n : ℕ} (i : fin n) : i.succ.reflect = i.reflect.inc :=
begin
  let h := congr_arg fin.reflect (reflect_inc (i.reflect)),
  rw [reflect_reflect, reflect_reflect] at h,
  exact h.symm
end

lemma inc_lt_succ {n : ℕ} (i : fin n) : i.inc < i.succ :=
 by { cases i with i₀ hi, exact i₀.lt_succ_self }

def res {n : ℕ} {i : fin n} {j : fin n.succ} (h : (j : ℕ) ≤ (i : ℕ)) :
  fin n := ⟨j.val, lt_of_le_of_lt h i.is_lt⟩

@[simp] lemma coe_res {n : ℕ} {i : fin n} {j : fin n.succ} (h : (j : ℕ) ≤ (i : ℕ)) :
  (res h : ℕ) = (j : ℕ) := rfl
@[simp] lemma res_val {n : ℕ} {i : fin n} {j : fin n.succ} (h : (j : ℕ) ≤ (i : ℕ)) :
  (res h).val = j.val := rfl

def trunc {n : ℕ} (i : fin (n + 2)) : fin (n + 1) :=
  dite ((i : ℕ) < n + 1) (λ h, fin.mk i h) (λ h, fin.mk n n.lt_succ_self)

@[simp] lemma coe_trunc {n : ℕ} (i : fin (n + 2)) :
  (trunc i : ℕ) = if (i : ℕ)  < n + 1 then i else n :=
by { rw [trunc], split_ifs; refl }
@[simp] lemma trunc_val {n : ℕ} (i : fin (n + 2)) :
  (trunc i).val = if (i : ℕ)  < n + 1 then i.val else n := coe_trunc _

def pred' {n : ℕ} (i : fin (n + 2)) : fin (n + 1) :=
  ⟨i.val.pred, begin have hi : i.val < n + 2 := i.is_lt, cases i.val with i₀,
    { rw [nat.pred_zero], exact nat.zero_lt_succ n },
    { rw [nat.pred_succ], exact nat.lt_of_succ_lt_succ hi }
  end⟩

@[simp] lemma coe_pred' {n : ℕ} (i : fin (n + 2)) :
  (i.pred' : ℕ) = (i : ℕ).pred := rfl

lemma coe_inj {n : ℕ} {i j : fin n} (h : (i : ℕ) = (j : ℕ)) : i = j :=
fin.eq_of_veq h

def pred_alt {n : ℕ} {i : ℕ} (h : i.succ < n.succ) : fin n :=
 ⟨i,nat.lt_of_succ_lt_succ h⟩

/- Zero is not a successor -/
lemma zero_ne_succ : ∀ {n : ℕ} {i : fin n}, (0 : fin n.succ) ≠ i.succ
| n ⟨i_val,_⟩ := λ e, nat.no_confusion (congr_arg subtype.val e)

/- Zero is less than any successor -/
lemma zero_lt_succ : ∀ {n : ℕ} {i : fin n}, (0 : fin n.succ) < i.succ
| n ⟨i_val,_⟩ := nat.zero_lt_succ i_val

/- The successor map preserves order -/
lemma succ_le_succ {n : ℕ} {i j : fin n} (h : i ≤ j) : i.succ ≤ j.succ :=
 by {cases i,cases j,dsimp[has_le.le,fin.le],apply nat.succ_le_succ h,}

/- The successor map preserves strict order -/
lemma succ_lt_succ {n : ℕ} {i j : fin n} (h : i < j) : i.succ < j.succ :=
 by {cases i,cases j,dsimp[has_lt.lt,fin.lt],apply nat.succ_lt_succ h,}

/- The successor map reflects order -/
lemma le_of_succ_le_succ {n : ℕ} {i j : fin n} (h : i.succ ≤ j.succ) : i ≤ j :=
 by {cases i,cases j,dsimp[has_le.le,fin.le],apply nat.le_of_succ_le_succ h,}

/- The successor map reflects strict order -/
lemma lt_of_succ_lt_succ {n : ℕ} {i j : fin n} (h : i.succ < j.succ) : i < j :=
 by {cases i,cases j,dsimp[has_lt.lt,fin.lt],apply nat.lt_of_succ_lt_succ h,}

/- This function produces a list of all the elements of (fin n) -/
def elems_list : ∀ (n : ℕ), list (fin n)
| 0 := @list.nil _
| (n + 1) := list.cons 0 ((elems_list n).map fin.succ)

/-The number of elements of (fin n) is n -/
lemma elems_list_length : ∀ (n : ℕ), (elems_list n).length = n
| 0 := rfl
| (n + 1) := congr_arg nat.succ
             ((list.length_map fin.succ (elems_list n)).trans
              (elems_list_length n))

/- The list of elements has no duplicates -/
def elems_list_nodup : ∀ (n : ℕ), list.nodup (elems_list n)
| 0 := @list.pairwise.nil _ ne
| (n + 1) := begin
  let old_list := (elems_list n).map fin.succ,
  have h : function.injective (fin.succ : (fin n) → (fin (n + 1))) :=
   λ _ _ e, fin.succ_inj.mp e,
  have old_nodup : list.nodup old_list :=
   list.nodup.map h (elems_list_nodup n),
  have not_mem_old : ∀ k ∈ old_list, (0 : fin n.succ) ≠ k :=
  begin
   intros k k_in_old zero_eq_k,
   let h1 := (list.mem_map.mp k_in_old),
   exact exists.elim h1 (λ k0 h2,zero_ne_succ (zero_eq_k.trans h2.right.symm)),
  end,
  exact list.pairwise.cons (not_mem_old) (old_nodup)
 end

/- Every element occurs in our list of elements -/
def elems_list_complete {n : ℕ} (k : fin n) : k ∈ (elems_list n) :=
begin
 induction n with n0 ih,
 {exact fin.elim0 k,},
 {dsimp[elems_list],
  rw[list.mem_cons_eq],
  cases k with k_val k_is_lt,
  cases k_val with k0_val,
  {left,apply fin.eq_of_veq,refl,},
  {have k0_is_lt : k0_val < n0 := nat.lt_of_succ_lt_succ k_is_lt,
   let k0 : fin n0 := ⟨k0_val,k0_is_lt⟩,
   have h0 : k0.succ = ⟨k0_val.succ,k_is_lt⟩ :=
   by {apply fin.eq_of_veq,refl,},
   right,
   apply list.mem_map.mpr,
   existsi k0,
   exact ⟨ih k0,h0⟩,
  }
 }
end

/- Convert our list of elements to a set -/
def elems_finset (n : ℕ) : finset (fin n) :=
{ val := elems_list n,
  nodup := elems_list_nodup n
}

/- Every element is in our set of elements -/
def elems_finset_complete {n : ℕ} (k : fin n) : k ∈ (elems_finset n) :=
 elems_list_complete k

/-
 This function returns the least element of (fin n) satisfying a given
 predicate p.  For this to work, we need a decision procedure for p
 (given as an implicit typeclass argument) and also a proof that at
 least one element of (fin n) satisfies p.  Moreover, we return the
 least element k packaged together with proofs of its properties.
 Thus, if this function returns x, then x.val is the relevant value
 of k, and x.property.left is a proof of (p k), and x.property.right
 is a proof that k is minimal with respect to this.
-/
def least_element {n : ℕ} (p : fin n → Prop) [d : decidable_pred p] (e : ∃ k, p k) :
 {k : fin n // p k ∧ ∀ j, p j → k ≤ j} :=
begin
 tactic.unfreeze_local_instances,
 induction n with n0 ih,
 {exfalso, cases e with i _,exact fin.elim0 i,},
 {
   by_cases pz : (p 0),
    {exact ⟨0, pz, λ j _,fin.zero_le j⟩},
    {let p0 : fin n0 → Prop := λ k0, p k0.succ,
     let d0 : decidable_pred p0 := λ k0, d k0.succ,
     have e0 : ∃ k0, p0 k0 :=
      begin
       rcases e with ⟨⟨k_val,k_is_lt⟩,p_k⟩,
       rcases k_val with _ | k0_val,
        {contradiction},
        {have k0_is_lt : k0_val < n0 := nat.lt_of_succ_lt_succ k_is_lt,
         let k0 : fin n0 := ⟨k0_val,k0_is_lt⟩,
         existsi k0,assumption
        }
      end,
     rcases (@ih p0 d0 e0) with ⟨k0,p0_k0,k0_min⟩,
     let k := fin.succ k0,
     have p_k : p k := p0_k0,
     have k_min : ∀ j, p j → k ≤ j :=
     begin
      intro j,
      cases j with j_val j_is_lt,rcases j_val with _ | j0_val;
       simp[has_le.le,fin.le],
      {intro pz0, exact false.elim (pz pz0),},
      {have j0_is_lt : j0_val < n0 := nat.lt_of_succ_lt_succ j_is_lt,
       let j0 : fin n0 := ⟨j0_val,j0_is_lt⟩,
       intro p0_j0,
       exact nat.succ_le_succ (k0_min j0 p0_j0),
       }
     end,
     exact ⟨k,p_k,k_min⟩
    }
 }
end

/-
 This is essentially the same as the previous function, but formulated
 in terms of a finite subset of (fin n) rather than a predicate.
-/
def finset_least_element {n : ℕ} (s : finset (fin n)) (e : s.nonempty) :
 {k : fin n // k ∈ s ∧ ∀ j, j ∈ s → k ≤ j} :=
  least_element (λ k,k ∈ s) (nonempty.bex e)

/-
 We now have a similar function for finding the largest element of
 a finite subset of (fin n).  For technical reasons we have found it
 more convenient to do this directly with finite sets rather than
 predicates.
-/

def finset_largest_element {n : ℕ} (s : finset (fin n)) (e : s.nonempty) :
 {k : fin n // k ∈ s ∧ ∀ j, j ∈ s → j ≤ k} :=
begin
 induction n with n0 ih,
 {exfalso,
  cases (nonempty.bex e) with i _,
  exact fin.elim0 i,},
 {by_cases hn1 : fin.last n0 ∈ s,
  { exact ⟨fin.last n0,⟨hn1,λ j _,j.le_last⟩⟩ },
  { have h_last : ∀ (i : fin n0.succ) (h₁ : ¬ (i < fin.last n0))
            (h₂ : i ∈ s), false :=
     begin intros,
      have : (i = fin.last n0) := le_antisymm (fin.le_last i) (le_of_not_gt h₁),
      rw[this] at h₂, exact hn1 h₂,
     end,
    let s0 := univ.filter (λ i0 : fin n0, i0.inc ∈ s),
    have e0 : s0.nonempty := begin
     rcases (nonempty.bex e) with ⟨i,i_in_s⟩,
     by_cases i_lt_n0 : i < fin.last n0,
     { let i0 : fin n0 := ⟨i,i_lt_n0⟩,
       have : i = i0.inc := by { ext, refl },
       rw[this] at i_in_s,
       have i_in_s0 : i0 ∈ s0 := finset.mem_filter.mpr ⟨mem_univ i0,i_in_s⟩,
       exact ⟨i0,i_in_s0⟩,
     },{exfalso, exact h_last i i_lt_n0 i_in_s}
    end,
    rcases (ih s0 e0) with ⟨k0,⟨k0_in_s0,k0_max⟩⟩,
    let k : fin n0.succ := k0.inc,
    have k_in_s : k ∈ s := (mem_filter.mp k0_in_s0).2,
    have k_max : ∀ j, j ∈ s → j ≤ k := λ j j_in_s, begin
     by_cases j_lt_n0 : (j : ℕ) < n0,
     { rcases j with ⟨j,j_lt_n⟩,
       exact k0_max ⟨j,j_lt_n0⟩ (mem_filter.mpr ⟨mem_univ _,j_in_s⟩) },
     { exfalso,exact h_last j j_lt_n0 j_in_s}
    end,
    exact ⟨k,⟨k_in_s,k_max⟩⟩,
  },
 }
end

def fin.list_Ico {n : ℕ} (i : fin n) (j : fin n.succ) :
  list (fin n) := (list.Ico i j).attach.map
   (λ x, ⟨x.val,lt_of_lt_of_le (list.Ico.mem.mp x.property).right
                               (nat.le_of_lt_succ j.is_lt)⟩)

end fin