/-
Copyright (c) 2019 The Flypitch Project. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.

Authors: Jesse Han, Floris van Doorn
-/
/- theorems which we should (maybe) backport to mathlib -/

import algebra.order.group data.set.intervals.disjoint data.set.countable set_theory.cofinality
       topology.opens --topology.maps
       tactic
       tactic.lint

universes u v w w'

inductive dvector (α : Type u) : ℕ → Type u
| nil {} : dvector 0
| cons : ∀{n} (x : α) (xs : dvector n), dvector (n+1)

inductive dfin : ℕ → Type
| fz {n} : dfin (n+1)
| fs {n} : dfin n → dfin (n+1)

instance has_zero_dfin {n} : has_zero $ dfin (n+1) := ⟨dfin.fz⟩

-- note from Mario --- use dfin to synergize with dvector
namespace dvector
section dvectors
local notation h :: t  := dvector.cons h t
local notation `[` l:(foldr `, ` (h t, dvector.cons h t) dvector.nil `]`) := l
variables {α : Type u} {β : Type v} {γ : Type w} {n : ℕ}

@[simp] protected lemma zero_eq : ∀(xs : dvector α 0), xs = []
| [] := rfl

@[simp] protected def concat : ∀{n : ℕ} (xs : dvector α n) (x : α), dvector α (n+1)
| _ []      x' := [x']
| _ (x::xs) x' := x::concat xs x'

@[simp] protected def nth : ∀{n : ℕ} (xs : dvector α n) (m : ℕ) (h : m < n), α
| _ []      m     h := by { exfalso, exact nat.not_lt_zero m h }
| _ (x::xs) 0     h := x
| _ (x::xs) (m+1) h := nth xs m (lt_of_add_lt_add_right h)

protected lemma nth_cons {n : ℕ} (x : α) (xs : dvector α n) (m : ℕ) (h : m < n) :
  dvector.nth (x::xs) (m+1) (nat.succ_lt_succ h) = dvector.nth xs m h :=
by refl

@[reducible, simp] protected def last {n : ℕ} (xs : dvector α (n+1)) : α :=
  xs.nth n (by {repeat{constructor}})

protected def nth' {n : ℕ} (xs : dvector α n) (m : fin n) : α :=
xs.nth m.1 m.2

protected def nth'' : ∀ {n : ℕ} (xs : dvector α n) (m : dfin n), α
| _ (x::xs) dfin.fz       := x
| _ (x::xs) (dfin.fs (m)) := nth'' xs m

