/-
Copyright (c) 2018 Jeremy Avigad. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Author: Jeremy Avigad

The W construction as a multivariate polynomial functor.
-/
import mvpfunctor.basic
universes u v

namespace mvpfunctor
open typevec

variables {n : ℕ} (P : mvpfunctor.{u} (n+1))

/- defines a typevec of labels to assign to each node of P.last.W -/
inductive W_path : P.last.W → fin' n → Type u
| root (a : P.A) (f : P.last.B a → P.last.W) (i : fin' n) (c : P.drop.B a i) :
    W_path ⟨a, f⟩ i
| child (a : P.A) (f : P.last.B a → P.last.W) (i : fin' n) (j : P.last.B a) (c : W_path (f j) i) :
    W_path ⟨a, f⟩ i

def W_path_cases_on {α : typevec n} {a : P.A} {f : P.last.B a → P.last.W}
    (g' : P.drop.B a ⟹ α) (g : Π j : P.last.B a, P.W_path (f j) ⟹ α) :
  P.W_path ⟨a, f⟩ ⟹ α :=
begin
  intros i x, cases x,
  case W_path.root : c { exact g' i c },
  case W_path.child : j c { exact g j i c}
end

def W_path_dest_left {α : typevec n} {a : P.A} {f : P.last.B a → P.last.W}
    (h : P.W_path ⟨a, f⟩ ⟹ α) :
  P.drop.B a ⟹ α :=
λ i c, h i (W_path.root a f i c)

def W_path_dest_right {α : typevec n} {a : P.A} {f : P.last.B a → P.last.W}
    (h : P.W_path ⟨a, f⟩ ⟹ α) :
  Π j : P.last.B a, P.W_path (f j) ⟹ α :=
λ j i c, h i (W_path.child a f i j c)

theorem W_path_dest_left_W_path_cases_on
    {α : typevec n} {a : P.A} {f : P.last.B a → P.last.W}
    (g' : P.drop.B a ⟹ α) (g : Π j : P.last.B a, P.W_path (f j) ⟹ α) :
  P.W_path_dest_left (P.W_path_cases_on g' g) = g' := rfl

theorem W_path_dest_right_W_path_cases_on
    {α : typevec n} {a : P.A} {f : P.last.B a → P.last.W}
    (g' : P.drop.B a ⟹ α) (g : Π j : P.last.B a, P.W_path (f j) ⟹ α) :
  P.W_path_dest_right (P.W_path_cases_on g' g) = g := rfl

theorem W_path_cases_on_eta {α : typevec n} {a : P.A} {f : P.last.B a → P.last.W}
    (h : P.W_path ⟨a, f⟩ ⟹ α) :
  P.W_path_cases_on (P.W_path_dest_left h) (P.W_path_dest_right h) = h :=
by ext i x; cases x; reflexivity

theorem comp_W_path_cases_on {α β : typevec n} (h : α ⟹ β) {a : P.A} {f : P.last.B a → P.last.W}
    (g' : P.drop.B a ⟹ α) (g : Π j : P.last.B a, P.W_path (f j) ⟹ α) :
  h ⊚ P.W_path_cases_on g' g = P.W_path_cases_on (h ⊚ g') (λ i, h ⊚ g i) :=
by ext i x; cases x; reflexivity

def Wp : mvpfunctor n :=
{ A := P.last.W, B := P.W_path }

def W (α : typevec n) : Type* := P.Wp.apply α

instance mvfunctor_W : mvfunctor P.W := by delta W; apply_instance

/-
First, describe operations on `W` as a polynomial functor.
-/

def Wp_mk {α : typevec n} (a : P.A) (f : P.last.B a → P.last.W) (f' : P.W_path ⟨a, f⟩ ⟹ α) :
  P.W α :=
⟨⟨a, f⟩, f'⟩

def Wp_rec {α : typevec n} {C : Type*}
  (g : Π (a : P.A) (f : P.last.B a → P.last.W),
    (P.W_path ⟨a, f⟩ ⟹ α) → (P.last.B a → C) → C) :
  Π (x : P.last.W) (f' : P.W_path x ⟹ α), C
| ⟨a, f⟩ f' := g a f f' (λ i, Wp_rec (f i) (P.W_path_dest_right f' i))

theorem Wp_rec_eq {α : typevec n} {C : Type*}
    (g : Π (a : P.A) (f : P.last.B a → P.last.W),
      (P.W_path ⟨a, f⟩ ⟹ α) → (P.last.B a → C) → C)
    (a : P.A) (f : P.last.B a → P.last.W) (f' : P.W_path ⟨a, f⟩ ⟹ α) :
  P.Wp_rec g ⟨a, f⟩ f' = g a f f' (λ i, P.Wp_rec g (f i) (P.W_path_dest_right f' i)) :=
rfl

-- Note: we could replace Prop by Type* and obtain a dependent recursor

theorem Wp_ind {α : typevec n} {C : Π x : P.last.W, P.W_path x ⟹ α → Prop}
  (ih : ∀ (a : P.A) (f : P.last.B a → P.last.W)
    (f' : P.W_path ⟨a, f⟩ ⟹ α),
      (∀ i : P.last.B a, C (f i) (P.W_path_dest_right f' i)) → C ⟨a, f⟩ f') :
  Π (x : P.last.W) (f' : P.W_path x ⟹ α), C x f'
| ⟨a, f⟩ f' := ih a f f' (λ i, Wp_ind _ _)

/-
Now think of W as defined inductively by the data ⟨a, f', f⟩ where
- `a  : P.A` is the shape of the top node
- `f' : P.drop.B a ⟹ α` is the contents of the top node
- `f  : P.last.B a → P.last.W` are the subtrees
 -/

def W_mk {α : typevec n} (a : P.A) (f' : P.drop.B a ⟹ α) (f : P.last.B a → P.W α) :
  P.W α :=
let g  : P.last.B a → P.last.W  := λ i, (f i).fst,
    g' : P.W_path ⟨a, g⟩ ⟹ α := P.W_path_cases_on f' (λ i, (f i).snd) in
⟨⟨a, g⟩, g'⟩

def W_rec {α : typevec n} {C : Type*}
    (g : Π a : P.A, ((P.drop).B a ⟹ α) → ((P.last).B a → P.W α) → ((P.last).B a → C) → C) :
  P.W α → C
| ⟨a, f'⟩ :=
  let g' (a : P.A) (f : P.last.B a → P.last.W) (h : P.W_path ⟨a, f⟩ ⟹ α)
        (h' : P.last.B a → C) : C :=
      g a (P.W_path_dest_left h) (λ i, ⟨f i, P.W_path_dest_right h i⟩) h' in
  P.Wp_rec g' a f'

theorem W_rec_eq {α : typevec n} {C : Type*}
    (g : Π a : P.A, ((P.drop).B a ⟹ α) → ((P.last).B a → P.W α) → ((P.last).B a → C) → C)
    (a : P.A) (f' : P.drop.B a ⟹ α) (f : P.last.B a → P.W α) :
  P.W_rec g (P.W_mk a f' f) = g a f' f (λ i, P.W_rec g (f i)) :=
begin
  rw [W_mk, W_rec], dsimp, rw [Wp_rec_eq],
  dsimp only [W_path_dest_left_W_path_cases_on, W_path_dest_right_W_path_cases_on],
  congr; ext1 i; cases (f i); refl
end

theorem W_ind {α : typevec n} {C : P.W α → Prop}
    (ih : ∀ (a : P.A) (f' : P.drop.B a ⟹ α) (f : P.last.B a → P.W α),
      (∀ i, C (f i)) → C (P.W_mk a f' f)) :
  ∀ x, C x :=
begin
  intro x, cases x with a f,
  apply @Wp_ind n P α (λ a f, C ⟨a, f⟩), dsimp,
  intros a f f' ih',
  dsimp [W_mk] at ih,
  let ih'' := ih a (P.W_path_dest_left f') (λ i, ⟨f i, P.W_path_dest_right f' i⟩),
  dsimp at ih'', rw W_path_cases_on_eta at ih'',
  apply ih'',
  apply ih'
end

theorem W_cases {α : typevec n} {C : P.W α → Prop}
    (ih : ∀ (a : P.A) (f' : P.drop.B a ⟹ α) (f : P.last.B a → P.W α), C (P.W_mk a f' f)) :
  ∀ x, C x :=
P.W_ind (λ a f' f ih', ih a f' f)

def W_map {α β : typevec n} (g : α ⟹ β) : P.W α → P.W β :=
λ x, g <$$> x

theorem W_mk_eq {α : typevec n} (a : P.A) (f : P.last.B a → P.last.W)
    (g' : P.drop.B a ⟹ α) (g : Π j : P.last.B a, P.W_path (f j) ⟹ α) :
  P.W_mk a g' (λ i, ⟨f i, g i⟩) =
    ⟨⟨a, f⟩, P.W_path_cases_on g' g⟩ := rfl

theorem W_map_W_mk {α β : typevec n} (g : α ⟹ β)
    (a : P.A) (f' : P.drop.B a ⟹ α) (f : P.last.B a → P.W α) :
  g <$$> P.W_mk a f' f = P.W_mk a (g ⊚ f') (λ i, g <$$> f i) :=
begin
  show _ = P.W_mk a (g ⊚ f') (mvfunctor.map g ∘ f),
  have : mvfunctor.map g ∘ f = λ i, ⟨(f i).fst, g ⊚ ((f i).snd)⟩,
  { ext i : 1, dsimp [function.comp], cases (f i), refl },
  rw this,
  have : f = λ i, ⟨(f i).fst, (f i).snd⟩,
  { ext1, cases (f x), refl },
  rw this, dsimp,
  rw [W_mk_eq, W_mk_eq],
  have h := mvpfunctor.map_eq P.Wp g,
  rw [h, comp_W_path_cases_on]
end

-- TODO: this technical theorem is used in one place in constructing the initial algebra.
-- Can it be avoided?

@[reducible] def apply_append1 {α : typevec n} {β : Type*}
    (a : P.A) (f' : P.drop.B a ⟹ α) (f : P.last.B a → β) :
  P.apply (append1 α β) :=
⟨a, split_fun f' f⟩

theorem map_apply_append1 {α γ : typevec n} (g : α ⟹ γ)
  (a : P.A) (f' : P.drop.B a ⟹ α) (f : P.last.B a → P.W α) :
append_fun g (P.W_map g) <$$> P.apply_append1 a f' f =
  P.apply_append1 a (g ⊚ f') (λ x, P.W_map g (f x)) :=
by rw [apply_append1, apply_append1, map_eq, append_fun, ← split_fun_comp]; refl

/-
Yet another view of the W type: as a fixed point for a multivariate polynomial functor.
These are needed to use the W-construction to construct a fixed point of a qpf, since
the qpf axioms are expressed in terms of `map` on `P`.
-/

def W_mk' {α : typevec n} : P.apply (α.append1 (P.W α)) → P.W α
| ⟨a, f⟩ := P.W_mk a (drop_fun f) (last_fun f)

def W_dest' {α : typevec.{u} n} : P.W α → P.apply (α.append1 (P.W α)) :=
P.W_rec (λ a f' f _, ⟨a, split_fun f' f⟩)

theorem W_dest'_W_mk {α : typevec n}
    (a : P.A) (f' : P.drop.B a ⟹ α) (f : P.last.B a → P.W α) :
  P.W_dest' (P.W_mk a f' f) = ⟨a, split_fun f' f⟩ :=
by rw [W_dest', W_rec_eq]

theorem W_dest'_W_mk' {α : typevec n} (x : P.apply (α.append1 (P.W α))) :
  P.W_dest' (P.W_mk' x) = x :=
by cases x with a f; rw [W_mk', W_dest'_W_mk, split_drop_fun_last_fun]

end mvpfunctor


import data.quot

import tidy.tidy

lemma eq_is_refl {α : Type} {r : α → α → Prop} : equivalence r → reflexive r
:= by intro h; exact and.elim_left h
lemma eq_is_symm {α : Type} {r : α → α → Prop} : equivalence r → symmetric r
:= by intro h; exact and.elim_left (and.elim_right h)
lemma eq_is_trans {α : Type} {r : α → α → Prop} : equivalence r → transitive r := by intro h; exact and.elim_right (and.elim_right h)

def bop (α : Type) := α → α → α
def prebop (α β : Type) := α → α → β

def bop_rel_assoc {α : Type} (r : α → α → Prop) (γ : bop α)
:= ∀ a b c : α, r (γ (γ a b) c) (γ a (γ b c))
def bop_rel_comm {α : Type} (r : α → α → Prop) (γ : bop α)
:= ∀ a b : α, r (γ a b) (γ b a)

def bop_assoc {α : Type} (γ : bop α) := bop_rel_assoc eq γ
def bop_comm {α : Type} (γ : bop α) := bop_rel_comm eq γ

def bop_rel_invar_first {α : Type} (r : α → α → Prop) (γ : bop α)
:= ∀ a b c : α, r a b → r (γ a c) (γ b c)
def bop_rel_invar {α : Type} (r : α → α → Prop) (γ : bop α)
:= ∀ a b c d : α, r a c → r b d → r (γ a b) (γ c d)
structure liftable_bop := mk ::
    {α : Type}
    (s : setoid α)
    (bop : bop α)
    (class_invar : bop_rel_invar s.r bop)

lemma bop_comm_easy_invar {α : Type} {s : setoid α} {γ : bop α} : bop_rel_comm s.r γ → bop_rel_invar_first s.r γ → bop_rel_invar s.r γ :=
begin
    have htrans : transitive s.r, by exact eq_is_trans s.iseqv,
    have hsymm : symmetric s.r, by exact eq_is_symm s.iseqv,
    intros hcomm hfirst,
    unfold bop_rel_comm at *,
    unfold bop_rel_invar_first at *,
    unfold bop_rel_invar at *,
    intros a b c d hac hbd,
    apply htrans,
    apply hfirst a c b hac,
    apply htrans,
    apply hcomm c b,
    apply hsymm,
    apply htrans,
    apply hcomm c d,
    exact hfirst d b c (hsymm hbd),
end

def induced_quobop {α : Type} (s : setoid α) (γ : bop α) : prebop α (quotient s)
:= λ a b : α, quot.mk s.r (γ a b)

lemma lift_well_defined {α : Type} (s : setoid α) (γ : bop α) (class_invar : bop_rel_invar s.r γ)
: ∀ (a b c d : α), a ≈ c → b ≈ d → induced_quobop s γ a b = induced_quobop s γ c d :=
begin
    intros a b c d hac hbd,
    tidy,
    unfold bop_rel_invar at class_invar,
    specialize class_invar a b c d hac hbd,
    unfold induced_quobop,
    apply quot.sound,
    assumption,
end

def induced_bop {α : Type} (s : setoid α) (γ : bop α)
    (class_invar : bop_rel_invar s.r γ) : bop (quotient s)
:= quotient.lift₂ (induced_quobop s γ) (lift_well_defined s γ class_invar)

def lift_bop (lb : liftable_bop) : bop (quotient lb.s)
:= induced_bop lb.s lb.bop lb.class_invar

theorem compute_lift (lb : liftable_bop):
∀ a b : lb.α, (lift_bop lb) (quot.mk lb.s.r a) (quot.mk lb.s.r b) = quot.mk lb.s.r (lb.bop a b) := by tidy

--FIXME a single tactic should solve both of these below

lemma lift_assoc (lb : liftable_bop) : bop_rel_assoc lb.s.r lb.bop → bop_assoc (lift_bop lb) :=
begin
    intros hassoc a b c,
    -- unfold bop_assoc,
    -- unfold bop_rel_assoc at *,
    have haw : quot.mk lb.s.r (quot.out a) = a, by apply quotient.out_eq,
    have hbw : quot.mk lb.s.r (quot.out b) = b, by apply quotient.out_eq,
    have hcw : quot.mk lb.s.r (quot.out c) = c, by apply quotient.out_eq,
    rw eq.symm haw,
    rw eq.symm hbw,
    rw eq.symm hcw,
    rewrite (compute_lift lb (quot.out a) (quot.out b)),
    rewrite (compute_lift lb (quot.out b) (quot.out c)),
    rewrite (compute_lift lb (lb.bop (quot.out a) (quot.out b)) (quot.out c)),
    rewrite (compute_lift lb (quot.out a) (lb.bop (quot.out b) (quot.out c))),
    apply quot.sound,
    exact hassoc (quot.out a) (quot.out b) (quot.out c),
end

lemma lift_comm (lb : liftable_bop) : bop_rel_comm lb.s.r lb.bop → bop_comm (lift_bop lb) :=
begin
    intros hcomm a b,
    -- unfold bop_comm,
    -- unfold bop_rel_comm at *,
    have haw : quot.mk lb.s.r (quot.out a) = a, by apply quotient.out_eq,
    have hbw : quot.mk lb.s.r (quot.out b) = b, by apply quotient.out_eq,
    rw eq.symm haw,
    rw eq.symm hbw,
    rewrite (compute_lift lb (quot.out a) (quot.out b)),
    rewrite (compute_lift lb (quot.out b) (quot.out a)),
    apply quot.sound,
    exact hcomm (quot.out a) (quot.out b),
end


/- Copyright (c) 2022 Sina Hazratpour. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
----------------

# Structures (bundled)
Sina Hazratpour
Introduction to Proof
MATH 301, Johns Hopkins University, Fall 2022
-/

import ..prooflab
import .lec7_predicate

namespace PROOFS

namespace STR  --nested inside the namespace PROOFS

variables {X Y Z : Type}
variable {f : X → Y}

/-! ## Some Simple Structures -/

-- The structure of RGB colors

-- every RGB color has a "red" component, a "green" component, and a "blue" component. Therefore, we have three fields `red`, `green` and `blue` in the structure `rgb`.
-- https://en.wikipedia.org/wiki/RGB_color_model#/media/File:RGB_combination_on_wall.png

structure rgb :=
(red green blue : ℕ)

-- For instance JHU Heritage Blue is R0 G45 B114
-- first we give the type of the structure instance and then the value of the instance
-- `JHU_Heritage_Blue` is an instance specified by the value `⟨0, 45, 114⟩`

/-! ### Instances of Structures -/

def JHU_Heritage_Blue :
  rgb := ⟨0, 45, 114⟩

#print JHU_Heritage_Blue -- the command to access the previously defined instances of structures.

-- We have three __projections__ to get access to the fields of rgb
#check rgb.red -- this is a function which maps a tuple of `rgb` to the value of its `red` component.
#check rgb.green
#check rgb.blue

#check JHU_Heritage_Blue.red -- this is the value of applying `rgb.red` to `JHU_Heritage_Blue`. `JHU_Heritage_Blue.red` is a shorthand notation for `rgb.red JHU_Heritage_Blue`.

#eval JHU_Heritage_Blue.red
#eval JHU_Heritage_Blue.green
#eval rgb.green JHU_Heritage_Blue

/-! ### Defining Functions on Structures -/

def shuffle (c : rgb) : rgb := -- we have to give the components of `shuffle c`.
{ red   := rgb.green c,
  green := rgb.blue c,
  blue  := rgb.red c }

def shuffle_alt (c : rgb) : rgb := -- we have to give the components of `shuffle c`.
{ red   := c.green,
  green := c.blue,
  blue  := c.red }

#reduce shuffle (JHU_Heritage_Blue)
#reduce shuffle (shuffle (JHU_Heritage_Blue))
-- https://g.co/kgs/mvHSbz

#reduce shuffle(shuffle (shuffle (JHU_Heritage_Blue)))

lemma three_shuffle_is_nil :
  shuffle ∘ shuffle ∘ shuffle = id :=
begin
  funext c, -- we want to prove for any arbitray `x : rgb` the application of LHS and the RHS to `x` are the same.
  dsimp, -- definitionally simplify both sides
  cases c, -- to prove two colors are the same we have to prove they have equal components.
  refl,
end

@[ext]
structure R1 := (x : ℝ)

def folding : ℝ → R1 :=
λ a,

@[ext]
structure R2 := (x : ℝ) (y : ℝ)

@[ext] -- this is used to prove two instances of R3 are the same by proving their components are the same.
structure R3 := (x : ℝ) (y : ℝ) (z : ℝ)

/-
The @[ext] annotation tells Lean to automatically generate theorems that can be used to __prove that two instances of a structure are equal when each of their components are equal__, a property known as __extensionality__.  Therefore, if a theorem involves a concept defined by an @[ext] annotation, we can use tactic `ext` to reduce an equation between two elements of the structure to equations between the components.
-/

--three projection
#check R3.x
#check R3.y
#check R3.z

/-! ### Equality of Instances of Structures -/

example (a b : R3) (h : a = b)  :
  (a.x = b.x) :=
begin
  exact congr_arg R3.x h,
end

example (a b : R3) (h : a = b)  :
  (a.x = b.x) :=
begin
  cases a, -- reduces `a` to its components
  cases b, -- reduces `b` to its components
  dsimp,
  cases h, -- we don't undertand this because equality is an inductive type in a way which is too advanced for us now.
  refl,
end

-- Challenge: fill in the `sorry`
example (a b : R3) :
  a = b ↔ (a.x = b.x) ∧ (a.y = b.y) ∧ (a.z = b.z) :=
begin
  split,
  intro h,
  {
    split,
    {
      exact congr_arg R3.x h,
    },
    {
      split,
      {
        sorry,
      },
      {
        sorry,
      },
    },
  },
  {
    intro h,
    obtain ⟨h₁, h₂, h₃⟩ := h,
    ext,
    assumption',
  },
end

/-
We can define points by specifying their coordinates. Lean provides multiple ways of doing that.
-/

section some_affine_points
-- the first way:

def Pt_0 : R1 :=
{
  x := 0,
}

def vect_a (a: ℝ)  : R1 :=
{
  x:= a,
}

#reduce vect_a -- takes r : ℝ to <r>
#check vect_a 2 --

def Pt_0p1 : R2 :=
{
  x := 0,
  y := 1,
}

def Pt_0p1_alt  : R2 :=
⟨0 , 1⟩

#check Pt_0p1 -- an instance of R2 which is to say a point on the 2-dim plane

def Pt_0n1 : R2 :=
{
  x := 0,
  y := -1
}

def Pt_n1p1n1 : R3 :=
{
  x := -1,
  y := 1,
  z := -1
}

def Pt_p1n1p1 : R3 :=
{
  x := 1,
  y := -1,
  z := 1
}

end some_affine_points

/-! ### Functions between structures -/

/-!  #### Projections
Projections π_i : ℝⁿ → ℝ, for 1 ≤ i ≤ n, are functions defined by the assignment
π_i (x_1, … ,x_n) = x_i
The i-th projection picks the i-th coordinate and forgets the rest of the coordinates.
-/

def R2.proj₁ (a : R2) : R1 :=
⟨ a.x ⟩

def R2.proj₂ (a : R2) : R1 :=
⟨ a.y ⟩

--Challenge: define all of the projections `R3 → R1`

def R3.proj₁ (a : R3) : R1 := ⟨ a.x ⟩
def R3.proj₂ (a : R3) : R1 := ⟨ a.y ⟩
def R3.proj₃ (a : R3) : R1 := ⟨ a.z ⟩

def sum_of_components (a : R3) : ℝ :=
a.x + a.y + a.z

#check sum_of_components

#eval sum_of_components Pt_n1p1n1

example : R2.proj₁ Pt_0n1 = ⟨ 0 ⟩ :=
begin
 rw R2.proj₁,
 rw [Pt_0n1],
end

-- There are three functions ℝ³ → ℝ² made out of projections:

def R3.proj_to_2d₁ (a : R3) : R2 := ⟨a.x, a.y⟩
def R3.proj_to_2d₂ (a : R3) : R2 := ⟨a.x, a.z⟩
def R3.proj_to_2d₃ (a : R3) : R2 := ⟨a.y, a.z⟩

lemma proj_comp₁ : R2.proj₁ ∘ R3.proj_to_2d₁ = R3.proj₁ :=
begin
  funext a,
  simp,
  rw [R3.proj_to_2d₁],
  rw [R2.proj₁],
  refl, --just prove x=x
end

-- Write down and prove six other lemmas corresponding to five different compositions. For instance:

lemma proj_comp₂ : R2.proj₂ ∘ R3.proj_to_2d₁ = R3.proj₂ :=
begin
  funext,
  refl,
end

lemma proj_comp₃ : R2.proj₁ ∘ R3.proj_to_2d₂ = R3.proj₁ :=
begin
  funext,
  refl,
end

lemma proj_comp₄ : R2.proj₂ ∘ R3.proj_to_2d₂ = R3.proj₃ :=
begin
  funext,
  refl,
end

lemma proj_comp₅ : R2.proj₁ ∘ R3.proj_to_2d₃ = R3.proj₂ :=
begin
  funext,
  refl,
end

lemma proj_comp₆ : R2.proj₂ ∘ R3.proj_to_2d₃ = R3.proj₃ :=
begin
  funext,
  refl,
end

/-!  #### Addition
Similar to the addition of real numbers, we can add affine points. You know this from the vector addition.
-/

def R1.add (a b : R1) : R1 := ⟨a.x + b.x⟩

def R1_add_alt (a b : ℝ) : ℝ := a + b

def R2.add (a b : R2) : R2 := ⟨a.x + b.x, a.y + b.y⟩

def R3.add (a b : R3) : R3 := ⟨a.x + b.x, a.y + b.y, a.z + b.z⟩

#check R3.add

-- #eval R2.add Pt_0n1 Pt_0p1
-- #eval R3.add Pt_n1p1n1 Pt_p1n1p1

/-
It is often convenient to use anonymous projection notation, which allows us to write `P₁ .add P₂` instead of `R2.add P₁ P₂`.
-/

example :  Pt_0n1 .add Pt_0p1 = ⟨0, 0⟩ :=
begin
  ext,
  repeat
  {
    unfold R2.add,
    rw [Pt_0n1, Pt_0p1],
    ring_nf,
  },
end

example :  Pt_n1p1n1 .add Pt_p1n1p1 = ⟨0, 0, 0⟩ :=
begin
  ext,
  repeat {
    unfold R3.add,
    rw [Pt_n1p1n1, Pt_p1n1p1],
    ring_nf,
  },
end

/-
Below we name our theorem `R2.add_comm` to avoid ambiguity with a generic theorem like `add_comm`.
-/

theorem R2.add_comm (a b : R2) :
   a .add b = b .add a :=
begin
  -- rw [R2.add, R2.add],
  unfold R2.add,
  ext,
  dsimp,
  repeat {apply add_comm},
end

#check add_comm
#check R2.add_comm

--Challenge: Prove the theorem above for points in the 3-d space.
theorem R3.add_comm (a b :R3) : a .add b =  b .add a :=
begin
  unfold R3.add,
  ext,
  repeat { apply add_comm },
end

-- challenge: prove the associativity of addition in 2 and 3 dimensions

theorem R2.add_assoc (a b c : R2) :
   (a .add b) .add c =  a .add (b .add c) :=
  begin
    unfold R2.add,
    ext,
    repeat {simp},
    repeat {apply add_assoc},
  end

theorem R3.add_assoc (a b c : R3) :
 (a .add b) .add c = a .add ( b .add c) :=
begin
  unfold R3.add,
  ext,
  repeat {simp},
  repeat {apply add_assoc},
end

--Challenge: We can prove the associativity of addition in 2d from as the associativity of addition in 3d where the last (z) coordinate is 0 for points a b c. Can you implement this idea in Lean?

/-
Consider the following "embeddings" (draw a geometric picture of these maps)
-/

def R1.embed₁  (a : R1) : R2 :=
{
  x := a.x,
  y := 0,
}

def R1.embed₂  (a : R1) : R2 :=
{
  x := 0,
  y := a.x,
}

-- the three embeddings which keep x-axis fixed:
def R2.xembed₁  (a : R2) : R3 :=
{
  x := a.x,
  y := a.y,
  z := 0,
}

def R2.xembed₂  (a : R2) : R3 :=
{
  x := a.x,
  y := 0,
  z := a.y,
}

def R2.xembed₃  (a : R2) : R3 :=
{
  x := 0,
  y := a.x,
  z := a.y,
}

/-! ### Algebraic Structures-/

structure preorder_bundled:=
(carrier : Type) -- a type of carrier (as underlying type)
(rel : carrier → carrier → Prop) -- a binary relation saying when two elements of the carrier are related to each to other
(rflx : reflexive rel) -- this is an axiom/propety of relation `rel` saying that any term/element is related to itself.
(trns : transitive rel) -- this is an axiom/propety of relation `rel` saying that if we have three terms and the first two of which are related to each other through the relation `rel` and the last two of which are related to each other through the relation `rel`, then the first and the third are related to each other through the relation `rel`

#check preorder_bundled.carrier -- the underlying type of preorder_bundled_bundledstructure
#check preorder_bundled.rflx
#check preorder_bundled.trns
#reduce preorder_bundled.trns

#check transitive
#reduce @transitive

#check preorder_bundled.carrier -- the underlying type of preorder_bundled structure
#check preorder_bundled.rflx

-- an instance of a preorder_bundled structure
def preorder_bundled_nat_eq : preorder_bundled :=
{
  carrier := ℕ,
  rel := λ m, λ n, m = n,
  rflx := by {unfold reflexive,intro x, refl, },
  trns := by {unfold transitive, apply eq.trans,},
}

#check preorder_bundled_nat_eq
#print preorder_bundled_nat_eq

#reduce preorder_bundled.carrier preorder_bundled_nat_eq
#reduce preorder_bundled_nat_eq.carrier

#check preorder_bundled_nat_eq
#print preorder_bundled_nat_eq

#reduce preorder_bundled.carrier preorder_bundled_nat_eq
#reduce preorder_bundled_nat_eq.carrier

#reduce preorder_bundled_nat_eq.rflx

def preorder_bundled_nat_le : preorder_bundled :=
{
  carrier := ℕ,
  rel := λ m, λ n, m ≤ n,
  rflx := by {unfold reflexive,intro x, refl, },
  trns := by {unfold transitive, apply le_trans,},
}

section
variables b b' : bool
#check b && b'
#eval ff && tt
#eval tt && tt
end

@[simp]
def bool_and : bool → bool → bool
| _  ff  := ff
| ff _ := ff
| tt  tt := tt

lemma bool_and_assoc {x y z : bool}  :
  x && y && z = x && (y && z) :=
begin
simp,
end

def preorder_bundled_bool : preorder_bundled :=
{
  carrier := bool,
  rel := λ b, λ b', b && b' = b,
  rflx := by { unfold reflexive,
               intro x, --
               cases x,
               repeat {refl},
               },
  trns := by { unfold transitive,
               intros x y z,
               intros h₁ h₂, rw ← h₁, rw bool_and_assoc, rw h₂},
}

/- Morphisms between preorders -/
structure preorder_bundled.morphism :=
(dom cod : preorder_bundled)
(to_fun : dom.carrier → cod.carrier)
(respect_rel : ∀ {a b : dom.carrier}, dom.rel a b → cod.rel (to_fun a) (to_fun b))

/- An instance of a morphism between two preorders on natural numbers-/
def preorder_bundled_nat_eq_to_nat_le : preorder_bundled.morphism :=
{
  dom := preorder_bundled_nat_eq,
  cod := preorder_bundled_nat_le,
  to_fun := id,
  respect_rel := by {intros a b, simp, apply le_of_eq, }
}

end STR

-- STR.

end PROOFS

-- PROOFS.STR.


/-
Copyright (c) 2022 Yury Kudryashov. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Yury Kudryashov
-/
import order.succ_pred.basic
import data.set.lattice

/-!
# Intervals `Ixx (f x) (f (order.succ x))`

In this file we prove

* `monotone.bUnion_Ico_Ioc_map_succ`: if `α` is a linear archimedean succ order and `β` is a linear
  order, then for any monotone function `f` and `m n : α`, the union of intervals
  `set.Ioc (f i) (f (order.succ i))`, `m ≤ i < n`, is equal to `set.Ioc (f m) (f n)`;

* `monotone.pairwise_disjoint_on_Ioc_succ`: if `α` is a linear succ order, `β` is a preorder, and
  `f : α → β` is a monotone function, then the intervals `set.Ioc (f n) (f (order.succ n))` are
  pairwise disjoint.

For the latter lemma, we also prove various order dual versions.
-/

open set order

variables {α β : Type*} [linear_order α]

namespace monotone

/-- If `α` is a linear archimedean succ order and `β` is a linear order, then for any monotone
function `f` and `m n : α`, the union of intervals `set.Ioc (f i) (f (order.succ i))`, `m ≤ i < n`,
is equal to `set.Ioc (f m) (f n)` -/
lemma bUnion_Ico_Ioc_map_succ [succ_order α] [is_succ_archimedean α]
  [linear_order β] {f : α → β} (hf : monotone f) (m n : α) :
  (⋃ i ∈ Ico m n, Ioc (f i) (f (succ i))) = Ioc (f m) (f n) :=
begin
  cases le_total n m with hnm hmn,
  { rw [Ico_eq_empty_of_le hnm, Ioc_eq_empty_of_le (hf hnm), bUnion_empty] },
  { refine succ.rec _ _ hmn,
    { simp only [Ioc_self, Ico_self, bUnion_empty] },
    { intros k hmk ihk,
      rw [← Ioc_union_Ioc_eq_Ioc (hf hmk) (hf $ le_succ _), union_comm, ← ihk],
      by_cases hk : is_max k,
      { rw [hk.succ_eq, Ioc_self, empty_union] },
      { rw [Ico_succ_right_eq_insert_of_not_is_max hmk hk, bUnion_insert] } } }
end

/-- If `α` is a linear succ order, `β` is a preorder, and `f : α → β` is a monotone function, then
the intervals `set.Ioc (f n) (f (order.succ n))` are pairwise disjoint. -/

/-- If `α` is a linear succ order, `β` is a preorder, and `f : α → β` is a monotone function, then
the intervals `set.Ico (f n) (f (order.succ n))` are pairwise disjoint. -/
lemma pairwise_disjoint_on_Ico_succ [succ_order α] [preorder β] {f : α → β} (hf : monotone f) :
  pairwise (disjoint on (λ n, Ico (f n) (f (succ n)))) :=
(pairwise_disjoint_on _).2 $ λ m n hmn x ⟨⟨_, h₁⟩, ⟨h₂, _⟩⟩, h₁.not_le $
  (hf $ succ_le_of_lt hmn).trans h₂

/-- If `α` is a linear succ order, `β` is a preorder, and `f : α → β` is a monotone function, then
the intervals `set.Ioo (f n) (f (order.succ n))` are pairwise disjoint. -/
lemma pairwise_disjoint_on_Ioo_succ [succ_order α] [preorder β] {f : α → β} (hf : monotone f) :
  pairwise (disjoint on (λ n, Ioo (f n) (f (succ n)))) :=
hf.pairwise_disjoint_on_Ico_succ.mono $ λ i j h, h.mono Ioo_subset_Ico_self Ioo_subset_Ico_self

/-- If `α` is a linear pred order, `β` is a preorder, and `f : α → β` is a monotone function, then
the intervals `set.Ioc (f order.pred n) (f n)` are pairwise disjoint. -/
lemma pairwise_disjoint_on_Ioc_pred [pred_order α] [preorder β] {f : α → β} (hf : monotone f) :
  pairwise (disjoint on (λ n, Ioc (f (pred n)) (f n))) :=
by simpa only [(∘), dual_Ico] using hf.dual.pairwise_disjoint_on_Ico_succ

/-- If `α` is a linear pred order, `β` is a preorder, and `f : α → β` is a monotone function, then
the intervals `set.Ico (f order.pred n) (f n)` are pairwise disjoint. -/
lemma pairwise_disjoint_on_Ico_pred [pred_order α] [preorder β] {f : α → β} (hf : monotone f) :
  pairwise (disjoint on (λ n, Ico (f (pred n)) (f n))) :=
by simpa only [(∘), dual_Ioc] using hf.dual.pairwise_disjoint_on_Ioc_succ

/-- If `α` is a linear pred order, `β` is a preorder, and `f : α → β` is a monotone function, then
the intervals `set.Ioo (f order.pred n) (f n)` are pairwise disjoint. -/
lemma pairwise_disjoint_on_Ioo_pred [pred_order α] [preorder β] {f : α → β} (hf : monotone f) :
  pairwise (disjoint on (λ n, Ioo (f (pred n)) (f n))) :=
by simpa only [(∘), dual_Ioo] using hf.dual.pairwise_disjoint_on_Ioo_succ

end monotone

namespace antitone

/-- If `α` is a linear succ order, `β` is a preorder, and `f : α → β` is an antitone function, then
the intervals `set.Ioc (f (order.succ n)) (f n)` are pairwise disjoint. -/
lemma pairwise_disjoint_on_Ioc_succ [succ_order α] [preorder β] {f : α → β} (hf : antitone f) :
  pairwise (disjoint on (λ n, Ioc (f (succ n)) (f n))) :=
hf.dual_left.pairwise_disjoint_on_Ioc_pred

/-- If `α` is a linear succ order, `β` is a preorder, and `f : α → β` is an antitone function, then
the intervals `set.Ico (f (order.succ n)) (f n)` are pairwise disjoint. -/
lemma pairwise_disjoint_on_Ico_succ [succ_order α] [preorder β] {f : α → β} (hf : antitone f) :
  pairwise (disjoint on (λ n, Ico (f (succ n)) (f n))) :=
hf.dual_left.pairwise_disjoint_on_Ico_pred

/-- If `α` is a linear succ order, `β` is a preorder, and `f : α → β` is an antitone function, then
the intervals `set.Ioo (f (order.succ n)) (f n)` are pairwise disjoint. -/
lemma pairwise_disjoint_on_Ioo_succ [succ_order α] [preorder β] {f : α → β} (hf : antitone f) :
  pairwise (disjoint on (λ n, Ioo (f (succ n)) (f n))) :=
hf.dual_left.pairwise_disjoint_on_Ioo_pred

/-- If `α` is a linear pred order, `β` is a preorder, and `f : α → β` is an antitone function, then
the intervals `set.Ioc (f n) (f (order.pred n))` are pairwise disjoint. -/
lemma pairwise_disjoint_on_Ioc_pred [pred_order α] [preorder β] {f : α → β} (hf : antitone f) :
  pairwise (disjoint on (λ n, Ioc (f n) (f (pred n)))) :=
hf.dual_left.pairwise_disjoint_on_Ioc_succ

/-- If `α` is a linear pred order, `β` is a preorder, and `f : α → β` is an antitone function, then
the intervals `set.Ico (f n) (f (order.pred n))` are pairwise disjoint. -/
lemma pairwise_disjoint_on_Ico_pred [pred_order α] [preorder β] {f : α → β} (hf : antitone f) :
  pairwise (disjoint on (λ n, Ico (f n) (f (pred n)))) :=
hf.dual_left.pairwise_disjoint_on_Ico_succ

/-- If `α` is a linear pred order, `β` is a preorder, and `f : α → β` is an antitone function, then
the intervals `set.Ioo (f n) (f (order.pred n))` are pairwise disjoint. -/
lemma pairwise_disjoint_on_Ioo_pred [pred_order α] [preorder β] {f : α → β} (hf : antitone f) :
  pairwise (disjoint on (λ n, Ioo (f n) (f (pred n)))) :=
hf.dual_left.pairwise_disjoint_on_Ioo_succ

end antitone


-- import init.data.nat.basic
-- import init.algebra.ring
-- import init.algebra.norm_num
import tactic
import data.nat.parity
import data.finset
import data.fintype
import algebra.big_operators
import data.real.basic
set_option class.instance_max_depth 15000000

#eval 2

open_locale classical

--open_local matrix

--Alice only sees r and Bob only sees c. The strategy isn't (r,c) → (...) but two maps, r→(r1 r2 r3) and c → (c1 c2 c3)
--I'm using 0 and 1 instead of Green and Red as the two options to fill squares. This makes checking parity of strategies easier

--fin 3 (type = {1,2,3})
--eventually we will be interested in relative probabilities

------------METHOD 1: enumerate all the constraints as concisely as possible and reduce to show we get a contraditcion----------------------------------
--try namespace outside of def but enclosing it
def checkStrategyrc (r c : ℕ) (strategy : ((ℕ → ℕ × ℕ × ℕ) × (ℕ → ℕ × ℕ × ℕ))) : Prop :=
        --functionalize this with lists.
        let r1 := (strategy.1 r).1,
        r2 := (strategy.1 r).2.1,
        r3 := (strategy.1 r).2.2,
        c1 := (strategy.2 c).1,
        c2 := (strategy.2 c).2.1,
        c3 := (strategy.2 c).2.2

        in nat.even(r1 + r2 + r3) ∧ (¬ nat.even(c1 + c2 + c3)) ∧
        ((r = 1 ∧ c = 1 ∧ r1 = c1) ∨ (r = 1 ∧ c = 2 ∧ r2 = c1) ∨ (r = 1 ∧ c = 3 ∧ r3 = c1)
        ∨(r = 2 ∧ c = 1 ∧ r1 = c2) ∨ (r = 2 ∧ c = 2 ∧ r2 = c2) ∨ (r = 2 ∧ c = 3 ∧ r3 = c2)
        ∨(r = 3 ∧ c = 1 ∧ r1 = c3) ∨ (r = 3 ∧ c = 2 ∧ r2 = c3) ∨ (r = 3 ∧ c = 3 ∧ r3 = c3))

--checks all three conditions are met for the strategy
def checkStrategy (strategy : ((ℕ → ℕ × ℕ × ℕ) × (ℕ → ℕ × ℕ × ℕ))) : Prop :=
    (checkStrategyrc 1 1 strategy) ∧ (checkStrategyrc 1 2 strategy) ∧ (checkStrategyrc 1 3 strategy) ∧
    (checkStrategyrc 2 1 strategy) ∧ (checkStrategyrc 2 2 strategy) ∧ (checkStrategyrc 2 3 strategy) ∧
    (checkStrategyrc 3 1 strategy) ∧ (checkStrategyrc 3 2 strategy) ∧ (checkStrategyrc 3 3 strategy)

--someone on Zulip said to try putting this not directly after the import statements. This seems to have helped

--given a strategy, we can't have it satisfy all the conditions

theorem noStrategy2 (strategy : ((ℕ → ℕ × ℕ × ℕ) × (ℕ → ℕ × ℕ × ℕ))) : ¬ (checkStrategy (strategy)) :=
begin
intro s,
rw checkStrategy at s,
repeat {rw checkStrategyrc at s},
revert s,
rw (show 1 = 2 ↔ false, by norm_num),
rw (show 2 = 1 ↔ false, by norm_num),
rw (show 3 = 1 ↔ false, by norm_num),
rw (show 1 = 3 ↔ false, by norm_num),
rw (show 3 = 2 ↔ false, by norm_num),
rw (show 2 = 3 ↔ false, by norm_num),
repeat {simp only [false_and, false_or, and_false, or_false]},
rw (show 1=1 ↔ true, by norm_num),
rw (show 2=2 ↔ true, by norm_num),
rw (show 3=3 ↔ true, by norm_num),
simp only [true_and, and_true, true_or, or_true],
intro s,
rcases s with ⟨⟨s1, t1, u1⟩, ⟨s2, t2, u2⟩, ⟨s3, t3, u3⟩,
               ⟨s4, t4, u4⟩, ⟨s5, t5, u5⟩, ⟨s6, t6, u6⟩,
               ⟨s7, t7, u7⟩, ⟨s8, t8, u8⟩, ⟨s9, t9, u9⟩⟩,
 -- fails
rw u1 at *,
rw u2 at *,
rw u3 at *,
rw u4 at *,
rw u5 at *,
rw u6 at *,
rw u7 at *,
rw u8 at *,
rw u9 at *,
apply odd_add_even t1 (odd_add_odd t2 t3),
convert even_add_even s1 (even_add_even s4 s7) using 1,
ring,

--seems like norm_num, finish, or safe could be useful here

--every case here has a false equality and-ed with something else. How do I replace them with false and reduce?
--how do I tell it that we only care about the cases where r,c ∈ {1,2,3} and then do cases on those?
end

--------------General case: mxn where m and n are odd
def checkStrategyMN {m n : nat} (strategyA : fin m → fin n → nat) (strategyB: fin n → fin m → nat) : Prop :=
(∀ r : fin m, (∀ c : fin n, ((finset.univ.sum (strategyA r)).even) ∧ (¬ (finset.univ.sum (strategyB c)).even) ∧ ((strategyA r c) = (strategyB c r))))

-- (∀ r : fin m, (finset.univ.sum (strategyA r)).even) ∧ (∀ c : fin n, ¬ (finset.univ.sum (strategyB c)).even) ∧
-- (∀ r : m, ∀ c : n, ((strategyA r c) = (strategyB c r)))

theorem noStrategyMN {m n : nat} (strategyA : fin m → fin n → nat) (strategyB: fin n → fin m → nat) : ((¬ m.even) ∧ (¬ n.even)) → ¬ (checkStrategyMN strategyA strategyB) :=
begin
rw checkStrategyMN,
intro h,
push_neg,
--??????????????????????
end

theorem q : 1 = 1 ↔ true :=
begin
squeeze_simp,
end

----Method 2: show sampling---

#check [[1,2],[1,2,3,4],[1,2,3,4,0],[]]

def board {m n : nat} (strategyA : fin m → fin n → nat) (strategyB: fin n → fin m → nat) : fin m → fin n → nat := strategyA --woah man...these representations are THE SAME!!!! (function that returns a vector and a matrix)

def consistent {m n : nat} (strategyA : fin m → fin n → nat) (strategyB: fin n → fin m → nat) : Prop
:= ∀ (r : fin m) (c : fin n), (strategyA r c) = (strategyB c r)

def sampleA {m n : nat} (board : fin m → fin n → nat) : fin m → fin n → nat := board

def sampleB {m n : nat} (board : fin m → fin n → nat) : fin n → fin m → nat := λ (n : fin n) (m : fin m), board m n
#check sampleA
#check sampleB

lemma board_equiv_strategy {m n : nat} (strategyA : fin m → fin n → nat) (strategyB: fin n → fin m → nat) :
(consistent strategyA strategyB) → (strategyA = ((sampleA (board strategyA strategyB))) ∧ (strategyB = (sampleB (board strategyA strategyB))))
:=
begin
intro h,
split,
rw sampleA,
rw board,
rw board,
rw sampleB,
rw consistent at h,
ext i,
rw h, --Logically this should work and seems pretty simple. How do I tell lean to do this???????????
end

def each_row_sum_even {m n : nat} (board : fin m → fin n → nat) : Prop := ∀ (r : fin m), (finset.univ.sum (sampleA board r)).even

def each_col_sum_odd {m n : nat} (board : fin m → fin n → nat) : Prop := ∀ (c : fin n), ¬(finset.univ.sum (sampleB board c)).even

def even_strategy {m n : nat} (strategyA : fin m → fin n → nat) : Prop := (∀ r : fin m, ((finset.univ.sum (strategyA r)).even))

def odd_strategy {m n : nat} (strategyB : fin n → fin m → nat) : Prop := (∀ (c : fin n), ¬ (finset.univ.sum (strategyB c)).even)

lemma even_strategy_implies_even_rows {m n : nat} (strategyA : fin m → fin n → nat) (strategyB : fin n → fin m → nat)
: (consistent strategyA strategyB) → (even_strategy strategyA) → each_row_sum_even (board strategyA strategyB)
:=
begin
rw even_strategy,
rw each_row_sum_even,
rw sampleA,
rw board,
intros h1 h2,
exact h2,
end

--In order to talk about a board we need to assume the two strategies are consistent. Or else we need to define the board differently to allowfor this
lemma odd_strategy_implies_odd_cols {m n : nat} (strategyA : fin m → fin n → nat) (strategyB : fin n → fin m → nat)
: ((consistent strategyA strategyB) ∧ odd_strategy strategyB) → each_col_sum_odd (board strategyA strategyB)
:=
begin
intro h,
cases h with h1 h2,
have h3 := board_equiv_strategy strategyA strategyB h1,
cases h3 with h4 h5,
rw each_col_sum_odd,
rw ← h5,
rw odd_strategy at h2,
exact h2,
end

--switch to mathlib matrix implementation
--Posted on Zulip about this-------------------
--Does this actually sum rows???????? We don't need a column one because we have our sampling function sampleB which is like a transpose
def matrix_sum {m n : ℕ} (M : fin m → fin n → ℕ ) : ℕ :=
finset.univ.sum $ λ i, finset.univ.sum $ M i

def row_sum {m n : nat} (board : fin m → fin n → nat) : nat := matrix_sum (sampleA board)

def col_sum {m n : nat} (board : fin m → fin n → nat) : nat := matrix_sum (sampleB board)

--how does this use sorry?????
theorem sum_univ_fin_eq_sum_range (n : ℕ) (f : fin n → ℝ) :
  finset.sum finset.univ f = (finset.range n).sum (λ i, if hi : i < n then f ⟨i, hi⟩ else 0) :=
begin
  set F : ℕ → ℝ := λ i, if hi : i < n then f ⟨i, hi⟩ else 0 with hF,
  have H : f = λ (i : fin n), F (i.val),
  { ext i,
    rw hF,
    show f i = dite (i.val < n) (λ (hi : i.val < n), f ⟨i.val, hi⟩) (λ (hi : ¬i.val < n), 0),
    rw dif_pos i.is_lt,
    cases i, refl,
  },
  rw H,
  rw ←finset.sum_image,
  { congr',
    -- ⊢ finset.image (λ (x : fin n), x.val) finset.univ = finset.range n
    ext j, -- sigh
    rw [finset.mem_range, finset.mem_image],
    split,
      rintro ⟨⟨j,hj⟩, _, rfl⟩,
      exact hj,
    intro hj,
    use ⟨j, hj⟩,
    split, apply finset.mem_univ, refl
  },
  intros _ _ _ _,
  exact fin.eq_of_veq,
end

lemma row_sum_eq_col_sum {m n : nat} (board : fin m → fin n → nat) : row_sum board = col_sum board
:=
begin
rw row_sum,
rw col_sum,
rw matrix_sum,
rw matrix_sum,
rw sampleB,
rw sampleA,
have h := sum_univ_fin_eq_sum_range,
sorry,
-- finset.sum_comm,
end

theorem noStrategyMN2 {m n : nat} (strategyA : fin m → fin n → nat) (strategyB: fin n → fin m → nat) :
¬ ((consistent strategyA strategyB) ∧  (even_strategy strategyA) ∧ (odd_strategy strategyB))
:=
begin
intro h,
cases h with c y,
cases y with even odd,
have cEven := even,
have x := even_strategy_implies_even_rows strategyA strategyB c even,  --why is this not ok???????
have y := odd_strategy_implies_odd_cols strategyA strategyB (c ∧ even),
end

------------------------tests-----------------
theorem myTheorem : ¬ (∀ x : nat, x = 2) :=
begin
intro h,
specialize h 0,
end

------Ideas----
--use mathlib matrix representation


/-
Copyright (c) 2021 Bhavik Mehta. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Bhavik Mehta
-/
import Mathlib.PrePort
import Mathlib.Lean3Lib.init.default
import Mathlib.category_theory.limits.shapes.pullbacks
import Mathlib.category_theory.limits.shapes.binary_products
import Mathlib.category_theory.limits.preserves.shapes.pullbacks
import Mathlib.PostPort

universes v u₁ u₂

namespace Mathlib

/-!
# Relating monomorphisms and epimorphisms to limits and colimits

If `F` preserves (resp. reflects) pullbacks, then it preserves (resp. reflects) monomorphisms.

## TODO

Dualise and apply to functor categories.

-/

namespace category_theory

/-- If `F` preserves pullbacks, then it preserves monomorphisms. -/
protected instance preserves_mono {C : Type u₁} {D : Type u₂} [category C] [category D] (F : C ⥤ D)
    {X : C} {Y : C} (f : X ⟶ Y) [limits.preserves_limit (limits.cospan f f) F] [mono f] :
    mono (functor.map F f) :=
  sorry

/-- If `F` reflects pullbacks, then it reflects monomorphisms. -/
theorem reflects_mono {C : Type u₁} {D : Type u₂} [category C] [category D] (F : C ⥤ D) {X : C}
    {Y : C} (f : X ⟶ Y) [limits.reflects_limit (limits.cospan f f) F] [mono (functor.map F f)] :
    mono f :=
  sorry

end Mathlib


import data.finsupp
import algebra.ring
import .to_finset
import .to_multiset
import to_semiring

noncomputable theory

local infix ^ := monoid.pow

open classical multiset
local attribute [instance] prop_decidable
--can the priority be set better? Because now we often have to provide parentheses
local notation a `~ᵤ` b : 50 := associated a b

universe u
variable {α : Type u}
variable [comm_semiring α]

def unit_of_mul_eq_one  {a b : α} (h1 : a * b = 1) : units α :=
units.mk a b h1 (by {rw mul_comm _ _ at h1, exact h1})

--removed protected
@[refl] lemma associated.refl : ∀ (x : α), x ~ᵤ x :=
assume x, let ⟨u, hu⟩ := is_unit_one in ⟨u, by {rw [←hu], rw [one_mul]}⟩

@[symm] lemma associated.symm {x y : α} (h : x ~ᵤ y) : y ~ᵤ x :=
let ⟨u, hu⟩ := h in ⟨u⁻¹, by rw [hu, ←mul_assoc, units.inv_mul, one_mul]⟩

--Why protected??
@[trans] lemma associated.trans {x y z: α} (h1 : x ~ᵤ y)(h2 : y ~ᵤ z): x ~ᵤ z :=
let ⟨u1, hu1⟩ := h1 in
let ⟨u2, hu2⟩ := h2 in
exists.intro (u1 * u2) $ by rw [hu1, hu2, ←mul_assoc, units.mul_coe]

lemma associated.eqv : equivalence (@associated α _) :=
mk_equivalence (@associated α _) (@associated.refl α _) (@associated.symm α _) (@associated.trans α _)

--correct simp?
@[simp] lemma associated_zero_iff_eq_zero {a : α} : (a ~ᵤ (0 : α)) ↔ a = 0 :=
iff.intro
  (assume h1, let ⟨u, h2⟩ := h1 in by simp [h2, *])
  (assume h1, by rw h1)

lemma associated_of_mul_eq_one {a b : α} (h1 : a * b = 1) : a ~ᵤ b :=
begin
  have h2 : b * a = 1,
  { rwa mul_comm a b at h1},
  have h3 : a * a * (b * b) = 1,
  { rwa [←mul_assoc, @mul_assoc _ _ a a _, h1, mul_one]},
  have h4 : b * b * (a * a) = 1,
  { rwa [mul_comm _ _] at h3},
  exact ⟨units.mk (a * a) (b * b) h3 h4, by {rw [units.val_coe], simp [mul_assoc, h1]}⟩,
end

lemma is_unit_left_iff_exists_mul_eq_one [comm_semiring α] {a: α} : (is_unit a) ↔ ∃ b, a * b = 1 :=
begin
  apply iff.intro,
  {
    intro h1,
    rcases h1 with ⟨aᵤ, ha⟩,
    subst ha,
    exact ⟨aᵤ.inv, by {rw [←units.inv_coe, units.mul_inv]}⟩,
  },
  {
    intro h1,
    rcases h1 with ⟨b, h2⟩,
    have h3 : b * a = 1,
    { rw [mul_comm a b]at h2, exact h2},
    exact ⟨⟨a, b, h2, h3⟩, rfl⟩,
  }
end

lemma is_unit_right_iff_exists_mul_eq_one {b: α} : (is_unit b) ↔ ∃ a, a * b = 1 :=
begin
  have h1 : (is_unit b) ↔ ∃ a, b * a = 1,
  from @is_unit_left_iff_exists_mul_eq_one _ _ _ b,
  constructor,
  {
    intro h2,
    rw h1 at h2,
    let a := some h2,
    have h3 : b * a = 1,
    from some_spec h2,
    rw mul_comm b a at h3,
    exact ⟨a, h3⟩
  },
  {
    intro h2,
    rw h1,
    let a := some h2,
    have h3 : a * b = 1,
    from some_spec h2,
    rw mul_comm a b at h3,
    exact ⟨a, h3⟩,
  }
end

--Should also make a right.
lemma is_unit_left_of_is_unit_mul {a b : α} : is_unit (a * b) → is_unit a :=
begin
  intro h1,
  rcases h1 with ⟨u, hu⟩,

  have h2 : a * (b* (↑u⁻¹ : α) ) = 1,
  {
    exact calc a * (b* (↑u⁻¹ : α) ) = (a * b) * (↑u⁻¹ : α) : by rw ← mul_assoc
    ... = u.val * (↑u⁻¹ : α) : by simp [units.val_coe, *]
    ... = u.val * u.inv : by rw units.inv_coe
    ... = 1 : u.val_inv,
  },
  rw @is_unit_left_iff_exists_mul_eq_one _ _ _ a,
  exact ⟨(b * ↑u⁻¹), h2 ⟩,
end

lemma is_unit_right_of_is_unit_mul {a b : α} : is_unit (a * b) → is_unit b :=
begin
  rw mul_comm a b,
  exact is_unit_left_of_is_unit_mul,
end

lemma is_unit_of_mul_eq_one_left {a b : α} (h : a * b = 1): is_unit a :=
begin
  rw is_unit_left_iff_exists_mul_eq_one,
  exact ⟨b , h⟩
end

lemma is_unit_of_mul_eq_one_right {a b : α} (h : a * b = 1): is_unit b :=
begin
  rw is_unit_right_iff_exists_mul_eq_one,
  exact ⟨a , h⟩
end

--naming
lemma prod_not_is_unit_eq_one_iff_eq_zero {p : multiset α}: (∀ a, a ∈ p → (¬ (is_unit a))) → (p.prod = 1 ↔ p = 0) :=
begin

  by_cases h1 : (p = 0),
  {
    simp [h1]
  },
  {
    have h2 : ∃a , a ∈ p,
    from multiset.exists_mem_of_ne_zero h1,
    let h := some h2,
    have h3 : h ∈ p,
    from some_spec h2,
    have h4 : ∃ t, p = h :: t,
    from multiset.exists_cons_of_mem h3,
    let t := some h4,
    have h5 : p = h :: t,
    from some_spec h4,
    intro h6,
    constructor,
    {
      intro h7,
      rw h5 at h7,
      simp at h7,
      rw mul_comm h _ at h7,
      have h8 : is_unit h,
      {
        rw is_unit_right_iff_exists_mul_eq_one,
        exact ⟨multiset.prod t, h7⟩,
      },
      have h9 : h ∈ p,
      {rw h5, simp},
      have : ¬is_unit h,
      from h6 h h9,
      contradiction,
    },
    {
      intro h7,
      simp *,
    }
  }
end

lemma is_unit_mul_div {a b : α} (h : is_unit a) : a * b ∣ b :=
begin
  by_cases h1 : (b = 0),
  {
    simp * at *,
  },
  {
    rcases h with ⟨u, hu ⟩,
    have h1 : b = a * b * u.inv,
    {
      exact calc b = 1 * b : by simp
      ... = (u.val*u.inv) * b : by rw [u.val_inv]
      ... = (a * u.inv) * b : by rw [←units.val_coe u, ← hu]
      ... = _ : by simp [mul_assoc, mul_comm u.inv b],
    },
    exact ⟨u.inv, h1⟩
  }
end

lemma mul_is_unit_div {a b : α} (h : is_unit a) : b * a ∣ b :=
begin
  rw mul_comm b a,
  exact is_unit_mul_div h,
end

lemma dvd_of_mem_prod {a x : α} {b : multiset α} (h1 : a = b.prod) (h2 : x ∈ b) : x ∣ a :=
begin
  rw ←cons_erase h2 at h1,
  simp at h1,
  split,
  exact h1,
end

lemma is_unit_of_associated {p b : α}(h1 : is_unit p)(h2 : p ~ᵤ b) : is_unit b :=
begin
  rw associated at h2,
  rw is_unit_left_iff_exists_mul_eq_one at h1,
  let u := some h2,
  have h3 : p = ↑u * b,
  from some_spec h2,
  let q := some h1,
  have h4 : p * q = 1,
  from some_spec h1,
  have h5 : (q * ↑u) * b = 1,
  {
    exact calc (q * ↑u) * b = q * (↑u * b) : by simp only [mul_assoc]
    ... = q * p : by rw h3
    ... = p * q : by simp [mul_comm]
    ... = _ : h4,
  },
  rw is_unit_right_iff_exists_mul_eq_one,
  exact ⟨(q * ↑u), h5⟩
end

lemma dvd_dvd_of_associated {a b : α}
   : (a ~ᵤ b) → ( a ∣ b) ∧ ( b ∣ a):=
assume h1, let ⟨u, h2⟩ := h1 in
and.intro
  (have h3 : u.inv * a = b, from
    (calc u.inv * a = u.inv * (↑u * b) : by rw h2
        ... = (u.inv * u.val) * b : by {simp [units.val_coe, mul_assoc]}
        ... = b : by simp [u.inv_val]),
   dvd.intro_left _ h3)
  (dvd.intro_left _ h2.symm)

lemma asssociated_one_iff_is_unit {a : α} : (a ~ᵤ 1) ↔ is_unit a :=
begin
  constructor,
  {
    intro h1,
    rw associated at h1,
    let u := some h1,
    have h2: a = ↑u * 1,
    from some_spec h1,
    have h3 : ↑(u⁻¹) * a = 1,
    {
      exact calc ↑u⁻¹ * a = ↑u⁻¹ * (↑u * 1) : by rw h2
      ... = (↑u⁻¹ * ↑u) * 1 : by simp
      ... = 1 : by simp [units.inv_mul]
    },

    rw is_unit_right_iff_exists_mul_eq_one,
    exact ⟨↑u⁻¹, h3⟩,
  },
  {
    intro h1,
    rcases h1 with ⟨aᵤ, ha⟩,
    exact ⟨aᵤ, by simp *⟩,
  }
end

lemma mul_associated_mul_of_associated_of_associated {a b c d : α} (h1 : a ~ᵤ c) (h2: b ~ᵤ d) : (a * b) ~ᵤ (c * d) :=
begin
  rcases h1 with ⟨u1, hu1⟩,
  rcases h2 with ⟨u2, hu2⟩,
  fapply exists.intro,
  exact u1 * u2,
  rw [hu1, hu2, mul_assoc],
  exact calc ↑u1 * (c * (↑u2 * d)) = ↑u1 * ((c * ↑u2) * d): by simp [mul_assoc]
    ... = ↑u1 * ((↑u2 * c) * d): by simp [mul_comm]
    ... = ↑u1 * ↑u2 * c * d: by simp [mul_assoc]
    ... = _ : by rw [units.mul_coe, mul_assoc]
end

lemma associated_of_mul_is_unit {a b c : α} (h1 : is_unit b) (h2 : a * b = c) : (a ~ᵤ c) :=
begin
  apply associated.symm,
  rcases h1 with ⟨u, hu⟩,
  apply exists.intro u,
  subst hu,
  simp [mul_comm, *],
end

lemma associated.dvd_of_associated {a b c : α} (h1 : a ~ᵤ b) (h2 : b ∣ c) : a ∣ c :=
begin
  rcases h1 with ⟨u, hu⟩,
  rcases h2 with ⟨d, hd⟩,
  fapply exists.intro,
  exact u.inv * d,
  rw mul_comm _ b at hu,
  rw [hu,←mul_assoc],
  apply eq.symm,
  exact calc b * ↑u * u.inv * d = b * (↑u * u.inv) * d : by simp [mul_assoc]
  ... = c : by simp [units.val_coe, u.val_inv, hd]
end

lemma is_unit_of_mul_is_unit_left {a b : α} (h : is_unit (a * b)) : is_unit a :=
begin
  rcases h with ⟨c, hc⟩,
  have h1: a * b * c.inv = 1,
  {
    rw [hc, units.val_coe c, c.val_inv],
  },
  rw mul_assoc at h1,
  exact is_unit_of_mul_eq_one_left h1,
end

lemma is_unit_of_mul_is_unit_right {a b : α} (h : is_unit (a * b)) : is_unit b :=
begin
  rw mul_comm at h,
  exact is_unit_of_mul_is_unit_left h,
end

lemma is_unit_mul_iff_is_unit_and_is_unit {a b : α} : is_unit (a * b) ↔ is_unit a ∧ is_unit b :=
begin
  split,
  {
    intros h,
    exact ⟨is_unit_of_mul_is_unit_left h, is_unit_of_mul_is_unit_right h⟩,
  },
  {
    intros h,
    exact is_unit_mul_of_is_unit_of_is_unit h.1 h.2,
  }
end

--Naming?
lemma not_is_unit_of_not_is_unit_dvd {a b : α} (h1 : ¬is_unit a) (h2 : a ∣ b) : ¬is_unit b :=
begin
  rcases h2 with ⟨c, hc⟩,
  subst hc,
  by_contradiction h2,
  have : is_unit a,
    from is_unit_left_of_is_unit_mul h2,
  contradiction,
end

---Gcds

--gcds
class has_gcd (α : Type u) [comm_semiring α] := --can we define it for comm_monoid?
(gcd : α → α → α)
(gcd_right : ∀ a b, gcd a b ∣ b)
(gcd_left  : ∀ a b, gcd a b ∣ a)
(gcd_min   : ∀ a b g, g ∣ a → g ∣ b → g ∣ gcd a b)

section gcd_sr
variables [has_gcd α] {a b c : α}

def gcd : α → α → α := has_gcd.gcd
def gcd_min := has_gcd.gcd_min a b c  --Correct???
def gcd_left := has_gcd.gcd_left a b --use {a b : α}?
def gcd_right := has_gcd.gcd_right a b

def coprime (a b : α) := is_unit (gcd a b)

lemma coprime_def : (coprime a b) = (is_unit $ gcd a b) :=
rfl

@[simp] lemma gcd_zero_zero_eq_zero : gcd (0 : α) 0 = 0 :=
begin
  by_contradiction,
  have h1 : (0 : α)∣0,
  {simp},
  have h2 : 0 ∣ (gcd (0 : α) 0),
  from gcd_min h1 h1,
  have : (gcd (0 : α) 0) = 0,
  from eq_zero_of_zero_dvd h2,
  contradiction
end

end gcd_sr


import combinatorics.simple_graph.subgraph
import combinatorics.simple_graph.connectivity
import combinatorics.simple_graph.matching
import local.set
import local.subgraph

namespace simple_graph
variables {V : Type*} {G : simple_graph V} {M : G.subgraph}
variables {u v : V}
variables {p: path G u v}

def walk.to_subgraph (w: walk G u v): G.subgraph :=
 { verts := {v |  v ∈ w.support},
   adj := (λ x y, ⟦(x, y)⟧ ∈ w.edges),
   adj_sub := λ x y, walk.adj_of_mem_edges w,
   edge_vert := λ x y, w.fst_mem_support_of_mem_edges,
   symm := by simp [symmetric, sym2.eq_swap] }

instance : has_coe (walk G u v) (G.subgraph) := ⟨ walk.to_subgraph ⟩

theorem walk.length_pos_of_ne (w: walk G u v): u ≠ v → 0 < w.length :=
by cases w; simp

theorem walk.nth_le_support_iff_get_vert (w: walk G u v) {n: ℕ} (hn: n < w.support.length):
  w.support.nth_le n hn = w.get_vert n :=
begin
  induction w generalizing n,
  { simp [walk.get_vert] },
  cases n,
  { simp [walk.get_vert] },
  simpa [walk.get_vert] using w_ih _
end

theorem walk.nth_le_edge (w: walk G u v) {n : ℕ} (hn: n < w.edges.length):
  w.edges.nth_le n hn = ⟦ (w.get_vert n, w.get_vert (n + 1)) ⟧ :=
begin
  induction w generalizing n,
  { cases hn },
  cases n,
  { simp [walk.get_vert] },
  simpa [walk.get_vert] using w_ih _
end

theorem walk.mem_support_iff_coe_verts (w: walk G u v) (x: V):
  x ∈ w.support ↔ x ∈ (w:G.subgraph).verts := by refl

theorem walk.coe_verts_iff_get_vert (w: walk G u v) (x: V):
  x ∈ (w:G.subgraph).verts ↔ ∃ n ≤ w.length, w.get_vert n = x :=
by simp only [← walk.mem_support_iff_coe_verts, list.mem_iff_nth_le,
    walk.nth_le_support_iff_get_vert, walk.length_support, nat.lt_succ_iff]

@[simp]
theorem walk.start_mem_coe_verts (w: walk G u v):
  u ∈ (w:G.subgraph).verts := by simp [← w.mem_support_iff_coe_verts]

@[simp]
theorem walk.end_mem_coe_verts (w: walk G u v):
  v ∈ (w:G.subgraph).verts := by simp [← w.mem_support_iff_coe_verts]

theorem walk.mem_edges_iff_coe_adj (w: walk G u v) (x y: V):
  ⟦(x, y)⟧ ∈ w.edges ↔ (w:G.subgraph).adj x y := by refl

theorem walk.adj_get_vert_succ' (w: walk G u v) {n: ℕ} (hn: n < w.length):
  (w:G.subgraph).adj (w.get_vert n) (w.get_vert (n+1)) :=
begin
  induction w generalizing n,
  { cases hn },
  cases n,
  { simp [walk.get_vert, walk.get_vert_zero, ← walk.mem_edges_iff_coe_adj] },
  simpa [walk.get_vert, walk.get_vert_zero, ← walk.mem_edges_iff_coe_adj]
    using or.inr (w_ih (nat.succ_lt_succ_iff.mp hn))
end

theorem walk.adj_succ_get_vert' (w: walk G u v) {n: ℕ} (hn: n < w.length):
  (w:G.subgraph).adj (w.get_vert (n+1)) (w.get_vert n) :=
  (w:G.subgraph).adj_symm (w.adj_get_vert_succ' hn)

theorem walk.adj_get_vert_pred' (w: walk G u v) {n: ℕ} (hn₀: 0 < n) (hn₁: n ≤ w.length):
  (w:G.subgraph).adj (w.get_vert n) (w.get_vert (n-1)) :=
begin
  cases n,
  { cases hn₀ },
  simpa [nat.succ_eq_add_one] using w.adj_succ_get_vert' (nat.lt_of_succ_le hn₁)
end

lemma walk.coe_fst_mem_verts_of_adj (w : G.walk u v) {x y: V}:
  (w:G.subgraph).adj x y → x ∈ (w:G.subgraph).verts :=
begin
  rw [← w.mem_support_iff_coe_verts, ← w.mem_edges_iff_coe_adj],
  exact w.fst_mem_support_of_mem_edges
end

theorem path.get_vert_inj (p: path G u v) {n m: ℕ} (hn: n ≤ (p:walk G u v).length) (hm: m ≤ (p:walk G u v).length):
  (p:walk G u v).get_vert n = (p:walk G u v).get_vert m → n = m :=
begin
  rw [← nat.lt_succ_iff, nat.succ_eq_add_one, ← walk.length_support] at hn hm,
  simp [← (p:walk G u v).nth_le_support_iff_get_vert hn,
    ← (p:walk G u v).nth_le_support_iff_get_vert hm,
    list.nodup.nth_le_inj_iff p.nodup_support]
end

theorem path.get_vert_inj_ne (p: path G u v) {n m: ℕ} (hn: n ≤ (p:walk G u v).length) (hm: m ≤ (p:walk G u v).length):
  n ≠ m → (p:walk G u v).get_vert n ≠ (p:walk G u v).get_vert m :=
by simpa [not_imp_not] using p.get_vert_inj hn hm

theorem path.get_vert_inj_iff (p: path G u v) {n m: ℕ} (hn: n ≤ (p:walk G u v).length) (hm: m ≤ (p:walk G u v).length):
  (p:walk G u v).get_vert n = (p:walk G u v).get_vert m ↔ n = m :=
  ⟨ p.get_vert_inj hn hm, congr_arg _ ⟩

theorem path.coe_verts_iff_get_vert (p: path G u v) (x: V):
  x ∈ (p:G.subgraph).verts ↔ ∃ n ≤ (p:walk G u v).length, (p:walk G u v).get_vert n = x :=
  walk.coe_verts_iff_get_vert (p:walk G u v) x

theorem path.mem_edges_iff_coe_adj (p: path G u v) (x y: V):
  ⟦(x, y)⟧ ∈ (p:walk G u v).edges ↔ (p:G.subgraph).adj x y := by refl

theorem path.neighbors (p: path G u v) {n: ℕ} (hn: n ≤ (p:walk G u v).length) {x: V}:
  (p:G.subgraph).adj ((p:walk G u v).get_vert n) x →
    n < (p:walk G u v).length ∧ ((p:walk G u v).get_vert (n + 1)) = x ∨
    0 < n  ∧ ((p:walk G u v).get_vert (n - 1)) = x :=
begin
  simp only [← p.mem_edges_iff_coe_adj, walk.length_edges, walk.nth_le_edge,
    list.mem_iff_nth_le, sym2.rel_iff, quotient.eq],
  intros h,
  rcases h with ⟨m, hm, h⟩,
  cases h,
  { rw [← p.get_vert_inj (le_of_lt hm) hn h.left],
    exact or.inl ⟨hm, h.right⟩ },
  { rw [← p.get_vert_inj (nat.succ_le_of_lt hm) hn h.right, nat.succ_sub_one],
    exact or.inr ⟨nat.zero_lt_succ _, h.left⟩ }
end

theorem path.neighbors' (p: path G u v) {n: ℕ} (hn: n ≤ (p:walk G u v).length) {x: V}:
  (p:G.subgraph).adj ((p:walk G u v).get_vert n) x →
    ((p:walk G u v).get_vert (n + 1)) = x ∨
    ((p:walk G u v).get_vert (n - 1)) = x :=
begin
  intro hadj,
  cases p.neighbors hn hadj,
  exact or.inl h.right,
  exact or.inr h.right
end

theorem path.start_unique_adj (p: path G u v) (hne: u ≠ v):
  ∃! x, (p:G.subgraph).adj u x :=
begin
  simp only [← (p:walk G u v).get_vert_zero],
  refine ⟨(p:walk G u v).get_vert 1, walk.adj_get_vert_succ' _ (walk.length_pos_of_ne _ hne), _⟩,
  intros y hy,
  cases p.neighbors (nat.zero_le _) hy,
  { exact h.right.symm },
  { cases h.left }
end

theorem path.end_unique_adj (p: path G u v) (hne: u ≠ v):
  ∃! x, (p:G.subgraph).adj v x :=
begin
  simp only [← (p:walk G u v).get_vert_length],
  refine ⟨(p:walk G u v).get_vert ((p:walk G u v).length -1),
    walk.adj_get_vert_pred' _ (walk.length_pos_of_ne _ hne) (le_refl _),
    _⟩,
  intros y hy,
  cases p.neighbors (le_refl _) hy,
  { exact absurd h.left (lt_irrefl _) },
  { exact h.right.symm }
end

end simple_graph


import simple_graph

universes u
variables {V : Type u}

section list

lemma list.cons_nth_le_succ
  {α : Type*} {hd : α} (tl : list α)
  (n : ℕ) (hn : n + 1 < (tl.cons hd).length)
  (h_auto : n < tl.length := by tidy)
  :
(tl.cons hd).nth_le (n + 1) hn = tl.nth_le n h_auto := rfl

lemma list.cons_nth_le_succ'
  {α : Type*} (l : list α)
  (n : ℕ) (hn : n + 1 < l.length)
  (h_auto : n < l.tail.length)
  :
l.nth_le (n + 1) hn = l.tail.nth_le n h_auto :=
by { cases l, { cases hn }, simp; refl }

@[simp] lemma list.nth_le_succ_tail
  {α : Type*} (l : list α)
  (n : ℕ) (hn : n < l.tail.length)
  (h_auto : n + 1 < l.length)
  -- (h_auto : n + 1 < l.length := by { simp at hn, omega })
   :
l.nth_le (n + 1) h_auto = l.tail.nth_le n hn :=
by { cases l, tidy }

@[simp] lemma list.tail_nth_le_zero
  {α : Type*} (l : list α) [inhabited α]
  (h_auto : 0 < l.length) :
list.nth_le l 0 h_auto = l.head :=
by { cases l, { cases h_auto }, tidy, }

end list

namespace simple_graph
variables (G : simple_graph V)

/-- Morally, a path is an alternating list of vertices and edges,
  with incidences between adjacent objects -/
@[ext] structure path :=
(head : V)
(tail : list V)
(edges : list G.E)
(length_eq : edges.length = tail.length)
(adj : ∀ (n : ℕ) (hn : n < edges.length),
  let u := (list.cons head tail).nth_le n (by { simp; omega }) in
  let v := (list.cons head tail).nth_le (n + 1) (by { simp, cc }) in
  u ≠ v ∧ u ∈ edges.nth_le n hn ∧ v ∈ edges.nth_le n hn)

namespace path
variables {G}
variables (p : G.path)

section classical
open_locale classical
/-- The last vertex in p. -/
noncomputable def last : V := if h : p.tail = list.nil then p.head else p.tail.last h

end classical

/-- The ordered list of all vertices in p, starting at p.head and ending at p.sink. -/
def vertices : list V := p.head :: p.tail

/-- The number of edges in p. -/
def length : ℕ := p.tail.length
-- should probably make sure this doesn't become a problem if we run into infinite graphs?

@[simp] lemma tail_length_eq : p.tail.length = p.length := rfl
@[simp] lemma edges_length_eq : p.edges.length = p.length :=  by simp [p.length_eq]
@[simp] lemma vertices_tail : p.vertices.tail = p.tail := by simp [path.vertices]
@[simp] lemma vertices_length : p.vertices.length = p.length + 1 := by simp [path.vertices]

#check list.nth_eq_some
lemma head_ne_tail_head [inhabited V] (h : p.tail ≠ list.nil) : p.head ≠ p.tail.head :=
begin
  rcases p.adj 0 _ with ⟨hp, _⟩, dsimp at hp, convert hp,
  cases hp1 : p.tail,
  { contradiction },
  { simp [hp1] },
  { revert h, rw ← list.length_pos_iff_ne_nil, simp },
end

-- begin

-- end

-- variables {s t : V}

variables {p}
/-- p.edge_mem e holds if e is an edge along path p. -/
def edge_mem (e : G.E) (p : G.path) : Prop := e ∈ p.edges
-- this instance doesn't fire and I don't know why
instance has_mem_edge : has_mem G.E G.path :=
{ mem := edge_mem }

/-- p.vertex_mem v holds if v is a vertex along path p. -/
def vertex_mem (v : V) (p : G.path) : Prop := v ∈ p.vertices
instance has_mem_vertices : has_mem V G.path :=
{ mem := vertex_mem }
variables (p)

/-- The empty path based at vertex v. -/
def empty (G : simple_graph V) (v : V) : G.path :=
{ head := v,
  tail := list.nil,
  edges := list.nil,
  length_eq := rfl,
  adj := by rintros _ ⟨_⟩ }

instance [inhabited V] : inhabited G.path := { default := empty G (arbitrary V) }

@[simp]
lemma empty_length (v : V) : (empty G v).length = 0 := by refl

lemma edge_mem_empty {v : V} (e : G.E) : ¬ (empty G v).edge_mem e :=
by simp [empty, edge_mem]

lemma vertex_mem_empty {u v : V} : u ∈ (empty G v) ↔ u = v :=
by { unfold has_mem.mem vertex_mem, simp [empty, vertices], apply or_false }

/-- p.cons e hp hs is the path extending `p` by edge `e`. -/
def cons {s : V} (e : G.E) (hp : p.head ∈ e) (hs : s ∈ e) (hsp : s ≠ p.head) : G.path :=
{ head := s,
  tail := p.vertices,
  edges := list.cons e p.edges,
  length_eq := by { simp [vertices] },
  adj := begin
    intros n hn _ _,
    cases n, { simp, tauto },
    simp; apply p.adj,
  end }

@[simp] lemma edge_mem_cons {s : V} (hd e : G.E) (hp : p.head ∈ hd) (hs : s ∈ hd) (hsp : s ≠ p.head) :
  (p.cons hd hp hs hsp).edge_mem e ↔ e = hd ∨ p.edge_mem e :=
by simp [path.cons, path.vertices, edge_mem]

@[simp] lemma vertex_mem_cons {v s : V} (hd : G.E) (hp : p.head ∈ hd) (hs : s ∈ hd) (hsp : s ≠ p.head) :
  v ∈ (p.cons hd hp hs hsp) ↔ v = s ∨ v ∈ p :=
by refl

@[simp] lemma cons_length {s : V} (hd : G.E) (hp : p.head ∈ hd) (hs : s ∈ hd) (hsp : s ≠ p.head) :
  (p.cons hd hp hs hsp).length = p.length + 1 :=
by { unfold cons length, simp [vertices] }

@[simp] lemma cons_vertices {s : V} (hd : G.E) (hp : p.head ∈ hd) (hs : s ∈ hd) (hsp : s ≠ p.head) :
  (p.cons hd hp hs hsp).vertices = list.cons s p.vertices :=
by { dsimp [vertices, cons], simp }

lemma edges_eq_nil_iff : p.edges = list.nil ↔ p.tail = list.nil :=
by rw [← list.length_eq_zero, p.length_eq, list.length_eq_zero]

lemma length_eq_zero_iff_eq_empty : p.length = 0 ↔ p = empty G p.head :=
begin
  erw list.length_eq_zero,
  split; intro h, swap, rw h, simp [empty],
  ext, work_on_goal 2 {rw ← edges_eq_nil_iff at h},
  any_goals {simp [empty, h]},
end

lemma cases_on' [inhabited V] :
  (∃ v, p = empty G v) ∨
  ∃ (tl : G.path) v e (hs : tl.head ∈ e) (hv : v ∈ e) (hvp : v ≠ tl.head), p = tl.cons e hs hv hvp :=
begin
  cases hp : p.edges with hd tl,
  { left, use p.head, ext, { simp [empty] },
    { suffices : p.tail = list.nil, { simp [empty, this] },
      rwa edges_eq_nil_iff at hp },
    simp [hp, empty] },
  have hp_nil : ¬ p.edges = list.nil, { simp [hp] },
  rw edges_eq_nil_iff at hp_nil,

  rcases p.adj 0 _ with ⟨hvs, hv, hs⟩, simp only [list.nth_le, zero_add] at hs,
  repeat { rw list.nth_le_zero at * },
  set q : G.path := { head := p.tail.head,
    tail := list.tail p.tail,
    edges := list.tail p.edges,
    length_eq := by simp [p.length_eq],
    adj := _},
  swap, { intros, have := p.adj (n + 1) (by { simp only [list.length_tail] at hn, exact nat.add_lt_of_lt_sub_right hn, }),
    simp only [list.nth_le] at this ⊢,
    cases this with huv this,
    cases hp_tail : p.tail with p_hd p_tl, { contradiction },
    dsimp [u,v], simp [hp_tail],   split,
    { contrapose! huv, symmetry, convert huv using 1; simp [hp_tail, huv]; refl },
    -- simp [hp_tail, this],
    -- rw list.tail_nth_le,
    convert this using 2,
    any_goals { simp [hp_tail]; refl },
    -- { rw list.cons_head_tail hp_nil, refl },
    iterate 2 { rwa list.cons_nth_le_succ' },
    },
  right, use [q, p.head, hd],
  simp only [hp, list.head] at hs hv, swap, { simp [hp] },
  dsimp, use [hs, hv], split,
  ext,
  { simp [path.cons] },
  { dsimp [q, path.cons, path.vertices], rwa list.cons_head_tail, },
  { dsimp [q, path.cons], simp [hp] },
  revert hvs, simp,
end

@[elab_as_eliminator]
lemma induction_on [inhabited V]
  (P : G.path → Prop)
  (P_empty : ∀ v, P $ empty G v)
  (P_inductive : ∀ p e hs {v} (hv : v ∈ e) (hsv), P p → P (p.cons e hs hv hsv)) :
P p :=
begin
  suffices : ∀ k (q : G.path), q.length = k → P q, { apply this p.length, refl },
  intro k, induction k with k hk, { intros, convert P_empty _, rwa ← length_eq_zero_iff_eq_empty },
  intro q, rcases q.cases_on' with ⟨_,rfl⟩|⟨_,_,_,_,_,_,rfl⟩, { intro, apply P_empty },
  intro, apply P_inductive, apply hk, simp at a, omega,
end

lemma consecutive_vertex_ne [inhabited V] {n} (h : n < p.length) :
p.vertices.nth_le n (by { simp, linarith }) ≠
p.vertices.nth_le (n+1) (by { simp, linarith }) :=
begin
  revert n,
  convert p.induction_on (λ q, ∀ n (h : n < q.length), q.vertices.nth_le n _ ≠ q.vertices.nth_le (n+1) _) _ _,
  { simp }, iterate 2 { simp, omega },
  { rintros _ _ ⟨⟩ },
  clear p, intros _ _ _ _ _ _ h n hn,
  cases n, { simpa },
  convert h _ _,
  simp at hn, omega,
end

@[ext] lemma eq_of_vertices_eq [inhabited V] (q : G.path) :  p = q ↔ p.vertices = q.vertices :=
{ mp := by tidy,
  mpr := begin
    intro h, have h_tail : p.tail = q.tail,
    { dsimp [vertices] at h, simp only [] at h, tauto },
    have h_length : p.length = q.length := by rw [← tail_length_eq, h_tail, tail_length_eq],
    ext, { tidy }, { simp [h_tail] },
    by_cases hn : n < p.length; have hnq := by { rw h_length at hn, exact hn },
    swap, { simp [hn, hnq, list.nth_eq_some] },
    suffices : p.edges.nth_le n _ = q.edges.nth_le n _,
    { simp [hn, hnq, list.nth_eq_some]; refine eq.congr this rfl },
    rw edge_eq_iff,
    set u := p.vertices.nth_le n (by { simp [path.vertices], linarith }),
    set v := p.vertices.nth_le (n+1) (by { simp [path.vertices], linarith }),
    use [u, v],
    split, symmetry, apply consecutive_vertex_ne,
    rcases p.adj n _ with ⟨_, hpu, hpv⟩,
    rcases q.adj n _ with ⟨_, hqu, hqv⟩,
    split, { exact hpu },
    split, { convert hqu, dsimp [u], simp_rw h, refl },
    split, { exact hpv },
    { convert hqv, dsimp [v], simp_rw h, refl },
  end }

/-- p.is_cycle if p starts and ends in the same place. -/
def is_cycle : Prop := p.head = p.last

/-- p.is_trail if p has no repeated edges. -/
def is_trail : Prop := list.nodup p.edges

/-- p.is_tour if p has no repeated vertices. -/
def is_tour : Prop := list.nodup p.vertices
-- maybe prove that `is_tour → is_Eulerian`

/-- p.is_Eulerian if p hits each edge exactly once. -/
def is_Eulerian : Prop := p.is_trail ∧ ∀ e : G.E, p.edge_mem e

/-- p.is_maximal if the length of p is greater than or equal to the length of every other path. -/
def is_maximal : Prop := p.is_tour ∧ ∀ (q : path G), q.length ≤ p.length --should probably figure out some fintype stuff here lol

structure simple_cycle : Prop :=
(is_cycle : p.is_cycle)
(is_tour : p.is_tour)

lemma tour_is_trail : p.is_tour → p.is_trail :=
begin
  intro h,
  unfold is_trail,
  unfold is_tour at h,
  -- vertices are all pairwise ne
  -- edges are defined by their vertices `edge_of_adj`
  -- edges are equal iff endpoints are equal `edge_eq_iff'`
  sorry,
end

end path

end simple_graph