import tactic
import tactic.induction

noncomputable theory
open_locale classical

variable {α : Type*}

def get_max [inhabited α] [linear_order α] (P : α → Prop) :=
classical.epsilon (λ (x : α), P x ∧ ∀ (y : α), x < y → ¬P y)

lemma epsilon_eq [inhabited α] {P : α → Prop} {x : α}
  (h₁ : P x) (h₂ : ∀ (y : α), P y → y = x) : classical.epsilon P = x :=
begin
  have h₃ : P = (λ (y : α), y = x),
  { ext y, split; intro h₃,
    { exact h₂ y h₃ },
    { rwa h₃ }},
  subst h₃, apply classical.epsilon_singleton,
end

lemma nat_get_max_spec {P : ℕ → Prop}
  (h₁ : ∃ (x : ℕ), P x) (h₂ : ∃ (x : ℕ), ∀ (y : ℕ), x ≤ y → ¬P y) :
  P (get_max P) ∧ ∀ (x : ℕ), get_max P < x → ¬P x :=
begin
  cases h₁ with m h₁, cases h₂ with n h₂, induction n with n ih,
  { cases h₂ m (zero_le m) h₁ },
  { simp_rw nat.succ_le_iff at h₂, by_cases h₃ : P n,
    { have : get_max P = n,
      { rw get_max, apply epsilon_eq,
        { use h₃, rintro k hk, exact h₂ k hk, },
        { rintro k ⟨h₄, h₅⟩, by_contra h₆,
          rw [←ne, ne_iff_lt_or_gt] at h₆, cases h₆,
          { cases h₅ n h₆ h₃ }, { cases h₂ k h₆ h₄ }}},
      rw this at *, clear this, exact ⟨h₃, h₂⟩ },
    { apply ih, rintro k hk, rw le_iff_eq_or_lt at hk, rcases hk with rfl | hk,
      { exact h₃ },
      { exact h₂ k hk }}},
end

lemma list.take_join_of_lt {l : list (list α)} {n : ℕ}
  (h : n < l.join.length) :
  ∃ (m k : ℕ) hh, k < (l.nth_le m hh).length ∧
  l.join.take n = (l.take m).join ++ (l.nth_le m hh).take k :=