protected def mem : ∀{n : ℕ} (x : α) (xs : dvector α n), Prop
| _ x []       := false
| _ x (x'::xs) := x = x' ∨ mem x xs
instance {n : ℕ} : has_mem α (dvector α n) := ⟨dvector.mem⟩

protected def pmem : ∀{n : ℕ} (x : α) (xs : dvector α n), Type
| _ x []       := empty
| _ x (x'::xs) := psum (x = x') (pmem x xs)

protected lemma mem_of_pmem : ∀{n : ℕ} {x : α} {xs : dvector α n} (hx : xs.pmem x), x ∈ xs
| _ x []       hx := by cases hx
| _ x (x'::xs) hx := by cases hx;[exact or.inl hx, exact or.inr (mem_of_pmem hx)]

@[simp] protected def map (f : α → β) : ∀{n : ℕ}, dvector α n → dvector β n
| _ []      := []
| _ (x::xs) := f x :: map xs

@[simp] protected def map2 (f : α → β → γ) : ∀{n : ℕ}, dvector α n → dvector β n → dvector γ n
| _ []      []      := []
| _ (x::xs) (y::ys) := f x y :: map2 xs ys

@[simp] protected lemma map_id : ∀{n : ℕ} (xs : dvector α n), xs.map (λx, x) = xs
| _ []      := rfl
| _ (x::xs) := by { dsimp, simp* }

@[simp] protected lemma map_congr_pmem {f g : α → β} :
  ∀{n : ℕ} {xs : dvector α n} (h : ∀x, xs.pmem x → f x = g x), xs.map f = xs.map g
| _ []      h := rfl
| _ (x::xs) h :=
  begin
    dsimp, congr' 1, exact h x (psum.inl rfl), apply map_congr_pmem,
    intros x hx, apply h, right, exact hx
  end

@[simp] protected lemma map_congr_mem {f g : α → β} {n : ℕ} {xs : dvector α n}
  (h : ∀x, x ∈ xs → f x = g x) : xs.map f = xs.map g :=
dvector.map_congr_pmem $ λx hx, h x $ dvector.mem_of_pmem hx

@[simp] protected lemma map_congr {f g : α → β} (h : ∀x, f x = g x) :
  ∀{n : ℕ} (xs : dvector α n), xs.map f = xs.map g
| _ []      := rfl
| _ (x::xs) := by { dsimp, simp* }

@[simp] protected lemma map_map (g : β → γ) (f : α → β): ∀{n : ℕ} (xs : dvector α n),
  (xs.map f).map g = xs.map (λx, g (f x))
  | _ []      := rfl
  | _ (x::xs) := by { dsimp, simp* }

protected lemma map_inj {f : α → β} (hf : ∀{{x x'}}, f x = f x' → x = x') {n : ℕ}
  {xs xs' : dvector α n} (h : xs.map f = xs'.map f) : xs = xs' :=
begin
  induction xs; cases xs', refl, simp at h, congr;[apply hf, apply xs_ih]; simp [h]
end

@[simp] protected lemma map_concat (f : α → β) : ∀{n : ℕ} (xs : dvector α n) (x : α),
  (xs.concat x).map f = (xs.map f).concat (f x)
| _ []      x' := by refl
| _ (x::xs) x' := by { dsimp, congr' 1, exact map_concat xs x' }

@[simp] protected lemma map_nth (f : α → β) : ∀{n : ℕ} (xs : dvector α n) (m : ℕ) (h : m < n),
  (xs.map f).nth m h = f (xs.nth m h)
| _ []      m     h := by { exfalso, exact nat.not_lt_zero m h }
| _ (x::xs) 0     h := by refl
| _ (x::xs) (m+1) h := by exact map_nth xs m _

protected lemma concat_nth : ∀{n : ℕ} (xs : dvector α n) (x : α) (m : ℕ) (h' : m < n+1)
  (h : m < n), (xs.concat x).nth m h' = xs.nth m h
| _ []      x' m     h' h := by { exfalso, exact nat.not_lt_zero m h }
| _ (x::xs) x' 0     h' h := by refl
| _ (x::xs) x' (m+1) h' h := by { dsimp, exact concat_nth xs x' m _ _ }

@[simp] protected lemma concat_nth_last : ∀{n : ℕ} (xs : dvector α n) (x : α) (h : n < n+1),
  (xs.concat x).nth n h = x
| _ []      x' h := by refl
| _ (x::xs) x' h := by { dsimp, exact concat_nth_last xs x' _ }

@[simp] protected lemma concat_nth_last' : ∀{n : ℕ} (xs : dvector α n) (x : α) (h : n < n+1),
  (xs.concat x).last = x
:= by apply dvector.concat_nth_last

@[simp] protected def append : ∀{n m : ℕ} (xs : dvector α n) (xs' : dvector α m), dvector α (m+n)
| _ _ []       xs := xs
| _ _ (x'::xs) xs' := x'::append xs xs'

@[simp]protected def insert : ∀{n : ℕ} (x : α) (k : ℕ) (xs : dvector α n), dvector α (n+1)
| n x 0 xs := (x::xs)
| 0 x k xs := (x::xs)
| (n+1) x (k+1) (y::ys) := (y::insert x k ys)

@[simp] protected lemma insert_at_zero :
  ∀{n : ℕ} (x : α) (xs : dvector α n), dvector.insert x 0 xs = (x::xs) :=
by {intros, induction n; refl} -- why doesn't {intros, refl} work?

@[simp] protected lemma insert_nth : ∀{n : ℕ} (x : α) (k : ℕ) (xs : dvector α n) (h : k < n+1),
  (dvector.insert x k xs).nth k h = x
| 0 x k xs h := by {cases h, refl, exfalso, apply nat.not_lt_zero, assumption }
| n x 0 xs h := by {induction n, refl, simp*}
| (n+1) x (k+1) (y::ys) h := by simp*

protected lemma insert_cons {n k} {x y : α} {v : dvector α n} :
  (x::(v.insert y k)) = (x::v).insert y (k+1) :=
by {induction v, refl, simp*}

/- Given a proof that n ≤ m, return the nth initial segment of -/
@[simp]protected def trunc : ∀ (n) {m : ℕ} (h : n ≤ m) (xs : dvector α m), dvector α n
| 0 0 _ xs := []
| 0 (m+1) _ xs := []
| (n+1) 0 _ xs := by {exfalso, cases _x}
| (n+1) (m+1) h (x::xs) := (x::@trunc n m (by { simp at h, exact h }) xs)

@[simp]protected lemma trunc_n_n {n : ℕ} {h : n ≤ n} {v : dvector α n} : dvector.trunc n h v = v :=
  by {induction v, refl, solve_by_elim}

@[simp]protected lemma trunc_0_n {n : ℕ} {h : 0 ≤ n} {v : dvector α n} : dvector.trunc 0 h v = [] :=
  by {induction v, refl, simp}

@[simp]protected lemma trunc_nth {n m l: ℕ} {h : n ≤ m} {h' : l < n} {v : dvector α m} :
  (v.trunc n h).nth l h' = v.nth l (lt_of_lt_of_le h' h) :=
begin
  induction m generalizing n l, have : n = 0, by cases h; simp, subst this, cases h',
  cases n; cases l, {cases h'}, {cases h'}, {cases v, refl},
  cases v, simp only [m_ih, dvector.nth, dvector.trunc]
end

protected lemma nth_irrel1 :
  ∀{n k : ℕ} {h : k < n + 1} {h' : k < n + 1 + 1} (v : dvector α (n+1)) (x : α),
  (x :: (v.trunc n (nat.le_succ n))).nth k h = (x::v).nth k h' :=
by {intros, apply @dvector.trunc_nth _ _ _ _ (by simp) h (x::v)}

protected def cast {n m} (p : n = m) : dvector α n → dvector α m :=
by { subst p, exact id }

@[simp] protected lemma cast_irrel {n m} {p p' : n = m} {v : dvector α n} :
  v.cast p = v.cast p' := by refl

@[simp] protected lemma cast_rfl {n m} {p : n = m} {q : m = n} {v : dvector α n} :
  (v.cast p).cast q = v := by {subst p, refl}

protected lemma cast_hrfl {n m} {p : n = m} {v : dvector α n} : v.cast p == v :=
by { subst p, refl }

@[simp] protected lemma cast_trans {n m o} {p : n = m} {q : m = o} {v : dvector α n} :
  (v.cast p).cast q = v.cast (trans p q) :=
by { subst p, subst q, refl }

@[simp] lemma cast_cons {α} : ∀{n m} (h : n + 1 = m + 1) (x : α) (v : dvector α n),
  (x::v).cast h = x :: v.cast (nat.succ_inj'.mp h) :=
by { intros, cases h, refl }

@[simp] lemma cast_append_nil {α} : ∀{n} (v : dvector α n) (h : 0 + n = n),
  (v.append ([])).cast h = v
| _ ([])   h := by refl
| _ (x::v) h := by { simp only [true_and, dvector.append, cast_cons, eq_self_iff_true],
  exact cast_append_nil v (by simp only [zero_add]) }

@[simp] protected def remove_mth : ∀ {n : ℕ} (m : ℕ) (xs : dvector α (n+1)) , dvector α (n)
  | 0 _ _  := dvector.nil
  | n 0 (dvector.cons y ys) := ys
  | (n+1) (k+1) (dvector.cons y ys) := dvector.cons y (remove_mth k ys)

@[simp]protected def replace : ∀{n : ℕ} (x : α) (k : ℕ) (xs : dvector α n), dvector α (n)
| n x 0 (y::ys) := (x::ys)
| 0 x k ys := ys
| (n+1) x (k+1) (y::ys) := (y::replace x k ys)

protected lemma insert_nth_lt {α} : ∀{n k l : ℕ} (x : α) (xs : dvector α n) (h : l < n)
  (h' : l < n + 1) (h2 : l < k), (xs.insert x k).nth l h' = xs.nth l h
| n     0     l     x xs h h' h2 := by cases h2
| 0     (k+1) l     x xs h h' h2 := by cases h
| (n+1) (k+1) 0     x (x'::xs) h h' h2 := by refl
| (n+1) (k+1) (l+1) x (x'::xs) h h' h2 :=
  by { simp, apply insert_nth_lt, apply nat.lt_of_succ_lt_succ h2 }

protected lemma insert_nth_gt' {α} : ∀{n k l : ℕ} (x : α) (xs : dvector α n) (h : l - 1 < n)
  (h' : l < n + 1) (h2 : k < l), (xs.insert x k).nth l h' = xs.nth (l-1) h
| n     0     0     x xs h h' h2 := by cases h2
| n     0     (l+1) x xs h h' h2 := by { simp }
| 0     (k+1) 0     x xs h h' h2 := by { cases h }
| 0     (k+1) (l+1) x xs h h' h2 := by { cases h' with _ h', cases h' }
| (n+1) (k+1) 0     x (x'::xs) h h' h2 := by cases h2
| (n+1) (k+1) 1     x (x'::xs) h h' h2 := by { cases h2 with _ h2, cases h2 }
| (n+1) (k+1) (l+2) x (x'::xs) h h' h2 :=
  by { simp, convert insert_nth_gt' x xs _ _ _,
    { exact nat.lt_of_succ_lt_succ h },
    apply nat.lt_of_succ_lt_succ h2 }

@[simp] protected lemma insert_nth_gt_simp {α} : ∀{n k l : ℕ} (x : α) (xs : dvector α n)
  (h' : l < n + 1)
  (h2 : k < l), (xs.insert x k).nth l h' =
  xs.nth (l-1) ((tsub_lt_iff_right (nat.one_le_of_lt h2)).mpr h') :=
λ n k l x xs h' h2, dvector.insert_nth_gt' x xs _ h' h2

protected lemma insert_nth_gt {α} :
  ∀{n k l : ℕ} (x : α) (xs : dvector α n) (h : l < n) (h' : l + 1 < n + 1)
  (h2 : k < l + 1), (xs.insert x k).nth (l+1) h' = xs.nth l h :=
λ n k l x xs h h' h2, dvector.insert_nth_gt' x xs h h' h2

@[simp]lemma replace_head {n x z} {xs : dvector α n} : (x::xs).replace z 0 = z::xs := rfl

@[simp]lemma replace_neck {n x y z} {xs : dvector α n} : (x::y::xs).replace z 1 = x::z::xs := rfl

@[simp] def foldr (f : α → β → β) (b : β) : ∀{n}, dvector α n → β
| _ []       := b
| _ (a :: l) := f a (foldr l)

@[simp] def zip : ∀{n}, dvector α n → dvector β n → dvector (α × β) n
| _ [] []               := []
| _ (x :: xs) (y :: ys) := ⟨x, y⟩ :: zip xs ys

open lattice
/-- The finitary infimum -/
def fInf [semilattice_inf α] [order_top α] (xs : dvector α n) : α :=
xs.foldr (λ(x b : α), x ⊓ b) ⊤

@[simp] lemma fInf_nil [semilattice_inf α] [order_top α] : fInf [] = (⊤ : α) := by refl
@[simp] lemma fInf_cons [semilattice_inf α] [order_top α] (x : α) (xs : dvector α n) :
  fInf (x::xs) = x ⊓ fInf xs := by refl

/-- The finitary supremum -/
def fSup [semilattice_sup α] [order_bot α] (xs : dvector α n) : α :=
xs.foldr (λ(x b : α), x ⊔ b) ⊥

@[simp] lemma fSup_nil [semilattice_sup α] [order_bot α] : fSup [] = (⊥ : α) := by refl
@[simp] lemma fSup_cons [semilattice_sup α] [order_bot α] (x : α) (xs : dvector α n) :
  fSup (x::xs) = x ⊔ fSup xs := by refl

/- how to make this protected? -/
inductive rel [setoid α] : ∀{n}, dvector α n → dvector α n → Prop
| rnil : rel [] []
| rcons {n} {x x' : α} {xs xs' : dvector α n} (hx : x ≈ x') (hxs : rel xs xs') :
    rel (x::xs) (x'::xs')
open dvector.rel

protected lemma rel_refl [setoid α] : ∀{n} (xs : dvector α n), xs.rel xs
| _ []      := rnil
| _ (x::xs) := rcons (setoid.refl _) (rel_refl xs)

protected lemma rel_symm [setoid α] {n} {{xs xs' : dvector α n}} (h : xs.rel xs') : xs'.rel xs :=
by { induction h; constructor, exact setoid.symm h_hx, exact h_ih }

protected lemma rel_trans [setoid α] {n} {{xs₁ xs₂ xs₃ : dvector α n}}
  (h₁ : xs₁.rel xs₂) (h₂ : xs₂.rel xs₃) : xs₁.rel xs₃ :=
begin
  induction h₁ generalizing h₂, exact h₂,
  cases h₂, constructor, exact setoid.trans h₁_hx h₂_hx, exact h₁_ih h₂_hxs
end

-- protected def rel [setoid α] : ∀{n}, dvector α n → dvector α n → Prop
-- | _ []      []        := true
-- | _ (x::xs) (x'::xs') := x ≈ x' ∧ rel xs xs'

-- protected def rel_refl [setoid α] : ∀{n} (xs : dvector α n), xs.rel xs
-- | _ []      := trivial
-- | _ (x::xs) := ⟨by refl, rel_refl xs⟩

-- protected def rel_symm [setoid α] : ∀{n} {{xs xs' : dvector α n}}, xs.rel xs' → xs'.rel xs
-- | _ []      []        h := trivial
-- | _ (x::xs) (x'::xs') h := ⟨setoid.symm h.1, rel_symm h.2⟩

-- protected def rel_trans [setoid α] : ∀{n} {{xs₁ xs₂ xs₃ : dvector α n}},
--   xs₁.rel xs₂ → xs₂.rel xs₃ → xs₁.rel xs₃
-- | _ []        []        []        h₁ h₂ := trivial
-- | _ (x₁::xs₁) (x₂::xs₂) (x₃::xs₃) h₁ h₂ := ⟨setoid.trans h₁.1 h₂.1, rel_trans h₁.2 h₂.2⟩

instance setoid [setoid α] : setoid (dvector α n) :=
⟨dvector.rel, dvector.rel_refl, dvector.rel_symm, dvector.rel_trans⟩

def quotient_lift {α : Type u} {β : Sort v} {R : setoid α} : ∀{n} (f : dvector α n → β)
  (h : ∀{{xs xs'}}, xs ≈ xs' → f xs = f xs') (xs : dvector (quotient R) n), β
| _     f h []      := f ([])
| (n+1) f h (x::xs) :=
  begin
    refine quotient.lift
      (λx, quotient_lift (λ xs, f $ x::xs) (λxs xs' hxs, h (rcons (setoid.refl x) hxs)) xs) _ x,
    intros x x' hx, dsimp, congr, apply funext, intro xs, apply h, exact rcons hx xs.rel_refl
  end

lemma quotient_beta {α : Type u} {β : Sort v} {R : setoid α} {n} (f : dvector α n → β)
  (h : ∀{{xs xs'}}, xs ≈ xs' → f xs = f xs') (xs : dvector α n) :
  (xs.map quotient.mk).quotient_lift f h = f xs :=
begin
  induction xs, refl, apply xs_ih
end
end dvectors
end dvector

namespace set
lemma disjoint_iff_eq_empty {α} {s t : set α} : disjoint s t ↔ s ∩ t = ∅ := disjoint_iff

@[simp] lemma not_nonempty_iff {α} {s : set α} : ¬set.nonempty s ↔ s = ∅ :=
by rw [←ne_empty_iff_nonempty, not_not]

lemma neq_neg_of_nonempty {α : Type*} {P : set α} (H_nonempty : nonempty α) : P ≠ Pᶜ :=
begin
  intro H_eq, let a : α := classical.choice (by apply_instance),
  have := congr_fun H_eq a,
  classical, by_cases HP : P a,
    {from absurd HP (by rwa this at HP)},
    {from absurd (by rwa this) HP}
end

@[simp] lemma subset_bInter_iff {α β} {s : set α} {t : set β} {u : α → set β} :
  t ⊆ (⋂ x ∈ s, u x) ↔ ∀ x ∈ s, t ⊆ u x :=
⟨λ h x hx y hy, by { have := h hy, rw mem_Inter₂ at this, exact this x hx }, subset_Inter₂⟩

lemma ne_empty_of_subset {α} {s t : set α} (h : s ⊆ t) (hs : s ≠ ∅) : t ≠ ∅ :=
by { rw [set.ne_empty_iff_nonempty] at hs ⊢, cases hs with x hx, exact ⟨x, h hx⟩ }

end set

section topological_space
open lattice filter topological_space set
variables {α : Type u} {β : Type v} {ι : Type w} {π : ι → Type w'} [∀x, topological_space (π x)]

variables [t : topological_space α] [topological_space β]

lemma subbasis_subset_basis {s : set (set α)} :
  s \ {∅} ⊆ ((λf, ⋂₀ f) '' {f:set (set α) | finite f ∧ f ⊆ s ∧ ⋂₀ f ≠ ∅}) :=
begin
  intros o ho, refine ⟨{o}, ⟨finite_singleton o, _, _⟩, _⟩,
  { rw [singleton_subset_iff], exact ho.1 },
  { rw [sInter_singleton], refine mt mem_singleton_iff.mpr ho.2 },
  dsimp only, rw [sInter_singleton]
end

include t

lemma mem_opens {x : α} {o : opens α} : x ∈ o ↔ x ∈ o.1 := by refl

lemma is_open_map_of_is_topological_basis {s : set (set α)}
  (hs : is_topological_basis s) (f : α → β) (hf : ∀x ∈ s, is_open (f '' x)) :
  is_open_map f :=
begin
  intros o ho,
  rcases hs.open_eq_Union ho with ⟨γ, g, rfl, hg⟩,
  rw [image_Union], apply is_open_Union, intro i, apply hf, apply hg
end

lemma interior_bInter_subset {β} {s : set β} (f : β → set α) :
  interior (⋂i ∈ s, f i) ⊆ ⋂i ∈ s, interior (f i) :=
begin
  intros x hx, rw [mem_interior] at hx, rcases hx with ⟨t, h1t, h2t, h3t⟩,
  rw [subset_bInter_iff] at h1t,
  rw [mem_Inter₂], intros y hy, rw [mem_interior],
  refine ⟨t, h1t y hy, h2t, h3t⟩
end

lemma nonempty_basis_subset {b : set (set α)}
  (hb : is_topological_basis b) {u : set α} (hu : u ≠ ∅) (ou : _root_.is_open u) :
  ∃v ∈ b, v ≠ ∅ ∧ v ⊆ u :=
begin
  simp only [set.ne_empty_iff_nonempty] at hu ⊢, cases hu with x hx,
  rcases hb.exists_subset_of_mem_open hx ou with ⟨o, h1o, h2x, h2o⟩,
  exact ⟨o, h1o, ⟨x, h2x⟩, h2o⟩
end

end topological_space

namespace ordinal
variable {σ : Type*}

theorem well_ordering_thm : ∃ (r : σ → σ → Prop), is_well_order σ r :=
⟨_, (rel_embedding.preimage embedding_to_cardinal (<)).is_well_order⟩

theorem enum_typein' {α : Type u} (r : α → α → Prop) [is_well_order α r] (a : α) :
  enum r (typein r a) (typein_lt_type r a) = a :=
enum_typein r a

end ordinal

namespace cardinal

section cardinal_lemmas

local prefix `#`:65 := cardinal.mk

lemma exists_mem_compl_of_mk_lt_mk {α} (P : set α) (H_lt : cardinal.mk P  < cardinal.mk α) :
  ∃ x : α, x ∈ Pᶜ :=
begin
  haveI : decidable (∃ (x : α), x ∈ Pᶜ) := classical.prop_decidable _,
  by_contra a, push_neg at a,
  replace a := (by finish : ∀ x, x ∈ P),
  suffices : mk α ≤ mk P ,
    by {exact absurd H_lt (not_lt.mpr ‹_›)},
  refine mk_le_of_injective _, from λ _, ⟨‹_›, a ‹_›⟩, tidy
end

@[simp]lemma mk_union_countable_of_countable {α} {P Q : set α} (HP : #P ≤ omega) (HQ : #Q ≤ omega) :
  #((P ∪ Q : set α)) ≤ omega :=
begin
  have this₁ := @mk_union_add_mk_inter _ (P) (Q),
  transitivity (#↥(P ∪ Q)) + #↥(P ∩ Q),
    { apply le_add_right, exact le_rfl },
    { rw[this₁], rw[<-(add_eq_self (by refl : cardinal.omega ≤ cardinal.omega))],
      refine cardinal.add_le_add _ _; from ‹_› }
end

lemma nonzero_of_regular {κ : cardinal} (H_reg : cardinal.is_regular κ) : 0 < κ.ord :=
by {rw cardinal.lt_ord, from lt_of_lt_of_le omega_pos H_reg.left}

lemma injection_of_mk_le {α β : Type u} (H_le : #α ≤ #β) : ∃ f : α → β, function.injective f :=
begin
  rw cardinal.out_embedding at H_le,
  have := classical.choice H_le,
  cases this with f Hf,
  suffices : ∃ g₁ : α → quotient.out (#α), function.injective g₁ ∧
    ∃ g₂ : quotient.out (#β) → β, function.injective g₂,
    by {rcases this with ⟨g₁,Hg₁,g₂,Hg₂⟩, use g₂ ∘ f ∘ g₁, exact Hg₂.comp (Hf.comp Hg₁) },
  have this₁ : #(quotient.out (#α)) = #α := mk_out _,
  have this₂ : #(quotient.out _) = #β := mk_out _,
  erw quotient.eq' at this₁ this₂, replace this₁ := classical.choice this₁,
  replace this₂ := classical.choice this₂,
  cases this₁, cases this₂,
  refine ⟨this₁_inv_fun, function.left_inverse.injective this₁_right_inv,
    this₂_to_fun, function.left_inverse.injective this₂_left_inv⟩
end

end cardinal_lemmas

end cardinal

------------------------------------------------------- maybe not move to mathlib ------------------

/- theorems which we should not backport to mathlib, because they are duplicates or which need to
  be cleaned up first -/

namespace nat
protected lemma pred_lt_iff_lt_succ {m n : ℕ} (H : 1 ≤ m) : pred m < n ↔ m < succ n :=
--nat.sub_lt_right_iff_lt_add H
tsub_lt_iff_right H

@[simp]lemma le_of_le_and_ne_succ {x y : ℕ} (H : x ≤ y + 1) (H' : x ≠ y + 1) : x ≤ y :=
by simp only [*, nat.lt_of_le_and_ne, nat.le_of_lt_succ, ne.def, not_false_iff]

end nat

namespace tactic
namespace interactive
/- maybe we should use congr' 1 instead? -/
meta def congr1 : tactic unit :=
do focus1 (congr_core >> all_goals (try reflexivity >> try assumption))

open interactive interactive.types
/-- a variant of `exact` which elaborates its argument before unifying it with the target. This variant might succeed if `exact` fails because a lot of definitional reduction is needed to verify that the term has the correct type. Metavariables which are not synthesized become new subgoals. This is similar to have := q, exact this. Another approach to obtain (rougly) the same is `apply q` -/
meta def rexact (q : interactive.parse texpr) : tactic unit :=
do n ← mk_fresh_name,
p ← i_to_expr q,
e ← note n none p,
tactic.exact e

end interactive
end tactic

/- logic -/
namespace classical

noncomputable def psigma_of_exists {α : Type u} {p : α → Prop} (h : ∃x, p x) : Σ' x, p x :=
begin
  haveI : nonempty α := nonempty_of_exists h,
  exact ⟨epsilon p, epsilon_spec h⟩
end

/- this is a special case of `some_spec2` -/
lemma some_eq {α : Type u} {p : α → Prop} {h : ∃ (a : α), p a} (x : α)
  (hx : ∀y, p y → y = x) : classical.some h = x :=
classical.some_spec2 _ hx

lemma or_not_iff_true (p : Prop) : (p ∨ ¬ p) ↔ true :=
⟨λ_, trivial, λ_, or_not⟩

lemma nonempty_of_not_empty {α : Type u} (s : set α) (h : ¬ s = ∅) : set.nonempty s :=
set.ne_empty_iff_nonempty.mp h

lemma nonempty_of_not_empty_finset {α : Type u} (s : finset α) (h : ¬ s = ∅) :
  set.nonempty (s : set α) :=
finset.nonempty_iff_ne_empty.mpr h

end classical

namespace list
@[simp] protected def to_set {α : Type u} (l : list α) : set α := { x | x ∈ l }

lemma to_set_map {α : Type u} {β : Type v} (f : α → β) (l : list α) :
  (l.map f).to_set = f '' l.to_set :=
by apply set.ext; intro b; simp [list.to_set]

lemma exists_of_to_set_subset_image {α : Type u} {β : Type v} {f : α → β} {l : list β}
  {t : set α} (h : l.to_set ⊆ f '' t) : ∃(l' : list α), l'.to_set ⊆ t ∧ map f l' = l :=
begin
  induction l,
  { exact ⟨[], set.empty_subset t, rfl⟩ },
  { rcases h (mem_cons_self _ _) with ⟨x, hx, rfl⟩,
    rcases l_ih (λx hx, h $ mem_cons_of_mem _ hx) with ⟨xs, hxs, hxs'⟩,
    exact ⟨x::xs, set.union_subset (λy hy, by induction hy; exact hx) hxs, by simp*⟩ }
end

end list

namespace nat
/- nat.sub_add_comm -/
lemma add_sub_swap {n k : ℕ} (h : k ≤ n) (m : ℕ) : n + m - k = n - k + m :=
by rw [add_comm, nat.add_sub_assoc h, add_comm]

end nat

lemma imp_eq_congr {a b c d : Prop} (h₁ : a = b) (h₂ : c = d) : (a → c) = (b → d) :=
by subst h₁; subst h₂; refl

lemma forall_eq_congr {α : Sort u} {p q : α → Prop} (h : ∀ a, p a = q a) :
  (∀ a, p a) = ∀ a, q a :=
have h' : p = q, from funext h, by subst h'; refl

namespace set
/- Some of these lemmas might be duplicates of those in data.set.lattice -/

variables {α : Type u} {β : Type v} {γ : Type w}

/-set.ne_empty_iff_exists_mem.mpr-/
lemma ne_empty_of_exists_mem {s : set α} : ∀(h : ∃x, x ∈ s), s ≠ ∅ :=
ne_empty_iff_nonempty.mpr

lemma inter_sUnion_ne_empty_of_exists_mem
  {b : set α} {𝓕 : set $ set α} (H : ∃ f ∈ 𝓕, b ∩ f ≠ ∅) : b ∩ ⋃₀ 𝓕 ≠ ∅ :=
begin
  simp_rw ne_empty_iff_nonempty at H ⊢,
  obtain ⟨f, hf, x, hx, hxf⟩ := H,
  exact ⟨x, hx, f, hf, hxf⟩
end

@[simp] lemma mem_image_univ {f : α → β} {x} : f x ∈ f '' set.univ := ⟨x, ⟨trivial, rfl⟩⟩

-- todo: only use image_preimage_eq_of_subset
lemma image_preimage_eq_of_subset_image {f : α → β} {s : set β}
  {t : set α} (h : s ⊆ f '' t) : f '' (f ⁻¹' s) = s :=
subset.antisymm
  (image_preimage_subset f s)
  (λ x hx, begin rcases h hx with ⟨a, ha, rfl⟩, apply mem_image_of_mem f, exact hx end)

lemma subset_union_left_of_subset {s t : set α} (h : s ⊆ t) (u : set α) : s ⊆ t ∪ u :=
subset.trans h (subset_union_left t u)

lemma subset_union_right_of_subset {s u : set α} (h : s ⊆ u) (t : set α) : s ⊆ t ∪ u :=
subset.trans h (subset_union_right t u)

/- subset_sUnion_of_mem -/
lemma subset_sUnion {s : set α} {t : set (set α)} (h : s ∈ t) : s ⊆ ⋃₀ t :=
λx hx, ⟨s, ⟨h, hx⟩⟩

lemma subset_union2_left {s t u : set α} : s ⊆ s ∪ t ∪ u :=
subset.trans (subset_union_left _ _) (subset_union_left _ _)

lemma subset_union2_middle {s t u : set α} : t ⊆ s ∪ t ∪ u :=
subset.trans (subset_union_right _ _) (subset_union_left _ _)

def change {π : α → Type*} [decidable_eq α] (f : Πa, π a) {x : α} (z : π x) (y : α) : π y :=
if h : x = y then (@eq.rec _ _ π z _ h) else f y

lemma dif_mem_pi {π : α → Type*} (i : set α) (s : Πa, set (π a)) [decidable_eq α]
  (f : Πa, π a) (hf : f ∈ pi i s) {x : α} (z : π x) (h : x ∈ i → z ∈ s x) :
  change f z ∈ pi i s :=
begin
  intros y hy, dsimp only,
  by_cases hxy : x = y,
  { rw [change, dif_pos hxy], subst hxy, exact h hy },
  { rw [change, dif_neg hxy], apply hf y hy }
end

lemma image_pi_pos {π : α → Type*} (i : set α) (s : Πa, set (π a)) [decidable_eq α]
  (hp : set.nonempty (pi i s)) (x : α) (hx : x ∈ i) : (λ(f : Πa, π a), f x) '' pi i s = s x :=
begin
  apply subset.antisymm,
  { rintro _ ⟨f, hf, rfl⟩, exact hf x hx },
  intros z hz, have := hp, rcases this with ⟨f, hf⟩,
  refine ⟨_, dif_mem_pi i s f hf z (λ _, hz), _⟩,
  simp only [change, dif_pos rfl]
end

lemma image_pi_neg {π : α → Type*} (i : set α) (s : Πa, set (π a)) [decidable_eq α]
  (hp : set.nonempty (pi i s)) (x : α) (hx : x ∉ i) : (λ(f : Πa, π a), f x) '' pi i s = univ :=
begin
  rw [eq_univ_iff_forall], intro z, have := hp, rcases this with ⟨f, hf⟩,
  refine ⟨_, dif_mem_pi i s f hf z _, _⟩,
  intro hx', exfalso, exact hx hx',
  simp only [change, dif_pos rfl]
end

end set
open nat

namespace nonempty
variables {α : Sort u} {β : Sort v} {γ : Sort w}

protected lemma iff (mp : α → β) (mpr : β → α) : nonempty α ↔ nonempty β :=
⟨nonempty.map mp, nonempty.map mpr⟩

end nonempty

/-- The type α → (α → ... (α → β)...) with n α's. We require that α and β live in the same universe, otherwise we have to use ulift. -/
def arity' (α β : Type u) : ℕ → Type u
| 0     := β
| (n+1) := α → arity' n

namespace arity'
section arity'
local notation h :: t  := dvector.cons h t
local notation `[` l:(foldr `, ` (h t, dvector.cons h t) dvector.nil `]`) := l
def arity'_constant {α β : Type u} : ∀{n : ℕ}, β → arity' α β n
| 0     b := b
| (n+1) b := λ_, arity'_constant b

@[simp] def of_dvector_map {α β : Type u} : ∀{l} (f : dvector α l → β), arity' α β l
| 0     f := f ([])
| (l+1) f := λx, of_dvector_map $ λxs, f $ x::xs

@[simp] def arity'_app {α β : Type u} : ∀{l}, arity' α β l → dvector α l → β
| _ b []      := b
| _ f (x::xs) := arity'_app (f x) xs

@[simp] lemma arity'_app_zero {α β : Type u} (f : arity' α β 0) (xs : dvector α 0) :
  arity'_app f xs = f :=
by cases xs; refl

def arity'_postcompose {α β γ : Type u} (g : β → γ) : ∀{n} (f : arity' α β n), arity' α γ n
| 0     b := g b
| (n+1) f := λx, arity'_postcompose (f x)

def arity'_postcompose2 {α β γ δ : Type u} (h : β → γ → δ) :
  ∀{n} (f : arity' α β n) (g : arity' α γ n), arity' α δ n
| 0     b c := h b c
| (n+1) f g := λx, arity'_postcompose2 (f x) (g x)

def arity'_precompose {α β γ : Type u} : ∀{n} (g : arity' β γ n) (f : α → β), arity' α γ n
| 0     c f := c
| (n+1) g f := λx, arity'_precompose (g (f x)) f

inductive arity'_respect_setoid {α β : Type u} [R : setoid α] : ∀{n}, arity' α β n → Type u
| r_zero (b : β) : @arity'_respect_setoid 0 b
| r_succ (n : ℕ) (f : arity' α β (n+1)) (h₁ : ∀{{a a'}}, a ≈ a' → f a = f a')
  (h₂ : ∀a, arity'_respect_setoid (f a)) : arity'_respect_setoid f
open arity'_respect_setoid

instance subsingleton_arity'_respect_setoid {α β : Type u} [R : setoid α] {n} (f : arity' α β n) :
  subsingleton (arity'_respect_setoid f) :=
begin
  constructor, intros h h', induction h generalizing h'; cases h'; try {refl}; congr,
  apply funext, intro x, apply h_ih
end

def arity'_quotient_lift {α β : Type u} {R : setoid α} :
  ∀{n}, (Σ(f : arity' α β n), arity'_respect_setoid f) → arity' (quotient R) β n
| _ ⟨_, r_zero b⟩         := b
| _ ⟨_, r_succ n f h₁ h₂⟩ :=
  begin
    apply quotient.lift (λx, arity'_quotient_lift ⟨f x, h₂ x⟩),
    intros x x' r, dsimp,
    apply congr_arg, exact sigma.eq (h₁ r) (subsingleton.elim _ _)
  end

-- def arity'_quotient_beta {α β : Type u} {R : setoid α} {n} (f : arity' α β n)
--   (hf : arity'_respect_setoid f) (xs : dvector α n) :
--   arity'_app (arity'_quotient_lift ⟨f, hf⟩) (xs.map quotient.mk) = arity'_app f xs :=
-- begin
--   induction hf,
--   { simp [arity'_quotient_lift] },
--   dsimp [arity'_app], sorry
-- end

def for_all {α : Type u} (P : α → Prop) : Prop := ∀x, P x

@[simp] def arity'_map2 {α β : Type u} (q : (α → β) → β) (f : β → β → β) :
  ∀{n}, arity' α β n → arity' α β n → β
| 0     x y := f x y
| (n+1) x y := q (λz, arity'_map2 (x z) (y z))

@[simp] lemma arity'_map2_refl {α : Type} {f : Prop → Prop → Prop} (r : ∀A, f A A) :
  ∀{n} (x : arity' α Prop n), arity'_map2 for_all f x x
| 0     x := r x
| (n+1) x := λy, arity'_map2_refl (x y)

def arity'_imp {α : Type} {n : ℕ} (f₁ f₂ : arity' α Prop n) : Prop :=
arity'_map2 for_all (λP Q, P → Q) f₁ f₂

def arity'_iff {α : Type} {n : ℕ} (f₁ f₂ : arity' α Prop n) : Prop :=
arity'_map2 for_all iff f₁ f₂

lemma arity'_iff_refl {α : Type} {n : ℕ} (f : arity' α Prop n) : arity'_iff f f :=
arity'_map2_refl iff.refl f

lemma arity'_iff_rfl {α : Type} {n : ℕ} {f : arity' α Prop n} : arity'_iff f f :=
arity'_iff_refl f

end arity'
end arity'

@[simp]lemma lt_irrefl' {α} [preorder α] {Γ : α} (H_lt : Γ < Γ) : false := lt_irrefl _ ‹_›

namespace lattice

class nontrivial_complete_boolean_algebra (α : Type*) extends complete_boolean_algebra α :=
  {bot_lt_top : (⊥ : α) < (⊤ : α)}

@[simp]lemma nontrivial.bot_lt_top {α : Type*} [H : nontrivial_complete_boolean_algebra α] :
  (⊥ : α) < ⊤ := H.bot_lt_top

@[simp]lemma nontrivial.bot_neq_top {α : Type*} [H : nontrivial_complete_boolean_algebra α] :
  ¬ (⊥ = (⊤ : α)) := by {change _ ≠ _, rw[lt_top_iff_ne_top.symm], simp}

@[simp]lemma nontrivial.top_neq_bot {α : Type*} [H : nontrivial_complete_boolean_algebra α] :
  ¬ (⊤ = (⊥ : α)) := λ _, nontrivial.bot_neq_top $ eq.symm ‹_›

def antichain {β : Type*} [lattice β] [bounded_order β] (s : set β) :=
  ∀ x ∈ s, ∀ y ∈ s, x ≠ y → x ⊓ y = (⊥ : β)

theorem inf_supr_eq {α ι : Type*} [complete_distrib_lattice α] {a : α} {s : ι → α} :
  a ⊓ (⨆(i:ι), s i) = ⨆(i:ι), a ⊓ s i :=
  eq.trans inf_Sup_eq $
    begin
      rw[<-inf_Sup_eq], suffices : (⨆(i:ι), a ⊓ s i) = ⨆(b∈(set.range s)), a ⊓ b,
      by {rw[this], apply inf_Sup_eq}, simp, apply le_antisymm,
      apply supr_le, intro i, apply le_supr_of_le (s i), apply le_supr_of_le i,
      apply le_supr_of_le rfl, refl,
      repeat{apply supr_le, intro}, rw[<-i_2], apply le_supr_of_le i_1, refl
    end

theorem supr_inf_eq {α ι : Type*} [complete_distrib_lattice α] {a : α} {s : ι → α} :
  (⨆(i:ι), s i) ⊓ a = ⨆(i:ι), (s i ⊓ a) :=
by simp[inf_comm,inf_supr_eq]

theorem sup_infi_eq {α ι : Type*} [complete_distrib_lattice α] {a : α} {s : ι → α} :
  a ⊔ (⨅(i:ι), s i) = ⨅(i:ι), a ⊔ s i :=
  eq.trans sup_Inf_eq $
    begin
      rw[<-sup_Inf_eq], suffices : (⨅(i:ι), a ⊔ s i) = ⨅(b∈(set.range s)), a ⊔ b,
      by {rw[this], apply sup_Inf_eq}, simp, apply le_antisymm,
      repeat{apply le_infi, intro}, rw[<-i_2], apply infi_le_of_le i_1, refl,
      repeat{apply infi_le_of_le}, show ι, from ‹ι›, show α, exact s i, refl, refl
    end

theorem infi_sup_eq {α ι : Type*} [complete_distrib_lattice α] {a : α} {s : ι → α} :
 (⨅(i:ι), s i) ⊔ a = ⨅(i:ι), s i ⊔ a :=
by {rw[sup_comm], conv{to_rhs, simp[sup_comm]}, apply sup_infi_eq}

/- These next two lemmas are duplicates, but with better names -/
@[simp]lemma inf_self {α : Type*} [lattice α] {a : α} : a ⊓ a = a :=
  inf_idem

@[simp]lemma sup_self {α : Type*} [lattice α] {a : α} : a ⊔ a = a :=
  sup_idem

lemma bot_lt_iff_not_le_bot {α} [lattice α] [bounded_order α] {a : α} : ⊥ < a ↔ (¬ a ≤ ⊥) :=
by rw[le_bot_iff]; exact bot_lt_iff_ne_bot

lemma false_of_bot_lt_and_le_bot
  {α} [lattice α] [bounded_order α] {a : α} (H_lt : ⊥ < a) (H_le : a ≤ ⊥) : false :=
absurd H_le (bot_lt_iff_not_le_bot.mp ‹_›)

lemma lt_top_iff_not_top_le {α} [lattice α] [bounded_order α] {a : α} : a < ⊤ ↔ (¬ ⊤ ≤ a) :=
by rw[top_le_iff]; exact lt_top_iff_ne_top

lemma bot_lt_resolve_left {𝔹} [lattice 𝔹] [bounded_order 𝔹] {a b : 𝔹} (H_lt' : ⊥ < a ⊓ b) : ⊥ < b :=
begin
  haveI := classical.prop_decidable, by_contra H, rw[bot_lt_iff_not_le_bot] at H H_lt',
  apply H_lt', simp at H, simp*
end

lemma bot_lt_resolve_right {𝔹} [lattice 𝔹] [bounded_order 𝔹] {a b : 𝔹} (H_lt : ⊥ < b)
  (H_lt' : ⊥ < a ⊓ b) : ⊥ < a :=
by rw[inf_comm] at H_lt'; exact bot_lt_resolve_left ‹_›

lemma le_bot_iff_not_bot_lt {𝔹} [lattice 𝔹] [bounded_order 𝔹] {a : 𝔹} : ¬ ⊥ < a ↔ a ≤ ⊥ :=
by { rw bot_lt_iff_not_le_bot, tauto! }

/--
  Given an indexed supremum (⨆i, s i) and (H : Γ ≤ ⨆i, s i), there exists some i such that ⊥ < Γ ⊓ s i.
-/
lemma nonzero_inf_of_nonzero_le_supr {α : Type*} [complete_distrib_lattice α]
  {ι : Type*} {s : ι → α} {Γ : α} (H_nonzero : ⊥ < Γ) (H : Γ ≤ ⨆i, s i) : ∃ i, ⊥ < Γ ⊓ s i :=
begin
  haveI := classical.prop_decidable, by_contra H', push_neg at H',
  simp [bot_lt_iff_not_le_bot, -le_bot_iff] at H', replace H' := supr_le_iff.mpr H',
  have H_absorb : Γ ⊓ (⨆(i : ι), s i) = Γ :=
    by {exact le_antisymm (inf_le_left) (le_inf le_rfl ‹_›)},
  suffices this : (Γ ⊓ ⨆ (i : ι), s i) ≤ ⊥,
    by {rw[H_absorb, le_bot_iff] at this, simpa[this] using H_nonzero},
  rwa[inf_supr_eq]
end

/--
  Material implication in a Boolean algebra
-/
def imp {α : Type*} [boolean_algebra α] : α → α → α :=
  λ a₁ a₂, a₁ᶜ ⊔ a₂

local infix ` ⟹ `:65 := lattice.imp

@[reducible, simp]def biimp {α : Type*} [boolean_algebra α] : α → α → α :=
  λ a₁ a₂, (a₁ ⟹ a₂) ⊓ (a₂ ⟹ a₁)

local infix ` ⇔ `:50 := lattice.biimp

lemma biimp_mp {α : Type*} [boolean_algebra α] {a₁ a₂ : α} : (a₁ ⇔ a₂) ≤ (a₁ ⟹ a₂) :=
  by apply inf_le_left

lemma biimp_mpr {α : Type*} [boolean_algebra α] {a₁ a₂ : α} : (a₁ ⇔ a₂) ≤ (a₂ ⟹ a₁) :=
  by apply inf_le_right

lemma biimp_comm {α : Type*} [boolean_algebra α] {a₁ a₂ : α} : (a₁ ⇔ a₂) = (a₂ ⇔ a₁) :=
by {unfold biimp, rw inf_comm}

lemma biimp_symm {α : Type*} [boolean_algebra α] {a₁ a₂ : α} {Γ : α} :
  Γ ≤ (a₁ ⇔ a₂) ↔ Γ ≤ (a₂ ⇔ a₁) :=
by rw biimp_comm

@[simp]lemma imp_le_of_right_le {α : Type*} [boolean_algebra α] {a a₁ a₂ : α} {h : a₁ ≤ a₂} :
  a ⟹ a₁ ≤ (a ⟹ a₂) :=
sup_le (le_sup_left) (le_sup_of_le_right h)

@[simp]lemma imp_le_of_left_le {α : Type*} [boolean_algebra α] {a a₁ a₂ : α} {h : a₂ ≤ a₁} :
  a₁ ⟹ a ≤ (a₂ ⟹ a) :=
sup_le (le_sup_of_le_left (compl_le_compl h)) (le_sup_right)

@[simp]lemma imp_le_of_left_right_le {α : Type*} [boolean_algebra α] {a₁ a₂ b₁ b₂ : α}
{h₁ : b₁ ≤ a₁} {h₂ : a₂ ≤ b₂} :
  a₁ ⟹ a₂ ≤ b₁ ⟹ b₂ :=
sup_le (le_sup_of_le_left (compl_le_compl h₁)) (le_sup_of_le_right h₂)

lemma neg_le_neg' {α : Type*} [boolean_algebra α] {a b : α} : b ≤ aᶜ → a ≤ bᶜ :=
by {intro H, rw[show b = bᶜᶜ, by simp] at H, rwa[<-compl_le_compl_iff_le]}

lemma inf_imp_eq {α : Type*} [boolean_algebra α] {a b c : α} :
  a ⊓ (b ⟹ c) = (a ⟹ b) ⟹ (a ⊓ c) :=
by unfold imp; simp[inf_sup_left]

@[simp]lemma imp_bot {α : Type*} [boolean_algebra α]  {a : α} : a ⟹ ⊥ = aᶜ := by simp[imp]

@[simp]lemma top_imp {α : Type*} [boolean_algebra α] {a : α} : ⊤ ⟹ a = a := by simp[imp]

@[simp]lemma imp_self {α : Type*} [boolean_algebra α] {a : α} : a ⟹ a = ⊤ := by simp[imp]

lemma imp_neg_sub {α : Type*} [boolean_algebra α] {a₁ a₂ : α} :  (a₁ ⟹ a₂)ᶜ = a₁ \ a₂ :=
begin
  rw [imp],
  simp [sdiff_eq]
end

lemma inf_eq_of_le {α : Type*} [distrib_lattice α] {a b : α} (h : a ≤ b) : a ⊓ b = a :=
  by apply le_antisymm; simp[*,le_inf]

lemma imp_inf_le {α : Type*} [boolean_algebra α] (a b : α) : (a ⟹ b) ⊓ a ≤ b :=
by { unfold imp, rw [inf_sup_right], simp }

lemma le_of_sub_eq_bot {α : Type*} [boolean_algebra α] {a b : α} (h : bᶜ ⊓ a = ⊥) : a ≤ b :=
begin
  apply le_of_inf_eq, rw [←compl_compl b, ←sdiff_eq], apply disjoint.sdiff_eq_left,
  simpa [disjoint, inf_comm] using h
end

lemma le_neg_of_inf_eq_bot {α : Type*} [boolean_algebra α] {a b : α} (h : b ⊓ a = ⊥) : a ≤ bᶜ :=
by { apply le_of_sub_eq_bot, rwa [compl_compl] }

lemma sub_eq_bot_of_le {α : Type*} [boolean_algebra α] {a b : α} (h : a ≤ b) : bᶜ ⊓ a = ⊥ :=
by rw [←inf_eq_of_le h, inf_comm, inf_assoc, inf_compl_eq_bot, inf_bot_eq]

lemma inf_eq_bot_of_le_neg {α : Type*} [boolean_algebra α] {a b : α} (h : a ≤ bᶜ) : b ⊓ a = ⊥ :=
by { rw [←compl_compl b], exact sub_eq_bot_of_le h }

/-- the deduction theorem in β -/
@[simp]lemma imp_top_iff_le {α : Type*} [boolean_algebra α] {a₁ a₂ : α} :
  (a₁ ⟹ a₂ = ⊤) ↔ a₁ ≤ a₂ :=
begin
  unfold imp, refine ⟨_,_⟩; intro H,
    { have := congr_arg (λ x, x ⊓ a₁) H, rw[sup_comm] at this,
      finish[inf_sup_right] },
    { have := sup_le_sup_right H a₁ᶜ, finish }
end
/- ∀ {α : Type u_1} [_inst_1 : boolean_algebra α] {a₁ a₂ : α}, a₁ ⟹ a₂ = ⊤ ↔ a₁ ≤ a₂ -/

lemma curry_uncurry {α : Type*} [boolean_algebra α] {a b c : α} : ((a ⊓ b) ⟹ c) = (a ⟹ (b ⟹ c)) :=
  by simp[imp]; ac_refl

/-- the actual deduction theorem in β, thinking of ≤ as a turnstile -/
@[ematch]lemma deduction {α : Type*} [boolean_algebra α] {a b c : α} : a ⊓ b ≤ c ↔ a ≤ (b ⟹ c) :=
  by {[smt] eblast_using [curry_uncurry, imp_top_iff_le]}

-- lemma deduction_simp {α : Type*} [boolean_algebra α] {a b c : α} : a ≤ (b ⟹ c) ↔ a ⊓ b ≤ c := deduction.symm

-- lemma imp_top {α : Type*} [complete_boolean_algebra α] (a : α) : a ≤ a ⟹ ⊤ :=
-- by {rw[<-deduction]; simp}

-- /-- Given an η : option α → β, where β is a complete lattice, we have that the supremum of η
--     is equal to (η none) ⊔ ⨆(a:α) η (some a)-/
-- @[simp]lemma supr_option {α β : Type*} [complete_lattice β] {η : option α → β} : (⨆(x : option α), η x) = (η none) ⊔ ⨆(a : α), η (some a) :=
-- begin
--   apply le_antisymm, tidy, cases i, apply le_sup_left,
--   apply le_sup_right_of_le, apply le_supr (λ x, η (some x)) i, apply le_supr, apply le_supr
-- end

-- /-- Given an η : option α → β, where β is a complete lattice, we have that the infimum of η
--     is equal to (η none) ⊓ ⨅(a:α) η (some a)-/
-- @[simp]lemma infi_option {α β : Type*} [complete_lattice β] {η : option α → β} : (⨅(x : option α), η x) = (η none) ⊓ ⨅(a : α), η (some a) :=
-- begin
--   apply le_antisymm, tidy, tactic.rotate 2, cases i, apply inf_le_left,
--   apply inf_le_right_of_le, apply infi_le (λ x, η (some x)) i, apply infi_le, apply infi_le
-- end

-- lemma supr_option' {α β : Type*} [complete_lattice β] {η : α → β} {b : β} : (⨆(x : option α), (option.rec b η x : β) : β) = b ⊔ ⨆(a : α), η a :=
--   by rw[supr_option]

-- lemma infi_option' {α β : Type*} [complete_lattice β] {η : α → β} {b : β} : (⨅(x : option α), (option.rec b η x : β) : β) = b ⊓ ⨅(a : α), η a :=
--   by rw[infi_option]

-- /-- Let A : α → β such that b = ⨆(a : α) A a. Let c < b. If, for all a : α, A a ≠ b → A a ≤ c,
-- then there exists some x : α such that A x = b. -/
-- lemma supr_max_of_bounded {α β : Type*} [complete_lattice β] {A : α → β} {b c : β}
-- {h : b = ⨆(a:α), A a} {h_lt : c < b} {h_bounded : ∀ a : α, A a ≠ b → A a ≤ c} :
--   ∃ x : α, A x = b :=
-- begin
--   haveI : decidable ∃ (x : α), A x = b := classical.prop_decidable _,
--   by_contra, rw[h] at a, simp at a,
--   suffices : b ≤ c, by {suffices : c < c, by {exfalso, have this' := lt_irrefl,
--   show Type*, exact β, show preorder (id β), by {dsimp, apply_instance}, exact this' c this},
--   exact lt_of_lt_of_le h_lt this},
--   rw[h], apply supr_le, intro a', from h_bounded a' (by convert a a')
-- end

-- /-- Let A : α → β such that b ≤ ⨆(a : α) A a. Let c < b. If, for all a : α, A a ≠ b → A a ≤ c,
-- then there exists some x : α such that b ≤ A x. -/
-- lemma supr_max_of_bounded' {α β : Type*} [complete_lattice β] {A : α → β} {b c : β}
-- {h : b ≤ ⨆(a:α), A a} {h_lt : c < b} {h_bounded : ∀ a : α, (¬ b ≤ A a) → A a ≤ c} :
--   ∃ x : α, b ≤ A x :=
-- begin
--   haveI : decidable ∃ (x : α), b ≤ A x := classical.prop_decidable _,
--   by_contra, simp at a,
--   suffices : b ≤ c, by {suffices : c < c, by {exfalso, have this' := lt_irrefl,
--   show Type*, exact β, show preorder (id β), by {dsimp, apply_instance}, exact this' c this},
--   exact lt_of_lt_of_le h_lt this},
--   apply le_trans h, apply supr_le, intro a', from h_bounded a' (a a')
-- end

-- /-- As a consequence of the previous lemma, if ⨆(a : α), A a = ⊤ such that whenever A a ≠ ⊤ → A α = ⊥, there exists some x : α such that A x = ⊤. -/
-- lemma supr_eq_top_max {α β : Type*} [complete_lattice β] {A : α → β} {h_nondeg : ⊥ < (⊤ : β)}
-- {h_top : (⨆(a : α), A a) = ⊤} {h_bounded : ∀ a : α, A a ≠ ⊤ → A a = ⊥} : ∃ x : α, A x = ⊤ :=
--   by {apply supr_max_of_bounded, cc, exact h_nondeg, tidy}

-- lemma supr_eq_Gamma_max {α β : Type*} [complete_lattice β] {A : α → β} {Γ : β} (h_nonzero : ⊥ < Γ)
-- (h_Γ : Γ ≤ (⨆a, A a)) (h_bounded : ∀ a, (¬ Γ ≤ A a) → A a = ⊥) : ∃ x : α, Γ ≤ A x :=
-- begin
--   apply supr_max_of_bounded', from ‹_›, from ‹_›, intros a H,
--   specialize h_bounded a ‹_›, rwa[le_bot_iff]
-- end

-- /-- "eoc" means the opposite of "coe", of course -/
-- lemma eoc_supr {ι β : Type*} {s : ι → β} [complete_lattice β] {X : set ι} :
--   (⨆(i : X), s i) = ⨆(i ∈ X), s i :=
-- begin
--   apply le_antisymm; repeat{apply supr_le; intro},
--   apply le_supr_of_le i.val, apply le_supr_of_le, exact i.property, refl,
--   apply le_supr_of_le, swap, use i, assumption, refl
-- end

-- /- Can reindex sup over all sets -/
-- lemma supr_all_sets {ι β : Type*} {s : ι → β} [complete_lattice β] :
--   (⨆(i:ι), s i) = ⨆(X : set ι), (⨆(x : X), s x) :=
-- begin
--   apply le_antisymm,
--     {apply supr_le, intro i, apply le_supr_of_le {i}, apply le_supr_of_le, swap,
--      use i, from set.mem_singleton i, simp},
--     {apply supr_le, intro X, apply supr_le, intro i, apply le_supr}
-- end

-- lemma supr_all_sets' {ι β : Type*} {s : ι → β} [complete_lattice β] :
--   (⨆(i:ι), s i) = ⨆(X : set ι), (⨆(x ∈ X), s x) :=
-- by {convert supr_all_sets using 1, simp[eoc_supr]}

-- -- `b ≤ ⨆(i:ι) c i` if there exists an s : set ι such that b ≤ ⨆ (i : s), c s
-- lemma le_supr_of_le' {ι β : Type*} {s : ι → β} {b : β} [complete_lattice β]
--   (H : ∃ X : set ι, b ≤ ⨆(x:X), s x) : b ≤ ⨆(i:ι), s i :=
-- begin
--   rcases H with ⟨X, H_X⟩, apply le_trans H_X,
--   conv{to_rhs, rw[supr_all_sets]},
--   from le_supr_of_le X (by refl)
-- end

-- lemma le_supr_of_le'' {ι β : Type*} {s : ι → β} {b : β} [complete_lattice β]
--   (H : ∃ X : set ι, b ≤ ⨆(x ∈ X), s x) : b ≤ ⨆(i:ι), s i :=
-- by {apply le_supr_of_le', convert H using 1, simp[eoc_supr]}

-- lemma infi_congr {ι β : Type*} {s₁ s₂ : ι → β} [complete_lattice β] {h : ∀ i : ι, s₁ i = s₂ i} :
--   (⨅(i:ι), s₁ i) = ⨅(i:ι), s₂ i :=
-- by simp*

-- @[simp]lemma supr_congr {ι β : Type*} {s₁ s₂ : ι → β} [complete_lattice β] {h : ∀ i : ι, s₁ i = s₂ i} :
--   (⨆(i:ι), s₁ i) = ⨆(i:ι), s₂ i :=
-- by simp*

-- lemma imp_iff {β : Type*} {a b : β} [complete_boolean_algebra β] : a ⟹ b = -a ⊔ b := by refl

-- lemma sup_inf_left_right_eq {β} [distrib_lattice β] {a b c d : β} :
--   (a ⊓ b) ⊔ (c ⊓ d) = (a ⊔ c) ⊓ (a ⊔ d) ⊓ (b ⊔ c) ⊓ (b ⊔ d) :=
-- by {rw[sup_inf_right, sup_inf_left, sup_inf_left]; ac_refl}

-- lemma inf_sup_right_left_eq {β} [distrib_lattice β] {a b c d : β} :
--   (a ⊔ b) ⊓ (c ⊔ d) = (a ⊓ c) ⊔ (a ⊓ d) ⊔ (b ⊓ c) ⊔ (b ⊓ d) :=
-- by {rw[inf_sup_right, inf_sup_left, inf_sup_left], ac_refl}

-- -- by {[smt] eblast_using[sup_inf_right, sup_inf_left]}
-- -- interesting, this takes like 5 seconds
-- -- probably because both of those rules can be applied pretty much everywhere in the goal
-- -- and eblast is trying all of them

-- lemma eq_neg_of_partition {β} [boolean_algebra β] {a₁ a₂ : β} (h_anti : a₁ ⊓ a₂ = ⊥) (h_partition : a₁ ⊔ a₂ = ⊤) :
--   a₂ = - a₁ :=
-- begin
--   rw[show -a₁ = ⊤ ⊓ -a₁, by simp], rw[<-sub_eq],
--   rw[<-h_partition,sub_eq], rw[inf_sup_right],
--   simp*, rw[<-sub_eq], rw[inf_comm] at h_anti,
--   from (sub_eq_left h_anti).symm
-- end

lemma le_trans' {β} [lattice β] {a₁ a₂ a₃ : β} (h₁ : a₁ ≤ a₂) {h₂ : a₁ ⊓ a₂ ≤ a₃} : a₁ ≤ a₃ :=
begin
  suffices : a₁ ≤ a₁ ⊓ a₂, from le_trans this ‹_›,
  rw[show a₁ = a₁ ⊓ a₁, by simp], conv {to_rhs, rw[inf_assoc]},
  apply inf_le_inf, refl, apply le_inf, refl, assumption
end

@[simp]lemma top_le_imp_top {β : Type*} {b : β} [boolean_algebra β] : ⊤ ≤ b ⟹ ⊤ :=
by rw[<-deduction]; apply le_top

lemma poset_yoneda_iff {β : Type*} [partial_order β] {a b : β} :
  a ≤ b ↔ (∀ {Γ : β}, Γ ≤ a → Γ ≤ b) := ⟨λ _, by finish, λ H, by specialize @H a; finish⟩

lemma poset_yoneda_top {β : Type*} [lattice β] [bounded_order β] {b : β} :
  ⊤ ≤ b ↔ (∀ {Γ : β}, Γ ≤ b) := ⟨λ _, by finish, λ H, by apply H⟩

lemma poset_yoneda {β : Type*} [partial_order β] {a b : β} (H : ∀ Γ : β, Γ ≤ a → Γ ≤ b) : a ≤ b :=
by rwa poset_yoneda_iff

lemma poset_yoneda_inv {β : Type*} [partial_order β] {a b : β} (Γ : β) (H : a ≤ b) :
  Γ ≤ a → Γ ≤ b := by rw poset_yoneda_iff at H; apply H

lemma split_context {β : Type*} [lattice β] {a₁ a₂ b : β} {H : ∀ Γ : β, Γ ≤ a₁ ∧ Γ ≤ a₂ → Γ ≤ b} :
  a₁ ⊓ a₂ ≤ b := by {apply poset_yoneda, intros Γ H', apply H, finish}

example {β : Type*} [lattice β] [bounded_order β] : ⊤ ⊓ (⊤ : β) ⊓ ⊤ ≤ ⊤ :=
begin
  apply split_context, intros _ a, simp only [le_inf_iff] at a, auto.split_hyps, from ‹_›
end

lemma context_Or_elim {β : Type*} [complete_boolean_algebra β] {ι} {s : ι → β} {Γ b : β}
  (h : Γ ≤ ⨆(i:ι), s i) {h' : ∀ i, s i ⊓ Γ ≤ s i → s i ⊓ Γ ≤ b} : Γ ≤ b :=
begin
  apply le_trans' h, rw[inf_comm], rw[deduction], apply supr_le, intro i, rw[<-deduction],
  specialize h' i, apply h', apply inf_le_left
end

lemma context_or_elim {β : Type*} [complete_boolean_algebra β] {Γ a₁ a₂ b : β}
  (H : Γ ≤ a₁ ⊔ a₂) {H₁ : a₁ ⊓ Γ ≤ a₁ → a₁ ⊓ Γ ≤ b} {H₂ : a₂ ⊓ Γ ≤ a₂ → a₂ ⊓ Γ ≤ b} : Γ ≤ b :=
begin
  apply le_trans' H, rw[inf_comm], rw[deduction], apply sup_le; rw[<-deduction];
  [apply H₁, apply H₂]; from inf_le_left
end

lemma bv_em_aux {β : Type*} [complete_boolean_algebra β] (Γ : β) (b : β) : Γ ≤ b ⊔ bᶜ :=
le_trans le_top $ by rw [sup_compl_eq_top]

lemma bv_em {β : Type*} [complete_boolean_algebra β] {Γ : β} (b : β) : Γ ≤ b ⊔ bᶜ :=
bv_em_aux _ _

lemma diagonal_supr_le_supr {α} [complete_lattice α]
  {ι} {s : ι → ι → α} {Γ : α} (H : Γ ≤ ⨆ i, s i i) : Γ ≤ ⨆ i j, s i j :=
le_trans H $ supr_le $ λ i,  le_supr_of_le i $ le_supr_of_le i $ by refl

lemma diagonal_infi_le_infi {α} [complete_lattice α]
  {ι} {s : ι → ι → α} {Γ : α} (H : Γ ≤ ⨅ i j, s i j) : Γ ≤ ⨅ i, s i i :=
le_trans H $ le_infi $ λ i, infi_le_of_le i $ infi_le_of_le i $ by refl

lemma context_and_intro {β : Type*} [lattice β] {Γ} {a₁ a₂ : β}
  (H₁ : Γ ≤ a₁) (H₂ : Γ ≤ a₂) : Γ ≤ a₁ ⊓ a₂ := le_inf ‹_› ‹_›

lemma specialize_context {β : Type*} [partial_order β]
  {Γ b : β} (Γ' : β) {H_le : Γ' ≤ Γ} (H : Γ ≤ b) : Γ' ≤ b := _root_.le_trans H_le H

lemma context_specialize_aux {β : Type*} [complete_boolean_algebra β] {ι : Type*} {s : ι → β}
  (j : ι) {Γ : β} {H : Γ ≤ (⨅ i, s i)} : Γ ≤ (⨅i, s i) ⟹ s j :=
by {apply le_trans H, rw[<-deduction], apply inf_le_of_right_le, apply infi_le}

lemma context_specialize {β : Type*} [complete_lattice β] {ι : Type*} {s : ι → β}
  {Γ : β} (H : Γ ≤ (⨅ i, s i)) (j : ι) : Γ ≤ s j :=
_root_.le_trans H (infi_le _ _)

lemma context_specialize_strict {β : Type*} [complete_lattice β] {ι : Type*} {s : ι → β}
  {Γ : β} (H : Γ < (⨅ i, s i)) (j : ι) : Γ < s j :=
begin
  apply lt_iff_le_and_ne.mpr, split, from _root_.le_trans (le_of_lt H) (infi_le _ _),
  intro H', apply @lt_irrefl β _ _, show β, from (⨅ i, s i),
  apply lt_of_le_of_lt, show β, from Γ, rw[H'], apply infi_le, from ‹_›
end

lemma context_split_inf_left {β : Type*} [complete_lattice β] {a₁ a₂ Γ: β} (H : Γ ≤ a₁ ⊓ a₂) :
  Γ ≤ a₁ := by {rw[le_inf_iff] at H, finish}

lemma context_split_inf_right {β : Type*} [complete_lattice β] {a₁ a₂ Γ: β} (H : Γ ≤ a₁ ⊓ a₂) :
  Γ ≤ a₂ :=
by {rw[le_inf_iff] at H, finish}

lemma context_imp_elim {β : Type*} [complete_boolean_algebra β]
  {a b Γ: β} (H₁ : Γ ≤ a ⟹ b) (H₂ : Γ ≤ a) : Γ ≤ b :=
begin
  apply le_trans' H₁, apply le_trans, apply inf_le_inf H₂, refl,
  rw[inf_comm], simp [imp, inf_sup_right, inf_le_left],
end

lemma context_imp_intro {β : Type*} [complete_boolean_algebra β]
  {a b Γ : β} (H : a ⊓ Γ ≤ a → a ⊓ Γ ≤ b) : Γ ≤ a ⟹ b :=
by {rw[<-deduction, inf_comm], from H (inf_le_left)}

instance imp_to_pi {β } [complete_boolean_algebra β] {Γ a b : β} :
  has_coe_to_fun (Γ ≤ a ⟹ b) (λ x, Γ ≤ a → Γ ≤ b) :=
{ coe := λ H₁ H₂, by {apply context_imp_elim; from ‹_›}}

instance infi_to_pi {ι β} [complete_boolean_algebra β] {Γ : β} {ϕ : ι → β} :
  has_coe_to_fun (Γ ≤ infi ϕ) (λ x, Π i : ι, Γ ≤ ϕ i):=
{
  coe := λ H₁ i, by {change Γ ≤ ϕ i, change Γ ≤ _ at H₁, finish}}

lemma bv_absurd {β} [boolean_algebra β] {Γ : β} (b : β) (H₁ : Γ ≤ b) (H₂ : Γ ≤ bᶜ) : Γ ≤ ⊥ :=
@le_trans _ _ _ (b ⊓ bᶜ) _ (le_inf ‹_› ‹_›) inf_compl_eq_bot.le

lemma neg_imp {β : Type*} [boolean_algebra β] {a b : β} : (a ⟹ b)ᶜ = a ⊓ bᶜ :=
by simp[imp]

lemma nonzero_wit {β : Type*} [complete_lattice β] {ι : Type*} {s : ι → β} :
  (⊥ < (⨆i, s i)) → ∃ j, (⊥ < s j) :=
begin
  intro H, have := bot_lt_iff_not_le_bot.mp ‹_›,
  haveI : decidable (∃ (j : ι), ⊥ < s j) := classical.prop_decidable _,
  by_contra a, apply this, apply supr_le, intro i, rw[not_exists] at a,
  specialize a i, haveI : decidable (s i ≤ ⊥) := classical.prop_decidable _,
  by_contra, have := @bot_lt_iff_not_le_bot β _ _ (s i), tauto
end

-- lemma nonzero_wit' {β : Type*} [complete_distrib_lattice β] {ι : Type*} {s : ι → β} {Γ : β}
--   (H_nonzero : ⊥ < Γ) (H_le : Γ ≤ ⨆ i , s i ):
--   ∃ j, (⊥ < s j ⊓ Γ) :=
-- begin
--   haveI : decidable (∃ j, (⊥ < s j ⊓ Γ)) := classical.prop_decidable _,
--   by_contra H, push_neg at H, simp only [(not_congr bot_lt_iff_not_le_bot)] at H,
--   have this : (⨆j, s j ⊓ Γ) ≤ ⊥ := supr_le (λ i, classical.by_contradiction $ H ‹_›),
--   rw[<-supr_inf_eq] at this,
--   suffices H_bad : Γ ⊓ Γ ≤ ⊥,
--     by {[smt] eblast_using [bot_lt_iff_not_le_bot, inf_self], },
--   exact le_trans (inf_le_inf ‹_› (by refl)) ‹_›,
-- end

def CCC (𝔹 : Type u) [boolean_algebra 𝔹] : Prop :=
  ∀ ι : Type u, ∀ 𝓐 : ι → 𝔹, (∀ i, ⊥ < 𝓐 i) →
    (∀ i j, i ≠ j → 𝓐 i ⊓ 𝓐 j ≤ ⊥) → (cardinal.mk ι) ≤ cardinal.omega

@[reducible]noncomputable def Prop_to_bot_top {𝔹 : Type u} [has_bot 𝔹] [has_top 𝔹] : Prop → 𝔹 :=
λ p, by {haveI : decidable p := classical.prop_decidable _, by_cases p, from ⊤, from ⊥}

@[simp]lemma Prop_to_bot_top_true {𝔹 : Type u} [has_bot 𝔹] [has_top 𝔹] {p : Prop} {H : p} :
  Prop_to_bot_top p = (⊤ : 𝔹) := by simp[*, Prop_to_bot_top]

@[simp]lemma Prop_to_bot_top_false {𝔹 : Type u} [has_bot 𝔹] [has_top 𝔹] {p : Prop} {H : ¬ p} :
  Prop_to_bot_top p = (⊥ : 𝔹) := by simp[*, Prop_to_bot_top]

lemma bv_by_contra {𝔹} [boolean_algebra 𝔹] {Γ b : 𝔹} (H : Γ ≤ bᶜ ⟹ ⊥) : Γ ≤ b := by simpa using H

-- noncomputable def to_boolean_valued_set {𝔹} [has_bot 𝔹] [has_top 𝔹] {α} : set α → (α → 𝔹) :=
-- λ s, Prop_to_bot_top ∘ s

run_cmd mk_simp_attr `bv_push_neg

attribute [bv_push_neg] compl_infi compl_supr compl_Inf compl_Sup compl_inf
  compl_sup compl_top compl_bot compl_compl lattice.neg_imp

end lattice

namespace tactic
namespace interactive

meta def back_chaining : tactic unit := local_context >>= tactic.back_chaining_core skip (`[simp*])

section natded_tactics
open tactic interactive tactic.tidy
open lean.parser lean interactive.types

local postfix `?`:9001 := optional
meta def bv_intro : interactive.parse ident_? → tactic unit
| none := propagate_tags (`[refine le_infi _] >> intro1 >> tactic.skip)
| (some n) := propagate_tags (`[refine le_infi _] >> tactic.intro n >> tactic.skip)

meta def get_name : ∀(e : expr), name
| (expr.const c [])          := c
| (expr.local_const _ c _ _) := c
| _                          := name.anonymous

meta def lhs_rhs_of_le (e : expr) : tactic (expr × expr) :=
do `(%%x ≤ %%y) <- pure e,
   return (x,y)

meta def lhs_of_le (e : expr) : tactic expr :=
lhs_rhs_of_le e >>= λ x, return x.1

meta def rhs_of_le (e : expr) : tactic expr :=
lhs_rhs_of_le e >>= λ x, return x.2

-- meta def lhs_of_le (e : expr) : tactic expr :=
-- do v_a <- mk_mvar,
--    e' <- to_expr ``(%%v_a ≤ _),
--    unify e e',
--    return v_a

meta def goal_is_bot : tactic bool :=
do b <- get_goal >>= rhs_of_le,
   succeeds $ to_expr ``(by refl : %%b = ⊥)

meta def hyp_is_ineq (e : expr) : tactic bool :=
  (do `(%%x ≤ %%y) <- infer_type e,
     return tt)<|> return ff

meta def hyp_is_neg_ineq (e : expr) : tactic bool :=
  (do `(%%x ≤ - %%y) <- infer_type e,
     return tt) <|> return ff

meta def trace_inequalities : tactic unit :=
  (local_context >>= λ l, l.mfilter (hyp_is_ineq)) >>= trace

meta def hyp_is_ineq_sup (e : expr) : tactic bool :=
  (do `(%%x ≤ %%y ⊔ %%z) <- infer_type e,
     return tt)<|> return ff

meta def get_current_context : tactic expr := target >>= lhs_of_le

meta def trace_sup_inequalities : tactic unit :=
  (local_context >>= λ l, l.mfilter (hyp_is_ineq_sup)) >>= trace

meta def specialize_context_at (H : interactive.parse ident) (Γ : interactive.parse texpr) : tactic unit :=
do e <- resolve_name H,
   tactic.replace H ``(lattice.specialize_context %%Γ %%e),
   swap >> try `[refine lattice.le_top] >> skip

meta def specialize_context_core (Γ_old : expr) : tactic unit :=
do  v_a <- target >>= lhs_of_le,
    tp <- infer_type Γ_old,
    Γ_name <- get_unused_name "Γ",
    v <- mk_mvar, v' <- mk_mvar,
    Γ_new <- pose Γ_name none v,
    -- TODO(jesse) try replacing to_expr with an expression via mk_app instead
    new_goal <- to_expr ``((%%Γ_new : %%tp) ≤ %%v'),
    tactic.change new_goal,
    ctx <- local_context,
    ctx' <- ctx.mfilter
      (λ e, (do infer_type e >>= lhs_of_le >>= λ e', succeeds $ is_def_eq Γ_old e') <|> return ff),
      ctx'.mmap' (λ H, tactic.replace (get_name H) ``(lattice.le_trans _ _ _ (by exact inf_le_right <|> simp : %%Γ_new ≤ _) %%H)),
    ctx2 <- local_context,
    ctx2' <- ctx.mfilter (λ e, (do infer_type e >>= lhs_of_le >>= instantiate_mvars >>= λ e', succeeds $ is_def_eq Γ_new e') <|> return ff),
    -- trace ctx2',
    ctx2'.mmap' (λ H, do H_tp <- infer_type H,
                         e'' <- lhs_of_le H_tp,
                         succeeds (unify Γ_new e'') >>
                   tactic.replace (get_name H) ``(_ : %%Γ_new ≤ _) >> swap >> assumption)

meta def specialize_context_core' (Γ_old : expr) : tactic unit :=
do  v_a <- target >>= lhs_of_le,
    tp <- infer_type Γ_old,
    Γ_name <- get_unused_name "Γ",
    v <- mk_mvar, v' <- mk_mvar,
    Γ_new <- pose Γ_name none v,
    -- TODO(jesse) try replacing to_expr with an expression via mk_app instead
    new_goal <- to_expr ``((%%Γ_new : %%tp) ≤ %%v'),
    tactic.change new_goal,
    ctx <- local_context,
    ctx' <- ctx.mfilter
      (λ e, (do infer_type e >>= lhs_of_le >>= λ e', succeeds $ is_def_eq Γ_old e') <|> return ff),
      ctx'.mmap' (λ H, to_expr ``(le_trans (by exact inf_le_right <|> simp : %%Γ_new ≤ _) %%H) >>= λ foo, tactic.note (get_name H) none foo),
    ctx2 <- local_context,
    ctx2' <- ctx.mfilter (λ e, (do infer_type e >>= lhs_of_le >>= instantiate_mvars >>= λ e', succeeds $ is_def_eq Γ_new e') <|> return ff),
    -- trace ctx2',
    ctx2'.mmap' (λ H, do H_tp <- infer_type H,
                         e'' <- lhs_of_le H_tp,
                         succeeds (unify Γ_new e'') >>
                   tactic.replace (get_name H) ``(_ : %%Γ_new ≤ _) >> swap >> assumption)

meta def specialize_context_assumption_core (Γ_old : expr) : tactic unit :=
do  v_a <- target >>= lhs_of_le,
    tp <- infer_type Γ_old,
    Γ_name <- get_unused_name "Γ",
    v <- mk_mvar, v' <- mk_mvar,
    Γ_new <- pose Γ_name none v,
    -- TODO(jesse) try replacing to_expr with an expression via mk_app instead
    new_goal <- to_expr ``((%%Γ_new : %%tp) ≤ %%v'),
    tactic.change new_goal,
    ctx <- local_context,
    ctx' <- ctx.mfilter
      (λ e, (do infer_type e >>= lhs_of_le >>= λ e', succeeds $ is_def_eq Γ_old e') <|> return ff),
      ctx'.mmap' (λ H, tactic.replace (get_name H) ``(le_trans (by exact inf_le_right <|> assumption : %%Γ_new ≤ _) %%H)),
    ctx2 <- local_context,
    ctx2' <- ctx.mfilter (λ e, (do infer_type e >>= lhs_of_le >>= instantiate_mvars >>= λ e', succeeds $ is_def_eq Γ_new e') <|> return ff),
    -- trace ctx2',
    ctx2'.mmap' (λ H, do H_tp <- infer_type H,
                         e'' <- lhs_of_le H_tp,
                         succeeds (unify Γ_new e'') >>
                   tactic.replace (get_name H) ``(_ : %%Γ_new ≤ _) >> swap >> assumption)

/-- If the goal is an inequality `a ≤ b`, extracts `a` and attempts to specialize all
  facts in context of the form `Γ ≤ d` to `a ≤ d` (this requires a ≤ Γ) -/
meta def specialize_context (Γ : interactive.parse texpr) : tactic unit :=
do
  Γ_old <- i_to_expr Γ,
  specialize_context_core Γ_old

meta def specialize_context_assumption (Γ : interactive.parse texpr) : tactic unit :=
do
  Γ_old <- i_to_expr Γ,
  specialize_context_assumption_core Γ_old

meta def specialize_context' (Γ : interactive.parse texpr) : tactic unit :=
do
  Γ_old <- i_to_expr Γ,
  specialize_context_core' Γ_old

example {β : Type u} [lattice β] [bounded_order β] {a b : β} {H : ⊤ ≤ b} : a ≤ b :=
by {specialize_context (⊤ : β), assumption}

meta def bv_exfalso : tactic unit :=
  `[refine le_trans _ (_root_.lattice.bot_le)]

meta def bv_cases_at (H : interactive.parse ident) (i : interactive.parse ident_) (H_i : interactive.parse ident?)  : tactic unit :=
do
  e₀ <- resolve_name H,
  e₀' <- to_expr e₀,
  Γ_old <- target >>= lhs_of_le,
  `[refine lattice.context_Or_elim %%e₀'],
  match H_i with
  | none :=  tactic.intro i >> ((get_unused_name H) >>= tactic.intro)
  | (some n) := tactic.intro i >> (tactic.intro n)
  end,
  specialize_context_core Γ_old

meta def bv_cases_at' (H : interactive.parse ident) (i : interactive.parse ident_) (H_i : interactive.parse ident?)  : tactic unit :=
do
  e₀ <- resolve_name H,
  e₀' <- to_expr e₀,
  Γ_old <- target >>= lhs_of_le,
  `[refine lattice.context_Or_elim %%e₀'],
  match H_i with
  | none :=  tactic.intro i >> ((get_unused_name H) >>= tactic.intro)
  | (some n) := tactic.intro i >> (tactic.intro n)
  end,
  specialize_context_core' Γ_old

meta def bv_cases_at'' (H : interactive.parse ident) (i : interactive.parse ident_)  : tactic unit :=
do
  e₀ <- resolve_name H,
  e₀' <- to_expr e₀,
  Γ_old <- target >>= lhs_of_le,
  `[refine lattice.context_Or_elim %%e₀'],
  tactic.intro i >> ((get_unused_name H) >>= tactic.intro) >>
  skip

-- here `e` is the proof of Γ ≤ a ⊔ b
meta def bv_or_elim_at_core (e : expr) (Γ_old : expr) (n_H : name) : tactic unit :=
do
   n <- get_unused_name (n_H ++ "left"),
   n' <- get_unused_name (n_H ++ "right"),
   `[apply lattice.context_or_elim %%e],
   (tactic.intro n) >> specialize_context_core Γ_old, swap,
   (tactic.intro n') >> specialize_context_core Γ_old, swap

meta def bv_or_elim_at_core' (e : expr) (Γ_old : expr) (n_H : name) : tactic unit :=
do
   n <- get_unused_name (n_H ++ "left"),
   n' <- get_unused_name (n_H ++ "right"),
   `[apply lattice.context_or_elim %%e],
   (tactic.intro n) >> specialize_context_core' Γ_old, swap,
   (tactic.intro n') >> specialize_context_core' Γ_old, swap

meta def bv_or_elim_at_core'' (e : expr) (Γ_old : expr) (n_H : name) : tactic unit :=
do
   n <- get_unused_name (n_H ++ "left"),
   n' <- get_unused_name (n_H ++ "right"),
   `[apply lattice.context_or_elim %%e]; tactic.clear e,
   (tactic.intro n) >> specialize_context_core' Γ_old, swap,
   (tactic.intro n') >> specialize_context_core' Γ_old, swap

meta def bv_or_elim_at (H : interactive.parse ident) : tactic unit :=
do Γ_old <- target >>= lhs_of_le,
   e <- resolve_name H >>= to_expr,
   bv_or_elim_at_core e Γ_old H

-- `px` is a term of type `𝔹`; this cases on "`px ∨ ¬ px`"
meta def bv_cases_on (px : interactive.parse texpr) (opt_id : interactive.parse (tk "with" *> ident)?) : tactic unit :=
do Γ_old ← target >>= lhs_of_le,
   e ← to_expr ``(lattice.bv_em_aux %%Γ_old %%px),
   let nm := option.get_or_else opt_id "H",
   get_unused_name nm >>= bv_or_elim_at_core e Γ_old

meta def bv_or_elim_at' (H : interactive.parse ident) : tactic unit :=
do Γ_old <- target >>= lhs_of_le,
   e <- resolve_name H >>= to_expr,
   bv_or_elim_at_core' e Γ_old H

-- `px` is a term of type `𝔹`; this cases on "`px ∨ ¬ px`"
meta def bv_cases_on' (px : interactive.parse texpr) (opt_id : interactive.parse (tk "with" *> ident)?) : tactic unit :=
do Γ_old ← target >>= lhs_of_le,
   e ← to_expr ``(lattice.bv_em_aux %%Γ_old %%px),
   let nm := option.get_or_else opt_id "H",
   get_unused_name nm >>= bv_or_elim_at_core' e Γ_old

example {β : Type*} [complete_boolean_algebra β] {Γ : β} : Γ ≤ ⊤ :=
begin
  bv_cases_on ⊤,
    { from ‹_› },
    { by simp* }
end

-- TODO(jesse) debug these
-- meta def auto_or_elim_step : tactic unit :=
-- do  ctx <- local_context >>= (λ l, l.mfilter hyp_is_ineq_sup),
--     if ctx.length > 0 then
--     ctx.mmap' (λ e, do Γ_old <- target >>= lhs_of_le, bv_or_elim_at_core e Γ_old)
--     else tactic.failed

-- meta def auto_or_elim : tactic unit := tactic.repeat auto_or_elim_step

-- example {β ι : Type u} [lattice.complete_boolean_algebra β] {s : ι → β} {H' : ⊤ ≤ ⨆i, s i} {b : β} : b ≤ ⊤ :=
-- by {specialize_context ⊤, bv_cases_at H' i, specialize_context Γ, sorry }

meta def bv_exists_intro (i : interactive.parse texpr): tactic unit :=
  `[refine le_supr_of_le %%i _]

def eta_beta_cfg : dsimp_config :=
{ md := reducible,
  max_steps := simp.default_max_steps,
  canonize_instances := tt,
  single_pass := ff,
  fail_if_unchanged := ff,
  eta := tt,
  zeta := ff,
  beta := tt,
  proj := ff,
  iota := ff,
  unfold_reducible := ff,
  memoize := tt }

meta def bv_specialize_at (H : interactive.parse ident) (j : interactive.parse texpr) : tactic unit :=
do n <- get_unused_name H,
   e_H <- resolve_name H,
   e <- to_expr ``(lattice.context_specialize %%e_H %%j),
   note n none e >>= λ h, dsimp_hyp h none [] eta_beta_cfg

meta def bv_to_pi (H : interactive.parse ident) : tactic unit :=
do   e_H <- resolve_name H,
     e_rhs <- to_expr e_H >>= infer_type >>= rhs_of_le,
     (tactic.replace H  ``(lattice.context_specialize %%e_H) <|>
     tactic.replace H ``(lattice.context_imp_elim %%e_H)) <|>
     tactic.fail "target is not a ⨅ or an ⟹"

meta def bv_to_pi' : tactic unit :=
do ctx <- (local_context >>= (λ l, l.mfilter hyp_is_ineq)),
   ctx.mmap' (λ e, try ((tactic.replace (get_name e)  ``(lattice.context_specialize %%e) <|>
     tactic.replace (get_name e) ``(lattice.context_imp_elim %%e))))

meta def bv_split_at (H : interactive.parse ident) : tactic unit :=
do e_H <- resolve_name H,
   tactic.replace H ``(le_inf_iff.mp %%e_H),
   resolve_name H >>= to_expr >>= cases_core

meta def bv_split : tactic unit :=
do ctx <- (local_context >>= (λ l, l.mfilter hyp_is_ineq)),
   ctx.mmap' (λ e, try (tactic.replace (get_name e) ``(lattice.le_inf_iff.mp %%e))),
   auto_cases >> skip

meta def bv_and_intro (H₁ H₂ : interactive.parse ident) : tactic unit :=
do
  H₁ <- resolve_name H₁,
  H₂ <- resolve_name H₂,
  e <- to_expr ``(lattice.context_and_intro %%H₁ %%H₂),
   n <- get_unused_name "H",
   note n none e >> skip

meta def bv_imp_elim_at (H₁ : interactive.parse ident) (H₂ : interactive.parse texpr) : tactic unit :=
do n <- get_unused_name "H",
   e₁ <- resolve_name H₁,
   e <- to_expr ``(lattice.context_imp_elim %%e₁ %%H₂),
   note n none e >>= λ h, dsimp_hyp h none [] eta_beta_cfg

meta def bv_mp (H : interactive.parse ident) (H₂ : interactive.parse texpr) : tactic unit :=
do
   n <- get_unused_name H,
   e_H <- resolve_name H,
   e_L <- to_expr H₂,
   pr <- to_expr ``(le_trans %%e_H %%e_L),
   note n none pr >>= λ h, dsimp_hyp h none [] eta_beta_cfg

meta def bv_imp_intro (nm : interactive.parse $ optional ident_) : tactic unit :=
match nm with
| none := do Γ_old <- target >>= lhs_of_le,
  `[refine lattice.context_imp_intro _ ] >> (get_unused_name "H" >>= tactic.intro) >> skip,
  specialize_context_core Γ_old
| (some n) := do Γ_old <- target >>= lhs_of_le,
  `[refine lattice.context_imp_intro _ ] >> (tactic.intro n) >> skip,
  specialize_context_core Γ_old
end

meta def bv_imp_intro' (nm : interactive.parse $ optional ident_) : tactic unit :=
match nm with
| none := do Γ_old <- target >>= lhs_of_le,
  `[refine lattice.context_imp_intro _] >> (get_unused_name "H" >>= tactic.intro) >> skip,
  specialize_context_core' Γ_old
| (some n) := do Γ_old <- target >>= lhs_of_le,
  `[refine lattice.context_imp_intro _] >> (tactic.intro n) >> skip,
  specialize_context_core' Γ_old
end

meta def tidy_context_tactics : list (tactic string) :=
[ reflexivity                                 >> pure "refl",
  propositional_goal >> assumption            >> pure "assumption",
  intros1                                     >>= λ ns, pure ("intros " ++ (" ".intercalate (ns.map (λ e, e.to_string)))),
  auto_cases,
  `[simp only [_root_.lattice.le_inf_iff] at *]                                >> pure "simp only [le_inf_iff] at *",
  propositional_goal >> (`[solve_by_elim])    >> pure "solve_by_elim"
]

meta def tidy_split_goals_tactics : list (tactic string) :=
[ reflexivity >> pure "refl",
 propositional_goal >> assumption >> pure "assumption",
  propositional_goal >> (`[solve_by_elim])    >> pure "solve_by_elim",
  `[refine lattice.le_inf _ _] >> pure "refine lattice.le_inf _ _",
  `[exact bv_refl]        >> pure "exact bv_refl _",
  `[rw[bSet.bv_eq_symm]] >> assumption >> pure "rw[bSet.bv_eq_symm], assumption",
   bv_intro none >> pure "bv_intro"
]

meta def bv_split_goal (trace : interactive.parse $ optional (tk "?")) : tactic unit :=
  tactic.tidy {trace_result := trace.is_some, tactics := tidy_split_goals_tactics}

meta def bv_or_inr : tactic unit := `[refine le_sup_right_of_le _]
meta def bv_or_inl : tactic unit := `[refine le_sup_left_of_le _]

/--
Succeeds on `e` iff `e` can be matched to the pattern x ≤ - y
-/
private meta def is_le_neg (e : expr) : tactic (expr × expr) :=
do `(%%x ≤ - %%y) <- pure e, return (x,y)

-- private meta def le_not (lhs : expr) (rhs : expr) : expr → tactic expr := λ e,
-- do `(%%x ≤ - %%y) <- pure e,
--    is_def_eq x lhs >> is_def_eq y rhs >> return e

/--
Given an expr `e` such that the type of `e` is `x ≤ -y`, succeed if an expression of type `x ≤ y` is in context and return it.
-/
private meta def find_dual_of (ctx_le : list expr) (ctx_le_negated : list expr) (e : expr) : tactic expr :=
do `(%%y₁ ≤ - %%y₂) <- (infer_type e),
   match ctx_le with
   | [] := tactic.fail "there are no hypotheses"
   | hd :: tl := do b <- (succeeds (do `(%%x₁ ≤ %%x₂) <- (infer_type hd),
                                       is_def_eq x₁ y₁, is_def_eq x₂ y₂)),
                    if b then return hd else by exact _match tl
   end

private meta def find_dual (xs : list expr) : tactic (expr × expr) :=
do xs' <- (xs.mfilter (λ x, succeeds (do `(- %%y) <- ((infer_type x) >>= (rhs_of_le)), skip))),
   match xs' with
   | list.nil := tactic.fail "no negated terms found"
   | (hd :: tl) := (do hd' <- find_dual_of xs xs' hd, return (hd', hd)) <|> by exact _match tl
   end

meta def bv_contradiction  : tactic unit :=
do ctx <- (local_context >>= λ l, l.mfilter (hyp_is_ineq)),
   (h₁,h₂) <- find_dual ctx,
   bv_exfalso >> mk_app (`lattice.bv_absurd) [h₁,h₂] >>= tactic.exact

meta structure context_cfg :=
(trace_result : bool := ff)
(trace_result_prefix : string := "/- `tidy_context` says -/ refine poset_yoneda _, ")
(tactics : list(tactic string) := tidy_context_tactics)

meta def cfg_of_context_cfg : context_cfg → cfg :=
λ X, { trace_result := X.trace_result,
  trace_result_prefix := X.trace_result_prefix,
  tactics := X.tactics}

meta def tidy_context (cfg : context_cfg := {}) : tactic unit :=
`[refine _root_.lattice.poset_yoneda _] >> tactic.tidy (cfg_of_context_cfg cfg)

def with_h_asms {𝔹} [lattice 𝔹] (Γ : 𝔹) : Π (xs : list (𝔹)) (g : 𝔹), Prop
 | [] x := Γ ≤ x
 | (x :: xs) y := Γ ≤ x → with_h_asms xs y

-- intended purpose is to make specialized contexts opaque with have-statements

-- suppose we eliminate an existential quantification over S : ι → 𝔹

-- this introduces a new index i : ι into context, and now we have to add additionally the assumption that Γ ≤ S i.

-- Therefore, the next step is to revert all dependences except for i, so that we then have

-- ∀ Γ'', with_h_asms Γ'' [p,q,r,S i] g → (Γ' ≤ p → Γ' ≤ q → Γ' ≤ r → Γ' ≤ S i → Γ' ≤ g)
-- some work still has to be done in showing
-- that Γ' ≤ Γ and applying le_trans, but this should be cleaner because the specific substitutions are no longer accessible.

end natded_tactics
end interactive
end tactic

namespace lattice

local infix ` ⟹ `:75 := lattice.imp

-- example {𝔹} [complete_boolean_algebra 𝔹] {a b c : 𝔹} :
--  ( a ⟹ b ) ⊓ ( b ⟹ c ) ≤ a ⟹ c :=
-- by {tidy_context, bv_imp_intro Ha, exact a_1_right (a_1_left Ha)}
-- tactic state before final step:
-- a b c Γ : β,
-- Γ_1 : β := a ⊓ Γ,
-- a_1_left : Γ_1 ≤ a ⟹ b,
-- a_1_right : Γ_1 ≤ b ⟹ c,
-- Ha : Γ_1 ≤ a
-- ⊢ Γ_1 ≤ c

example {β : Type*} [complete_boolean_algebra β] {a b c : β} :
 ( a ⟹ b ) ⊓ ( b ⟹ c ) ≤ a ⟹ c :=
begin
  rw[<-deduction], unfold imp, rw[inf_sup_right, inf_sup_right],
  simp only [inf_assoc, sup_assoc], refine sup_le _ _,
  ac_change (aᶜ ⊓ a) ⊓ (bᶜ ⊔ c) ≤ c,
  from inf_le_of_left_le (by simp), rw[inf_sup_right],
  let x := _, let y := _, change b ⊓ (x ⊔ y) ≤ _,
  rw[inf_sup_left], apply sup_le,
  { simp[x, inf_assoc.symm] },
  { from inf_le_of_right_le (by simp) }
end

end lattice


import Lbar.finsupp_instance

--  The lemmas in this file are likely no longer needed
open finset finsupp
open_locale big_operators

section families_of_add_comm_groups

variables {S : Fintype} {α β : Type*}

--  Not needed anymore: the `seminormed_add_comm_group` instance has been removed
lemma sum_nnnorm_add_le [seminormed_add_comm_group α] (F G : S → α) :
  ∥F + G∥₊ ≤ ∥F∥₊ + ∥G∥₊ :=
show ∑ s, ∥F s + G s∥₊ ≤ ∑ s, ∥F s∥₊ + ∑ s, ∥G s∥₊, from
le_trans (sum_le_sum (λ i hi, nnnorm_add_le _ _)) sum_add_distrib.le

--  Not needed anymore: this was a helper lemma for the triangle inequality
lemma add_zero_dists [decidable_eq α] [add_zero_class β] {l : α} {x y z : α →₀ β}
  (h : x l + y l + z l = 0) (hl : l ∈ x.support) :
  l ∈ y.support ∪ z.support :=
begin
  simp only [mem_support_iff, ne.def, mem_union] at hl ⊢,
  contrapose! hl,
  simpa only [hl, add_zero] using h,
end

--  Not needed anymore: this was a helper lemma for the triangle inequality
lemma dists [decidable_eq α] [add_group β] {l : α} {x y z : α →₀ β} (hl : l ∈ (x - z).support) :
  l ∈ (x - y).support ∪ (y - z).support :=
have xz : l ∈ (- (x - z)).support, by rwa support_neg,
add_zero_dists (by simp only [neg_sub, finsupp.coe_sub, pi.sub_apply, sub_add_sub_cancel, sub_self]) xz

end families_of_add_comm_groups


import topology.category.Profinite
import category_theory.filtered

import locally_constant.analysis
import analysis.normed.group.SemiNormedGroup.kernels

/-!

# The functor of locally constant maps

The functor sending a seminormed group `V` and a profinite type `S` to the seminormed group
of locally constant maps from `S` to `V` (with the sup norm).

## Main definition

- `LocallyConstant : SemiNormedGroup ⥤ Profiniteᵒᵖ ⥤ SemiNormedGroup` : the functor.

-/

noncomputable theory

set_option pp.proofs true

namespace SemiNormedGroup
open opposite locally_constant

local attribute [instance] locally_constant.semi_normed_group locally_constant.pseudo_metric_space

/-- The bifunctor of locally constant maps from profinite spaces to seminormed groups.
    The effects on homs of groups or space are defined in terms of push-forward
    (ie. post-composition) and pull-back (ie. pre-composition) of locally constant maps
    respectively. -/
@[simps]
def LocallyConstant : SemiNormedGroup ⥤ Profiniteᵒᵖ ⥤ SemiNormedGroup :=
{ obj := λ V,
  { obj := λ S, SemiNormedGroup.of $ locally_constant (unop S : Profinite) V,
    map := λ S₁ S₂ f, comap_hom (f.unop) (f.unop.continuous),
    map_id' := λ S, comap_hom_id,
    map_comp' := λ S₁ S₂ S₃ f g, (comap_hom_comp _ _ _ _).symm },
  map := λ V W f,
  { app := λ S, map_hom f,
    naturality' := λ S₁ S₂ g,
    begin
      dsimp, ext,
      simp only [map_hom_apply, comap_hom_apply, category_theory.coe_comp,
        function.comp_app, map_apply, coe_comap, g.unop.continuous]
    end } ,
  map_id' := by { intros, ext, refl },
  map_comp' := by { intros, ext, refl } }

@[simp]
lemma LocallyConstant_map_apply (M : SemiNormedGroup) (X Y : Profinite) (f : X ⟶ Y)
  (g : (LocallyConstant.obj M).obj (op Y)) (x : X) :
  ((LocallyConstant.obj M).map f.op g).to_fun x = g.to_fun (f x) :=
begin
  dsimp [LocallyConstant, comap],
  split_ifs,
  { refl },
  all_goals { exfalso, apply h, continuity }
end

lemma LocallyConstant_obj_map_norm_noninc (V : SemiNormedGroup) (X Y : Profiniteᵒᵖ) (φ : X ⟶ Y) :
  ((LocallyConstant.obj V).map φ).norm_noninc :=
comap_hom_norm_noninc _ _

open category_theory

universe u

-- TODO: Fix the statement below using bounded colimits.
--@[nolint unused_arguments]
--instance {M : SemiNormedGroup.{u}} {J : Type u} [small_category J] [is_filtered J] :
--  limits.preserves_colimits_of_shape J (LocallyConstant.obj M) := by admit

end SemiNormedGroup

#lint- only unused_arguments def_lemma doc_blame


import tactic.hint
import tactic

lemma ex1 {P Q : Prop} (p : P) (h : P → Q) : Q :=
begin
  hint,
  /- the following tactics make progress:
     ----
     Try this: solve_by_elim
     Try this: finish
     Try this: tauto
  -/
  -- solve_by_elim, -- Give proof: h p
  -- tauto, -- Give proof: h p
  finish, -- Give proof:   (id
  --   (propext
  --     (iff_true_intro
  --         (id
  --           (((imp_congr_eq (propext (iff_true_intro p)) (eq.refl Q)).trans
  --               (propext (forall_prop_of_true true.intro))).mp
  --               h))))).mpr
  -- (classical.by_contradiction
  --     (λ (a : ¬true),
  --       (λ (P Q : Prop) (p : P) (h : Q) (a : ¬true), false.rec false (false_of_true_eq_false (eq_false_intro a))) P
  --         Q
  --         p
  --         (((imp_congr_eq (propext (iff_true_intro p)) (eq.refl Q)).trans
  --             (propext (forall_prop_of_true true.intro))).mp
  --             h)
  --         a))
end


/-
Copyright (c) 2017 Johannes Hölzl. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Author: Johannes Hölzl

Enumerate elements of a set with a select function.
-/
import Mathlib.PrePort
import Mathlib.Lean3Lib.init.default
import Mathlib.data.set.lattice
import Mathlib.tactic.wlog
import Mathlib.PostPort

universes u_1

namespace Mathlib

namespace set

def enumerate {α : Type u_1} (sel : set α → Option α) : set α → ℕ → Option α := sorry

theorem enumerate_eq_none_of_sel {α : Type u_1} (sel : set α → Option α) {s : set α}
    (h : sel s = none) {n : ℕ} : enumerate sel s n = none :=
  sorry

theorem enumerate_eq_none {α : Type u_1} (sel : set α → Option α) {s : set α} {n₁ : ℕ} {n₂ : ℕ} :
    enumerate sel s n₁ = none → n₁ ≤ n₂ → enumerate sel s n₂ = none :=
  sorry

theorem enumerate_mem {α : Type u_1} (sel : set α → Option α)
    (h_sel : ∀ (s : set α) (a : α), sel s = some a → a ∈ s) {s : set α} {n : ℕ} {a : α} :
    enumerate sel s n = some a → a ∈ s :=
  sorry

theorem enumerate_inj {α : Type u_1} (sel : set α → Option α) {n₁ : ℕ} {n₂ : ℕ} {a : α} {s : set α}
    (h_sel : ∀ (s : set α) (a : α), sel s = some a → a ∈ s) (h₁ : enumerate sel s n₁ = some a)
    (h₂ : enumerate sel s n₂ = some a) : n₁ = n₂ :=
  sorry

end Mathlib


/-
Copyright (c) 2020 Joseph Myers. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Author: Joseph Myers.
-/
import Mathlib.PrePort
import Mathlib.Lean3Lib.init.default
import Mathlib.linear_algebra.affine_space.independent
import Mathlib.linear_algebra.finite_dimensional
import Mathlib.PostPort

universes u_1 u_2 u_3 u_4

namespace Mathlib

/-!
# Finite-dimensional subspaces of affine spaces.

This file provides a few results relating to finite-dimensional
subspaces of affine spaces.

## Main definitions

* `collinear` defines collinear sets of points as those that span a
  subspace of dimension at most 1.

-/

/-- The `vector_span` of a finite set is finite-dimensional. -/
theorem finite_dimensional_vector_span_of_finite (k : Type u_1) {V : Type u_2} {P : Type u_3} [field k] [add_comm_group V] [module k V] [add_torsor V P] {s : set P} (h : set.finite s) : finite_dimensional k ↥(vector_span k s) :=
  finite_dimensional.span_of_finite k (set.finite.vsub h h)

/-- The `vector_span` of a family indexed by a `fintype` is
finite-dimensional. -/
protected instance finite_dimensional_vector_span_of_fintype (k : Type u_1) {V : Type u_2} {P : Type u_3} [field k] [add_comm_group V] [module k V] [add_torsor V P] {ι : Type u_4} [fintype ι] (p : ι → P) : finite_dimensional k ↥(vector_span k (set.range p)) :=
  finite_dimensional_vector_span_of_finite k (set.finite_range p)

/-- The `vector_span` of a subset of a family indexed by a `fintype`
is finite-dimensional. -/
protected instance finite_dimensional_vector_span_image_of_fintype (k : Type u_1) {V : Type u_2} {P : Type u_3} [field k] [add_comm_group V] [module k V] [add_torsor V P] {ι : Type u_4} [fintype ι] (p : ι → P) (s : set ι) : finite_dimensional k ↥(vector_span k (p '' s)) :=
  finite_dimensional_vector_span_of_finite k (set.finite.image p (set.finite.of_fintype s))

/-- The direction of the affine span of a finite set is
finite-dimensional. -/
theorem finite_dimensional_direction_affine_span_of_finite (k : Type u_1) {V : Type u_2} {P : Type u_3} [field k] [add_comm_group V] [module k V] [add_torsor V P] {s : set P} (h : set.finite s) : finite_dimensional k ↥(affine_subspace.direction (affine_span k s)) :=
  Eq.symm (direction_affine_span k s) ▸ finite_dimensional_vector_span_of_finite k h

/-- The direction of the affine span of a family indexed by a
`fintype` is finite-dimensional. -/
protected instance finite_dimensional_direction_affine_span_of_fintype (k : Type u_1) {V : Type u_2} {P : Type u_3} [field k] [add_comm_group V] [module k V] [add_torsor V P] {ι : Type u_4} [fintype ι] (p : ι → P) : finite_dimensional k ↥(affine_subspace.direction (affine_span k (set.range p))) :=
  finite_dimensional_direction_affine_span_of_finite k (set.finite_range p)

/-- The direction of the affine span of a subset of a family indexed
by a `fintype` is finite-dimensional. -/
protected instance finite_dimensional_direction_affine_span_image_of_fintype (k : Type u_1) {V : Type u_2} {P : Type u_3} [field k] [add_comm_group V] [module k V] [add_torsor V P] {ι : Type u_4} [fintype ι] (p : ι → P) (s : set ι) : finite_dimensional k ↥(affine_subspace.direction (affine_span k (p '' s))) :=
  finite_dimensional_direction_affine_span_of_finite k (set.finite.image p (set.finite.of_fintype s))

/-- The `vector_span` of a finite subset of an affinely independent
family has dimension one less than its cardinality. -/
theorem findim_vector_span_image_finset_of_affine_independent {k : Type u_1} {V : Type u_2} {P : Type u_3} [field k] [add_comm_group V] [module k V] [add_torsor V P] {ι : Type u_4} {p : ι → P} (hi : affine_independent k p) {s : finset ι} {n : ℕ} (hc : finset.card s = n + 1) : finite_dimensional.findim k ↥(vector_span k (p '' ↑s)) = n := sorry

/-- The `vector_span` of a finite affinely independent family has
dimension one less than its cardinality. -/
theorem findim_vector_span_of_affine_independent {k : Type u_1} {V : Type u_2} {P : Type u_3} [field k] [add_comm_group V] [module k V] [add_torsor V P] {ι : Type u_4} [fintype ι] {p : ι → P} (hi : affine_independent k p) {n : ℕ} (hc : fintype.card ι = n + 1) : finite_dimensional.findim k ↥(vector_span k (set.range p)) = n := sorry

/-- If the `vector_span` of a finite subset of an affinely independent
family lies in a submodule with dimension one less than its
cardinality, it equals that submodule. -/
theorem vector_span_image_finset_eq_of_le_of_affine_independent_of_card_eq_findim_add_one {k : Type u_1} {V : Type u_2} {P : Type u_3} [field k] [add_comm_group V] [module k V] [add_torsor V P] {ι : Type u_4} {p : ι → P} (hi : affine_independent k p) {s : finset ι} {sm : submodule k V} [finite_dimensional k ↥sm] (hle : vector_span k (p '' ↑s) ≤ sm) (hc : finset.card s = finite_dimensional.findim k ↥sm + 1) : vector_span k (p '' ↑s) = sm :=
  finite_dimensional.eq_of_le_of_findim_eq hle (findim_vector_span_image_finset_of_affine_independent hi hc)

/-- If the `vector_span` of a finite affinely independent
family lies in a submodule with dimension one less than its
cardinality, it equals that submodule. -/
theorem vector_span_eq_of_le_of_affine_independent_of_card_eq_findim_add_one {k : Type u_1} {V : Type u_2} {P : Type u_3} [field k] [add_comm_group V] [module k V] [add_torsor V P] {ι : Type u_4} [fintype ι] {p : ι → P} (hi : affine_independent k p) {sm : submodule k V} [finite_dimensional k ↥sm] (hle : vector_span k (set.range p) ≤ sm) (hc : fintype.card ι = finite_dimensional.findim k ↥sm + 1) : vector_span k (set.range p) = sm :=
  finite_dimensional.eq_of_le_of_findim_eq hle (findim_vector_span_of_affine_independent hi hc)

/-- If the `affine_span` of a finite subset of an affinely independent
family lies in an affine subspace whose direction has dimension one
less than its cardinality, it equals that subspace. -/
theorem affine_span_image_finset_eq_of_le_of_affine_independent_of_card_eq_findim_add_one {k : Type u_1} {V : Type u_2} {P : Type u_3} [field k] [add_comm_group V] [module k V] [add_torsor V P] {ι : Type u_4} {p : ι → P} (hi : affine_independent k p) {s : finset ι} {sp : affine_subspace k P} [finite_dimensional k ↥(affine_subspace.direction sp)] (hle : affine_span k (p '' ↑s) ≤ sp) (hc : finset.card s = finite_dimensional.findim k ↥(affine_subspace.direction sp) + 1) : affine_span k (p '' ↑s) = sp := sorry

/-- If the `affine_span` of a finite affinely independent family lies
in an affine subspace whose direction has dimension one less than its
cardinality, it equals that subspace. -/
theorem affine_span_eq_of_le_of_affine_independent_of_card_eq_findim_add_one {k : Type u_1} {V : Type u_2} {P : Type u_3} [field k] [add_comm_group V] [module k V] [add_torsor V P] {ι : Type u_4} [fintype ι] {p : ι → P} (hi : affine_independent k p) {sp : affine_subspace k P} [finite_dimensional k ↥(affine_subspace.direction sp)] (hle : affine_span k (set.range p) ≤ sp) (hc : fintype.card ι = finite_dimensional.findim k ↥(affine_subspace.direction sp) + 1) : affine_span k (set.range p) = sp := sorry

/-- The `vector_span` of a finite affinely independent family whose
cardinality is one more than that of the finite-dimensional space is
`⊤`. -/
theorem vector_span_eq_top_of_affine_independent_of_card_eq_findim_add_one {k : Type u_1} {V : Type u_2} {P : Type u_3} [field k] [add_comm_group V] [module k V] [add_torsor V P] {ι : Type u_4} [finite_dimensional k V] [fintype ι] {p : ι → P} (hi : affine_independent k p) (hc : fintype.card ι = finite_dimensional.findim k V + 1) : vector_span k (set.range p) = ⊤ :=
  finite_dimensional.eq_top_of_findim_eq (findim_vector_span_of_affine_independent hi hc)

/-- The `affine_span` of a finite affinely independent family whose
cardinality is one more than that of the finite-dimensional space is
`⊤`. -/
theorem affine_span_eq_top_of_affine_independent_of_card_eq_findim_add_one {k : Type u_1} {V : Type u_2} {P : Type u_3} [field k] [add_comm_group V] [module k V] [add_torsor V P] {ι : Type u_4} [finite_dimensional k V] [fintype ι] {p : ι → P} (hi : affine_independent k p) (hc : fintype.card ι = finite_dimensional.findim k V + 1) : affine_span k (set.range p) = ⊤ := sorry

/-- The `vector_span` of `n + 1` points in an indexed family has
dimension at most `n`. -/
theorem findim_vector_span_image_finset_le (k : Type u_1) {V : Type u_2} {P : Type u_3} [field k] [add_comm_group V] [module k V] [add_torsor V P] {ι : Type u_4} (p : ι → P) (s : finset ι) {n : ℕ} (hc : finset.card s = n + 1) : finite_dimensional.findim k ↥(vector_span k (p '' ↑s)) ≤ n := sorry

/-- The `vector_span` of an indexed family of `n + 1` points has
dimension at most `n`. -/
theorem findim_vector_span_range_le (k : Type u_1) {V : Type u_2} {P : Type u_3} [field k] [add_comm_group V] [module k V] [add_torsor V P] {ι : Type u_4} [fintype ι] (p : ι → P) {n : ℕ} (hc : fintype.card ι = n + 1) : finite_dimensional.findim k ↥(vector_span k (set.range p)) ≤ n := sorry

/-- `n + 1` points are affinely independent if and only if their
`vector_span` has dimension `n`. -/
theorem affine_independent_iff_findim_vector_span_eq (k : Type u_1) {V : Type u_2} {P : Type u_3} [field k] [add_comm_group V] [module k V] [add_torsor V P] {ι : Type u_4} [fintype ι] (p : ι → P) {n : ℕ} (hc : fintype.card ι = n + 1) : affine_independent k p ↔ finite_dimensional.findim k ↥(vector_span k (set.range p)) = n := sorry

/-- `n + 1` points are affinely independent if and only if their
`vector_span` has dimension at least `n`. -/
theorem affine_independent_iff_le_findim_vector_span (k : Type u_1) {V : Type u_2} {P : Type u_3} [field k] [add_comm_group V] [module k V] [add_torsor V P] {ι : Type u_4} [fintype ι] (p : ι → P) {n : ℕ} (hc : fintype.card ι = n + 1) : affine_independent k p ↔ n ≤ finite_dimensional.findim k ↥(vector_span k (set.range p)) := sorry

/-- `n + 2` points are affinely independent if and only if their
`vector_span` does not have dimension at most `n`. -/
theorem affine_independent_iff_not_findim_vector_span_le (k : Type u_1) {V : Type u_2} {P : Type u_3} [field k] [add_comm_group V] [module k V] [add_torsor V P] {ι : Type u_4} [fintype ι] (p : ι → P) {n : ℕ} (hc : fintype.card ι = n + bit0 1) : affine_independent k p ↔ ¬finite_dimensional.findim k ↥(vector_span k (set.range p)) ≤ n := sorry

/-- `n + 2` points have a `vector_span` with dimension at most `n` if
and only if they are not affinely independent. -/
theorem findim_vector_span_le_iff_not_affine_independent (k : Type u_1) {V : Type u_2} {P : Type u_3} [field k] [add_comm_group V] [module k V] [add_torsor V P] {ι : Type u_4} [fintype ι] (p : ι → P) {n : ℕ} (hc : fintype.card ι = n + bit0 1) : finite_dimensional.findim k ↥(vector_span k (set.range p)) ≤ n ↔ ¬affine_independent k p :=
  iff.symm (iff.mp not_iff_comm (iff.symm (affine_independent_iff_not_findim_vector_span_le k p hc)))

/-- A set of points is collinear if their `vector_span` has dimension
at most `1`. -/
def collinear (k : Type u_1) {V : Type u_2} {P : Type u_3} [field k] [add_comm_group V] [module k V] [add_torsor V P] (s : set P) :=
  vector_space.dim k ↥(vector_span k s) ≤ 1

/-- The definition of `collinear`. -/
theorem collinear_iff_dim_le_one (k : Type u_1) {V : Type u_2} {P : Type u_3} [field k] [add_comm_group V] [module k V] [add_torsor V P] (s : set P) : collinear k s ↔ vector_space.dim k ↥(vector_span k s) ≤ 1 :=
  iff.rfl

/-- A set of points, whose `vector_span` is finite-dimensional, is
collinear if and only if their `vector_span` has dimension at most
`1`. -/
theorem collinear_iff_findim_le_one (k : Type u_1) {V : Type u_2} {P : Type u_3} [field k] [add_comm_group V] [module k V] [add_torsor V P] (s : set P) [finite_dimensional k ↥(vector_span k s)] : collinear k s ↔ finite_dimensional.findim k ↥(vector_span k s) ≤ 1 := sorry

/-- The empty set is collinear. -/
theorem collinear_empty (k : Type u_1) {V : Type u_2} (P : Type u_3) [field k] [add_comm_group V] [module k V] [add_torsor V P] : collinear k ∅ := sorry

/-- A single point is collinear. -/
theorem collinear_singleton (k : Type u_1) {V : Type u_2} {P : Type u_3} [field k] [add_comm_group V] [module k V] [add_torsor V P] (p : P) : collinear k (singleton p) := sorry

/-- Given a point `p₀` in a set of points, that set is collinear if and
only if the points can all be expressed as multiples of the same
vector, added to `p₀`. -/
theorem collinear_iff_of_mem (k : Type u_1) {V : Type u_2} {P : Type u_3} [field k] [add_comm_group V] [module k V] [add_torsor V P] {s : set P} {p₀ : P} (h : p₀ ∈ s) : collinear k s ↔ ∃ (v : V), ∀ (p : P), p ∈ s → ∃ (r : k), p = r • v +ᵥ p₀ := sorry

/-- A set of points is collinear if and only if they can all be
expressed as multiples of the same vector, added to the same base
point. -/
theorem collinear_iff_exists_forall_eq_smul_vadd (k : Type u_1) {V : Type u_2} {P : Type u_3} [field k] [add_comm_group V] [module k V] [add_torsor V P] (s : set P) : collinear k s ↔ ∃ (p₀ : P), ∃ (v : V), ∀ (p : P), p ∈ s → ∃ (r : k), p = r • v +ᵥ p₀ := sorry

/-- Two points are collinear. -/
theorem collinear_insert_singleton (k : Type u_1) {V : Type u_2} {P : Type u_3} [field k] [add_comm_group V] [module k V] [add_torsor V P] (p₁ : P) (p₂ : P) : collinear k (insert p₁ (singleton p₂)) := sorry

/-- Three points are affinely independent if and only if they are not
collinear. -/
theorem affine_independent_iff_not_collinear (k : Type u_1) {V : Type u_2} {P : Type u_3} [field k] [add_comm_group V] [module k V] [add_torsor V P] (p : fin (bit1 1) → P) : affine_independent k p ↔ ¬collinear k (set.range p) := sorry

/-- Three points are collinear if and only if they are not affinely
independent. -/
theorem collinear_iff_not_affine_independent (k : Type u_1) {V : Type u_2} {P : Type u_3} [field k] [add_comm_group V] [module k V] [add_torsor V P] (p : fin (bit1 1) → P) : collinear k (set.range p) ↔ ¬affine_independent k p := sorry


/-
Copyright (c) 2020 Eric Wieser. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Eric Wieser
-/
import linear_algebra.multilinear.basic
import linear_algebra.tensor_product

/-!
# Constructions relating multilinear maps and tensor products.
-/

namespace multilinear_map

section dom_coprod

open_locale tensor_product

variables {R ι₁ ι₂ ι₃ ι₄ : Type*}
variables [comm_semiring R]
variables [decidable_eq ι₁] [decidable_eq ι₂][decidable_eq ι₃] [decidable_eq ι₄]
variables {N₁ : Type*} [add_comm_monoid N₁] [module R N₁]
variables {N₂ : Type*} [add_comm_monoid N₂] [module R N₂]
variables {N : Type*} [add_comm_monoid N] [module R N]

/-- Given two multilinear maps `(ι₁ → N) → N₁` and `(ι₂ → N) → N₂`, this produces the map
`(ι₁ ⊕ ι₂ → N) → N₁ ⊗ N₂` by taking the coproduct of the domain and the tensor product
of the codomain.

This can be thought of as combining `equiv.sum_arrow_equiv_prod_arrow.symm` with
`tensor_product.map`, noting that the two operations can't be separated as the intermediate result
is not a `multilinear_map`.

While this can be generalized to work for dependent `Π i : ι₁, N'₁ i` instead of `ι₁ → N`, doing so
introduces `sum.elim N'₁ N'₂` types in the result which are difficult to work with and not defeq
to the simple case defined here. See [this zulip thread](
https://leanprover.zulipchat.com/#narrow/stream/217875-Is-there.20code.20for.20X.3F/topic/Instances.20on.20.60sum.2Eelim.20A.20B.20i.60/near/218484619).
-/
@[simps apply]
def dom_coprod
  (a : multilinear_map R (λ _ : ι₁, N) N₁) (b : multilinear_map R (λ _ : ι₂, N) N₂) :
  multilinear_map R (λ _ : ι₁ ⊕ ι₂, N) (N₁ ⊗[R] N₂) :=
{ to_fun := λ v, a (λ i, v (sum.inl i)) ⊗ₜ b (λ i, v (sum.inr i)),
  map_add' := λ v i p q, by cases i; simp [tensor_product.add_tmul, tensor_product.tmul_add],
  map_smul' := λ v i c p, by cases i; simp [tensor_product.smul_tmul', tensor_product.tmul_smul] }

/-- A more bundled version of `multilinear_map.dom_coprod` that maps
`((ι₁ → N) → N₁) ⊗ ((ι₂ → N) → N₂)` to `(ι₁ ⊕ ι₂ → N) → N₁ ⊗ N₂`. -/
def dom_coprod' :
  multilinear_map R (λ _ : ι₁, N) N₁ ⊗[R] multilinear_map R (λ _ : ι₂, N) N₂ →ₗ[R]
  multilinear_map R (λ _ : ι₁ ⊕ ι₂, N) (N₁ ⊗[R] N₂) :=
tensor_product.lift $ linear_map.mk₂ R (dom_coprod)
  (λ m₁ m₂ n, by { ext, simp only [dom_coprod_apply, tensor_product.add_tmul, add_apply] })
  (λ c m n,   by { ext, simp only [dom_coprod_apply, tensor_product.smul_tmul', smul_apply] })
  (λ m n₁ n₂, by { ext, simp only [dom_coprod_apply, tensor_product.tmul_add, add_apply] })
  (λ c m n,   by { ext, simp only [dom_coprod_apply, tensor_product.tmul_smul, smul_apply] })

@[simp]
lemma dom_coprod'_apply
  (a : multilinear_map R (λ _ : ι₁, N) N₁) (b : multilinear_map R (λ _ : ι₂, N) N₂) :
  dom_coprod' (a ⊗ₜ[R] b) = dom_coprod a b := rfl

/-- When passed an `equiv.sum_congr`, `multilinear_map.dom_dom_congr` distributes over
`multilinear_map.dom_coprod`. -/
lemma dom_coprod_dom_dom_congr_sum_congr
  (a : multilinear_map R (λ _ : ι₁, N) N₁) (b : multilinear_map R (λ _ : ι₂, N) N₂)
  (σa : ι₁ ≃ ι₃) (σb : ι₂ ≃ ι₄) :
    (a.dom_coprod b).dom_dom_congr (σa.sum_congr σb) =
      (a.dom_dom_congr σa).dom_coprod (b.dom_dom_congr σb) := rfl

end dom_coprod

end multilinear_map


import data.fintype
import category_theory.limits.limits
import category_theory.monad.limits
import category_theory.monad
import category_theory.limits.shapes.equalizers
import tactic
import category_theory.monad.adjunction
universes u v u₂ v₂ v₁ u₁

namespace category_theory

open limits
section reflexive_pair
def reflexive_pair : Type v := limits.walking_parallel_pair.{v}
open limits.walking_parallel_pair
inductive reflexive_pair_hom : reflexive_pair.{v} → reflexive_pair.{v} → Type v
|left : reflexive_pair_hom zero one
|right : reflexive_pair_hom zero one
|back : reflexive_pair_hom one zero
|left_back : reflexive_pair_hom zero zero
|right_back : reflexive_pair_hom zero zero
|id : Π (X : reflexive_pair), reflexive_pair_hom X X
open reflexive_pair_hom

def reflexive_pair_hom.comp :
  Π (X Y Z : reflexive_pair.{v})
    (f : reflexive_pair_hom.{v} X Y) (g : reflexive_pair_hom.{v} Y Z),
    reflexive_pair_hom.{v} X Z
  | _ _ _ back left := reflexive_pair_hom.id _
  | _ _ _ back right := reflexive_pair_hom.id _
  | _ _ _ left back := left_back
  | _ _ _ right back := right_back
  | _ _ _ back left_back := back
  | _ _ _ back right_back := back
  | _ _ _ left_back left_back := left_back
  | _ _ _ right_back right_back := right_back
  | _ _ _ left_back left := left
  | _ _ _ left_back right := left
  | _ _ _ right_back left := right
  | _ _ _ right_back right := right
  | _ _ _ left_back right_back := left_back
  | _ _ _ right_back left_back := right_back
  | _ _ _ (id _) h := h
  | _ _ _ back (id zero) := back
  | _ _ _ left_back (id zero) := left_back
  | _ _ _ right_back (id zero) := right_back
  | _ _ _ left (id one) := left
  | _ _ _ right (id one) := right

end reflexive_pair
instance walking_parallel_pair_hom_category : small_category.{v} reflexive_pair :=
{ hom  := reflexive_pair_hom,
  id   := reflexive_pair_hom.id,
  comp := reflexive_pair_hom.comp,
  assoc' := begin intros, cases f; cases g; cases h, all_goals {refl} end,
  id_comp' := begin intros, cases f, all_goals {refl} end,
  comp_id' := begin intros, cases f, all_goals {refl} end,
}

variables {C : Type u} [𝒞 : category.{v} C]
include 𝒞
variables {A B : C}

structure split_coequaliser  (f g : A ⟶ B) :=
(cf : cofork f g)
(t : B ⟶ A)
(s : cf.X ⟶ B)
(p1 : s ≫ cf.π = 𝟙 _)
(p2 : t ≫ g = 𝟙 B)
(p3 : t ≫ f = cf.π ≫ s)

-- [todo] show it's a coequaliser
open category_theory

@[simp] lemma simp_parallel_zero {f g : A ⟶ B} (t : cofork f g) : t.ι.app walking_parallel_pair.zero = f ≫ t.π :=
begin rw  ← cocone.w t walking_parallel_pair_hom.left, refl end

/-- You can make a coequaliser by finding a π which uniquely factors any other cofork. -/
def is_coeq_lemma {f g : A ⟶ B} {X : C} (π : B ⟶ X)
  (e : f ≫ π = g ≫ π)
  (factor : ∀ {Y} (c : B ⟶ Y), (f ≫ c = g ≫ c) →  unique {m : X ⟶ Y // c = π ≫ m}) :
  has_colimit (parallel_pair f g) :=
  begin
    refine {cocone := cofork.of_π π e, is_colimit := _},
    refine {desc := λ c : cofork f g, _, fac' :=  λ c : cofork f g, _, uniq' :=  λ c : cofork f g, _},
    rcases (factor c.π c.condition) with ⟨⟨⟨k,h1⟩⟩,h2⟩, apply k,
    rcases (factor c.π c.condition) with ⟨⟨⟨k,h1⟩⟩,h2⟩, rintros (_|_),
      change (_ ≫ _) ≫ k = _,  rw category.assoc, rw ← h1, rw simp_parallel_zero,
      change π ≫ k = c.π, dsimp, rw h1,
    rcases (factor c.π c.condition) with ⟨⟨⟨k,h1⟩⟩,h2⟩,
        intros, change m = k,
         have, apply h2 ⟨m,eq.symm (w walking_parallel_pair.one)⟩,
         apply subtype.ext.1 this,
  end

def split_coequaliser_is_coequaliser {f g : A ⟶ B} (sc : split_coequaliser f g) : has_colimit (parallel_pair f g):=
begin
  refine is_coeq_lemma sc.cf.π _ _,
  apply limits.cofork.condition,
  intros, refine ⟨⟨⟨sc.s ≫ c,_⟩⟩,_⟩,
  rw [← category.assoc, ← sc.p3, category.assoc, a, ← category.assoc, sc.p2, category.id_comp],
  rintros ⟨m2,p⟩,
  apply subtype.ext.2,
  change m2 = sc.s ≫ c,
  rw [p, ← category.assoc, sc.p1], dsimp, simp
end

-- [todo] sort out universe polymorphism
variables {D : Type u} [𝒟 : category.{v} D]
include 𝒟

/-- Take a G-split coequaliser `cf` for `f,g : A ⟶ B`, then we have a coequaliser for `f,g` and `G` of this coequaliser is still a colimit.  -/
def creates_split_coequalisers (G : D ⥤ C) :=
Π {A B : D} (f g : A ⟶ B) (cf : split_coequaliser (G.map f) (G.map g)),
  Σ (hcl : has_colimit (parallel_pair f g)), is_colimit $ G.map_cocone hcl.cocone

variables {J : Type v} [𝒥 : small_category J]
include 𝒥

-- [todo] double check that mathlib doesn't have creates limits.

def creates_limits (d : J ⥤ C) (F : C ⥤ D) :=
Π [fl : has_limit (d ⋙ F)], Σ (l : has_limit d),
  is_limit $ F.map_cone l.cone

structure creates_limit (K : J ⥤ C) (F : C ⥤ D) (c : cone (K ⋙ F)) (t : is_limit c) :=
(upstairs : cone K)
(up_hits : F.map_cone upstairs ≅ c)
(any_up_is_lim : Π (up' : cone K) (iso : F.map_cone up' ≅ c), is_limit up')

-- Π (c : cone (d ⋙ F)) (t : is_limit c), (Σ (t : cone d), F.map_cone t ≅ c)

def creates_colimits (d : J ⥤ C) (F : C ⥤ D) :=
Π [fl : has_colimit (d ⋙ F)], Σ (l : has_colimit d),
  is_colimit $ F.map_cocone l.cocone

open category_theory.monad
open category_theory.monad.algebra

variables {T : C ⥤ C} [monad T]
omit 𝒟

-- def forget_really_creates_limits (d : J ⥤ algebra T) : @creates_limits (algebra T) _ C _ J _ d (monad.forget T : algebra T ⥤ C) := sorry

-- def monadic_creates_colimits (d : J ⥤ D) (R : D ⥤ C) [monadic_right_adjoint R] : (preserves_colimits T)

-- def precise_monadicity_1 (G : D ⥤ C) [is_right_adjoint G] : creates_split_coequalisers G → is_equivalence (monad.comparison G) :=
-- sorry
-- def precise_monadicity_2 (G : D ⥤ C) [ra : is_right_adjoint G] : is_equivalence (monad.comparison G) → creates_split_coequalisers G:=
-- begin
--   let F := ra.1,
--   rintros e A B f g ⟨cf, _⟩,
--   refine ⟨_,_,_⟩,

-- end

end category_theory