begin
  generalize hX : l.length = X, symmetry' at hX,
  generalize hN : l.join.length = N, symmetry' at hN,
  rw ←hN at h, have hl : l ≠ [],
  { rintro rfl, rw hN at h, cases h },
  generalize hP : (λ (m : ℕ), (l.take m).join.length ≤ n) = P, symmetry' at hP,
  generalize hm : get_max P = m, symmetry' at hm,
  generalize hk : n - (l.take m).join.length = k, symmetry' at hk,
  have hP0 : P 0, { rw hP, simp },
  have hPX : ∀ (r : ℕ), X ≤ r → ¬P r,
  { rintro r hr, rw hP, push_neg, convert h, rw hX at hr,
    rw [hN, list.take_all_of_le hr] },
  obtain ⟨hm₁, hm₂⟩ := nat_get_max_spec ⟨0, hP0⟩ ⟨X, hPX⟩, rw ←hm at hm₁ hm₂,
  have hm₃ : ¬P m.succ := hm₂ _ (nat.lt_succ_self m),
  refine ⟨m, k, _, _, _⟩,
  { rw ←hX, by_contra' hx, cases hPX m hx hm₁ },
  { generalize_proofs h₁, rw hP at hm₁ hm₃, push_neg at hm₃,
    by_contra' hk₁, obtain ⟨k, rfl⟩ := nat.exists_eq_add_of_le hk₁,
    replace hk := congr_arg (λ (x : ℕ), x + (l.take m).join.length) hk,
    dsimp at hk, rw nat.sub_add_cancel hm₁ at hk, rw ←hk at hm₃,
    contrapose! hm₃, rw [add_comm, ←add_assoc], convert le_self_add,
    simp [nat.succ_eq_add_one, list.take_add, list.join_append,
      list.length_append, list.take_one_drop_eq_of_lt_length h₁] },
  conv { to_lhs, rw [←list.take_append_drop m.succ l, list.join_append] },
  have hn₁ : (l.take m).join.length ≤ n, { rwa hP at hm₁ },
  have hn₂ : n < (l.take m.succ).join.length,
  { rw hP at hm₃, push_neg at hm₃, exact hm₃ },
  rw list.take_append_of_le_length (le_of_lt hn₂),
  change m.succ with m + 1, have hmX : m < X,
  { by_contra' hx, exact hPX m hx hm₁ },
  rw [list.take_add, list.join_append, list.take_one_drop_eq_of_lt_length,
    list.join_singleton], swap, { rwa ←hX },
  have : n = (list.take m l).join.length + k,
  { rw hk, exact (nat.add_sub_of_le hn₁).symm },
  subst this, rw list.take_append,
end

lemma list.take_join {l : list (list α)} {n : ℕ} (h : l ≠ []) :
  ∃ (m k : ℕ) hh, l.join.take n = (l.take m).join ++ (l.nth_le m hh).take k :=
begin
  by_cases h₁ : l.join.length ≤ n,
  { refine ⟨l.length - 1, (l.last h).length, _, _⟩,
    { apply nat.pred_lt, change ¬(l.length = 0), rwa list.length_eq_zero },
    { generalize_proofs hh, revert hh, intro hh,
      change l.length - 1 < l.length at hh,
      rw [list.take_all_of_le h₁, list.nth_le_length_sub_one hh],
      rw (_ : l.last h = (l.last h).take (l.last h).length), swap,
      { symmetry, apply list.take_all_of_le, refl },
      rw [list.take_length, ←list.join_drop_length_sub_one h, list.take_length,
        ←list.join_append, list.take_append_drop] }},
  { push_neg at h₁, obtain ⟨m, k, h₂, h₃, h₄⟩ := list.take_join_of_lt h₁,
    exact ⟨m, k, h₂, h₄⟩ },
end


/- Yul specification:
   https://docs.soliditylang.org/en/v0.8.9/yul.html
 -/

import data.fin.basic

def UInt256_max : ℕ := 2^256
def UInt256 := fin UInt256_max
def Literal := UInt256
def Identifier := string

lemma zero_lt_uint256_max : 0 < UInt256_max :=
  begin
    cases (nat.eq_zero_or_pos UInt256_max),
    exfalso,
    injection h,
  end

def literal_zero : Literal :=
  fin.mk 0 zero_lt_uint256_max

/-
  Types representing Expressions and Statements
  from the Yul specification. In contrast to the
  Yul specification, they are mutually recursive.
  This is to permit partial evaluated lexical scopes,
  so is needed to give a small step semantics for Yul.
-/

-- mutual inductive Expr, Statement
-- with Expr : Type
--   | FunctionCall : Identifier → list Expr → Expr
--   | Id : Identifier → Expr
--   | Lit : Literal → Expr
-- with Statement : Type
--   | Block : list Statement → Statement
--   | FunctionDefinition : Identifier → list Identifier → list Identifier → Statement → Statement
--   | VariableDeclaration : list Identifier → Expr → Statement
--   | Assignment : list Identifier → Expr → Statement
--   | If : Expr → list Statement → Statement
--   | ExpressionStatement : Expr -> Statement
--   | Switch : Expr → ((list (Literal × Statement)) × Statement) → Statement
--   | For : list Statement → Expr → list Statement → list Statement → Statement
--   | Break : Statement
--   | Continue : Statement
--   | Leave : Statement


/-
Copyright (c) 2015 Leonardo de Moura. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Leonardo de Moura

Set-like operations on lists
-/
import data.list.basic data.list.comb
open nat function decidable helper_tactics eq.ops

namespace list
section erase
variable {A : Type}
variable [H : decidable_eq A]
include H

definition erase (a : A) : list A → list A
| []     := []
| (b::l) :=
  match H a b with
  | inl e := l
  | inr n := b :: erase l
  end

lemma erase_nil (a : A) : erase a [] = [] :=
rfl

lemma erase_cons_head (a : A) (l : list A) : erase a (a :: l) = l :=
show match H a a with | inl e := l | inr n := a :: erase a l end = l,
by rewrite (@decidable_eq_inl_refl A H)

lemma erase_cons_tail {a b : A} (l : list A) : a ≠ b → erase a (b::l) = b :: erase a l :=
assume h : a ≠ b,
show match H a b with | inl e := l | inr n₁ := b :: erase a l end = b :: erase a l,
by rewrite (decidable_eq_inr_neg h)

lemma length_erase_of_mem {a : A} : ∀ {l}, a ∈ l → length (erase a l) = pred (length l)
| []         h := rfl
| [x]        h := by rewrite [mem_singleton h, erase_cons_head]
| (x::y::xs) h :=
  by_cases
   (suppose a = x, by rewrite [this, erase_cons_head])
   (suppose a ≠ x,
    have ainyxs : a ∈ y::xs, from or_resolve_right h this,
    by rewrite [erase_cons_tail _ this, *length_cons, length_erase_of_mem ainyxs])

lemma length_erase_of_not_mem {a : A} : ∀ {l}, a ∉ l → length (erase a l) = length l
| []      h   := rfl
| (x::xs) h   :=
  have anex   : a ≠ x,  from λ aeqx  : a = x,  absurd (or.inl aeqx) h,
  have aninxs : a ∉ xs, from λ ainxs : a ∈ xs, absurd (or.inr ainxs) h,
  by rewrite [erase_cons_tail _ anex, length_cons, length_erase_of_not_mem aninxs]

lemma erase_append_left {a : A} : ∀ {l₁} (l₂), a ∈ l₁ → erase a (l₁++l₂) = erase a l₁ ++ l₂
| []      l₂  h := absurd h !not_mem_nil
| (x::xs) l₂  h :=
  by_cases
   (λ aeqx : a = x, by rewrite [aeqx, append_cons, *erase_cons_head])
   (λ anex : a ≠ x,
    have ainxs : a ∈ xs, from mem_of_ne_of_mem anex h,
    by rewrite [append_cons, *erase_cons_tail _ anex, erase_append_left l₂ ainxs])

lemma erase_append_right {a : A} : ∀ {l₁} (l₂), a ∉ l₁ → erase a (l₁++l₂) = l₁ ++ erase a l₂
| []      l₂ h := rfl
| (x::xs) l₂ h :=
  by_cases
   (λ aeqx : a = x, by rewrite aeqx at h; exact (absurd !mem_cons h))
   (λ anex : a ≠ x,
    have nainxs : a ∉ xs, from not_mem_of_not_mem_cons h,
    by rewrite [append_cons, *erase_cons_tail _ anex, erase_append_right l₂ nainxs])

lemma erase_sub (a : A) : ∀ l, erase a l ⊆ l
| []      := λ x xine, xine
| (x::xs) := λ y xine,
  by_cases
    (λ aeqx : a = x, by rewrite [aeqx at xine, erase_cons_head at xine]; exact (or.inr xine))
    (λ anex : a ≠ x,
      have yinxe : y ∈ x :: erase a xs, by rewrite [erase_cons_tail _ anex at xine]; exact xine,
      have subxs : erase a xs ⊆ xs, from erase_sub xs,
      by_cases
        (λ yeqx : y = x, by rewrite yeqx; apply mem_cons)
        (λ ynex : y ≠ x,
          have yine  : y ∈ erase a xs, from mem_of_ne_of_mem ynex yinxe,
          have yinxs : y ∈ xs, from subxs yine,
          or.inr yinxs))

theorem mem_erase_of_ne_of_mem {a b : A} : ∀ {l : list A}, a ≠ b → a ∈ l → a ∈ erase b l
| []     n  i := absurd i !not_mem_nil
| (c::l) n  i := by_cases
  (λ beqc : b = c,
   have ainl : a ∈ l, from or.elim (eq_or_mem_of_mem_cons i)
     (λ aeqc : a = c, absurd aeqc (beqc ▸ n))
     (λ ainl : a ∈ l, ainl),
   by rewrite [beqc, erase_cons_head]; exact ainl)
  (λ bnec : b ≠ c, by_cases
    (λ aeqc : a = c,
      have aux : a ∈ c :: erase b l, by rewrite [aeqc]; exact !mem_cons,
      by rewrite [erase_cons_tail _ bnec]; exact aux)
    (λ anec : a ≠ c,
      have ainl  : a ∈ l, from mem_of_ne_of_mem anec i,
      have ainel : a ∈ erase b l, from mem_erase_of_ne_of_mem n ainl,
      have aux : a ∈ c :: erase b l, from mem_cons_of_mem _ ainel,
      by rewrite [erase_cons_tail _ bnec]; exact aux)) --

theorem mem_of_mem_erase {a b : A} : ∀ {l}, a ∈ erase b l → a ∈ l
| []     i := absurd i !not_mem_nil
| (c::l) i := by_cases
  (λ beqc : b = c, by rewrite [beqc at i, erase_cons_head at i]; exact (mem_cons_of_mem _ i))
  (λ bnec : b ≠ c,
    have i₁ : a ∈ c :: erase b l, by rewrite [erase_cons_tail _ bnec at i]; exact i,
    or.elim (eq_or_mem_of_mem_cons i₁)
      (λ aeqc  : a = c, by rewrite [aeqc]; exact !mem_cons)
      (λ ainel : a ∈ erase b l,
        have ainl : a ∈ l, from mem_of_mem_erase ainel,
        mem_cons_of_mem _ ainl))

theorem all_erase_of_all {p : A → Prop} (a : A) : ∀ {l}, all l p → all (erase a l) p
| []     h := by rewrite [erase_nil]; exact h
| (b::l) h :=
  have h₁ : all l p, from all_of_all_cons h,
  have   h₂ : all (erase a l) p, from all_erase_of_all h₁,
  have   pb : p b, from of_all_cons h,
  have h₃ : all (b :: erase a l) p, from all_cons_of_all pb h₂,
  by_cases
    (λ aeqb : a = b, by rewrite [aeqb, erase_cons_head]; exact h₁)
    (λ aneb : a ≠ b, by rewrite [erase_cons_tail _ aneb]; exact h₃)
end erase

/- disjoint -/
section disjoint
variable {A : Type}

definition disjoint (l₁ l₂ : list A) : Prop := ∀ ⦃a⦄, (a ∈ l₁ → a ∈ l₂ → false)

lemma disjoint_left {l₁ l₂ : list A} : disjoint l₁ l₂ → ∀ {a}, a ∈ l₁ → a ∉ l₂ :=
λ d a, d a

lemma disjoint_right {l₁ l₂ : list A} : disjoint l₁ l₂ → ∀ {a}, a ∈ l₂ → a ∉ l₁ :=
λ d a i₂ i₁, d a i₁ i₂

lemma disjoint.comm {l₁ l₂ : list A} : disjoint l₁ l₂ → disjoint l₂ l₁ :=
λ d a i₂ i₁, d a i₁ i₂

lemma disjoint_of_disjoint_cons_left {a : A} {l₁ l₂} : disjoint (a::l₁) l₂ → disjoint l₁ l₂ :=
λ d x xinl₁, disjoint_left d (or.inr xinl₁)

lemma disjoint_of_disjoint_cons_right {a : A} {l₁ l₂} : disjoint l₁ (a::l₂) → disjoint l₁ l₂ :=
λ d, disjoint.comm (disjoint_of_disjoint_cons_left (disjoint.comm d))

lemma disjoint_nil_left (l : list A) : disjoint [] l :=
λ a ab, absurd ab !not_mem_nil

lemma disjoint_nil_right (l : list A) : disjoint l [] :=
disjoint.comm (disjoint_nil_left l)

lemma disjoint_cons_of_not_mem_of_disjoint {a : A} {l₁ l₂} : a ∉ l₂ → disjoint l₁ l₂ → disjoint (a::l₁) l₂ :=
λ nainl₂ d x (xinal₁ : x ∈ a::l₁),
  or.elim (eq_or_mem_of_mem_cons xinal₁)
    (λ xeqa  : x = a, xeqa⁻¹ ▸ nainl₂)
    (λ xinl₁ : x ∈ l₁, disjoint_left d xinl₁)

lemma disjoint_of_disjoint_append_left_left : ∀ {l₁ l₂ l : list A}, disjoint (l₁++l₂) l → disjoint l₁ l
| []      l₂ l d := disjoint_nil_left l
| (x::xs) l₂ l d :=
  have nxinl : x ∉ l, from disjoint_left d !mem_cons,
  have d₁    : disjoint (xs++l₂) l, from disjoint_of_disjoint_cons_left d,
  have d₂    : disjoint xs l, from disjoint_of_disjoint_append_left_left d₁,
  disjoint_cons_of_not_mem_of_disjoint nxinl d₂

lemma disjoint_of_disjoint_append_left_right : ∀ {l₁ l₂ l : list A}, disjoint (l₁++l₂) l → disjoint l₂ l
| []      l₂ l d := d
| (x::xs) l₂ l d :=
  have d₁  : disjoint (xs++l₂) l, from disjoint_of_disjoint_cons_left d,
  disjoint_of_disjoint_append_left_right d₁

lemma disjoint_of_disjoint_append_right_left : ∀ {l₁ l₂ l : list A}, disjoint l (l₁++l₂) → disjoint l l₁ :=
λ l₁ l₂ l d, disjoint.comm (disjoint_of_disjoint_append_left_left (disjoint.comm d))

lemma disjoint_of_disjoint_append_right_right : ∀ {l₁ l₂ l : list A}, disjoint l (l₁++l₂) → disjoint l l₂ :=
λ l₁ l₂ l d, disjoint.comm (disjoint_of_disjoint_append_left_right (disjoint.comm d))

end disjoint

/- no duplicates predicate -/

inductive nodup {A : Type} : list A → Prop :=
| ndnil  : nodup []
| ndcons : ∀ {a l}, a ∉ l → nodup l → nodup (a::l)

section nodup
open nodup
variables {A B : Type}

theorem nodup_nil : @nodup A [] :=
ndnil

theorem nodup_cons {a : A} {l : list A} : a ∉ l → nodup l → nodup (a::l)  :=
λ i n, ndcons i n

theorem nodup_singleton (a : A) : nodup [a] :=
nodup_cons !not_mem_nil nodup_nil

theorem nodup_of_nodup_cons : ∀ {a : A} {l : list A}, nodup (a::l) → nodup l
| a xs (ndcons i n) := n

theorem not_mem_of_nodup_cons : ∀ {a : A} {l : list A}, nodup (a::l) → a ∉ l
| a xs (ndcons i n) := i

theorem not_nodup_cons_of_mem {a : A} {l : list A} : a ∈ l → ¬ nodup (a :: l) :=
λ ainl d, absurd ainl (not_mem_of_nodup_cons d)

theorem not_nodup_cons_of_not_nodup {a : A} {l : list A} : ¬ nodup l → ¬ nodup (a :: l) :=
λ nd d, absurd (nodup_of_nodup_cons d) nd

theorem nodup_of_nodup_append_left : ∀ {l₁ l₂ : list A}, nodup (l₁++l₂) → nodup l₁
| []      l₂ n := nodup_nil
| (x::xs) l₂ n :=
  have ndxs     : nodup xs,   from nodup_of_nodup_append_left (nodup_of_nodup_cons n),
  have nxinxsl₂ : x ∉ xs++l₂, from not_mem_of_nodup_cons n,
  have nxinxs   : x ∉ xs,     from not_mem_of_not_mem_append_left nxinxsl₂,
  nodup_cons nxinxs ndxs

theorem nodup_of_nodup_append_right : ∀ {l₁ l₂ : list A}, nodup (l₁++l₂) → nodup l₂
| []      l₂ n := n
| (x::xs) l₂ n := nodup_of_nodup_append_right (nodup_of_nodup_cons n)

theorem disjoint_of_nodup_append : ∀ {l₁ l₂ : list A}, nodup (l₁++l₂) → disjoint l₁ l₂
| []      l₂  d := disjoint_nil_left l₂
| (x::xs) l₂  d :=
  have nodup (x::(xs++l₂)),    from d,
  have x ∉ xs++l₂,             from not_mem_of_nodup_cons this,
  have nxinl₂ : x ∉ l₂,        from not_mem_of_not_mem_append_right this,
  take a, suppose a ∈ x::xs,
    or.elim (eq_or_mem_of_mem_cons this)
      (suppose a = x, this⁻¹ ▸ nxinl₂)
      (suppose ainxs : a ∈ xs,
        have nodup (x::(xs++l₂)), from d,
        have nodup (xs++l₂),      from nodup_of_nodup_cons this,
        have disjoint xs l₂,      from disjoint_of_nodup_append this,
        disjoint_left this ainxs)

theorem nodup_append_of_nodup_of_nodup_of_disjoint : ∀ {l₁ l₂ : list A}, nodup l₁ → nodup l₂ → disjoint l₁ l₂ → nodup (l₁++l₂)
| []      l₂ d₁ d₂ dsj := by rewrite [append_nil_left]; exact d₂
| (x::xs) l₂ d₁ d₂ dsj :=
  have ndxs     : nodup xs,            from nodup_of_nodup_cons d₁,
  have disjoint xs l₂,                 from disjoint_of_disjoint_cons_left dsj,
  have ndxsl₂   : nodup (xs++l₂),      from nodup_append_of_nodup_of_nodup_of_disjoint ndxs d₂ this,
  have nxinxs   : x ∉ xs,              from not_mem_of_nodup_cons d₁,
  have x ∉ l₂,                         from disjoint_left dsj !mem_cons,
  have x ∉ xs++l₂,                     from not_mem_append nxinxs this,
  nodup_cons this ndxsl₂

theorem nodup_app_comm {l₁ l₂ : list A} (d : nodup (l₁++l₂)) : nodup (l₂++l₁) :=
have d₁  : nodup l₁,       from nodup_of_nodup_append_left d,
have d₂  : nodup l₂,       from nodup_of_nodup_append_right d,
have dsj : disjoint l₁ l₂, from disjoint_of_nodup_append d,
nodup_append_of_nodup_of_nodup_of_disjoint d₂ d₁ (disjoint.comm dsj)

theorem nodup_head {a : A} {l₁ l₂ : list A} (d : nodup (l₁++(a::l₂))) : nodup (a::(l₁++l₂)) :=
have d₁    : nodup (a::(l₂++l₁)), from nodup_app_comm d,
have d₂    : nodup (l₂++l₁),      from nodup_of_nodup_cons d₁,
have d₃    : nodup (l₁++l₂),      from nodup_app_comm d₂,
have nain  : a ∉ l₂++l₁,          from not_mem_of_nodup_cons d₁,
have nain₂ : a ∉ l₂,              from not_mem_of_not_mem_append_left nain,
have nain₁ : a ∉ l₁,              from not_mem_of_not_mem_append_right nain,
nodup_cons (not_mem_append nain₁ nain₂) d₃

theorem nodup_middle {a : A} {l₁ l₂ : list A} (d : nodup (a::(l₁++l₂))) : nodup (l₁++(a::l₂)) :=
have d₁    : nodup (l₁++l₂),      from nodup_of_nodup_cons d,
have nain  : a ∉ l₁++l₂,          from not_mem_of_nodup_cons d,
have disj  : disjoint l₁ l₂,      from disjoint_of_nodup_append d₁,
have d₂    : nodup l₁,            from nodup_of_nodup_append_left d₁,
have d₃    : nodup l₂,            from nodup_of_nodup_append_right d₁,
have nain₂ : a ∉ l₂,              from not_mem_of_not_mem_append_right nain,
have nain₁ : a ∉ l₁,              from not_mem_of_not_mem_append_left nain,
have d₄    : nodup (a::l₂),       from nodup_cons nain₂ d₃,
have disj₂ : disjoint l₁ (a::l₂), from disjoint.comm (disjoint_cons_of_not_mem_of_disjoint nain₁ (disjoint.comm disj)),
nodup_append_of_nodup_of_nodup_of_disjoint d₂ d₄ disj₂

theorem nodup_map {f : A → B} (inj : injective f) : ∀ {l : list A}, nodup l → nodup (map f l)
| []      n := begin rewrite [map_nil], apply nodup_nil end
| (x::xs) n :=
  have nxinxs : x ∉ xs,           from not_mem_of_nodup_cons n,
  have ndxs   : nodup xs,         from nodup_of_nodup_cons n,
  have ndmfxs : nodup (map f xs), from nodup_map ndxs,
  have nfxinm : f x ∉ map f xs,   from
    λ ab : f x ∈ map f xs,
      obtain (y : A) (yinxs : y ∈ xs) (fyfx : f y = f x), from exists_of_mem_map ab,
      have yeqx : y = x, from inj fyfx,
      by subst y; contradiction,
  nodup_cons nfxinm ndmfxs

theorem nodup_erase_of_nodup [decidable_eq A] (a : A) : ∀ {l}, nodup l → nodup (erase a l)
| []     n := nodup_nil
| (b::l) n := by_cases
  (λ aeqb : a = b, by rewrite [aeqb, erase_cons_head]; exact (nodup_of_nodup_cons n))
  (λ aneb : a ≠ b,
    have nbinl   : b ∉ l,                  from not_mem_of_nodup_cons n,
    have ndl     : nodup l,                from nodup_of_nodup_cons n,
    have ndeal   : nodup (erase a l),      from nodup_erase_of_nodup ndl,
    have nbineal : b ∉ erase a l,          from λ i, absurd (erase_sub _ _ i) nbinl,
    have aux   : nodup (b :: erase a l), from nodup_cons nbineal ndeal,
    by rewrite [erase_cons_tail _ aneb]; exact aux)

theorem mem_erase_of_nodup [decidable_eq A] (a : A) : ∀ {l}, nodup l → a ∉ erase a l
| []     n := !not_mem_nil
| (b::l) n :=
  have ndl     : nodup l,       from nodup_of_nodup_cons n,
  have naineal : a ∉ erase a l, from mem_erase_of_nodup ndl,
  have nbinl : b ∉ l,         from not_mem_of_nodup_cons n,
  by_cases
  (λ aeqb : a = b, by rewrite [aeqb, erase_cons_head]; exact nbinl)
  (λ aneb : a ≠ b,
    have aux : a ∉ b :: erase a l, from
      assume ainbeal : a ∈ b :: erase a l, or.elim (eq_or_mem_of_mem_cons ainbeal)
        (λ aeqb   : a = b, absurd aeqb aneb)
        (λ aineal : a ∈ erase a l, absurd aineal naineal),
    by rewrite [erase_cons_tail _ aneb]; exact aux)

definition erase_dup [decidable_eq A] : list A → list A
| []        :=  []
| (x :: xs) :=  if x ∈ xs then erase_dup xs else x :: erase_dup xs

theorem erase_dup_nil [decidable_eq A] : erase_dup [] = ([] : list A)

theorem erase_dup_cons_of_mem [decidable_eq A] {a : A} {l : list A} : a ∈ l → erase_dup (a::l) = erase_dup l :=
assume ainl, calc
  erase_dup (a::l) = if a ∈ l then erase_dup l else a :: erase_dup l : rfl
              ...  = erase_dup l                                     : if_pos ainl

theorem erase_dup_cons_of_not_mem [decidable_eq A] {a : A} {l : list A} : a ∉ l → erase_dup (a::l) = a :: erase_dup l :=
assume nainl, calc
  erase_dup (a::l) = if a ∈ l then erase_dup l else a :: erase_dup l : rfl
              ...  = a :: erase_dup l                                : if_neg nainl

theorem mem_erase_dup [decidable_eq A] {a : A} : ∀ {l}, a ∈ l → a ∈ erase_dup l
| []     h  := absurd h !not_mem_nil
| (b::l) h  := by_cases
  (λ binl  : b ∈ l, or.elim (eq_or_mem_of_mem_cons h)
    (λ aeqb : a = b, by rewrite [erase_dup_cons_of_mem binl, -aeqb at binl]; exact (mem_erase_dup binl))
    (λ ainl : a ∈ l, by rewrite [erase_dup_cons_of_mem binl]; exact (mem_erase_dup ainl)))
  (λ nbinl : b ∉ l, or.elim (eq_or_mem_of_mem_cons h)
    (λ aeqb : a = b, by rewrite [erase_dup_cons_of_not_mem nbinl, aeqb]; exact !mem_cons)
    (λ ainl : a ∈ l, by rewrite [erase_dup_cons_of_not_mem nbinl]; exact (or.inr (mem_erase_dup ainl))))

theorem mem_of_mem_erase_dup [decidable_eq A] {a : A} : ∀ {l}, a ∈ erase_dup l → a ∈ l
| []     h := by rewrite [erase_dup_nil at h]; exact h
| (b::l) h := by_cases
  (λ binl  : b ∈ l,
    have h₁ : a ∈ erase_dup l, by rewrite [erase_dup_cons_of_mem binl at h]; exact h,
    or.inr (mem_of_mem_erase_dup h₁))
  (λ nbinl : b ∉ l,
    have h₁ : a ∈ b :: erase_dup l, by rewrite [erase_dup_cons_of_not_mem nbinl at h]; exact h,
    or.elim (eq_or_mem_of_mem_cons h₁)
      (λ aeqb  : a = b, by rewrite aeqb; exact !mem_cons)
      (λ ainel : a ∈ erase_dup l, or.inr (mem_of_mem_erase_dup ainel)))

theorem erase_dup_sub [decidable_eq A] (l : list A) : erase_dup l ⊆ l :=
λ a i, mem_of_mem_erase_dup i

theorem sub_erase_dup [decidable_eq A] (l : list A) : l ⊆ erase_dup l :=
λ a i, mem_erase_dup i

theorem nodup_erase_dup [decidable_eq A] : ∀ l : list A, nodup (erase_dup l)
| []        := by rewrite erase_dup_nil; exact nodup_nil
| (a::l)    := by_cases
  (λ ainl  : a ∈ l, by rewrite [erase_dup_cons_of_mem ainl]; exact (nodup_erase_dup l))
  (λ nainl : a ∉ l,
    have r   : nodup (erase_dup l), from nodup_erase_dup l,
    have nin : a ∉ erase_dup l, from
      assume ab : a ∈ erase_dup l, absurd (mem_of_mem_erase_dup ab) nainl,
    by rewrite [erase_dup_cons_of_not_mem nainl]; exact (nodup_cons nin r))

theorem erase_dup_eq_of_nodup [decidable_eq A] : ∀ {l : list A}, nodup l → erase_dup l = l
| []     d := rfl
| (a::l) d :=
  have nainl : a ∉ l, from not_mem_of_nodup_cons d,
  have dl : nodup l,  from nodup_of_nodup_cons d,
  by rewrite [erase_dup_cons_of_not_mem nainl, erase_dup_eq_of_nodup dl]

definition decidable_nodup [instance] [decidable_eq A] : ∀ (l : list A), decidable (nodup l)
| []     := inl nodup_nil
| (a::l) :=
  match decidable_mem a l with
  | inl p := inr (not_nodup_cons_of_mem p)
  | inr n :=
    match decidable_nodup l with
    | inl nd := inl (nodup_cons n nd)
    | inr d  := inr (not_nodup_cons_of_not_nodup d)
    end
  end

theorem nodup_product : ∀ {l₁ : list A} {l₂ : list B}, nodup l₁ → nodup l₂ → nodup (product l₁ l₂)
| []      l₂ n₁ n₂ := nodup_nil
| (a::l₁) l₂ n₁ n₂ :=
  have nainl₁ : a ∉ l₁,                      from not_mem_of_nodup_cons n₁,
  have n₃    : nodup l₁,                     from nodup_of_nodup_cons n₁,
  have n₄    : nodup (product l₁ l₂),  from nodup_product n₃ n₂,
  have dgen  : ∀ l, nodup l → nodup (map (λ b, (a, b)) l)
    | []     h := nodup_nil
    | (x::l) h :=
      have dl   : nodup l,                      from nodup_of_nodup_cons h,
      have dm   : nodup (map (λ b, (a, b)) l),  from dgen l dl,
      have nxin : x ∉ l,                        from not_mem_of_nodup_cons h,
      have npin : (a, x) ∉ map (λ b, (a, b)) l, from
        assume pin, absurd (mem_of_mem_map_pair₁ pin) nxin,
      nodup_cons npin dm,
  have dm    : nodup (map (λ b, (a, b)) l₂), from dgen l₂ n₂,
  have dsj   : disjoint (map (λ b, (a, b)) l₂) (product l₁ l₂), from
    λ p, match p with
         | (a₁, b₁) :=
            λ (i₁ : (a₁, b₁) ∈ map (λ b, (a, b)) l₂) (i₂ : (a₁, b₁) ∈ product l₁ l₂),
              have a₁inl₁ : a₁ ∈ l₁, from mem_of_mem_product_left i₂,
              have a₁eqa : a₁ = a, from eq_of_mem_map_pair₁ i₁,
              absurd (a₁eqa ▸ a₁inl₁) nainl₁
         end,
  nodup_append_of_nodup_of_nodup_of_disjoint dm n₄ dsj

theorem nodup_filter (p : A → Prop) [decidable_pred p] : ∀ {l : list A}, nodup l → nodup (filter p l)
| []     nd := nodup_nil
| (a::l) nd :=
  have   nainl : a ∉ l,              from not_mem_of_nodup_cons nd,
  have   ndl   : nodup l,            from nodup_of_nodup_cons nd,
  have ndf   : nodup (filter p l), from nodup_filter ndl,
  have nainf : a ∉ filter p l,     from
    assume ainf, absurd (mem_of_mem_filter ainf) nainl,
  by_cases
    (λ pa  : p a, by rewrite [filter_cons_of_pos _ pa]; exact (nodup_cons nainf ndf))
    (λ npa : ¬ p a, by rewrite [filter_cons_of_neg _ npa]; exact ndf)

lemma dmap_nodup_of_dinj {p : A → Prop} [h : decidable_pred p] {f : Π a, p a → B} (Pdi : dinj p f):
    ∀ {l : list A}, nodup l → nodup (dmap p f l)
| []     := take P, nodup.ndnil
| (a::l) := take Pnodup,
              decidable.rec_on (h a)
                (λ Pa,
                  begin
                    rewrite [dmap_cons_of_pos Pa],
                    apply nodup_cons,
                    apply (not_mem_dmap_of_dinj_of_not_mem Pdi Pa),
                    exact not_mem_of_nodup_cons Pnodup,
                    exact dmap_nodup_of_dinj (nodup_of_nodup_cons Pnodup)
                  end)
                (λ nPa,
                  begin
                    rewrite [dmap_cons_of_neg nPa],
                    exact dmap_nodup_of_dinj (nodup_of_nodup_cons Pnodup)
                  end)

end nodup

/- upto -/
definition upto : nat → list nat
| 0     := []
| (n+1) := n :: upto n

theorem upto_nil  : upto 0 = nil

theorem upto_succ (n : nat) : upto (succ n) = n :: upto n

theorem length_upto : ∀ n, length (upto n) = n
| 0        := rfl
| (succ n) := by rewrite [upto_succ, length_cons, length_upto]

theorem upto_ne_nil_of_ne_zero {n : ℕ} (H : n ≠ 0) : upto n ≠ nil :=
suppose upto n = nil,
have upto n = upto 0, from upto_nil ▸ this,
have n = 0, from calc
     n = length (upto n) : length_upto
   ... = length (upto 0) : this
   ... = 0 : length_upto,
H this

theorem upto_less : ∀ n, all (upto n) (λ i, i < n)
| 0        := trivial
| (succ n) :=
   have alln : all (upto n) (λ i, i < n), from upto_less n,
   all_cons_of_all (lt.base n) (all_implies alln (λ x h, lt.step h))

theorem nodup_upto : ∀ n, nodup (upto n)
| 0     := nodup_nil
| (n+1) :=
  have d : nodup (upto n), from nodup_upto n,
  have n : n ∉ upto n, from
    assume i : n ∈ upto n, absurd (of_mem_of_all i (upto_less n)) (nat.lt_irrefl n),
  nodup_cons n d

theorem lt_of_mem_upto {n i : nat} : i ∈ upto n → i < n :=
assume i, of_mem_of_all i (upto_less n)

theorem mem_upto_succ_of_mem_upto {n i : nat} : i ∈ upto n → i ∈ upto (succ n) :=
assume i, mem_cons_of_mem _ i

theorem mem_upto_of_lt : ∀ {n i : nat}, i < n → i ∈ upto n
| 0        i h := absurd h !not_lt_zero
| (succ n) i h :=
begin
  cases h with m h',
  { rewrite upto_succ, apply mem_cons},
  { exact mem_upto_succ_of_mem_upto (mem_upto_of_lt h')}
end

lemma upto_step : ∀ {n : nat}, upto (succ n) = (map succ (upto n))++[0]
| 0        := rfl
| (succ n) := begin rewrite [upto_succ n, map_cons, append_cons, -upto_step] end

/- union -/
section union
variable {A : Type}
variable [H : decidable_eq A]
include H

definition union : list A → list A → list A
| []      l₂ := l₂
| (a::l₁) l₂ := if a ∈ l₂ then union l₁ l₂ else a :: union l₁ l₂

theorem nil_union (l : list A) : union [] l = l

theorem union_cons_of_mem {a : A} {l₂} : ∀ (l₁), a ∈ l₂ → union (a::l₁) l₂ = union l₁ l₂ :=
take l₁, assume ainl₂, calc
  union (a::l₁) l₂ = if a ∈ l₂ then union l₁ l₂ else a :: union l₁ l₂ : rfl
                  ...   = union l₁ l₂                                           : if_pos ainl₂

theorem union_cons_of_not_mem {a : A} {l₂} : ∀ (l₁), a ∉ l₂ → union (a::l₁) l₂ = a :: union l₁ l₂ :=
take l₁, assume nainl₂, calc
  union (a::l₁) l₂ = if a ∈ l₂ then union l₁ l₂ else a :: union l₁ l₂ : rfl
                  ...   = a :: union l₁ l₂                                      : if_neg nainl₂

theorem union_nil : ∀ (l : list A), union l [] = l
| []     := !nil_union
| (a::l) := by rewrite [union_cons_of_not_mem _ !not_mem_nil, union_nil]

theorem mem_or_mem_of_mem_union : ∀ {l₁ l₂} {a : A}, a ∈ union l₁ l₂ → a ∈ l₁ ∨ a ∈ l₂
| []      l₂ a ainl₂ := by rewrite nil_union at ainl₂; exact (or.inr (ainl₂))
| (b::l₁) l₂ a ainbl₁l₂ := by_cases
  (λ binl₂  : b ∈ l₂,
    have ainl₁l₂ : a ∈ union l₁ l₂, by rewrite [union_cons_of_mem l₁ binl₂ at ainbl₁l₂]; exact ainbl₁l₂,
    or.elim (mem_or_mem_of_mem_union ainl₁l₂)
      (λ ainl₁, or.inl (mem_cons_of_mem _ ainl₁))
      (λ ainl₂, or.inr ainl₂))
  (λ nbinl₂ : b ∉ l₂,
    have ainb_l₁l₂ : a ∈ b :: union l₁ l₂, by rewrite [union_cons_of_not_mem l₁ nbinl₂ at ainbl₁l₂]; exact ainbl₁l₂,
    or.elim (eq_or_mem_of_mem_cons ainb_l₁l₂)
      (λ aeqb, by rewrite aeqb; exact (or.inl !mem_cons))
      (λ ainl₁l₂,
        or.elim (mem_or_mem_of_mem_union ainl₁l₂)
          (λ ainl₁, or.inl (mem_cons_of_mem _ ainl₁))
          (λ ainl₂, or.inr ainl₂)))

theorem mem_union_right {a : A} : ∀ (l₁) {l₂}, a ∈ l₂ → a ∈ union l₁ l₂
| []      l₂  h := by rewrite nil_union; exact h
| (b::l₁) l₂  h := by_cases
  (λ binl₂ : b ∈ l₂, by rewrite [union_cons_of_mem _ binl₂]; exact (mem_union_right _ h))
  (λ nbinl₂ : b ∉ l₂, by rewrite [union_cons_of_not_mem _ nbinl₂]; exact (mem_cons_of_mem _ (mem_union_right _ h)))

theorem mem_union_left {a : A} : ∀ {l₁} (l₂), a ∈ l₁ → a ∈ union l₁ l₂
| []      l₂  h := absurd h !not_mem_nil
| (b::l₁) l₂  h := by_cases
  (λ binl₂  : b ∈ l₂, or.elim (eq_or_mem_of_mem_cons h)
    (λ aeqb  : a = b,
      by rewrite [union_cons_of_mem l₁ binl₂, -aeqb at binl₂]; exact (mem_union_right _ binl₂))
    (λ ainl₁ : a ∈ l₁,
      by rewrite [union_cons_of_mem l₁ binl₂]; exact (mem_union_left _ ainl₁)))
  (λ nbinl₂ : b ∉ l₂, or.elim (eq_or_mem_of_mem_cons h)
    (λ aeqb  : a = b,
      by rewrite [union_cons_of_not_mem l₁ nbinl₂, aeqb]; exact !mem_cons)
    (λ ainl₁ : a ∈ l₁,
      by rewrite [union_cons_of_not_mem l₁ nbinl₂]; exact (mem_cons_of_mem _ (mem_union_left _ ainl₁))))

theorem mem_union_cons (a : A) (l₁ : list A) (l₂ : list A) : a ∈ union (a::l₁) l₂ :=
by_cases
  (λ ainl₂  : a ∈ l₂, mem_union_right _ ainl₂)
  (λ nainl₂ : a ∉ l₂, by rewrite [union_cons_of_not_mem _ nainl₂]; exact !mem_cons)

theorem nodup_union_of_nodup_of_nodup : ∀ {l₁ l₂ : list A}, nodup l₁ → nodup l₂ → nodup (union l₁ l₂)
| []      l₂ n₁   nl₂ := by rewrite nil_union; exact nl₂
| (a::l₁) l₂ nal₁ nl₂ :=
  have nl₁   : nodup l₁, from nodup_of_nodup_cons nal₁,
  have nl₁l₂ : nodup (union l₁ l₂), from nodup_union_of_nodup_of_nodup nl₁ nl₂,
  by_cases
    (λ ainl₂  : a ∈ l₂,
       by rewrite [union_cons_of_mem l₁ ainl₂]; exact nl₁l₂)
    (λ nainl₂ : a ∉ l₂,
       have nainl₁ : a ∉ l₁, from not_mem_of_nodup_cons nal₁,
       have nainl₁l₂ : a ∉ union l₁ l₂, from
         assume ainl₁l₂ : a ∈ union l₁ l₂, or.elim (mem_or_mem_of_mem_union ainl₁l₂)
           (λ ainl₁, absurd ainl₁ nainl₁)
           (λ ainl₂, absurd ainl₂ nainl₂),
       by rewrite [union_cons_of_not_mem l₁ nainl₂]; exact (nodup_cons nainl₁l₂ nl₁l₂))

theorem union_eq_append : ∀ {l₁ l₂ : list A}, disjoint l₁ l₂ → union l₁ l₂ = append l₁ l₂
| []      l₂ d := rfl
| (a::l₁) l₂ d :=
  have nainl₂ : a ∉ l₂, from disjoint_left d !mem_cons,
  have d₁ : disjoint l₁ l₂, from disjoint_of_disjoint_cons_left d,
  by rewrite [union_cons_of_not_mem _ nainl₂, append_cons, union_eq_append d₁]

theorem all_union {p : A → Prop} : ∀ {l₁ l₂ : list A}, all l₁ p → all l₂ p → all (union l₁ l₂) p
| []      l₂ h₁ h₂ := h₂
| (a::l₁) l₂ h₁ h₂ :=
  have h₁'   : all l₁ p, from all_of_all_cons h₁,
  have pa    : p a, from of_all_cons h₁,
  have au  : all (union l₁ l₂) p, from all_union h₁' h₂,
  have au' : all (a :: union l₁ l₂) p, from all_cons_of_all pa au,
  by_cases
    (λ ainl₂  : a ∈ l₂, by rewrite [union_cons_of_mem _ ainl₂]; exact au)
    (λ nainl₂ : a ∉ l₂, by rewrite [union_cons_of_not_mem _ nainl₂]; exact au')

theorem all_of_all_union_left {p : A → Prop} : ∀ {l₁ l₂ : list A}, all (union l₁ l₂) p → all l₁ p
| []      l₂  h := trivial
| (a::l₁) l₂  h :=
  have ain : a ∈ union (a::l₁) l₂, from !mem_union_cons,
  have pa  : p a, from of_mem_of_all ain h,
  by_cases
  (λ ainl₂  : a ∈ l₂,
    have al₁l₂ : all (union l₁ l₂) p, by rewrite [union_cons_of_mem _ ainl₂ at h]; exact h,
    have al₁   : all l₁ p, from all_of_all_union_left al₁l₂,
    all_cons_of_all pa al₁)
  (λ nainl₂ : a ∉ l₂,
    have aal₁l₂ : all (a::union l₁ l₂) p, by rewrite [union_cons_of_not_mem _ nainl₂ at h]; exact h,
    have al₁l₂ : all (union l₁ l₂) p, from all_of_all_cons aal₁l₂,
    have al₁   : all l₁ p, from all_of_all_union_left al₁l₂,
    all_cons_of_all pa al₁)

theorem all_of_all_union_right {p : A → Prop} : ∀ {l₁ l₂ : list A}, all (union l₁ l₂) p → all l₂ p
| []      l₂ h := by rewrite [nil_union at h]; exact h
| (a::l₁) l₂ h := by_cases
  (λ ainl₂  : a ∈ l₂, by rewrite [union_cons_of_mem _ ainl₂ at h]; exact (all_of_all_union_right h))
  (λ nainl₂ : a ∉ l₂,
    have h₁ : all (a :: union l₁ l₂) p, by rewrite [union_cons_of_not_mem _ nainl₂ at h]; exact h,
    all_of_all_union_right (all_of_all_cons h₁))

variable {B : Type}
theorem foldl_union_of_disjoint (f : B → A → B) (b : B) {l₁ l₂ : list A} (d : disjoint l₁ l₂)
        : foldl f b (union l₁ l₂) = foldl f (foldl f b l₁) l₂ :=
by rewrite [union_eq_append d, foldl_append]

theorem foldr_union_of_dijoint  (f : A → B → B) (b : B) {l₁ l₂ : list A} (d : disjoint l₁ l₂)
        : foldr f b (union l₁ l₂) = foldr f (foldr f b l₂) l₁ :=
by rewrite [union_eq_append d, foldr_append]
end union

/- insert -/
section insert
variable {A : Type}
variable [H : decidable_eq A]
include H

definition insert (a : A) (l : list A) : list A :=
if a ∈ l then l else a::l

theorem insert_eq_of_mem {a : A} {l : list A} : a ∈ l → insert a l = l :=
assume ainl, if_pos ainl

theorem insert_eq_of_not_mem {a : A} {l : list A} : a ∉ l → insert a l = a::l :=
assume nainl, if_neg nainl

theorem mem_insert (a : A) (l : list A) : a ∈ insert a l :=
by_cases
  (λ ainl  : a ∈ l, by rewrite [insert_eq_of_mem ainl]; exact ainl)
  (λ nainl : a ∉ l, by rewrite [insert_eq_of_not_mem nainl]; exact !mem_cons)

theorem mem_insert_of_mem {a : A} (b : A) {l : list A} : a ∈ l → a ∈ insert b l :=
assume ainl, by_cases
  (λ binl  : b ∈ l, by rewrite [insert_eq_of_mem binl]; exact ainl)
  (λ nbinl : b ∉ l, by rewrite [insert_eq_of_not_mem nbinl]; exact (mem_cons_of_mem _ ainl))

theorem eq_or_mem_of_mem_insert {x a : A} {l : list A} (H : x ∈ insert a l) : x = a ∨ x ∈ l :=
decidable.by_cases
  (assume H3: a ∈ l, or.inr (insert_eq_of_mem H3 ▸ H))
  (assume H3: a ∉ l,
    have H4: x ∈ a :: l, from insert_eq_of_not_mem H3 ▸ H,
    iff.mp !mem_cons_iff H4)

theorem mem_insert_iff (x a : A) (l : list A) : x ∈ insert a l ↔ x = a ∨ x ∈ l :=
iff.intro
  (!eq_or_mem_of_mem_insert)
  (assume H, or.elim H
    (assume H' : x = a, H'⁻¹ ▸ !mem_insert)
    (assume H' : x ∈ l, !mem_insert_of_mem H'))

theorem nodup_insert (a : A) {l : list A} : nodup l → nodup (insert a l) :=
assume n, by_cases
  (λ ainl  : a ∈ l, by rewrite [insert_eq_of_mem ainl]; exact n)
  (λ nainl : a ∉ l, by rewrite [insert_eq_of_not_mem nainl]; exact (nodup_cons nainl n))

theorem length_insert_of_mem {a : A} {l : list A} : a ∈ l → length (insert a l) = length l :=
assume ainl, by rewrite [insert_eq_of_mem ainl]

theorem length_insert_of_not_mem {a : A} {l : list A} : a ∉ l → length (insert a l) = length l + 1 :=
assume nainl, by rewrite [insert_eq_of_not_mem nainl]

theorem all_insert_of_all {p : A → Prop} {a : A} {l} : p a → all l p → all (insert a l) p :=
assume h₁ h₂, by_cases
  (λ ainl  : a ∈ l, by rewrite [insert_eq_of_mem ainl]; exact h₂)
  (λ nainl : a ∉ l, by rewrite [insert_eq_of_not_mem nainl]; exact (all_cons_of_all h₁ h₂))
end insert

/- inter -/
section inter
variable {A : Type}
variable [H : decidable_eq A]
include H

definition inter : list A → list A → list A
| []      l₂ := []
| (a::l₁) l₂ := if a ∈ l₂ then a :: inter l₁ l₂ else inter l₁ l₂

theorem inter_nil (l : list A) : inter [] l = []

theorem inter_cons_of_mem {a : A} (l₁ : list A) {l₂} : a ∈ l₂ → inter (a::l₁) l₂ = a :: inter l₁ l₂ :=
assume i, if_pos i

theorem inter_cons_of_not_mem {a : A} (l₁ : list A) {l₂} : a ∉ l₂ → inter (a::l₁) l₂ = inter l₁ l₂ :=
assume i, if_neg i

theorem mem_of_mem_inter_left : ∀ {l₁ l₂} {a : A}, a ∈ inter l₁ l₂ → a ∈ l₁
| []      l₂ a i := absurd i !not_mem_nil
| (b::l₁) l₂ a i := by_cases
  (λ binl₂  : b ∈ l₂,
    have aux : a ∈ b :: inter l₁ l₂, by rewrite [inter_cons_of_mem _ binl₂ at i]; exact i,
    or.elim (eq_or_mem_of_mem_cons aux)
      (λ aeqb : a = b, by rewrite [aeqb]; exact !mem_cons)
      (λ aini, mem_cons_of_mem _ (mem_of_mem_inter_left aini)))
  (λ nbinl₂ : b ∉ l₂,
    have ainl₁ : a ∈ l₁, by rewrite [inter_cons_of_not_mem _ nbinl₂ at i]; exact (mem_of_mem_inter_left i),
    mem_cons_of_mem _ ainl₁)

theorem mem_of_mem_inter_right : ∀ {l₁ l₂} {a : A}, a ∈ inter l₁ l₂ → a ∈ l₂
| []      l₂ a i := absurd i !not_mem_nil
| (b::l₁) l₂ a i := by_cases
  (λ binl₂  : b ∈ l₂,
    have aux : a ∈ b :: inter l₁ l₂, by rewrite [inter_cons_of_mem _ binl₂ at i]; exact i,
    or.elim (eq_or_mem_of_mem_cons aux)
      (λ aeqb : a = b, by rewrite [aeqb]; exact binl₂)
      (λ aini : a ∈ inter l₁ l₂, mem_of_mem_inter_right aini))
  (λ nbinl₂ : b ∉ l₂,
    by rewrite [inter_cons_of_not_mem _ nbinl₂ at i]; exact (mem_of_mem_inter_right i))

theorem mem_inter_of_mem_of_mem : ∀ {l₁ l₂} {a : A}, a ∈ l₁ → a ∈ l₂ → a ∈ inter l₁ l₂
| []      l₂ a i₁ i₂ := absurd i₁ !not_mem_nil
| (b::l₁) l₂ a i₁ i₂ := by_cases
  (λ binl₂  : b ∈ l₂,
    or.elim (eq_or_mem_of_mem_cons i₁)
      (λ aeqb  : a = b,
        by rewrite [inter_cons_of_mem _ binl₂, aeqb]; exact !mem_cons)
     (λ ainl₁ : a ∈ l₁,
        by rewrite [inter_cons_of_mem _ binl₂];
           apply mem_cons_of_mem;
           exact (mem_inter_of_mem_of_mem ainl₁ i₂)))
  (λ nbinl₂ : b ∉ l₂,
    or.elim (eq_or_mem_of_mem_cons i₁)
     (λ aeqb  : a = b, absurd (aeqb ▸ i₂) nbinl₂)
     (λ ainl₁ : a ∈ l₁,
       by rewrite [inter_cons_of_not_mem _ nbinl₂]; exact (mem_inter_of_mem_of_mem ainl₁ i₂)))

theorem nodup_inter_of_nodup : ∀ {l₁ : list A} (l₂), nodup l₁ → nodup (inter l₁ l₂)
| []      l₂ d := nodup_nil
| (a::l₁) l₂ d :=
  have d₁     : nodup l₁,            from nodup_of_nodup_cons d,
  have d₂     : nodup (inter l₁ l₂), from nodup_inter_of_nodup _ d₁,
  have nainl₁ : a ∉ l₁,              from not_mem_of_nodup_cons d,
  have naini  : a ∉ inter l₁ l₂,     from λ i, absurd (mem_of_mem_inter_left i) nainl₁,
  by_cases
    (λ ainl₂  : a ∈ l₂, by rewrite [inter_cons_of_mem _ ainl₂]; exact (nodup_cons naini d₂))
    (λ nainl₂ : a ∉ l₂, by rewrite [inter_cons_of_not_mem _ nainl₂]; exact d₂)

theorem inter_eq_nil_of_disjoint : ∀ {l₁ l₂ : list A}, disjoint l₁ l₂ → inter l₁ l₂ = []
| []      l₂ d := rfl
| (a::l₁) l₂ d :=
  have aux_eq : inter l₁ l₂ = [], from inter_eq_nil_of_disjoint (disjoint_of_disjoint_cons_left d),
  have nainl₂ : a ∉ l₂,           from disjoint_left d !mem_cons,
  by rewrite [inter_cons_of_not_mem _ nainl₂, aux_eq]

theorem all_inter_of_all_left {p : A → Prop} : ∀ {l₁} (l₂), all l₁ p → all (inter l₁ l₂) p
| []      l₂ h := trivial
| (a::l₁) l₂ h :=
  have h₁ : all l₁ p,                 from all_of_all_cons h,
  have h₂ : all (inter l₁ l₂) p,      from all_inter_of_all_left _ h₁,
  have pa : p a,                      from of_all_cons h,
  have h₃ : all (a :: inter l₁ l₂) p, from all_cons_of_all pa h₂,
  by_cases
    (λ ainl₂  : a ∈ l₂, by rewrite [inter_cons_of_mem _ ainl₂]; exact h₃)
    (λ nainl₂ : a ∉ l₂, by rewrite [inter_cons_of_not_mem _ nainl₂]; exact h₂)

theorem all_inter_of_all_right {p : A → Prop} : ∀ (l₁) {l₂}, all l₂ p → all (inter l₁ l₂) p
| []      l₂ h := trivial
| (a::l₁) l₂ h :=
  have h₁ : all (inter l₁ l₂) p, from all_inter_of_all_right _ h,
  by_cases
    (λ ainl₂  : a ∈ l₂,
      have pa : p a,                      from of_mem_of_all ainl₂ h,
      have h₂ : all (a :: inter l₁ l₂) p, from all_cons_of_all pa h₁,
      by rewrite [inter_cons_of_mem _ ainl₂]; exact h₂)
    (λ nainl₂ : a ∉ l₂, by rewrite [inter_cons_of_not_mem _ nainl₂]; exact h₁)

end inter
end list


import week_8.ideas.Z1

/-

## The map `φ.Z1 : Z1 G M →+ Z1 G N`.

Let `G` be a group. Or a monoid.

`Z1` is not just the construction of the group of cocycles
associated to a `G`-module `M`. `Z1` is a functor, which
means that we well as sending G-modules to abelian groups,
it also sends morphisms of `G`-modules to morphisms of abelian groups
(a new definition) and satisfies some theorems (the axioms
for a functor).

This file essentially all takes place in the `distrib_mul_hom`
namespace, because we are building more interface for `φ : M →+[G] N`.
We access this interface via dot notation. For example
`φ.Z1` is the group homomorphism `Z1 G M → Z1 G N`. In fact
this is main definition of the file.

### Definition of `φ.Z1 : Z1 G M →+ Z1 G N`

In this file we define the following function:
Given as input `φ : M →+[G] N` a G-module homomorphism,
we define the ouput `φ.Z1`, a group homomorphism `Z1 G M → Z1 G N`.

This is a two step process: first we define the underlying function,
we then prove that it's a group homomorphism.

3) the proof that the construction sending `φ` to `φ.Z1` is
functorial, i.e. sends the identity `id : M →+[G] M` to the identity
and function composition to function composition.
-/

namespace distrib_mul_action_hom

-- The Z1 construction is functorial in the module `M`. Let's construct
-- the relevant function, showing that if `φ : M →+[G] N` then
-- composition induces an additive group homomorphism `Z1 G M → Z1 G N`.
-- Just like `H0` we first define the auxiliary bare function,
-- and then beef it up to an abelian group homomorphism.

variables {G M N : Type} [monoid G]
  [add_comm_group M] [distrib_mul_action G M]
  [add_comm_group N] [distrib_mul_action G N]

-- note to self: if I change to Z1.coe_fn then I get a weird error
def Z1_coe_fn (φ : M →+[G] N) (f : Z1 G M) : Z1 G N :=
⟨λ g, φ (f g), begin
  -- need to prove that this function obtained by composing the cocycle
  -- f with the G-module homomorphism φ is also a cocycle.
  simp [←φ.map_smul, -map_smul, f.spec]
end⟩

@[norm_cast]
lemma Z1_coe_fn_coe_comp (φ : M →+[G] N) (f : Z1 G M) (g : G) :
  (Z1_coe_fn φ f g : N) = φ (f g) := rfl

def Z1 (φ : M →+[G] N) : Z1 G M →+ Z1 G N :=
-- to make a term of type `X →+ Y` (a group homomorphism) from a function
-- `f : X → Y` and
-- a proof that it preserves addition we use the following constructor:
add_monoid_hom.mk'
-- We now throw in the bare function
(Z1_coe_fn φ)
-- (or could try direct definition:)
-- (λ f, ⟨λ g, φ (f g), begin
--   -- need to prove that this function obtained by composing the cocycle
--   -- f with the G-module homomorphism φ is also a cocycle.
--   intros g h,
--   rw ←φ.map_smul,
--   rw f.spec,
--   simp,
-- end⟩)
-- and now the proof that it preserves addition
begin
  intros e f,
  ext g,
  simp [φ.Z1_coe_fn_coe_comp],
end

-- it's a functor
variables {P : Type} [add_comm_group P] [distrib_mul_action G P]

def map_comp (φ: M →+[G] N) (ψ : N →+[G] P) (z : _root_.Z1 G M) :
  (ψ.Z1) ((φ.Z1) z) = (ψ.comp φ).Z1 z :=
begin
  refl,
end

@[simp] lemma Z1_spec (φ : M →+[G] N) (a : _root_.Z1 G M) (g : G) :
  φ.Z1 a g = φ (a g) := rfl

@[simp] lemma Z1_spec' (φ : M →+[G] N) (a : _root_.Z1 G M) (g : G) :
  (φ.Z1 a : G → N) = (φ ∘ a) := rfl
end distrib_mul_action_hom


/-
Copyright (c) 2014 Microsoft Corporation. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Leonardo de Moura, Jeremy Avigad, Haitao Zhang
-/
import Mathlib.Mathport.Rename
-- a port of core Lean `init/function.lean`

/-!
# General operations on functions
-/

namespace Function

variable {α : Sort u₁} {β : Sort u₂} {φ : Sort u₃} {δ : Sort u₄} {ζ : Sort u₁}

@[reducible] def comp_right (f : β → β → β) (g : α → β) : β → α → β :=
λ b a => f b (g a)

@[reducible] def comp_left (f : β → β → β) (g : α → β) : α → β → β :=
λ a b => f (g a) b

/-- Given functions `f : β → β → φ` and `g : α → β`, produce a function `α → α → φ` that evaluates
`g` on each argument, then applies `f` to the results. Can be used, e.g., to transfer a relation
from `β` to `α`. -/
@[reducible] def onFun (f : β → β → φ) (g : α → β) : α → α → φ :=
λ x y => f (g x) (g y)

/-- Given functions `f : α → β → φ`, `g : α → β → δ` and a binary operator `op : φ → δ → ζ`,
produce a function `α → β → ζ` that applies `f` and `g` on each argument and then applies
`op` to the results.
-/
@[reducible] def combine (f : α → β → φ) (op : φ → δ → ζ) (g : α → β → δ)
  : α → β → ζ :=
λ x y => op (f x y) (g x y)

@[reducible] def swap {φ : α → β → Sort u₃} (f : ∀ x y, φ x y) : ∀ y x, φ x y :=
λ y x => f x y

@[reducible] def app {β : α → Sort u₂} (f : ∀ x, β x) (x : α) : β x :=
f x

@[inherit_doc onFun]
infixl:2 " on " => onFun

theorem right_id (f : α → β) : f ∘ id = f := rfl

#align function.comp_app Function.comp_apply

theorem comp.assoc (f : φ → δ) (g : β → φ) (h : α → β) : (f ∘ g) ∘ h = f ∘ (g ∘ h) := rfl

@[simp] theorem comp.left_id (f : α → β) : id ∘ f = f := rfl

@[simp] theorem comp.right_id (f : α → β) : f ∘ id = f := rfl

theorem comp_const_right (f : β → φ) (b : β) : f ∘ (const α b) = const α (f b) := rfl

/-- A function `f : α → β` is called injective if `f x = f y` implies `x = y`. -/
def Injective (f : α → β) : Prop := ∀ ⦃a₁ a₂⦄, f a₁ = f a₂ → a₁ = a₂

theorem Injective.comp {g : β → φ} {f : α → β} (hg : Injective g) (hf : Injective f) :
  Injective (g ∘ f) :=
fun _ _ h ↦ hf (hg h)

/-- A function `f : α → β` is called surjective if every `b : β` is equal to `f a`
for some `a : α`. -/
@[reducible] def Surjective (f : α → β) : Prop := ∀ b, ∃ a, f a = b

theorem Surjective.comp {g : β → φ} {f : α → β} (hg : Surjective g) (hf : Surjective f) :
  Surjective (g ∘ f) :=
λ (c : φ) => Exists.elim (hg c) (λ b hb => Exists.elim (hf b) (λ a ha =>
  Exists.intro a (show g (f a) = c from (Eq.trans (congrArg g ha) hb))))

/-- A function is called bijective if it is both injective and surjective. -/
def Bijective (f : α → β) := Injective f ∧ Surjective f

theorem Bijective.comp {g : β → φ} {f : α → β} : Bijective g → Bijective f → Bijective (g ∘ f)
| ⟨h_ginj, h_gsurj⟩, ⟨h_finj, h_fsurj⟩ => ⟨h_ginj.comp h_finj, h_gsurj.comp h_fsurj⟩

/-- `LeftInverse g f` means that g is a left inverse to f. That is, `g ∘ f = id`. -/
def LeftInverse (g : β → α) (f : α → β) : Prop := ∀ x, g (f x) = x

/-- `HasLeftInverse f` means that `f` has an unspecified left inverse. -/
def HasLeftInverse (f : α → β) : Prop := ∃ finv : β → α, LeftInverse finv f
#align function.has_left_inverse Function.HasLeftInverse

/-- `RightInverse g f` means that g is a right inverse to f. That is, `f ∘ g = id`. -/
def RightInverse (g : β → α) (f : α → β) : Prop := LeftInverse f g

/-- `hasRightInverse f` means that `f` has an unspecified right inverse. -/
def HasRightInverse (f : α → β) : Prop := ∃ finv : β → α, RightInverse finv f
#align function.has_right_inverse Function.HasRightInverse

theorem LeftInverse.injective {g : β → α} {f : α → β} : LeftInverse g f → Injective f :=
λ h a b hf => h a ▸ h b ▸ hf ▸ rfl

theorem HasLeftInverse.injective {f : α → β} : HasLeftInverse f → Injective f :=
λ h => Exists.elim h (λ _ inv => inv.injective)

theorem rightInverse_of_injective_of_leftInverse {f : α → β} {g : β → α}
    (injf : Injective f) (lfg : LeftInverse f g) :
  RightInverse f g :=
λ x => injf $ lfg $ f x
#align function.right_inverse_of_injective_of_left_inverse Function.rightInverse_of_injective_of_leftInverse

theorem RightInverse.surjective {f : α → β} {g : β → α} (h : RightInverse g f) : Surjective f :=
λ y => ⟨g y, h y⟩

theorem HasRightInverse.surjective {f : α → β} : HasRightInverse f → Surjective f
| ⟨_, inv⟩ => inv.surjective

theorem leftInverse_of_surjective_of_rightInverse {f : α → β} {g : β → α} (surjf : Surjective f)
  (rfg : RightInverse f g) : LeftInverse f g :=
λ y =>
  let ⟨x, hx⟩ := surjf y
  by rw [← hx, rfg]
#align function.left_inverse_of_surjective_of_right_inverse Function.leftInverse_of_surjective_of_rightInverse

theorem injective_id : Injective (@id α) := fun _ _ ↦ id

theorem surjective_id : Surjective (@id α) := λ a => ⟨a, rfl⟩

theorem bijective_id : Bijective (@id α) := ⟨injective_id, surjective_id⟩

end Function

namespace Function

variable {α : Type u₁} {β : Type u₂} {φ : Type u₃}

/-- Interpret a function on `α × β` as a function with two arguments. -/
@[inline] def curry : (α × β → φ) → α → β → φ :=
λ f a b => f (a, b)

/-- Interpret a function with two arguments as a function on `α × β` -/
@[inline] def uncurry : (α → β → φ) → α × β → φ :=
λ f a => f a.1 a.2

@[simp] theorem curry_uncurry (f : α → β → φ) : curry (uncurry f) = f :=
rfl

@[simp] theorem uncurry_curry (f : α × β → φ) : uncurry (curry f) = f :=
funext (λ ⟨_, _⟩ => rfl)

protected theorem LeftInverse.id {g : β → α} {f : α → β} (h : LeftInverse g f) : g ∘ f = id :=
funext h

protected theorem RightInverse.id {g : β → α} {f : α → β} (h : RightInverse g f) : f ∘ g = id :=
funext h

end Function


/-
Copyright (c) 2018 Robert Y. Lewis. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Robert Y. Lewis
-/
import data.polynomial.algebra_map
import data.polynomial.div
import topology.metric_space.cau_seq_filter

/-!
# Polynomials and limits

In this file we prove the following lemmas.

* `polynomial.continuous_eval₂: `polynomial.eval₂` defines a continuous function.
* `polynomial.continuous_aeval: `polynomial.aeval` defines a continuous function;
  we also prove convenience lemmas `polynomial.continuous_at_aeval`,
  `polynomial.continuous_within_at_aeval`, `polynomial.continuous_on_aeval`.
* `polynomial.continuous`:  `polynomial.eval` defines a continuous functions;
  we also prove convenience lemmas `polynomial.continuous_at`, `polynomial.continuous_within_at`,
  `polynomial.continuous_on`.
* `polynomial.tendsto_norm_at_top`: `λ x, ∥polynomial.eval (z x) p∥` tends to infinity provided that
  `λ x, ∥z x∥` tends to infinity and `0 < degree p`;
* `polynomial.tendsto_abv_eval₂_at_top`, `polynomial.tendsto_abv_at_top`,
  `polynomial.tendsto_abv_aeval_at_top`: a few versions of the previous statement for
  `is_absolute_value abv` instead of norm.

## Tags

polynomial, continuity
-/

open is_absolute_value filter

namespace polynomial

section topological_semiring

variables {R S : Type*} [semiring R] [topological_space R] [topological_semiring R]
  (p : polynomial R)

@[continuity]
protected lemma continuous_eval₂ [semiring S] (p : polynomial S) (f : S →+* R) :
  continuous (λ x, p.eval₂ f x) :=
begin
  dsimp only [eval₂_eq_sum, finsupp.sum],
  exact continuous_finset_sum _ (λ c hc, continuous_const.mul (continuous_pow _))
end

@[continuity]
protected lemma continuous : continuous (λ x, p.eval x) :=
p.continuous_eval₂ _

protected lemma continuous_at {a : R} : continuous_at (λ x, p.eval x) a :=
p.continuous.continuous_at

protected lemma continuous_within_at {s a} : continuous_within_at (λ x, p.eval x) s a :=
p.continuous.continuous_within_at

protected lemma continuous_on {s} : continuous_on (λ x, p.eval x) s :=
p.continuous.continuous_on

end topological_semiring

section topological_algebra

variables {R A : Type*} [comm_semiring R] [semiring A] [algebra R A]
  [topological_space A] [topological_semiring A]
  (p : polynomial R)

@[continuity]
protected lemma continuous_aeval : continuous (λ x : A, aeval x p) :=
p.continuous_eval₂ _

protected lemma continuous_at_aeval {a : A} : continuous_at (λ x : A, aeval x p) a :=
p.continuous_aeval.continuous_at

protected lemma continuous_within_at_aeval {s a} : continuous_within_at (λ x : A, aeval x p) s a :=
p.continuous_aeval.continuous_within_at

protected lemma continuous_on_aeval {s} : continuous_on (λ x : A, aeval x p) s :=
p.continuous_aeval.continuous_on

end topological_algebra

lemma tendsto_abv_eval₂_at_top {R S k α : Type*} [semiring R] [ring S] [linear_ordered_field k]
  (f : R →+* S) (abv : S → k) [is_absolute_value abv] (p : polynomial R) (hd : 0 < degree p)
  (hf : f p.leading_coeff ≠ 0) {l : filter α} {z : α → S} (hz : tendsto (abv ∘ z) l at_top) :
  tendsto (λ x, abv (p.eval₂ f (z x))) l at_top :=
begin
  revert hf, refine degree_pos_induction_on p hd _ _ _; clear hd p,
  { rintros c - hc,
    rw [leading_coeff_mul_X, leading_coeff_C] at hc,
    simpa [abv_mul abv] using hz.const_mul_at_top ((abv_pos abv).2 hc) },
  { intros p hpd ihp hf,
    rw [leading_coeff_mul_X] at hf,
    simpa [abv_mul abv] using  (ihp hf).at_top_mul_at_top hz },
  { intros p a hd ihp hf,
    rw [add_comm, leading_coeff_add_of_degree_lt (degree_C_le.trans_lt hd)] at hf,
    refine tendsto_at_top_of_add_const_right (abv (-f a)) _,
    refine tendsto_at_top_mono (λ _, abv_add abv _ _) _,
    simpa using ihp hf }
end

lemma tendsto_abv_at_top {R k α : Type*} [ring R] [linear_ordered_field k]
  (abv : R → k) [is_absolute_value abv] (p : polynomial R) (h : 0 < degree p)
  {l : filter α} {z : α → R} (hz : tendsto (abv ∘ z) l at_top) :
  tendsto (λ x, abv (p.eval (z x))) l at_top :=
tendsto_abv_eval₂_at_top _ _ _ h (mt leading_coeff_eq_zero.1 $ ne_zero_of_degree_gt h) hz

lemma tendsto_abv_aeval_at_top {R A k α : Type*} [comm_semiring R] [ring A] [algebra R A]
  [linear_ordered_field k] (abv : A → k) [is_absolute_value abv] (p : polynomial R)
  (hd : 0 < degree p) (h₀ : algebra_map R A p.leading_coeff ≠ 0)
  {l : filter α} {z : α → A} (hz : tendsto (abv ∘ z) l at_top) :
  tendsto (λ x, abv (aeval (z x) p)) l at_top :=
tendsto_abv_eval₂_at_top _ abv p hd h₀ hz

variables {α R : Type*} [normed_ring R] [is_absolute_value (norm : R → ℝ)]

lemma tendsto_norm_at_top (p : polynomial R) (h : 0 < degree p) {l : filter α} {z : α → R}
  (hz : tendsto (λ x, ∥z x∥) l at_top) :
  tendsto (λ x, ∥p.eval (z x)∥) l at_top :=
p.tendsto_abv_at_top norm h hz

lemma exists_forall_norm_le [proper_space R] (p : polynomial R) :
  ∃ x, ∀ y, ∥p.eval x∥ ≤ ∥p.eval y∥ :=
if hp0 : 0 < degree p
then p.continuous.norm.exists_forall_le $ p.tendsto_norm_at_top hp0 tendsto_norm_cocompact_at_top
else ⟨p.coeff 0, by rw [eq_C_of_degree_le_zero (le_of_not_gt hp0)]; simp⟩

end polynomial


/-
Copyright (c) 2022 Daniel Roca González. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Daniel Roca González
-/
import analysis.inner_product_space.projection
import analysis.inner_product_space.dual
import analysis.normed_space.banach
import analysis.normed_space.operator_norm
import topology.metric_space.antilipschitz

/-!
# The Lax-Milgram Theorem

We consider an Hilbert space `V` over `ℝ`
equipped with a bounded bilinear form `B : V →L[ℝ] V →L[ℝ] ℝ`.

Recall that a bilinear form `B : V →L[ℝ] V →L[ℝ] ℝ` is *coercive*
iff `∃ C, (0 < C) ∧ ∀ u, C * ∥u∥ * ∥u∥ ≤ B u u`.
Under the hypothesis that `B` is coercive
we prove the Lax-Milgram theorem:
that is, the map `inner_product_space.continuous_linear_map_of_bilin` from
`analysis.inner_product_space.dual` can be upgraded to a continuous equivalence
`is_coercive.continuous_linear_equiv_of_bilin : V ≃L[ℝ] V`.

## References

* We follow the notes of Peter Howard's Spring 2020 *M612: Partial Differential Equations* lecture,
  see[howard]

## Tags

dual, Lax-Milgram
-/

noncomputable theory
open is_R_or_C linear_map continuous_linear_map inner_product_space
open_locale real_inner_product_space nnreal

universe u

namespace is_coercive
variables {V : Type u} [inner_product_space ℝ V] [complete_space V]
variables {B : V →L[ℝ] V →L[ℝ] ℝ}

local postfix `♯`:1025 := @continuous_linear_map_of_bilin ℝ V _ _ _

lemma bounded_below (coercive : is_coercive B) :
  ∃ C, 0 < C ∧ ∀ v, C * ∥v∥ ≤ ∥B♯ v∥ :=
begin
  rcases coercive with ⟨C, C_ge_0, coercivity⟩,
  refine ⟨C, C_ge_0, _⟩,
  intro v,
  by_cases h : 0 < ∥v∥,
  { refine (mul_le_mul_right h).mp _,
    exact calc C * ∥v∥ * ∥v∥
        ≤ B v v : coercivity v
    ... = ⟪B♯ v, v⟫_ℝ : by simp
    ... ≤ ∥B♯ v∥ * ∥v∥ : real_inner_le_norm (B♯ v) v, },
  { have : v = 0 := by simpa using h,
    simp [this], }
end

lemma antilipschitz (coercive : is_coercive B) :
  ∃ C : ℝ≥0, 0 < C ∧ antilipschitz_with C B♯ :=
begin
  rcases coercive.bounded_below with ⟨C, C_pos, below_bound⟩,
  refine ⟨(C⁻¹).to_nnreal, real.to_nnreal_pos.mpr (inv_pos.mpr C_pos), _⟩,
  refine linear_map.antilipschitz_of_bound B♯ _,
  simp_rw [real.coe_to_nnreal',
    max_eq_left_of_lt (inv_pos.mpr C_pos),
    ←inv_mul_le_iff (inv_pos.mpr C_pos)],
  simpa using below_bound,
end

lemma ker_eq_bot (coercive : is_coercive B) : B♯.ker = ⊥ :=
begin
  rw [←ker_coe, linear_map.ker_eq_bot],
  rcases coercive.antilipschitz with ⟨_, _, antilipschitz⟩,
  exact antilipschitz.injective,
end

lemma closed_range (coercive : is_coercive B) : is_closed (B♯.range : set V) :=
begin
  rcases  coercive.antilipschitz with ⟨_, _, antilipschitz⟩,
  exact antilipschitz.is_closed_range B♯.uniform_continuous,
end

lemma range_eq_top (coercive : is_coercive B) : B♯.range = ⊤ :=
begin
  haveI := coercive.closed_range.complete_space_coe,
  rw ← B♯.range.orthogonal_orthogonal,
  rw submodule.eq_top_iff',
  intros v w mem_w_orthogonal,
  rcases coercive with ⟨C, C_ge_0, coercivity⟩,
  have : C * ∥w∥ * ∥w∥ ≤ 0 :=
  calc C * ∥w∥ * ∥w∥
       ≤ B w w : coercivity w
  ...  = ⟪B♯ w, w⟫_ℝ : by simp
  ...  = 0 : mem_w_orthogonal _ ⟨w, rfl⟩,
  have : ∥w∥ * ∥w∥ ≤ 0 := by nlinarith,
  have h : ∥w∥ = 0 := by nlinarith [norm_nonneg w],
  have w_eq_zero : w = 0 := by simpa using h,
  simp [w_eq_zero],
end

/--
The Lax-Milgram equivalence of a coercive bounded bilinear operator:
for all `v : V`, `continuous_linear_equiv_of_bilin B v` is the unique element `V`
such that `⟪continuous_linear_equiv_of_bilin B v, w⟫ = B v w`.
The Lax-Milgram theorem states that this is a continuous equivalence.
-/
def continuous_linear_equiv_of_bilin (coercive : is_coercive B) : V ≃L[ℝ] V :=
continuous_linear_equiv.of_bijective
  B♯
  coercive.ker_eq_bot
  coercive.range_eq_top

@[simp]
lemma continuous_linear_equiv_of_bilin_apply (coercive : is_coercive B) (v w : V) :
  ⟪coercive.continuous_linear_equiv_of_bilin v, w⟫_ℝ = B v w :=
continuous_linear_map_of_bilin_apply ℝ B v w

lemma unique_continuous_linear_equiv_of_bilin (coercive : is_coercive B) {v f : V}
  (is_lax_milgram : (∀ w, ⟪f, w⟫_ℝ = B v w)) :
  f = coercive.continuous_linear_equiv_of_bilin v :=
unique_continuous_linear_map_of_bilin ℝ B is_lax_milgram

end is_coercive


import data.set.intervals
import analysis.mean_inequalities_pow

import for_mathlib.nnreal
import for_mathlib.Profinite.extend
import pseudo_normed_group.category
import condensed.ab

.

open_locale big_operators nnreal

universe u
variables (p : ℝ≥0) (S : Fintype.{u})

/-- The functor represented by ℤ, i.e., sending a finite type `S` to `S → ℤ`,
  equipped with the "p-norm" sending `s ↦ f(s)` to `∑ₛ∥f(s)∥₊ᵖ`. This is the
  construction defined as a bare function. -/
@[derive add_comm_group]
def normed_free_pfpng (p : ℝ≥0) (S : Fintype.{u}) := S → ℤ

noncomputable theory
open_locale classical

instance : has_nnnorm (normed_free_pfpng p S) :=
⟨λ f, ∑ s, ∥f s∥₊ ^ (p:ℝ)⟩

namespace normed_free_pfpng

protected lemma nnnorm_def (f : normed_free_pfpng p S) : ∥f∥₊ = ∑ s, ∥f s∥₊ ^ (p:ℝ) := rfl

@[simp] lemma nnnorm_zero [fact (0 < p)] : ∥(0 : normed_free_pfpng p S)∥₊ = 0 :=
by { change ∑ _, _ = _, simp only [pi.zero_apply, nnnorm_zero, finset.sum_const, nsmul_eq_mul, mul_eq_zero, nat.cast_eq_zero, finset.card_eq_zero,
  nnreal.rpow_eq_zero_iff, eq_self_iff_true, ne.def, nnreal.coe_eq_zero, true_and],
  right, have : 0 < p := fact.out _, exact this.ne' }

@[simp] lemma nnnorm_neg (f : normed_free_pfpng p S) : ∥(-f)∥₊ = ∥f∥₊ :=
by { change ∑ _, _ = _, simpa }

lemma nnnorm_add [fact (0 < p)] [fact (p ≤ 1)]
  (f₁ f₂ : normed_free_pfpng p S) : ∥f₁ + f₂∥₊ ≤ ∥f₁∥₊ + ∥f₂∥₊ :=
begin
  change ∑ _, _ ≤ ∑ _, _ + ∑ _, _,
  rw ← finset.sum_add_distrib,
  apply finset.sum_le_sum,
  intros s _,
  have h0p : 0 < p := fact.out _,
  have hp1 : p ≤ 1 := fact.out _,
  calc ∥(f₁ + f₂) s∥₊ ^ ↑p
      ≤ (∥f₁ s∥₊ + ∥f₂ s∥₊) ^ ↑p : nnreal.rpow_le_rpow (nnnorm_add_le _ _) h0p.le
  ... ≤ ∥f₁ s∥₊ ^ ↑p + ∥f₂ s∥₊ ^ ↑p : nnreal.rpow_add_le_add_rpow _ _ h0p hp1,
end

instance (c) : topological_space { f : normed_free_pfpng p S | ∥f∥₊ ≤ c } := ⊥
instance (c) : discrete_topology { f : normed_free_pfpng p S | ∥f∥₊ ≤ c } := ⟨rfl⟩

lemma norm_eval_le {c : nnreal} (s : S)
  (f : normed_free_pfpng p S) (hf : ∥f∥₊ ≤ c) : ∥f s∥₊ ^ (p:ℝ) ≤ c :=
le_trans (begin
  apply @finset.single_le_sum S nnreal _ (λ t, ∥f t∥₊ ^ (p:ℝ)) finset.univ,
  { intros _ _, apply zero_le },
  { exact finset.mem_univ s }
end) hf

instance [fact (0 < p)] (c) : fintype { f : normed_free_pfpng p S | ∥f∥₊ ≤ c } :=
begin
  let A := { f : normed_free_pfpng p S | ∥f∥₊ ≤ c },
  let N := ⌈c ^ (p⁻¹:ℝ)⌉₊,
  have hN := @nat.le_ceil ℝ≥0 _ _ (c ^ (p⁻¹:ℝ)),
  have h0p : 0 < p := fact.out _,
  have h0pinv : 0 ≤ p⁻¹, { rw ← nnreal.inv_pos at h0p, exact h0p.le },
  let ι : A → S → set.Icc (-(N : ℤ)) N :=
    λ a s, ⟨a.1 s, _⟩,
  swap,
  { have := (nnreal.rpow_le_rpow (norm_eval_le p S s a.val a.2) h0pinv).trans hN,
    rw [← nnreal.coe_le_coe, ← nnreal.rpow_mul, ← nnreal.coe_mul,
      mul_inv_cancel h0p.ne', nnreal.coe_one, nnreal.rpow_one, nnreal.coe_nat_cast] at this,
    split,
    { rw [← neg_le_neg_iff] at this,
      exact_mod_cast this.trans (neg_abs_le_self (a.val s)), },
    { exact_mod_cast (le_abs_self _).trans this, } },
  have : function.injective ι,
  { rintros ⟨f,hf⟩ ⟨g,hg⟩ h,
    ext s,
    apply_fun (λ e, (e s).1) at h,
    assumption },
  apply fintype.of_injective ι this,
end

variables [fact (0 < p)] [fact (p ≤ 1)]

instance : profinitely_filtered_pseudo_normed_group (normed_free_pfpng p S) :=
{ filtration := λ c, { f | ∥ f ∥₊ ≤ c },
  filtration_mono := λ c₁ c₂ h f hf, le_trans hf h,
  zero_mem_filtration := λ c, by simp,
  neg_mem_filtration := λ c f hf, by simpa,
  add_mem_filtration := λ c₁ c₂ f₁ f₂ h₁ h₂,
    le_trans (nnnorm_add _ _ _ _) (add_le_add h₁ h₂),
  continuous_add' := λ c₁ c₂,
    continuous_of_discrete_topology,
  continuous_neg' := λ c, continuous_of_discrete_topology,
  continuous_cast_le := λ _ _ _, continuous_of_discrete_topology,
  ..(infer_instance : add_comm_group (normed_free_pfpng p S)) }

def map {S₁ S₂ : Fintype.{u}} (g : S₁ ⟶ S₂) :
  strict_comphaus_filtered_pseudo_normed_group_hom
  (normed_free_pfpng p S₁) (normed_free_pfpng p S₂) :=
{ to_fun := λ f s, ∑ t in finset.univ.filter (λ w, g w = s), f t,
  map_zero' := by simpa,
  map_add' := λ f g, by simpa [finset.sum_add_distrib],
  strict' := begin
    have h0p : 0 < p := fact.out _,
    have hp1 : p ≤ 1 := fact.out _,
    intros c f hf,
    refine le_trans _ hf,
    simp only [normed_free_pfpng.nnnorm_def],
    have : ∑ s₂, ∥(∑ t in finset.univ.filter (λ w, g w = s₂), f t)∥₊ ^ (p:ℝ) ≤
      ∑ s₂ : S₂, ∑ t in finset.univ.filter (λ w, g w = s₂), ∥f t∥₊ ^ (p:ℝ),
    { apply finset.sum_le_sum,
      intros i _,
      refine le_trans _ (nnreal.rpow_sum_le_sum_rpow _ _ h0p hp1),
      refine nnreal.rpow_le_rpow _ h0p.le,
      apply nnnorm_sum_le },
    refine le_trans this _,
    rw ← finset.sum_bUnion,
    apply le_of_eq,
    apply finset.sum_congr,
    { rw finset.eq_univ_iff_forall,
      intros x,
      rw finset.mem_bUnion,
      use [g x, by simp] },
    { intros s₁ _, refl },
    { intros x _ y _ h,
      rintros a hh,
      apply h,
      simp only [finset.inf_eq_inter, finset.mem_inter, finset.mem_filter,
        finset.mem_univ, true_and] at hh,
      rw [← hh.1, ← hh.2] }
  end,
  continuous' := λ c, continuous_of_discrete_topology }

@[simp]
lemma map_id : map p (𝟙 S) =
  strict_comphaus_filtered_pseudo_normed_group_hom.id :=
begin
  ext s,
  dsimp [map],
  simp [finset.filter_congr_decidable, finset.sum_filter],
end

@[simp]
lemma map_comp {S₁ S₂ S₃ : Fintype.{u}}
  (g₁ : S₁ ⟶ S₂) (g₂ : S₂ ⟶ S₃) :
  map p (g₁ ≫ g₂) =
  (map p g₂).comp (map p g₁) :=
begin
  ext s₃,
  dsimp [map],
  erw ← finset.sum_bUnion,
  apply finset.sum_congr,
  { ext s,
    split,
    { intro h, simp only [finset.mem_filter, finset.mem_univ, true_and] at h,
      rw finset.mem_bUnion,
      use [g₁ s, by simpa] },
    { intro h, simp only [finset.mem_bUnion, finset.mem_filter,
      finset.mem_univ, true_and, exists_prop, exists_eq_right'] at h,
      simpa, } },
  { intros s₁ h,
    rw finset.mem_bUnion at h },
  { intros x hx y hy,
    simp only [finset.coe_filter, finset.coe_univ, set.sep_univ,
      set.mem_set_of_eq] at hx hy,
    intros h a ha,
    simp only [finset.inf_eq_inter, finset.mem_inter, finset.mem_filter,
      finset.mem_univ, true_and] at ha,
    apply h, rw [← ha.1, ← ha.2] }
end

end normed_free_pfpng

variables [fact (0 < p)] [fact (p ≤ 1)]

/-- The functor represented by ℤ, i.e., sending a finite type `S` to
  `normed_free_pfpng p S`, otherwise known as `S → ℤ`,
  equipped with the "p-norm" sending `s ↦ f(s)` to `∑ₛ∥f(s)∥₊ᵖ`. This norm
  makes `S → ℤ` into a `profinitely_filtered_pseudo_normed_group`. -/
@[simps]
def normed_free_pfpng_functor : Fintype ⥤ ProFiltPseuNormGrp₁ :=
{ obj := λ S,
  { M := normed_free_pfpng p S,
    exhaustive' := λ f, ⟨∥f∥₊, le_refl _⟩ },
  map := λ S₁ S₂ f, normed_free_pfpng.map p f,
  map_id' := λ S, normed_free_pfpng.map_id p S,
  map_comp' := λ _ _ _ g₁ g₂, normed_free_pfpng.map_comp p g₁ g₂ }

def Fintype.normed_free_pfpng (T : Fintype) : ProFiltPseuNormGrp₁ :=
(normed_free_pfpng_functor p).obj T

def Fintype.normed_free_pfpng_unit :
  Fintype.to_Profinite ⟶ normed_free_pfpng_functor p ⋙ ProFiltPseuNormGrp₁.level.obj 1 :=
{ app := λ S,
  { to_fun := λ s,
    { val := λ t, if s = t then 1 else 0,
      property := begin
        show finset.sum _ _ ≤ _,
        rw finset.sum_eq_single_of_mem,
        swap 4, { exact s }, swap 2, { apply finset.mem_univ },
        { dsimp, rw [if_pos rfl, nnnorm_one, nnreal.one_rpow], },
        rintro t - ht, dsimp, rw [if_neg ht.symm, nnnorm_zero, nnreal.zero_rpow],
        have h0p : 0 < p := fact.out _, exact_mod_cast h0p.ne',
      end },
    continuous_to_fun := continuous_bot },
  naturality' := λ S T f, begin
    ext s t,
    delta ProFiltPseuNormGrp₁.level,
    simp only [Fintype.to_Profinite_map_to_fun, Profinite.coe_comp, continuous_map.coe_mk,
      function.comp_app, subtype.coe_mk, category_theory.functor.comp_map, normed_free_pfpng_functor_map,
      pseudo_normed_group.level_coe, subtype.coe_mk, normed_free_pfpng.map, finset.mem_filter, true_and,
      finset.mem_univ, strict_comphaus_filtered_pseudo_normed_group_hom.coe_mk, finset.sum_ite_eq],
  end }

def Profinite.normed_free_pfpng (S : Profinite) : ProFiltPseuNormGrp₁ :=
(Profinite.extend $ normed_free_pfpng_functor p).obj S

open category_theory
open category_theory.limits

def Profinite.normed_free_pfpng_level_iso (S : Profinite.{u}) (r) :
  (ProFiltPseuNormGrp₁.level.obj r).obj (S.normed_free_pfpng p) ≅
  limits.limit (S.fintype_diagram ⋙ normed_free_pfpng_functor p ⋙ ProFiltPseuNormGrp₁.level.obj r) :=
(is_limit_of_preserves (ProFiltPseuNormGrp₁.level.obj r)
  (limit.is_limit _)).cone_point_unique_up_to_iso $ limit.is_limit _

def Profinite.to_normed_free_pfpng (S : Profinite.{u}) :
  S ⟶ (ProFiltPseuNormGrp₁.level.obj 1).obj (S.normed_free_pfpng p) :=
(limit.is_limit _).map S.as_limit_cone (whisker_left _ $ Fintype.normed_free_pfpng_unit.{u u} p) ≫
(S.normed_free_pfpng_level_iso p 1).inv

--(limits.is_limit_of_preserves (ProFiltPseuNormGrp₁.level.obj 1) (limits.limit.is_limit _)).map
--  S.as_limit_cone $ whisker_left _ (Fintype.normed_free_pfpng_unit) ≫ (functor.associator _ _ _).inv

def Profinite.normed_free_pfpng_π (S : Profinite) (T : discrete_quotient S) :
  S.normed_free_pfpng p ⟶ (Fintype.of T).normed_free_pfpng p :=
category_theory.limits.limit.π _ _

lemma Profinite.normed_free_pfpng_π_w (S : Profinite) {T₁ T₂ : discrete_quotient S} (f : T₁ ⟶ T₂) :
  Profinite.normed_free_pfpng_π p S T₁ ≫ (S.fintype_diagram ⋙ normed_free_pfpng_functor p).map f =
  Profinite.normed_free_pfpng_π p S T₂ :=
category_theory.limits.limit.w (S.fintype_diagram ⋙ normed_free_pfpng_functor p) _


/-
Copyright (c) 2018 Jeremy Avigad. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Jeremy Avigad, Mario Carneiro, Simon Hudon
-/
import data.fin2
import data.typevec
import logic.function.basic
import tactic.basic

/-!

Functors between the category of tuples of types, and the category Type

Features:

`mvfunctor n` : the type class of multivariate functors
`f <$$> x`    : notation for map

-/

universes u v w

open_locale mvfunctor

/-- multivariate functors, i.e. functor between the category of type vectors
and the category of Type -/
class mvfunctor {n : ℕ} (F : typevec n → Type*) :=
(map : Π {α β : typevec n}, (α ⟹ β) → (F α → F β))

localized "infixr ` <$$> `:100 := mvfunctor.map" in mvfunctor

variables {n : ℕ}

namespace mvfunctor

variables {α β γ : typevec.{u} n} {F : typevec.{u} n → Type v} [mvfunctor F]

/-- predicate lifting over multivariate functors -/
def liftp {α : typevec n} (p : Π i, α i → Prop) (x : F α) : Prop :=
∃ u : F (λ i, subtype (p i)), (λ i, @subtype.val _ (p i)) <$$> u = x

/-- relational lifting over multivariate functors -/
def liftr {α : typevec n} (r : Π {i}, α i → α i → Prop) (x y : F α) : Prop :=
∃ u : F (λ i, {p : α i × α i // r p.fst p.snd}),
  (λ i (t : {p : α i × α i // r p.fst p.snd}), t.val.fst) <$$> u = x ∧
  (λ i (t : {p : α i × α i // r p.fst p.snd}), t.val.snd) <$$> u = y

/-- given `x : F α` and a projection `i` of type vector `α`, `supp x i` is the set
of `α.i` contained in `x` -/
def supp {α : typevec n} (x : F α) (i : fin2 n) : set (α i) :=
{ y : α i | ∀ ⦃p⦄, liftp p x → p i y }

theorem of_mem_supp {α : typevec n} {x : F α} {p : Π ⦃i⦄, α i → Prop} (h : liftp p x) (i : fin2 n):
  ∀ y ∈ supp x i, p y :=
λ y hy, hy h

end mvfunctor

/-- laws for `mvfunctor` -/
class is_lawful_mvfunctor {n : ℕ} (F : typevec n → Type*) [mvfunctor F] : Prop :=
(id_map       : ∀ {α : typevec n} (x : F α), typevec.id <$$> x = x)
(comp_map     : ∀ {α β γ : typevec n} (g : α ⟹ β) (h : β ⟹ γ) (x : F α),
                    (h ⊚ g) <$$> x = h <$$> g <$$> x)

open nat typevec

namespace mvfunctor

export is_lawful_mvfunctor (comp_map)
open is_lawful_mvfunctor

variables {α β γ : typevec.{u} n}
variables {F : typevec.{u} n → Type v} [mvfunctor F]

variables (p : α ⟹ repeat n Prop) (r : α ⊗ α ⟹ repeat n Prop)

/-- adapt `mvfunctor.liftp` to accept predicates as arrows -/
def liftp' : F α → Prop :=
mvfunctor.liftp $ λ i x, of_repeat $ p i x

/-- adapt `mvfunctor.liftp` to accept relations as arrows -/
def liftr' : F α → F α → Prop :=
mvfunctor.liftr $ λ i x y, of_repeat $ r i $ typevec.prod.mk _ x y

variables [is_lawful_mvfunctor F]

@[simp]
lemma id_map (x : F α) :
  typevec.id <$$> x = x :=
id_map x

@[simp]
lemma id_map' (x : F α) :
  (λ i a, a) <$$> x = x :=
id_map x

lemma map_map (g : α ⟹ β) (h : β ⟹ γ) (x : F α) :
  h <$$> g <$$> x = (h ⊚ g) <$$> x :=
eq.symm $ comp_map _ _ _

section liftp'

variables (F)

lemma exists_iff_exists_of_mono {p : F α → Prop} {q : F β → Prop} (f : α ⟹ β) (g : β ⟹ α)
  (h₀ : f ⊚ g = id)
  (h₁ : ∀ u : F α, p u ↔ q (f <$$> u)) :
  (∃ u : F α, p u) ↔ (∃ u : F β, q u) :=
begin
  split; rintro ⟨u,h₂⟩; [ use f <$$> u, use g <$$> u ],
  { apply (h₁ u).mp h₂ },
  { apply (h₁ _).mpr _,
    simp only [mvfunctor.map_map,h₀,is_lawful_mvfunctor.id_map,h₂] },
end
variables {F}

lemma liftp_def (x : F α) : liftp' p x ↔ ∃ u : F (subtype_ p), subtype_val p <$$> u = x :=
exists_iff_exists_of_mono F _ _ (to_subtype_of_subtype p) (by simp [mvfunctor.map_map])

lemma liftr_def (x y : F α) :
  liftr' r x y ↔
  ∃ u : F (subtype_ r), (typevec.prod.fst ⊚ subtype_val r) <$$> u = x ∧
                        (typevec.prod.snd ⊚ subtype_val r) <$$> u = y :=
exists_iff_exists_of_mono _ _ _ (to_subtype'_of_subtype' r)
  (by simp only [map_map, comp_assoc, subtype_val_to_subtype']; simp [comp])

end liftp'

end mvfunctor

open nat

namespace mvfunctor

open typevec

section liftp_last_pred_iff
variables  {F : typevec.{u} (n+1) → Type*} [mvfunctor F] [is_lawful_mvfunctor F]
           {α : typevec.{u} n}
variables (p : α ⟹ repeat n Prop)
          (r : α ⊗ α ⟹ repeat n Prop)

open mvfunctor

variables {β : Type u}
variables (pp : β → Prop)

private def f : Π (n α), (λ (i : fin2 (n + 1)), {p_1 // of_repeat (pred_last' α pp i p_1)}) ⟹
    λ (i : fin2 (n + 1)), {p_1 : (α ::: β) i // pred_last α pp p_1}
| _ α (fin2.fs i) x := ⟨ x.val, cast (by simp only [pred_last]; erw const_iff_true) x.property ⟩
| _ α fin2.fz x := ⟨ x.val, x.property ⟩

private def g : Π (n α), (λ (i : fin2 (n + 1)), {p_1 : (α ::: β) i // pred_last α pp p_1}) ⟹
    (λ (i : fin2 (n + 1)), {p_1 // of_repeat (pred_last' α pp i p_1)})
| _ α (fin2.fs i) x := ⟨ x.val, cast (by simp only [pred_last]; erw const_iff_true) x.property ⟩
| _ α fin2.fz x := ⟨ x.val, x.property ⟩

lemma liftp_last_pred_iff {β} (p : β → Prop) (x : F (α ::: β)) :
  liftp' (pred_last' _ p) x ↔ liftp (pred_last _ p) x :=
begin
  dsimp only [liftp,liftp'],
  apply exists_iff_exists_of_mono F (f _ n α) (g _ n α),
  { clear x _inst_2 _inst_1 F, ext i ⟨x,_⟩, cases i; refl },
  { intros, rw [mvfunctor.map_map,(⊚)],
    congr'; ext i ⟨x,_⟩; cases i; refl }
end

open function
variables (rr : β → β → Prop)

private def f :
  Π (n α),
    (λ (i : fin2 (n + 1)),
      {p_1 : _ × _ // of_repeat (rel_last' α rr i (typevec.prod.mk _ p_1.fst p_1.snd))}) ⟹
    λ (i : fin2 (n + 1)), {p_1 : (α ::: β) i × _ // rel_last α rr (p_1.fst) (p_1.snd)}
| _ α (fin2.fs i) x := ⟨ x.val, cast (by simp only [rel_last]; erw repeat_eq_iff_eq) x.property ⟩
| _ α fin2.fz x := ⟨ x.val, x.property ⟩

private def g :
  Π (n α), (λ (i : fin2 (n + 1)), {p_1 : (α ::: β) i × _ // rel_last α rr (p_1.fst) (p_1.snd)}) ⟹
    (λ (i : fin2 (n + 1)),
      {p_1 : _ × _ // of_repeat (rel_last' α rr i (typevec.prod.mk _ p_1.1 p_1.2))})
| _ α (fin2.fs i) x := ⟨ x.val, cast (by simp only [rel_last]; erw repeat_eq_iff_eq) x.property ⟩
| _ α fin2.fz x := ⟨ x.val, x.property ⟩

lemma liftr_last_rel_iff  (x y : F (α ::: β)) :
  liftr' (rel_last' _ rr) x y ↔ liftr (rel_last _ rr) x y :=
begin
  dsimp only [liftr,liftr'],
  apply exists_iff_exists_of_mono F (f rr _ _) (g rr _ _),
  { clear x y _inst_2 _inst_1 F, ext i ⟨x,_⟩ : 2, cases i; refl, },
  { intros, rw [mvfunctor.map_map,mvfunctor.map_map,(⊚),(⊚)],
    congr'; ext i ⟨x,_⟩; cases i; refl }
end

end liftp_last_pred_iff

end mvfunctor


/-
Copyright (c) 2020 Scott Morrison. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Scott Morrison
-/
import Mathlib.PrePort
import Mathlib.Lean3Lib.init.default
import Mathlib.category_theory.monoidal.category
import Mathlib.PostPort

universes v u

namespace Mathlib

/-!
# The two morphisms `λ_ (𝟙_ C)` and `ρ_ (𝟙_ C)` from `𝟙_ C ⊗ 𝟙_ C` to `𝟙_ C` are equal.

This is suprisingly difficult to prove directly from the usual axioms for a monoidal category!

This proof follows the diagram given at
https://people.math.osu.edu/penneys.2/QS2019/VicaryHandout.pdf

It should be a consequence of the coherence theorem for monoidal categories
(although quite possibly it is a necessary building block of any proof).
-/

namespace category_theory.monoidal_category

namespace unitors_equal

theorem cells_1_2 {C : Type u} [category C] [monoidal_category C] :
    iso.hom ρ_ = iso.inv λ_ ≫ (𝟙 ⊗ iso.hom ρ_) ≫ iso.hom λ_ :=
  sorry

theorem cells_4 {C : Type u} [category C] [monoidal_category C] :
    iso.inv λ_ ≫ (𝟙 ⊗ iso.hom λ_) = iso.hom λ_ ≫ iso.inv λ_ :=
  sorry

theorem cells_4' {C : Type u} [category C] [monoidal_category C] :
    iso.inv λ_ = iso.hom λ_ ≫ iso.inv λ_ ≫ (𝟙 ⊗ iso.inv λ_) :=
  sorry

theorem cells_3_4 {C : Type u} [category C] [monoidal_category C] : iso.inv λ_ = 𝟙 ⊗ iso.inv λ_ :=
  sorry

theorem cells_1_4 {C : Type u} [category C] [monoidal_category C] :
    iso.hom ρ_ = (𝟙 ⊗ iso.inv λ_) ≫ (𝟙 ⊗ iso.hom ρ_) ≫ iso.hom λ_ :=
  sorry

theorem cells_6 {C : Type u} [category C] [monoidal_category C] :
    (iso.inv ρ_ ⊗ 𝟙) ≫ iso.hom ρ_ = iso.hom ρ_ ≫ iso.inv ρ_ :=
  sorry

theorem cells_6' {C : Type u} [category C] [monoidal_category C] :
    iso.inv ρ_ ⊗ 𝟙 = iso.hom ρ_ ≫ iso.inv ρ_ ≫ iso.inv ρ_ :=
  sorry

theorem cells_5_6 {C : Type u} [category C] [monoidal_category C] : iso.inv ρ_ ⊗ 𝟙 = iso.inv ρ_ :=
  sorry

theorem cells_7 {C : Type u} [category C] [monoidal_category C] :
    𝟙 ⊗ iso.inv λ_ = (iso.inv ρ_ ⊗ 𝟙) ≫ iso.hom α_ :=
  sorry

theorem cells_1_7 {C : Type u} [category C] [monoidal_category C] :
    iso.hom ρ_ = iso.inv ρ_ ≫ iso.hom α_ ≫ (𝟙 ⊗ iso.hom ρ_) ≫ iso.hom λ_ :=
  sorry

theorem cells_8 {C : Type u} [category C] [monoidal_category C] :
    iso.hom α_ = iso.inv ρ_ ≫ (iso.hom α_ ⊗ 𝟙) ≫ iso.hom ρ_ :=
  sorry

theorem cells_14 {C : Type u} [category C] [monoidal_category C] :
    iso.inv ρ_ ≫ iso.inv ρ_ = iso.inv ρ_ ≫ (iso.inv ρ_ ⊗ 𝟙) :=
  sorry

theorem cells_9 {C : Type u} [category C] [monoidal_category C] :
    iso.hom α_ ⊗ 𝟙 = iso.hom α_ ≫ iso.hom α_ ≫ (𝟙 ⊗ iso.inv α_) ≫ iso.inv α_ :=
  sorry

theorem cells_10_13 {C : Type u} [category C] [monoidal_category C] :
    (iso.inv ρ_ ⊗ 𝟙) ≫ iso.hom α_ ≫ iso.hom α_ ≫ (𝟙 ⊗ iso.inv α_) ≫ iso.inv α_ =
        (𝟙 ⊗ iso.inv ρ_) ⊗ 𝟙 :=
  sorry

theorem cells_9_13 {C : Type u} [category C] [monoidal_category C] :
    (iso.inv ρ_ ⊗ 𝟙) ≫ (iso.hom α_ ⊗ 𝟙) = (𝟙 ⊗ iso.inv ρ_) ⊗ 𝟙 :=
  sorry

theorem cells_15 {C : Type u} [category C] [monoidal_category C] :
    iso.inv ρ_ ≫ ((𝟙 ⊗ iso.inv ρ_) ⊗ 𝟙) ≫ iso.hom ρ_ ≫ (𝟙 ⊗ iso.hom ρ_) = 𝟙 :=
  sorry

end unitors_equal

theorem unitors_equal {C : Type u} [category C] [monoidal_category C] : iso.hom λ_ = iso.hom ρ_ :=
  sorry

end Mathlib