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

Theorems that require decidability hypotheses are in the namespace "decidable".
Classical versions are in the namespace "classical".

Note: in the presence of automation, this whole file may be unnecessary. On the other hand,
maybe it is useful for writing automation.
-/
import data.prod tactic.cache

/-
    miscellany

    TODO: move elsewhere
-/

section miscellany

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

@[reducible] def hidden {a : α} := a

def empty.elim {C : Sort*} : empty → C.

instance : subsingleton empty := ⟨λa, a.elim⟩

instance : decidable_eq empty := λa, a.elim

@[priority 0] instance decidable_eq_of_subsingleton
  {α} [subsingleton α] : decidable_eq α
| a b := is_true (subsingleton.elim a b)

/- Add an instance to "undo" coercion transitivity into a chain of coercions, because
   most simp lemmas are stated with respect to simple coercions and will not match when
   part of a chain. -/
@[simp] theorem coe_coe {α β γ} [has_coe α β] [has_coe_t β γ]
  (a : α) : (a : γ) = (a : β) := rfl

@[simp] theorem coe_fn_coe_trans
  {α β γ} [has_coe α β] [has_coe_t_aux β γ] [has_coe_to_fun γ]
  (x : α) : @coe_fn α _ x = @coe_fn β _ x := rfl

@[simp] theorem coe_fn_coe_base
  {α β} [has_coe α β] [has_coe_to_fun β]
  (x : α) : @coe_fn α _ x = @coe_fn β _ x := rfl

@[simp] theorem coe_sort_coe_trans
  {α β γ} [has_coe α β] [has_coe_t_aux β γ] [has_coe_to_sort γ]
  (x : α) : @coe_sort α _ x = @coe_sort β _ x := rfl

@[simp] theorem coe_sort_coe_base
  {α β} [has_coe α β] [has_coe_to_sort β]
  (x : α) : @coe_sort α _ x = @coe_sort β _ x := rfl

/-- `pempty` is the universe-polymorphic analogue of `empty`. -/
@[derive decidable_eq]
inductive {u} pempty : Sort u

def pempty.elim {C : Sort*} : pempty → C.

instance subsingleton_pempty : subsingleton pempty := ⟨λa, a.elim⟩

lemma congr_arg_heq {α} {β : α → Sort*} (f : ∀ a, β a) : ∀ {a₁ a₂ : α}, a₁ = a₂ → f a₁ == f a₂
| a _ rfl := heq.rfl

lemma plift.down_inj {α : Sort*} : ∀ (a b : plift α), a.down = b.down → a = b
| ⟨a⟩ ⟨b⟩ rfl := rfl

end miscellany

/-
    propositional connectives
-/

@[simp] theorem false_ne_true : false ≠ true
| h := h.symm ▸ trivial

section propositional
variables {a b c d : Prop}

/- implies -/

theorem iff_of_eq (e : a = b) : a ↔ b := e ▸ iff.rfl

theorem iff_iff_eq : (a ↔ b) ↔ a = b := ⟨propext, iff_of_eq⟩

@[simp] theorem imp_self : (a → a) ↔ true := iff_true_intro id

theorem imp_intro {α β} (h : α) (h₂ : β) : α := h

theorem imp_false : (a → false) ↔ ¬ a := iff.rfl

theorem imp_and_distrib {α} : (α → b ∧ c) ↔ (α → b) ∧ (α → c) :=
⟨λ h, ⟨λ ha, (h ha).left, λ ha, (h ha).right⟩,
 λ h ha, ⟨h.left ha, h.right ha⟩⟩

@[simp] theorem and_imp : (a ∧ b → c) ↔ (a → b → c) :=
iff.intro (λ h ha hb, h ⟨ha, hb⟩) (λ h ⟨ha, hb⟩, h ha hb)

theorem iff_def : (a ↔ b) ↔ (a → b) ∧ (b → a) :=
iff_iff_implies_and_implies _ _

theorem iff_def' : (a ↔ b) ↔ (b → a) ∧ (a → b) :=
iff_def.trans and.comm

@[simp] theorem imp_true_iff {α : Sort*} : (α → true) ↔ true :=
iff_true_intro $ λ_, trivial

@[simp] theorem imp_iff_right (ha : a) : (a → b) ↔ b :=
⟨λf, f ha, imp_intro⟩

/- not -/

theorem not.elim {α : Sort*} (H1 : ¬a) (H2 : a) : α := absurd H2 H1

@[reducible] theorem not.imp {a b : Prop} (H2 : ¬b) (H1 : a → b) : ¬a := mt H1 H2

theorem not_not_of_not_imp : ¬(a → b) → ¬¬a :=
mt not.elim

theorem not_of_not_imp {α} : ¬(α → b) → ¬b :=
mt imp_intro

theorem dec_em (p : Prop) [decidable p] : p ∨ ¬p := decidable.em p

theorem by_contradiction {p} [decidable p] : (¬p → false) → p :=
decidable.by_contradiction

@[simp] theorem not_not [decidable a] : ¬¬a ↔ a :=
iff.intro by_contradiction not_not_intro

theorem of_not_not [decidable a] : ¬¬a → a :=
by_contradiction

theorem of_not_imp [decidable a] (h : ¬ (a → b)) : a :=
by_contradiction (not_not_of_not_imp h)

theorem not.imp_symm [decidable a] (h : ¬a → b) (hb : ¬b) : a :=
by_contradiction $ hb ∘ h

theorem not_imp_comm [decidable a] [decidable b] : (¬a → b) ↔ (¬b → a) :=
⟨not.imp_symm, not.imp_symm⟩

theorem imp.swap : (a → b → c) ↔ (b → a → c) :=
⟨function.swap, function.swap⟩

theorem imp_not_comm : (a → ¬b) ↔ (b → ¬a) :=
imp.swap

/- and -/

theorem not_and_of_not_left (b : Prop) : ¬a → ¬(a ∧ b) :=
mt and.left

theorem not_and_of_not_right (a : Prop) {b : Prop} : ¬b → ¬(a ∧ b) :=
mt and.right

theorem and.imp_left (h : a → b) : a ∧ c → b ∧ c :=
and.imp h id

theorem and.imp_right (h : a → b) : c ∧ a → c ∧ b :=
and.imp id h

lemma and.right_comm : (a ∧ b) ∧ c ↔ (a ∧ c) ∧ b :=
by simp [and.left_comm, and.comm]

lemma and.rotate : a ∧ b ∧ c ↔ b ∧ c ∧ a :=
by simp [and.left_comm, and.comm]

theorem and_not_self_iff (a : Prop) : a ∧ ¬ a ↔ false :=
iff.intro (assume h, (h.right) (h.left)) (assume h, h.elim)

theorem not_and_self_iff (a : Prop) : ¬ a ∧ a ↔ false :=
iff.intro (assume ⟨hna, ha⟩, hna ha) false.elim

theorem and_iff_left_of_imp {a b : Prop} (h : a → b) : (a ∧ b) ↔ a :=
iff.intro and.left (λ ha, ⟨ha, h ha⟩)

theorem and_iff_right_of_imp {a b : Prop} (h : b → a) : (a ∧ b) ↔ b :=
iff.intro and.right (λ hb, ⟨h hb, hb⟩)

lemma and.congr_right_iff : (a ∧ b ↔ a ∧ c) ↔ (a → (b ↔ c)) :=
⟨λ h ha, by simp [ha] at h; exact h, and_congr_right⟩

/- or -/

theorem or_of_or_of_imp_of_imp (h₁ : a ∨ b) (h₂ : a → c) (h₃ : b → d) : c ∨ d :=
or.imp h₂ h₃ h₁

theorem or_of_or_of_imp_left (h₁ : a ∨ c) (h : a → b) : b ∨ c :=
or.imp_left h h₁

theorem or_of_or_of_imp_right (h₁ : c ∨ a) (h : a → b) : c ∨ b :=
or.imp_right h h₁

theorem or.elim3 (h : a ∨ b ∨ c) (ha : a → d) (hb : b → d) (hc : c → d) : d :=
or.elim h ha (assume h₂, or.elim h₂ hb hc)

theorem or_imp_distrib : (a ∨ b → c) ↔ (a → c) ∧ (b → c) :=
⟨assume h, ⟨assume ha, h (or.inl ha), assume hb, h (or.inr hb)⟩,
  assume ⟨ha, hb⟩, or.rec ha hb⟩

theorem or_iff_not_imp_left [decidable a] : a ∨ b ↔ (¬ a → b) :=
⟨or.resolve_left, λ h, dite _ or.inl (or.inr ∘ h)⟩

theorem or_iff_not_imp_right [decidable b] : a ∨ b ↔ (¬ b → a) :=
or.comm.trans or_iff_not_imp_left

theorem not_imp_not [decidable a] : (¬ a → ¬ b) ↔ (b → a) :=
⟨assume h hb, by_contradiction $ assume na, h na hb, mt⟩

/- distributivity -/

theorem and_or_distrib_left : a ∧ (b ∨ c) ↔ (a ∧ b) ∨ (a ∧ c) :=
⟨λ ⟨ha, hbc⟩, hbc.imp (and.intro ha) (and.intro ha),
 or.rec (and.imp_right or.inl) (and.imp_right or.inr)⟩

theorem or_and_distrib_right : (a ∨ b) ∧ c ↔ (a ∧ c) ∨ (b ∧ c) :=
(and.comm.trans and_or_distrib_left).trans (or_congr and.comm and.comm)

theorem or_and_distrib_left : a ∨ (b ∧ c) ↔ (a ∨ b) ∧ (a ∨ c) :=
⟨or.rec (λha, and.intro (or.inl ha) (or.inl ha)) (and.imp or.inr or.inr),
 and.rec $ or.rec (imp_intro ∘ or.inl) (or.imp_right ∘ and.intro)⟩

theorem and_or_distrib_right : (a ∧ b) ∨ c ↔ (a ∨ c) ∧ (b ∨ c) :=
(or.comm.trans or_and_distrib_left).trans (and_congr or.comm or.comm)

/- iff -/

theorem iff_of_true (ha : a) (hb : b) : a ↔ b :=
⟨λ_, hb, λ _, ha⟩

theorem iff_of_false (ha : ¬a) (hb : ¬b) : a ↔ b :=
⟨ha.elim, hb.elim⟩

theorem iff_true_left (ha : a) : (a ↔ b) ↔ b :=
⟨λ h, h.1 ha, iff_of_true ha⟩

theorem iff_true_right (ha : a) : (b ↔ a) ↔ b :=
iff.comm.trans (iff_true_left ha)

theorem iff_false_left (ha : ¬a) : (a ↔ b) ↔ ¬b :=
⟨λ h, mt h.2 ha, iff_of_false ha⟩

theorem iff_false_right (ha : ¬a) : (b ↔ a) ↔ ¬b :=
iff.comm.trans (iff_false_left ha)

theorem not_or_of_imp [decidable a] (h : a → b) : ¬ a ∨ b :=
if ha : a then or.inr (h ha) else or.inl ha

theorem imp_iff_not_or [decidable a] : (a → b) ↔ (¬ a ∨ b) :=
⟨not_or_of_imp, or.neg_resolve_left⟩

theorem imp_or_distrib [decidable a] : (a → b ∨ c) ↔ (a → b) ∨ (a → c) :=
by simp [imp_iff_not_or, or.comm, or.left_comm]

theorem imp_or_distrib' [decidable b] : (a → b ∨ c) ↔ (a → b) ∨ (a → c) :=
by by_cases b; simp [h, or_iff_right_of_imp ((∘) false.elim)]

theorem not_imp_of_and_not : a ∧ ¬ b → ¬ (a → b)
| ⟨ha, hb⟩ h := hb $ h ha

@[simp] theorem not_imp [decidable a] : ¬(a → b) ↔ a ∧ ¬b :=
⟨λ h, ⟨of_not_imp h, not_of_not_imp h⟩, not_imp_of_and_not⟩

-- for monotonicity
lemma imp_imp_imp
  (h₀ : c → a) (h₁ : b → d) :
  (a → b) → (c → d) :=
assume (h₂ : a → b),
h₁ ∘ h₂ ∘ h₀

theorem peirce (a b : Prop) [decidable a] : ((a → b) → a) → a :=
if ha : a then λ h, ha else λ h, h ha.elim

theorem peirce' {a : Prop} (H : ∀ b : Prop, (a → b) → a) : a := H _ id

theorem not_iff_not [decidable a] [decidable b] : (¬ a ↔ ¬ b) ↔ (a ↔ b) :=
by rw [@iff_def (¬ a), @iff_def' a]; exact and_congr not_imp_not not_imp_not

theorem not_iff_comm [decidable a] [decidable b] : (¬ a ↔ b) ↔ (¬ b ↔ a) :=
by rw [@iff_def (¬ a), @iff_def (¬ b)]; exact and_congr not_imp_comm imp_not_comm

theorem not_iff [decidable a] [decidable b] : ¬ (a ↔ b) ↔ (¬ a ↔ b) :=
by split; intro h; [split, skip]; intro h'; [by_contradiction,intro,skip];
   try { refine h _; simp [*] }; rw [h',not_iff_self] at h; exact h

theorem iff_not_comm [decidable a] [decidable b] : (a ↔ ¬ b) ↔ (b ↔ ¬ a) :=
by rw [@iff_def a, @iff_def b]; exact and_congr imp_not_comm not_imp_comm

theorem iff_iff_and_or_not_and_not [decidable b] : (a ↔ b) ↔ (a ∧ b) ∨ (¬ a ∧ ¬ b) :=
by { split; intro h,
     { rw h; by_cases b; [left,right]; split; assumption },
     { cases h with h h; cases h; split; intro; { contradiction <|> assumption } } }

@[simp] theorem not_and_not_right [decidable b] : ¬(a ∧ ¬b) ↔ (a → b) :=
⟨λ h ha, h.imp_symm $ and.intro ha, λ h ⟨ha, hb⟩, hb $ h ha⟩

@[inline] def decidable_of_iff (a : Prop) (h : a ↔ b) [D : decidable a] : decidable b :=
decidable_of_decidable_of_iff D h

@[inline] def decidable_of_iff' (b : Prop) (h : a ↔ b) [D : decidable b] : decidable a :=
decidable_of_decidable_of_iff D h.symm

def decidable_of_bool : ∀ (b : bool) (h : b ↔ a), decidable a
| tt h := is_true (h.1 rfl)
| ff h := is_false (mt h.2 bool.ff_ne_tt)

/- de morgan's laws -/

theorem not_and_of_not_or_not (h : ¬ a ∨ ¬ b) : ¬ (a ∧ b)
| ⟨ha, hb⟩ := or.elim h (absurd ha) (absurd hb)

theorem not_and_distrib [decidable a] : ¬ (a ∧ b) ↔ ¬a ∨ ¬b :=
⟨λ h, if ha : a then or.inr (λ hb, h ⟨ha, hb⟩) else or.inl ha, not_and_of_not_or_not⟩

theorem not_and_distrib' [decidable b] : ¬ (a ∧ b) ↔ ¬a ∨ ¬b :=
⟨λ h, if hb : b then or.inl (λ ha, h ⟨ha, hb⟩) else or.inr hb, not_and_of_not_or_not⟩

@[simp] theorem not_and : ¬ (a ∧ b) ↔ (a → ¬ b) := and_imp

theorem not_and' : ¬ (a ∧ b) ↔ b → ¬a :=
not_and.trans imp_not_comm

theorem not_or_distrib : ¬ (a ∨ b) ↔ ¬ a ∧ ¬ b :=
⟨λ h, ⟨λ ha, h (or.inl ha), λ hb, h (or.inr hb)⟩,
 λ ⟨h₁, h₂⟩ h, or.elim h h₁ h₂⟩

theorem or_iff_not_and_not [decidable a] [decidable b] : a ∨ b ↔ ¬ (¬a ∧ ¬b) :=
by rw [← not_or_distrib, not_not]

theorem and_iff_not_or_not [decidable a] [decidable b] : a ∧ b ↔ ¬ (¬ a ∨ ¬ b) :=
by rw [← not_and_distrib, not_not]

end propositional

/- equality -/

section equality
variables {α : Sort*} {a b : α}

@[simp] theorem heq_iff_eq : a == b ↔ a = b :=
⟨eq_of_heq, heq_of_eq⟩

theorem proof_irrel_heq {p q : Prop} (hp : p) (hq : q) : hp == hq :=
have p = q, from propext ⟨λ _, hq, λ _, hp⟩,
by subst q; refl

theorem ne_of_mem_of_not_mem {α β} [has_mem α β] {s : β} {a b : α}
  (h : a ∈ s) : b ∉ s → a ≠ b :=
mt $ λ e, e ▸ h

theorem eq_equivalence : equivalence (@eq α) :=
⟨eq.refl, @eq.symm _, @eq.trans _⟩

lemma heq_of_eq_mp :
  ∀ {α β : Sort*} {a : α} {a' : β} (e : α = β) (h₂ : (eq.mp e a) = a'), a == a'
| α ._ a a' rfl h := eq.rec_on h (heq.refl _)

lemma rec_heq_of_heq {β} {C : α → Sort*} {x : C a} {y : β} (eq : a = b) (h : x == y) :
  @eq.rec α a C x b eq == y :=
by subst eq; exact h

@[simp] lemma {u} eq_mpr_heq {α β : Sort u} (h : β = α) (x : α) : eq.mpr h x == x :=
by subst h; refl
end equality

/-
  quantifiers
-/

section quantifiers
variables {α : Sort*} {p q : α → Prop} {b : Prop}

def Exists.imp := @exists_imp_exists

theorem forall_swap {α β} {p : α → β → Prop} : (∀ x y, p x y) ↔ ∀ y x, p x y :=
⟨function.swap, function.swap⟩

theorem exists_swap {α β} {p : α → β → Prop} : (∃ x y, p x y) ↔ ∃ y x, p x y :=
⟨λ ⟨x, y, h⟩, ⟨y, x, h⟩, λ ⟨y, x, h⟩, ⟨x, y, h⟩⟩

@[simp] theorem exists_imp_distrib : ((∃ x, p x) → b) ↔ ∀ x, p x → b :=
⟨λ h x hpx, h ⟨x, hpx⟩, λ h ⟨x, hpx⟩, h x hpx⟩

--theorem forall_not_of_not_exists (h : ¬ ∃ x, p x) : ∀ x, ¬ p x :=
--forall_imp_of_exists_imp h

theorem not_exists_of_forall_not (h : ∀ x, ¬ p x) : ¬ ∃ x, p x :=
exists_imp_distrib.2 h

@[simp] theorem not_exists : (¬ ∃ x, p x) ↔ ∀ x, ¬ p x :=
exists_imp_distrib

theorem not_forall_of_exists_not : (∃ x, ¬ p x) → ¬ ∀ x, p x
| ⟨x, hn⟩ h := hn (h x)

theorem not_forall {p : α → Prop}
    [decidable (∃ x, ¬ p x)] [∀ x, decidable (p x)] :
  (¬ ∀ x, p x) ↔ ∃ x, ¬ p x :=
⟨not.imp_symm $ λ nx x, nx.imp_symm $ λ h, ⟨x, h⟩,
 not_forall_of_exists_not⟩

@[simp] theorem not_forall_not [decidable (∃ x, p x)] :
  (¬ ∀ x, ¬ p x) ↔ ∃ x, p x :=
by haveI := decidable_of_iff (¬ ∃ x, p x) not_exists;
   exact not_iff_comm.1 not_exists

@[simp] theorem not_exists_not [∀ x, decidable (p x)] :
  (¬ ∃ x, ¬ p x) ↔ ∀ x, p x :=
by simp

@[simp] theorem forall_true_iff : (α → true) ↔ true :=
iff_true_intro (λ _, trivial)

-- Unfortunately this causes simp to loop sometimes, so we
-- add the 2 and 3 cases as simp lemmas instead
theorem forall_true_iff' (h : ∀ a, p a ↔ true) : (∀ a, p a) ↔ true :=
iff_true_intro (λ _, of_iff_true (h _))

@[simp] theorem forall_2_true_iff {β : α → Sort*} : (∀ a, β a → true) ↔ true :=
forall_true_iff' $ λ _, forall_true_iff

@[simp] theorem forall_3_true_iff {β : α → Sort*} {γ : Π a, β a → Sort*} :
  (∀ a (b : β a), γ a b → true) ↔ true :=
forall_true_iff' $ λ _, forall_2_true_iff

@[simp] theorem forall_const (α : Sort*) [inhabited α] : (α → b) ↔ b :=
⟨λ h, h (arbitrary α), λ hb x, hb⟩

@[simp] theorem exists_const (α : Sort*) [inhabited α] : (∃ x : α, b) ↔ b :=
⟨λ ⟨x, h⟩, h, λ h, ⟨arbitrary α, h⟩⟩

theorem forall_and_distrib : (∀ x, p x ∧ q x) ↔ (∀ x, p x) ∧ (∀ x, q x) :=
⟨λ h, ⟨λ x, (h x).left, λ x, (h x).right⟩, λ ⟨h₁, h₂⟩ x, ⟨h₁ x, h₂ x⟩⟩

theorem exists_or_distrib : (∃ x, p x ∨ q x) ↔ (∃ x, p x) ∨ (∃ x, q x) :=
⟨λ ⟨x, hpq⟩, hpq.elim (λ hpx, or.inl ⟨x, hpx⟩) (λ hqx, or.inr ⟨x, hqx⟩),
 λ hepq, hepq.elim (λ ⟨x, hpx⟩, ⟨x, or.inl hpx⟩) (λ ⟨x, hqx⟩, ⟨x, or.inr hqx⟩)⟩

@[simp] theorem exists_and_distrib_left {q : Prop} {p : α → Prop} :
  (∃x, q ∧ p x) ↔ q ∧ (∃x, p x) :=
⟨λ ⟨x, hq, hp⟩, ⟨hq, x, hp⟩, λ ⟨hq, x, hp⟩, ⟨x, hq, hp⟩⟩

@[simp] theorem exists_and_distrib_right {q : Prop} {p : α → Prop} :
  (∃x, p x ∧ q) ↔ (∃x, p x) ∧ q :=
by simp [and_comm]

@[simp] theorem forall_eq {a' : α} : (∀a, a = a' → p a) ↔ p a' :=
⟨λ h, h a' rfl, λ h a e, e.symm ▸ h⟩

@[simp] theorem exists_eq {a' : α} : ∃ a, a = a' := ⟨_, rfl⟩

@[simp] theorem exists_eq_left {a' : α} : (∃ a, a = a' ∧ p a) ↔ p a' :=
⟨λ ⟨a, e, h⟩, e ▸ h, λ h, ⟨_, rfl, h⟩⟩

@[simp] theorem exists_eq_right {a' : α} : (∃ a, p a ∧ a = a') ↔ p a' :=
(exists_congr $ by exact λ a, and.comm).trans exists_eq_left

@[simp] theorem forall_eq' {a' : α} : (∀a, a' = a → p a) ↔ p a' :=
by simp [@eq_comm _ a']

@[simp] theorem exists_eq_left' {a' : α} : (∃ a, a' = a ∧ p a) ↔ p a' :=
by simp [@eq_comm _ a']

@[simp] theorem exists_eq_right' {a' : α} : (∃ a, p a ∧ a' = a) ↔ p a' :=
by simp [@eq_comm _ a']

theorem forall_or_of_or_forall (h : b ∨ ∀x, p x) (x) : b ∨ p x :=
h.imp_right $ λ h₂, h₂ x

theorem forall_or_distrib_left {q : Prop} {p : α → Prop} [decidable q] :
  (∀x, q ∨ p x) ↔ q ∨ (∀x, p x) :=
⟨λ h, if hq : q then or.inl hq else or.inr $ λ x, (h x).resolve_left hq,
  forall_or_of_or_forall⟩

@[simp] theorem exists_prop {p q : Prop} : (∃ h : p, q) ↔ p ∧ q :=
⟨λ ⟨h₁, h₂⟩, ⟨h₁, h₂⟩, λ ⟨h₁, h₂⟩, ⟨h₁, h₂⟩⟩

@[simp] theorem exists_false : ¬ (∃a:α, false) := assume ⟨a, h⟩, h

theorem Exists.fst {p : b → Prop} : Exists p → b
| ⟨h, _⟩ := h

theorem Exists.snd {p : b → Prop} : ∀ h : Exists p, p h.fst
| ⟨_, h⟩ := h

@[simp] theorem forall_prop_of_true {p : Prop} {q : p → Prop} (h : p) : (∀ h' : p, q h') ↔ q h :=
@forall_const (q h) p ⟨h⟩

@[simp] theorem exists_prop_of_true {p : Prop} {q : p → Prop} (h : p) : (∃ h' : p, q h') ↔ q h :=
@exists_const (q h) p ⟨h⟩

@[simp] theorem forall_prop_of_false {p : Prop} {q : p → Prop} (hn : ¬ p) : (∀ h' : p, q h') ↔ true :=
iff_true_intro $ λ h, hn.elim h

@[simp] theorem exists_prop_of_false {p : Prop} {q : p → Prop} : ¬ p → ¬ (∃ h' : p, q h') :=
mt Exists.fst

end quantifiers

/- classical versions -/

namespace classical
variables {α : Sort*} {p : α → Prop}

local attribute [instance] prop_decidable

protected theorem not_forall : (¬ ∀ x, p x) ↔ (∃ x, ¬ p x) := not_forall

protected theorem forall_or_distrib_left {q : Prop} {p : α → Prop} :
  (∀x, q ∨ p x) ↔ q ∨ (∀x, p x) :=
forall_or_distrib_left

theorem cases {p : Prop → Prop} (h1 : p true) (h2 : p false) : ∀a, p a :=
assume a, cases_on a h1 h2

theorem or_not {p : Prop} : p ∨ ¬ p :=
by_cases or.inl or.inr

protected theorem or_iff_not_imp_left {p q : Prop} : p ∨ q ↔ (¬ p → q) :=
or_iff_not_imp_left

protected theorem or_iff_not_imp_right {p q : Prop} : q ∨ p ↔ (¬ p → q) :=
or_iff_not_imp_right

protected lemma not_not {p : Prop} : ¬¬p ↔ p := not_not

/- use shortened names to avoid conflict when classical namespace is open -/
noncomputable theorem dec (p : Prop) : decidable p := by apply_instance
noncomputable theorem dec_pred (p : α → Prop) : decidable_pred p := by apply_instance
noncomputable theorem dec_rel (p : α → α → Prop) : decidable_rel p := by apply_instance
noncomputable theorem dec_eq (α : Sort*) : decidable_eq α := by apply_instance

@[elab_as_eliminator]
noncomputable def {u} exists_cases {C : Sort u} (H0 : C) (H : ∀ a, p a → C) : C :=
if h : ∃ a, p a then H (classical.some h) (classical.some_spec h) else H0

lemma some_spec2 {α : Type*} {p : α → Prop} {h : ∃a, p a}
  (q : α → Prop) (hpq : ∀a, p a → q a) : q (some h) :=
hpq _ $ some_spec _

end classical

@[elab_as_eliminator]
noncomputable def {u} exists.classical_rec_on
 {α} {p : α → Prop} (h : ∃ a, p a) {C : Sort u} (H : ∀ a, p a → C) : C :=
H (classical.some h) (classical.some_spec h)

/-
   bounded quantifiers
-/

section bounded_quantifiers
variables {α : Sort*} {r p q : α → Prop} {P Q : ∀ x, p x → Prop} {b : Prop}

theorem bex_def : (∃ x (h : p x), q x) ↔ ∃ x, p x ∧ q x :=
⟨λ ⟨x, px, qx⟩, ⟨x, px, qx⟩, λ ⟨x, px, qx⟩, ⟨x, px, qx⟩⟩

theorem bex.elim {b : Prop} : (∃ x h, P x h) → (∀ a h, P a h → b) → b
| ⟨a, h₁, h₂⟩ h' := h' a h₁ h₂

theorem bex.intro (a : α) (h₁ : p a) (h₂ : P a h₁) : ∃ x (h : p x), P x h :=
⟨a, h₁, h₂⟩

theorem ball_congr (H : ∀ x h, P x h ↔ Q x h) :
  (∀ x h, P x h) ↔ (∀ x h, Q x h) :=
forall_congr $ λ x, forall_congr (H x)

theorem bex_congr (H : ∀ x h, P x h ↔ Q x h) :
  (∃ x h, P x h) ↔ (∃ x h, Q x h) :=
exists_congr $ λ x, exists_congr (H x)

theorem ball.imp_right (H : ∀ x h, (P x h → Q x h))
  (h₁ : ∀ x h, P x h) (x h) : Q x h :=
H _ _ $ h₁ _ _

theorem bex.imp_right (H : ∀ x h, (P x h → Q x h)) :
  (∃ x h, P x h) → ∃ x h, Q x h
| ⟨x, h, h'⟩ := ⟨_, _, H _ _ h'⟩

theorem ball.imp_left (H : ∀ x, p x → q x)
  (h₁ : ∀ x, q x → r x) (x) (h : p x) : r x :=
h₁ _ $ H _ h

theorem bex.imp_left (H : ∀ x, p x → q x) :
  (∃ x (_ : p x), r x) → ∃ x (_ : q x), r x
| ⟨x, hp, hr⟩ := ⟨x, H _ hp, hr⟩

theorem ball_of_forall (h : ∀ x, p x) (x) (_ : q x) : p x :=
h x

theorem forall_of_ball (H : ∀ x, p x) (h : ∀ x, p x → q x) (x) : q x :=
h x $ H x

theorem bex_of_exists (H : ∀ x, p x) : (∃ x, q x) → ∃ x (_ : p x), q x
| ⟨x, hq⟩ := ⟨x, H x, hq⟩

theorem exists_of_bex : (∃ x (_ : p x), q x) → ∃ x, q x
| ⟨x, _, hq⟩ := ⟨x, hq⟩

@[simp] theorem bex_imp_distrib : ((∃ x h, P x h) → b) ↔ (∀ x h, P x h → b) :=
by simp

theorem not_bex : (¬ ∃ x h, P x h) ↔ ∀ x h, ¬ P x h :=
bex_imp_distrib

theorem not_ball_of_bex_not : (∃ x h, ¬ P x h) → ¬ ∀ x h, P x h
| ⟨x, h, hp⟩ al := hp $ al x h

theorem not_ball [decidable (∃ x h, ¬ P x h)] [∀ x h, decidable (P x h)] :
  (¬ ∀ x h, P x h) ↔ (∃ x h, ¬ P x h) :=
⟨not.imp_symm $ λ nx x h, nx.imp_symm $ λ h', ⟨x, h, h'⟩,
 not_ball_of_bex_not⟩

theorem ball_true_iff (p : α → Prop) : (∀ x, p x → true) ↔ true :=
iff_true_intro (λ h hrx, trivial)

theorem ball_and_distrib : (∀ x h, P x h ∧ Q x h) ↔ (∀ x h, P x h) ∧ (∀ x h, Q x h) :=
iff.trans (forall_congr $ λ x, forall_and_distrib) forall_and_distrib

theorem bex_or_distrib : (∃ x h, P x h ∨ Q x h) ↔ (∃ x h, P x h) ∨ (∃ x h, Q x h) :=
iff.trans (exists_congr $ λ x, exists_or_distrib) exists_or_distrib

end bounded_quantifiers

namespace classical
local attribute [instance] prop_decidable

theorem not_ball {α : Sort*} {p : α → Prop} {P : Π (x : α), p x → Prop} :
  (¬ ∀ x h, P x h) ↔ (∃ x h, ¬ P x h) := _root_.not_ball

end classical

section nonempty
universes u v w
variables {α : Type u} {β : Type v} {γ : α → Type w}

attribute [simp] nonempty_of_inhabited

lemma exists_true_iff_nonempty {α : Sort*} : (∃a:α, true) ↔ nonempty α :=
iff.intro (λ⟨a, _⟩, ⟨a⟩) (λ⟨a⟩, ⟨a, trivial⟩)

@[simp] lemma nonempty_Prop {p : Prop} : nonempty p ↔ p :=
iff.intro (assume ⟨h⟩, h) (assume h, ⟨h⟩)

lemma not_nonempty_iff_imp_false {p : Prop} : ¬ nonempty α ↔ α → false :=
⟨λ h a, h ⟨a⟩, λ h ⟨a⟩, h a⟩

@[simp] lemma nonempty_sigma : nonempty (Σa:α, γ a) ↔ (∃a:α, nonempty (γ a)) :=
iff.intro (assume ⟨⟨a, c⟩⟩, ⟨a, ⟨c⟩⟩) (assume ⟨a, ⟨c⟩⟩, ⟨⟨a, c⟩⟩)

@[simp] lemma nonempty_subtype {α : Sort u} {p : α → Prop} : nonempty (subtype p) ↔ (∃a:α, p a) :=
iff.intro (assume ⟨⟨a, h⟩⟩, ⟨a, h⟩) (assume ⟨a, h⟩, ⟨⟨a, h⟩⟩)

@[simp] lemma nonempty_prod : nonempty (α × β) ↔ (nonempty α ∧ nonempty β) :=
iff.intro (assume ⟨⟨a, b⟩⟩, ⟨⟨a⟩, ⟨b⟩⟩) (assume ⟨⟨a⟩, ⟨b⟩⟩, ⟨⟨a, b⟩⟩)

@[simp] lemma nonempty_pprod {α : Sort u} {β : Sort v} :
  nonempty (pprod α β) ↔ (nonempty α ∧ nonempty β) :=
iff.intro (assume ⟨⟨a, b⟩⟩, ⟨⟨a⟩, ⟨b⟩⟩) (assume ⟨⟨a⟩, ⟨b⟩⟩, ⟨⟨a, b⟩⟩)

@[simp] lemma nonempty_sum : nonempty (α ⊕ β) ↔ (nonempty α ∨ nonempty β) :=
iff.intro
  (assume ⟨h⟩, match h with sum.inl a := or.inl ⟨a⟩ | sum.inr b := or.inr ⟨b⟩ end)
  (assume h, match h with or.inl ⟨a⟩ := ⟨sum.inl a⟩ | or.inr ⟨b⟩ := ⟨sum.inr b⟩ end)

@[simp] lemma nonempty_psum {α : Sort u} {β : Sort v} :
  nonempty (psum α β) ↔ (nonempty α ∨ nonempty β) :=
iff.intro
  (assume ⟨h⟩, match h with psum.inl a := or.inl ⟨a⟩ | psum.inr b := or.inr ⟨b⟩ end)
  (assume h, match h with or.inl ⟨a⟩ := ⟨psum.inl a⟩ | or.inr ⟨b⟩ := ⟨psum.inr b⟩ end)

@[simp] lemma nonempty_psigma {α : Sort u} {β : α → Sort v} :
  nonempty (psigma β) ↔ (∃a:α, nonempty (β a)) :=
iff.intro (assume ⟨⟨a, c⟩⟩, ⟨a, ⟨c⟩⟩) (assume ⟨a, ⟨c⟩⟩, ⟨⟨a, c⟩⟩)

@[simp] lemma nonempty_empty : ¬ nonempty empty :=
assume ⟨h⟩, h.elim

@[simp] lemma nonempty_ulift : nonempty (ulift α) ↔ nonempty α :=
iff.intro (assume ⟨⟨a⟩⟩, ⟨a⟩) (assume ⟨a⟩, ⟨⟨a⟩⟩)

@[simp] lemma nonempty_plift {α : Sort u} : nonempty (plift α) ↔ nonempty α :=
iff.intro (assume ⟨⟨a⟩⟩, ⟨a⟩) (assume ⟨a⟩, ⟨⟨a⟩⟩)

@[simp] lemma nonempty.forall {α : Sort u} {p : nonempty α → Prop} :
  (∀h:nonempty α, p h) ↔ (∀a, p ⟨a⟩) :=
iff.intro (assume h a, h _) (assume h ⟨a⟩, h _)

@[simp] lemma nonempty.exists {α : Sort u} {p : nonempty α → Prop} :
  (∃h:nonempty α, p h) ↔ (∃a, p ⟨a⟩) :=
iff.intro (assume ⟨⟨a⟩, h⟩, ⟨a, h⟩) (assume ⟨a, h⟩, ⟨⟨a⟩, h⟩)

lemma classical.nonempty_pi {α : Sort u} {β : α → Sort v} :
  nonempty (Πa:α, β a) ↔ (∀a:α, nonempty (β a)) :=
iff.intro (assume ⟨f⟩ a, ⟨f a⟩) (assume f, ⟨assume a, classical.choice $ f a⟩)

-- inhabited_of_nonempty already exists, in core/init/classical.lean, but the
-- assumption is not [...], which makes it unsuitable for some applications
noncomputable def classical.inhabited_of_nonempty' {α : Sort u} [h : nonempty α] : inhabited α :=
⟨classical.choice h⟩

-- `nonempty` cannot be a `functor`, because `functor` is restricted to Types.
lemma nonempty.map {α : Sort u} {β : Sort v} (f : α → β) : nonempty α → nonempty β
| ⟨h⟩ := ⟨f h⟩

end nonempty


def add (n m : Nat) : Nat := n + m
@[simp] theorem addZero x : add 0 x = x := by
  simp [add]

syntax "bigAdd0Seq! " num : term

macro_rules
  | `(bigAdd0Seq! $n) =>
    let n := n.toNat
    if n == 0 then
      `(0)
    else
      `(add 0 (bigAdd0Seq! $(Lean.quote (n - 1))))

set_option maxRecDepth 10000

theorem ex : bigAdd0Seq! 20 = 0 := by
  simp

#print ex


import data.real.basic
import data.fin.vec_notation
import data.fin_enum

universe u

/-!
### Dimension type classes
-/

class has_time (α : Type u) :=
[dec : decidable_eq α]
(time [] : α)
(h : [time].nodup)

class has_length (α : Type u) :=
[dec : decidable_eq α]
(length [] : α)
(h : [length].nodup)

class has_mass (α : Type u) :=
[dec : decidable_eq α]
(mass [] : α)
(h : [mass].nodup)

class has_amount_of_substance (α : Type u) :=
[dec : decidable_eq α]
(amount_of_substance [] : α)
(h : [amount_of_substance].nodup)

class has_electric_current (α : Type u) :=
[dec : decidable_eq α]
(electric_current [] : α)
(h : [electric_current].nodup)

class has_temperature (α : Type u) :=
[dec : decidable_eq α]
(temperature [] : α)
(h : [temperature].nodup)

class has_luminous_intensity (α : Type u) :=
[dec : decidable_eq α]
(luminous_intensity [] : α)
(h : [luminous_intensity].nodup)

attribute [instance] has_time.dec
attribute [instance] has_length.dec
attribute [instance] has_mass.dec
attribute [instance] has_amount_of_substance.dec
attribute [instance] has_electric_current.dec
attribute [instance] has_temperature.dec
attribute [instance] has_luminous_intensity.dec

/-!
### Def of dimensions and its properties
-/

def dimension (α : Type u) := α → ℚ

namespace dimension
def dimensionless (α) : dimension α := λ i, 0
instance {α} : has_one (dimension α) := ⟨dimension.dimensionless α⟩
instance {α} : nonempty (dimension α) := has_one.nonempty

protected noncomputable def add {α} [decidable_eq (dimension α)]: dimension α → dimension α → dimension α :=
classical.epsilon $ λ f, ∀ a b, a = b → f a b = a
protected noncomputable def sub {α} [decidable_eq (dimension α)]: dimension α → dimension α → dimension α :=
classical.epsilon $ λ f, ∀ a b, a = b → f a b = a
protected def mul {α} : dimension α → dimension α → dimension α
| a b := λ (i : α), a i + b i
protected def div {α} : dimension α → dimension α → dimension α
| a b := λ (i : α), a i - b i

protected def qpow {α} : dimension α → ℚ → dimension α
| a n := λ (i : α), n • (a i)
protected def npow {α} : dimension α → ℕ → dimension α
| a n := a.qpow ↑n
protected def zpow {α} : dimension α → ℤ → dimension α
| a n := a.qpow ↑n
protected def inv {α} : dimension α → dimension α
| a := a.zpow (-1)

noncomputable instance {α} [decidable_eq (dimension α)] : has_add (dimension α) := ⟨dimension.add⟩
noncomputable instance {α} [decidable_eq (dimension α)] : has_sub (dimension α) := ⟨dimension.sub⟩
instance {α} : has_mul (dimension α) := ⟨dimension.mul⟩
instance {α} : has_div (dimension α) := ⟨dimension.div⟩
instance {α} : has_pow (dimension α) ℕ := ⟨dimension.npow⟩
instance {α} : has_pow (dimension α) ℤ := ⟨dimension.zpow⟩
instance {α} : has_pow (dimension α) ℚ := ⟨dimension.qpow⟩
instance {α} : has_inv (dimension α) := ⟨dimension.inv⟩

--I would love to add unicode to make specific globabl notation for dimension derivatives and integrals,
--but thats more fluff than important

protected def derivative {α} : ℕ → dimension α → dimension α → dimension α
| n a b := a / (b ^ n)
protected def integral {α} : dimension α → dimension α → dimension α
| a b := a * b

@[simp] lemma add_def {α} (a b : dimension α) [decidable_eq (dimension α)] : a.add b = a + b := by refl
@[simp] lemma add_def' {α} (a : dimension α) [decidable_eq (dimension α)] : a.add a = a :=
begin
  generalize hb : a = b, symmetry' at hb,
  nth_rewrite 1 hb, revert b a hb, unfold dimension.add,
  apply classical.epsilon_spec (⟨λ a _, a, λ _ _ _, rfl⟩ :
    ∃ (f : dimension α → dimension α → dimension α), ∀ a b, a = b → f a b = a),
end
@[simp] lemma add_def'' {α} (a : dimension α) [decidable_eq (dimension α)] : a + a = a := by {rw [← add_def, add_def'],}
@[simp] lemma sub_def {α} (a b : dimension α) [decidable_eq (dimension α)] : a.sub b = a - b := by refl
@[simp] lemma sub_def' {α} (a : dimension α) [decidable_eq (dimension α)] : a.sub a = a :=
begin
  generalize hb : a = b, symmetry' at hb,
  nth_rewrite 1 hb, revert b a hb, unfold dimension.sub,
  apply classical.epsilon_spec (⟨λ a _, a, λ _ _ _, rfl⟩ :
    ∃ (f : dimension α → dimension α → dimension α), ∀ a b, a = b → f a b = a),
end
@[simp] lemma sub_def'' {α} (a : dimension α) [decidable_eq (dimension α)] : a - a = a := by {rw [← sub_def, sub_def'],}
@[simp] lemma mul_def {α} (a b : dimension α) : a.mul b = a * b := by refl
@[simp] lemma mul_def' {α} (a b : dimension α) : a * b = λ (i : α), a i + b i := by refl
@[simp] lemma div_def {α} (a b : dimension α) : a.div b = a / b := by refl
@[simp] lemma div_def' {α} (a b : dimension α) : a / b = λ (i : α), a i - b i := by refl
@[simp] lemma qpow_def {α} (a : dimension α) (b : ℚ) : a.qpow b = a^b := by refl
@[simp] lemma qpow_def' {α} (a : dimension α) (b : ℚ) : a ^ b = λ (i : α), b • (a i):= by refl
@[simp] lemma pow_def {α} (a : dimension α) (b : ℕ) : a.npow b = a^b := by refl
@[simp] lemma pow_def' {α} (a : dimension α) (b : ℕ) : a ^ b = λ (i : α), b • (a i) := by {simp, refl}
@[simp] lemma zpow_def {α} (a : dimension α) (b : ℤ) : a.zpow b = a^b := by refl
@[simp] lemma zpow_def' {α} (a : dimension α) (b : ℤ) : a ^ b = λ (i : α), b • (a i) := by {simp, refl}
@[simp] lemma inv_def {α} (a : dimension α) : a.inv = a⁻¹ := by refl
@[simp] lemma inv_def' {α} (a : dimension α) : a⁻¹ = λ (i : α), (-1 : ℤ) • (a i) := by {rw [← inv_def, dimension.inv, dimension.zpow, dimension.qpow], simp}

/-!
### Definition of the base dimensions
-/
def length (α) [has_length α] : dimension α :=
pi.single (has_length.length α) 1

def time (α) [has_time α] : dimension α :=
pi.single (has_time.time α) 1

def mass (α) [has_mass α] : dimension α :=
pi.single (has_mass.mass α) 1

def amount_of_substance (α) [has_amount_of_substance α] : dimension α :=
pi.single (has_amount_of_substance.amount_of_substance α) 1

def electric_current (α) [has_electric_current α] : dimension α :=
pi.single (has_electric_current.electric_current α) 1

def temperature (α) [has_temperature α] : dimension α :=
pi.single (has_temperature.temperature α) 1

def luminous_intensity (α) [has_luminous_intensity α] : dimension α :=
pi.single (has_luminous_intensity.luminous_intensity α) 1

protected def numbers_are_dimensionless (α : Type*) [ordered_semiring α] [nontrivial α] {β}: α → dimension β
|a := dimension.dimensionless β
instance {α} [ordered_semiring α] [nontrivial α] {β}: has_coe α (dimension β):= ⟨dimension.numbers_are_dimensionless α⟩

@[simp] lemma one_eq_dimensionless {α} : 1 = dimensionless α := rfl
@[simp] lemma dimensionless_def' {α} : dimensionless α = λ i, 0 := rfl

protected theorem mul_comm {α} (a b : dimension α) : a * b = b * a := by {simp, funext, rw add_comm}
protected theorem div_mul_comm {α} (a b c : dimension α) : a / c * b  = b / c * a := by {simp, funext, rw sub_add_comm}
protected theorem mul_assoc {α} (a b c : dimension α) : a * b * c = a * (b * c) := by {simp, funext, rw add_assoc}
protected theorem mul_one {α} (a : dimension α) : a*1 = a := by simp
protected theorem one_mul {α} (a : dimension α) : 1*a = a := by simp
protected theorem div_eq_mul_inv {α} (a b : dimension α) : a / b = a * b⁻¹ := by {simp, funext, rw sub_eq_add_neg}
protected theorem mul_left_inv {α} (a : dimension α) : a⁻¹*a = 1 := by {simp}
protected theorem mul_right_inv {α} (a : dimension α) : a*a⁻¹ = 1 := by {simp}
@[simp] protected lemma nat_numbers_are_dimensionless {α} {n : ℕ}: ↑n = (1 : dimension α) := rfl
@[simp] protected lemma int_numbers_are_dimensionless {α} {z : ℤ}: ↑z = (1 : dimension α) := rfl
@[simp] protected lemma rat_numbers_are_dimensionless {α} {q : ℚ}: ↑q = (1 : dimension α) := rfl
@[simp] protected lemma real_numbers_are_dimensionless {α} {r : ℝ}: ↑r = (1 : dimension α) := rfl

instance {α} : comm_group (dimension α) :=
begin
  refine_struct { mul := dimension.mul,
                  div := dimension.div,
                  inv := dimension.inv,
                  mul_assoc := dimension.mul_assoc,
                  one := dimensionless α,
                  npow := @npow_rec (dimension α) dimension.has_one dimension.has_mul,
                  zpow := @zpow_rec (dimension α) dimension.has_one dimension.has_mul dimension.has_inv,
                  one_mul := dimension.one_mul,
                  mul_one := dimension.mul_one,
                  mul_comm := dimension.mul_comm,
                  div_eq_mul_inv := dimension.div_eq_mul_inv,
                  mul_left_inv := dimension.mul_left_inv,},
  repeat {rintro ⟨_⟩, },
  iterate 8 {intro, refl,},
end
noncomputable theorem fun_equiv {α β c} (H : α ≃ β) : (α → c) → (β → c) :=
begin
  intros h h1,
  apply h (H.inv_fun h1),
end

noncomputable def dimension.to_tuple {α} [fintype α] [decidable_eq α] (a : dimension α) : fin (fintype.card α) → ℚ :=
begin
  have h := fintype.trunc_equiv_fin α,
  have h1 : α ≃ fin (fintype.card α) := trunc.out h,
  intro h2,
  apply fun_equiv h1 a h2,
end

/-!
### Other dimensions
-/
--physics
def velocity (α) [has_length α] [has_time α] : dimension α := length α / time α

def acceleration (α) [has_length α] [has_time α] : dimension α := length α / ((time α) ^ 2)

def force (α) [has_length α] [has_time α] [has_mass α] : dimension α := length α / ((time α) ^ 2) * mass α

theorem accel_eq_vel_div_time {α} [has_length α] [has_time α] : acceleration α = velocity α / time α :=
begin
  field_simp [velocity, acceleration],
  funext,
  ring_nf,
end

theorem force_eq_mass_mul_accel {α} [has_length α] [has_time α] [has_mass α] : force α = mass α * acceleration α :=
begin
  simp [force, acceleration],
  funext,
  ring_nf,
end

end dimension
/-!
### examples for personal understanding
-/
inductive system1
| time | length

instance : decidable_eq system1
| system1.time system1.time := is_true rfl
| system1.time system1.length := is_false (λ h, system1.no_confusion h)
| system1.length system1.time := is_false (λ h, system1.no_confusion h)
| system1.length system1.length := is_true rfl

lemma system1.time_nodup : [system1.time].nodup := by finish
lemma system1.length_nodup : [system1.length].nodup := by finish

instance : has_time system1 := {dec := system1.decidable_eq, time := system1.time, h := system1.time_nodup}
instance : has_length system1 := {dec := system1.decidable_eq, length := system1.length, h := system1.length_nodup}

lemma system1_length_to_has_length : system1.length = has_length.length system1:= by refl
lemma system1_time_to_has_time : system1.time = has_time.time system1:= by refl

--Working on cardinality to convert dimension as system1 → ℚ to fin n → ℚ for matrix
instance : fintype system1 := ⟨⟨multiset.cons system1.time (multiset.cons system1.length ∅), by simp⟩, λ x, by cases x; simp⟩

noncomputable def system1.dimension_equiv_rat_tuple : dimension system1 ≃ (fin 2 → ℚ) := equiv.arrow_congr (fintype.equiv_fin system1) (equiv.refl ℚ)

noncomputable instance : fin_enum system1 := ⟨fintype.card system1, (fintype.equiv_fin system1)⟩

theorem system1.dimension_eq_tuple (a : dimension system1) : system1.dimension_equiv_rat_tuple a = ![a system1.length, a system1.time] :=
begin

end

example (h) :   vector.nth h = ![1,2,3,4] :=
begin
  funext,

end
protected def system1.repr : system1 → string
| system1.length := "length"
| system1.time := "time"

instance : has_repr system1 := ⟨system1.repr⟩

open dimension
theorem system1.accel_eq_vel_div_time : acceleration system1 = velocity system1 / time system1 := accel_eq_vel_div_time

--This show that we index our tuple through the specific base dimension rather than the previous way of vector number

example : (dimension.time system1) system1.length = 0 :=
begin
  simp [dimension.time],
  apply pi.single_eq_of_ne,
  finish,
end

example : (dimension.length system1) * (dimension.length system1) = pi.single (has_length.length system1) 2 :=
begin
  simp [dimension.length],
  ext1,
  cases x,
  rw [pi.single_eq_of_ne, pi.single_eq_of_ne],
  iterate 4 {finish},
end

example : ((dimension.length system1) * (dimension.length system1)) system1.length = 2 :=
begin
  simp [dimension.length],
  finish,
end


import applications.topologies
import opens

/-!
The category `Sheaf` of (set-valued) sheaves on a site is defined, using the sheaf condition as
defined in `grothendieck.lean`. It's defined somewhat abstractly, but an equivalent condition
(`grothendieck.sheaf_condition'`) is given there too, which is more concrete.
-/
universes v u

noncomputable theory

namespace category_theory
namespace site_sheaf

open category limits

variables (C : Type u) [small_category C] (J : sieve_set C) [grothendieck J]

structure Sheaf :=
(P : Cᵒᵖ ⥤ Type u)
(sheaf_cond : grothendieck.sheaf_condition J P)

instance : category (Sheaf C J) := induced_category.category Sheaf.P

/--
The category of sheaves (in the Grothendieck sense) is equivalent to a special case of sheaves on
a local operator. We use this equivalence to transfer properties from the abstract topos theory
to the geometric case.
-/
def equiv_lt_sheaf : Sheaf C J ≌ sheaf (j J) :=
{ functor :=
  { obj := λ P, sheaf.mk P.P (equivalent_sheaf_conditions _ _ P.sheaf_cond),
    map := λ P Q f, f },
  inverse :=
  { obj := λ P, ⟨P.A, (equivalent_sheaf_conditions _ _).symm (get_condition P)⟩,
    map := λ P Q f, f },
  unit_iso := nat_iso.of_components (λ P, {hom := 𝟙 _, inv := 𝟙 _}) (by tidy),
  counit_iso := nat_iso.of_components (λ P, {hom := 𝟙 _, inv := 𝟙 _}) (by tidy) }

/-- The forgetful functor from sheaves to presheaves. -/
def forget_Sheaf : Sheaf C J ⥤ (Cᵒᵖ ⥤ Type u) := induced_functor _

instance : full (forget_Sheaf C J) := induced_category.full _
instance : faithful (forget_Sheaf C J) := induced_category.faithful _

/-- The sheafification functor for sheaves on a site. -/
def sheafify : (Cᵒᵖ ⥤ Type u) ⥤ Sheaf C J := sheafification (j J) ⋙ (equiv_lt_sheaf _ _).inverse

/-- The equivalence between Sheaf and sheaf commutes with their respective forgetful functors. -/
lemma forget_comm : forget_Sheaf C J = (equiv_lt_sheaf _ _).functor ⋙ sheaf.forget (j J) := rfl

/-- Sheafification is left adjoint to the inclusion into presheaves. -/
def Sheafy_adjoint : sheafify C J ⊣ forget_Sheaf C J :=
adjunction.comp _ _ (sheafification_is_adjoint (j J)) (equiv_lt_sheaf _ _).symm.to_adjunction

instance : is_right_adjoint (forget_Sheaf C J) :=
{ left := _, adj := Sheafy_adjoint C J }

/-- The category of sheaves is a reflective subcategory of presheaves -/
instance : reflective (forget_Sheaf C J) := {}.

/-- The forgetful functor creates limits. -/
instance : creates_limits (forget_Sheaf C J) :=
{ creates_limits_of_shape := λ D 𝒟,
  { creates_limit := λ K,
    begin
      change creates_limit _ ((equiv_lt_sheaf _ _).functor ⋙ sheaf.forget (j J)),
      apply_instance,
    end } }

/-- Sheafification preserves finite products -/
instance preserve_fin_prod (D : Type u) [decidable_eq D] [fintype D] : preserves_limits_of_shape (discrete D) (sheafify C J) :=
{ preserves_limit := λ K,
begin
  unfold sheafify,
  haveI := sheafification_preserves_finite_products (j J) D,
  apply_instance,
end }

/-- Sheafification preserves equalizers -/
instance preserve_equalizer : preserves_limits_of_shape walking_parallel_pair (sheafify C J) :=
{ preserves_limit := λ K,
begin
  unfold sheafify,
  haveI := sheafification_preserves_equalizers (j J),
  apply_instance,
end }

end site_sheaf

open topological_space topological_space.opens

/-- Sheaves on a space. -/
abbreviation Sh (X : Type u) [topological_space X] := site_sheaf.Sheaf (opens X) (covering X)

end category_theory


import  data.set.function
open  set

variables α β : Type
variables  A :set α
variables  B :set β
variable f:α → β
variable g:β → α
theorem Schroder_Bernstein:
inj_on f A ∧ inj_on g B ∧ maps_to f A B ∧ maps_to g B A → ∃ h:α → β, bij_on h A B
:=
sorry


/-
Copyright (c) 2015 Microsoft Corporation. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Leonardo de Moura, Jeremy Avigad, Mario Carneiro
-/
import Mathlib.Tactic.Alias
import Mathlib.Tactic.IrreducibleDef
import Mathlib.Mathport.Rename
import Mathlib.Init.Logic

/-! ### alignments from lean 3 `init.classical` -/

namespace Classical

#align classical.inhabited_of_nonempty Classical.inhabited_of_nonempty
#align classical.inhabited_of_exists Classical.inhabited_of_exists

attribute [local instance] propDecidable
attribute [local instance] decidableInhabited

alias axiomOfChoice ← axiom_of_choice -- TODO: fix in core
alias propComplete ← prop_complete -- TODO: fix in core

@[elab_as_elim] theorem cases_true_false (p : Prop → Prop)
    (h1 : p True) (h2 : p False) (a : Prop) : p a :=
  Or.elim (prop_complete a) (fun ht : a = True ↦ ht.symm ▸ h1) fun hf : a = False ↦ hf.symm ▸ h2

theorem cases_on (a : Prop) {p : Prop → Prop} (h1 : p True) (h2 : p False) : p a :=
  @cases_true_false p h1 h2 a

theorem cases {p : Prop → Prop} (h1 : p True) (h2 : p False) (a) : p a := cases_on a h1 h2
#align classical.cases Classical.cases

alias byCases ← by_cases
alias byContradiction ← by_contradiction

theorem eq_false_or_eq_true (a : Prop) : a = False ∨ a = True := (prop_complete a).symm

end Classical


import field_theory.polynomial_galois_group

open polynomial
open_locale polynomial big_operators

namespace mul_action

@[to_additive]
instance (α : Type*) {β : Type*} [monoid α] [fintype α] [mul_action α β] [decidable_eq β] (b : β) :
  fintype (orbit α b) := set.fintype_range _

@[to_additive]
instance (α : Type*) {β : Type*} [group α] [fintype α] [mul_action α β] [decidable_eq β]
  (x : mul_action.orbit_rel.quotient α β) :
  fintype x.orbit :=
quotient.rec_on_subsingleton' x (λ a, set.fintype_range _)

end mul_action

namespace minpoly

lemma eq_of_alg_hom_eq {K S T : Type*} [field K] [ring S] [ring T]
  [algebra K S] [algebra K T]
  (f : S →ₐ[K] T) (hf : function.injective f)
  {x : S} {y : T} (hx : is_integral K x) (h : y = f x) :
  minpoly K x = minpoly K y :=
minpoly.unique _ _ (minpoly.monic hx)
  (by rw [h, aeval_alg_hom_apply, minpoly.aeval, alg_hom.map_zero])
  (λ q q_monic root_q, minpoly.min _ _ q_monic
    (by rwa [h, aeval_alg_hom_apply, map_eq_zero_iff _ hf] at root_q))

end minpoly

section heq
universes u₁ u₂ u₃

namespace fun_like

variables {F F' : Sort u₁} {α α' : Sort u₂} {β : α → Sort u₃} {β' : α' → Sort u₃}
  [i : fun_like F α β] [i' : fun_like F' α' β']

lemma ext_heq {f : F} {f' : F'}
  (h₁ : F = F') (h₂ : α = α') (h₃ : β == β') (h₄ : i == i')
  (h : ∀ x x', x == x' → f x == f' x') :
  f == f' :=
by { unfreezingI { cases h₁, cases h₂, cases h₃, cases h₄, },
  exact heq_of_eq (fun_like.ext f f' (λ x, eq_of_heq (h x x heq.rfl))), }

lemma congr_heq {f : F} {f' : F'} {x : α} {x' : α'}
  (h₁ : f == f') (h₂ : x == x') (h₃ : β == β') (h₄ : i == i') :
  f x == f' x' :=
by { unfreezingI { cases h₁, cases h₂, cases h₃, cases h₄, }, refl, }

end fun_like

universe u

lemma cast_heq' {α β α' : Sort u} (h : α = β) {a : α} {a' : α'} (h' : a == a') : cast h a == a' :=
by { cases h, cases h', refl, }

end heq

namespace alg_equiv
variables {R : Type*} [comm_semiring R] {A₁ A₂ : Type*}
variables [semiring A₁] [semiring A₂]
variables [algebra R A₁] [algebra R A₂]
variables (e : A₁ ≃ₐ[R] A₂)

lemma symm_apply_eq {x y} : e.symm x = y ↔ x = e y :=
e.to_equiv.symm_apply_eq

end alg_equiv

namespace intermediate_field

variables (F : Type*) [field F] {E : Type*} [field E] [algebra F E] {α : E}

lemma adjoin_root_equiv_adjoin_symm_apply_gen (h : is_integral F α) :
  (adjoin_root_equiv_adjoin F h).symm (adjoin_simple.gen F α) =
    adjoin_root.root (minpoly F α) :=
by rw [alg_equiv.symm_apply_eq, adjoin_root_equiv_adjoin_apply_root]

end intermediate_field

namespace polynomial

variables {T : Type*} [comm_ring T]

noncomputable abbreviation aroots (p : T[X]) (S) [comm_ring S] [is_domain S] [algebra T S] : multiset S :=
(p.map (algebra_map T S)).roots

lemma aroots_def (p : T[X]) (S) [comm_ring S] [is_domain S] [algebra T S] :
  p.aroots S = (p.map (algebra_map T S)).roots := rfl

lemma aroots_map (p : T[X]) (S) (A) [comm_ring S] [is_domain S] [algebra T S]
  [comm_ring A] [is_domain A] [algebra S A] [algebra T A] [is_scalar_tower T S A] :
(p.map (algebra_map T S)).aroots A = p.aroots A :=
by rw [aroots_def, map_map, ← is_scalar_tower.algebra_map_eq T S A]

end polynomial

section gal_conj_classes
variables (F : Type*) [field F] (E : Type*) [field E] [algebra F E]

def is_gal_conj.setoid := mul_action.orbit_rel (E ≃ₐ[F] E) E
def gal_conj_classes := mul_action.orbit_rel.quotient (E ≃ₐ[F] E) E

local attribute [instance] is_gal_conj.setoid

variable {E}

def is_gal_conj (x y : E) : Prop := (is_gal_conj.setoid F E).r x y

-- need to fix the precedence
notation (name := is_gal_conj) x ` ≈g[`:50 F `] ` y := is_gal_conj F x y

instance [decidable_eq E] [fintype (E ≃ₐ[F] E)] (x y : E) : decidable (x ≈g[F] y) :=
  fintype.decidable_exists_fintype

instance [decidable_eq E] [fintype (E ≃ₐ[F] E)] : decidable_eq (gal_conj_classes F E) :=
@quotient.decidable_eq _ (is_gal_conj.setoid F E) (is_gal_conj.decidable F)

namespace is_gal_conj

instance : is_equiv E (is_gal_conj F) := quotient.has_equiv.equiv.is_equiv

@[refl] lemma refl (x : E) : x ≈g[F] x := refl x
@[symm] lemma symm {x y : E} : (x ≈g[F] y) → (y ≈g[F] x) := symm
@[trans] lemma trans {x y z : E} : (x ≈g[F] y) → (y ≈g[F] z) → (x ≈g[F] z) := trans

end is_gal_conj

namespace gal_conj_classes

def mk (x : E) : gal_conj_classes F E := ⟦x⟧

instance : has_zero (gal_conj_classes F E) := ⟨mk F 0⟩

lemma zero_def : (0 : gal_conj_classes F E) = mk F 0 := rfl

variable {F}

noncomputable def out (c : gal_conj_classes F E) : E := c.out

@[simp] theorem eq {x y : E} : mk F x = mk F y ↔ x ≈g[F] y := quotient.eq
@[simp] theorem out_eq (q : gal_conj_classes F E) : mk F q.out = q := q.out_eq
theorem mk_out (x : E) : (mk F x).out ≈ x := quotient.mk_out x
lemma mk_eq_iff_out {x : E} {c : gal_conj_classes F E} :
  mk F x = c ↔ x ≈g[F] c.out := quotient.mk_eq_iff_out
lemma eq_mk_iff_out {c : gal_conj_classes F E} {x : E} :
  c = mk F x ↔ c.out ≈g[F] x := quotient.eq_mk_iff_out
@[simp] lemma out_equiv_out {c₁ c₂ : gal_conj_classes F E} :
  (c₁.out ≈g[F] c₂.out) ↔ c₁ = c₂ := @quotient.out_equiv_out _ _ c₁ c₂

lemma equiv_zero_iff (x : E) : (x ≈g[F] 0) ↔ x = 0 :=
begin
  refine ⟨λ h, _, λ h, by rw [h]⟩,
  cases h with a ha,
  simp_rw [← ha, alg_equiv.smul_def, map_zero],
end

lemma out_eq_zero_iff (c : gal_conj_classes F E) : c.out = 0 ↔ c = 0 :=
by rw [zero_def, eq_mk_iff_out, equiv_zero_iff]

lemma zero_out : (0 : gal_conj_classes F E).out = 0 :=
(out_eq_zero_iff 0).mpr rfl

lemma mk_eq_zero_iff (x : E) : mk F x = 0 ↔ x = 0 :=
by rw [mk_eq_iff_out, zero_out, equiv_zero_iff]

lemma mk_zero : mk F (0 : E) = 0 :=
(mk_eq_zero_iff 0).mpr rfl

def orbit (c : gal_conj_classes F E) : set E := c.orbit

instance [decidable_eq E] [fintype (E ≃ₐ[F] E)] (c : gal_conj_classes F E) :
  fintype c.orbit :=
quotient.rec_on_subsingleton' c (λ a, set.fintype_range _)

lemma mem_orbit {x : E} {c : gal_conj_classes F E} :
  x ∈ c.orbit ↔ mk F x = c := mul_action.orbit_rel.quotient.mem_orbit

lemma orbit_zero : (0 : gal_conj_classes F E).orbit = {0} :=
by { ext, rw [mem_orbit, mk_eq_zero_iff], refl, }

instance : has_neg (gal_conj_classes F E) :=
  ⟨quotient.lift (λ (x : E), mk F (-x)) begin
    rintros _ y ⟨f, rfl⟩, rw [eq],
    use f, change f (-y) = -f y, rw [alg_equiv.map_neg],
end⟩

lemma mk_neg (x : E) : mk F (-x) = -mk F x := rfl

instance : has_involutive_neg (gal_conj_classes F E) :=
{ neg_neg := λ x, by rw [← out_eq x, ← mk_neg, ← mk_neg, neg_neg],
  ..(infer_instance : has_neg (gal_conj_classes F E)), }

lemma exist_mem_orbit_add_eq_zero (x y : gal_conj_classes F E) :
  (∃ (a b : E), (a ∈ x.orbit ∧ b ∈ y.orbit) ∧ a + b = 0) ↔ x = -y :=
begin
  simp_rw [mem_orbit],
  split,
  { rintros ⟨a, b, ⟨rfl, rfl⟩, h⟩,
    rw [← mk_neg, eq, add_eq_zero_iff_eq_neg.mp h], },
  { rintro rfl,
    refine ⟨-y.out, y.out, _⟩,
    simp_rw [mk_neg, out_eq, neg_add_self, eq_self_iff_true, true_and], },
end

variable [is_separable F E]

noncomputable def minpoly : gal_conj_classes F E → F[X] :=
quotient.lift (minpoly F) (λ (a b : E) ⟨f, h⟩, minpoly.eq_of_alg_hom_eq
  f.symm.to_alg_hom f.symm.injective
  (is_separable.is_integral F a) (h ▸ (f.symm_apply_apply b).symm))

lemma minpoly_mk (x : E) : minpoly (mk F x) = _root_.minpoly F x := rfl

lemma minpoly_out (c : gal_conj_classes F E) : _root_.minpoly F c.out = minpoly c :=
by rw [← c.out_eq, minpoly_mk, c.out_eq]

lemma minpoly.monic (c : gal_conj_classes F E) : (minpoly c).monic :=
by { rw [← c.out_eq, minpoly_mk], exact minpoly.monic (is_separable.is_integral F _), }

lemma minpoly.ne_zero (c : gal_conj_classes F E) : minpoly c ≠ 0 :=
by { rw [← c.out_eq, minpoly_mk], exact minpoly.ne_zero (is_separable.is_integral F _), }

lemma minpoly.irreducible (c : gal_conj_classes F E) : irreducible (minpoly c) :=
by { rw [← c.out_eq, minpoly_mk], exact minpoly.irreducible (is_separable.is_integral F _), }

lemma minpoly.splits [n : normal F E] (c : gal_conj_classes F E) :
  splits (algebra_map F E) (minpoly c) :=
by { rw [← c.out_eq, minpoly_mk], exact n.splits c.out, }

lemma minpoly.separable (c : gal_conj_classes F E) : separable (minpoly c) :=
by { rw [← c.out_eq, minpoly_mk], exact is_separable.separable F c.out, }

lemma minpoly.inj [normal F E] {c d : gal_conj_classes F E} (h : minpoly c = minpoly d) : c = d :=
begin
  let fc := intermediate_field.adjoin_root_equiv_adjoin F (is_separable.is_integral F c.out),
  let fd := intermediate_field.adjoin_root_equiv_adjoin F (is_separable.is_integral F d.out),
  let congr_f : adjoin_root (_root_.minpoly F c.out) ≃ₐ[F] adjoin_root (_root_.minpoly F d.out),
  { rw [minpoly_out, minpoly_out, h], },
  have congr_f_apply : ∀ x, congr_f x == x,
  { intro x, change congr_f x == (alg_equiv.refl : _ ≃ₐ[F] _) x,
    dsimp only [congr_f],
    refine fun_like.congr_heq _ heq.rfl _ _,
    { simp_rw [eq_mpr_eq_cast, cast_cast],
      refine cast_heq' _ (fun_like.ext_heq _ _ _ _ _),
      any_goals { rw [minpoly_out, h], },
      rintros x₁ x₂ rfl, refl, },
    all_goals { rw [minpoly_out, minpoly_out, h], }, },
  let f' := fc.symm.trans (congr_f.trans fd),
  let f := f'.lift_normal E,
  rw [← out_equiv_out],
  refine ⟨f.symm, _⟩,
  dsimp only [f, alg_equiv.smul_def],
  simp_rw [alg_equiv.symm_apply_eq, ← intermediate_field.adjoin_simple.algebra_map_gen F c.out,
    ← intermediate_field.adjoin_simple.algebra_map_gen F d.out, alg_equiv.lift_normal_commutes],
  apply congr_arg,
  simp_rw [f', alg_equiv.trans_apply, ← fd.symm_apply_eq, fc, fd,
    intermediate_field.adjoin_root_equiv_adjoin_symm_apply_gen],
  refine eq_of_heq (heq.trans _ (congr_f_apply _).symm),
  rw [minpoly_out, minpoly_out, h],
end

lemma minpoly.injective [normal F E] : function.injective (@minpoly F _ E _ _ _) :=
λ x y, minpoly.inj

lemma minpoly.nodup_aroots (c : gal_conj_classes F E) :
  ((minpoly c).aroots E).nodup :=
nodup_roots (minpoly.separable c).map

lemma aeval_minpoly_iff [normal F E] (x : E) (c : gal_conj_classes F E) :
  aeval x (minpoly c) = 0 ↔ mk F x = c :=
begin
  symmetry, split, { rintros rfl, exact minpoly.aeval _ _, },
  intros h,
  apply minpoly.inj,
  rw [minpoly_mk, ← minpoly.eq_of_irreducible (minpoly.irreducible c) h],
  rw [(minpoly.monic c).leading_coeff, inv_one, map_one, mul_one],
end

lemma root_set_minpoly_eq_orbit [normal F E] (c : gal_conj_classes F E) :
  (minpoly c).root_set E = c.orbit :=
begin
  ext x, rw [mem_orbit],
  simp_rw [mem_root_set, aeval_minpoly_iff x c],
  simp [minpoly.ne_zero c],
end

lemma aroots_minpoly_eq_orbit_val [decidable_eq E] [fintype (E ≃ₐ[F] E)] [normal F E]
  (c : gal_conj_classes F E) : (minpoly c).aroots E = c.orbit.to_finset.1 :=
begin
  simp_rw [← root_set_minpoly_eq_orbit, root_set_def, finset.to_finset_coe,
    multiset.to_finset_val], symmetry, rw [multiset.dedup_eq_self],
  exact nodup_roots ((separable_map _).mpr (minpoly.separable c)),
end

lemma orbit_eq_mk_aroots_minpoly [decidable_eq E] [fintype (E ≃ₐ[F] E)] [normal F E]
  (c : gal_conj_classes F E) :
  c.orbit.to_finset = ⟨(minpoly c).aroots E, minpoly.nodup_aroots c⟩ :=
by simpa only [aroots_minpoly_eq_orbit_val]

lemma minpoly.map_eq_prod [decidable_eq E] [fintype (E ≃ₐ[F] E)] [normal F E]
  (c : gal_conj_classes F E) :
  (minpoly c).map (algebra_map F E) = ∏ x in c.orbit.to_finset, (X - C x) :=
begin
  simp_rw [← root_set_minpoly_eq_orbit, finset.prod_eq_multiset_prod, root_set_def,
    finset.to_finset_coe, multiset.to_finset_val],
  rw [multiset.dedup_eq_self.mpr (nodup_roots _),
    prod_multiset_X_sub_C_of_monic_of_roots_card_eq (monic.map _ _)],
  { rw [splits_iff_card_roots.mp], rw [splits_id_iff_splits], exact minpoly.splits c, },
  { exact minpoly.monic c, },
  { exact (minpoly.separable c).map, },
end
/-
def class_of_roots_irreducible
  {q : F[X]} (q_splits : q.splits (algebra_map F E))
  (hq : _root_.irreducible q) : gal_conj_classes F E :=
⟦root_of_splits (algebra_map F E) q_splits (degree_pos_of_irreducible hq).ne'⟧

lemma minpoly_class_of_roots_irreducible_of_monic
  {q : F[X]} (q_splits : splits (algebra_map F E) q)
  (hq : _root_.irreducible q) (q_monic : q.monic) :
  (class_of_roots_irreducible q_splits hq).minpoly = q :=
begin
  dsimp only [class_of_roots_irreducible], rw [minpoly_mk],
  exact (minpoly.eq_of_irreducible_of_monic hq (map_root_of_splits _ _ _) q_monic).symm,
end

lemma minpoly_class_of_roots_irreducible
  {q : F[X]} (q_splits : splits (algebra_map F E) q)
  (hq : _root_.irreducible q) :
  (class_of_roots_irreducible q_splits hq).minpoly = q * C q.leading_coeff⁻¹ :=
begin
  dsimp only [class_of_roots_irreducible], rw [minpoly_mk],
  exact (minpoly.eq_of_irreducible hq (map_root_of_splits _ _ _)).symm,
end

lemma class_of_roots_irreducible_minpoly (c : gal_conj_classes F E)
  (h₁ : c.minpoly.splits (algebra_map F E)) (h₂ : irreducible c.minpoly) :
  class_of_roots_irreducible h₁ h₂ = c :=
begin
  dsimp only [class_of_roots_irreducible], apply minpoly.inj, rw [minpoly_mk],
  exact minpoly_class_of_roots_irreducible_of_monic _ _ (minpoly.monic c),
end

lemma root_set_C_mul (q : F[X]) {a : F} (a0 : a ≠ 0) :
  q.root_set E = (C a * q).root_set E :=
by { simp_rw [root_set, map_mul, map_C,
  roots_C_mul _ (((algebra_map F E).map_ne_zero).mpr a0)], }

lemma root_set_mul_C (q : F[X]) {a : F} (a0 : a ≠ 0) :
  q.root_set E = (q * C a).root_set E :=
by { rw [mul_comm], exact root_set_C_mul q a0, }

lemma root_set_eq_orbit {q : F[X]} (q_splits : splits (algebra_map F E) q)
  (hq : _root_.irreducible q) :
  q.root_set E = (class_of_roots_irreducible q_splits hq).orbit :=
begin
  rw [← root_set_minpoly_eq_orbit, minpoly_class_of_roots_irreducible, root_set_mul_C],
  exact inv_ne_zero (leading_coeff_ne_zero.mpr hq.ne_zero),
end

lemma aroots_eq_orbit {q : F[X]} (q_splits : splits (algebra_map F E) q)
  (hq : _root_.irreducible q) :
  q.aroots E =
    (class_of_roots_irreducible q_splits hq).orbit.to_finset.1 :=
begin
  simp_rw [← root_set_eq_orbit q_splits hq, root_set_def, to_finset_coe,
    multiset.to_finset_val], symmetry, rw [multiset.dedup_eq_self],
  exact nodup_roots ((separable_map _).mpr hq.separable),
end

def classes_of_roots {q : F[X]} (q_splits : q.splits (algebra_map F E)) :
  multiset (gal_conj_classes F E) :=
(unique_factorization_monoid.normalized_factors q).pmap
  (λ (q : F[X]) (hq : q.splits (algebra_map F E) ∧ irreducible q),
    class_of_roots_irreducible hq.1 hq.2)
  (λ d hd,
  begin
    refine ⟨_, unique_factorization_monoid.irreducible_of_normalized_factor _ hd⟩,
    have d_dvd_q := unique_factorization_monoid.dvd_of_mem_normalized_factors hd,
    refine splits_of_splits_of_dvd _ _ q_splits d_dvd_q,
    rintros rfl, simpa [unique_factorization_monoid.normalized_factors_zero] using hd,
  end)

section

open list multiset

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

variables (a : α) (s t : multiset α) (f g : α → multiset β)

namespace multiset

theorem pmap_congr' {p q : α → Prop} {f : Π a, p a → β} {g : Π a, q a → β}
  (s : multiset α) {H₁ H₂} :
  (∀ (a ∈ s) h₁ h₂, f a h₁ = g a h₂) → pmap f s H₁ = pmap g s H₂ := sorry

lemma count_dedup (m : multiset α) (a : α) :
  m.dedup.count a = if a ∈ m then 1 else 0 :=
by { rcases m, simp [count_dedup], }

@[simp]
lemma dedup_bind_dedup (m : multiset α) (f : α → multiset γ) :
  (m.dedup.bind f).dedup = (m.bind f).dedup :=
by { ext x, simp_rw [count_dedup, multiset.mem_bind, multiset.mem_dedup], }

@[simp]
lemma dedup_dedup (m : multiset α) :
  m.dedup.dedup = m.dedup :=
by { ext x, simp_rw [count_dedup, multiset.mem_dedup], }

@[simp]
lemma to_finset_dedup (m : multiset α) :
  m.dedup.to_finset = m.to_finset :=
by simp_rw [multiset.to_finset, dedup_dedup]

@[simp]
lemma to_finset_bind_dedup (m : multiset α) (f : α → multiset γ) :
  (m.dedup.bind f).to_finset = (m.bind f).to_finset :=
by simp_rw [multiset.to_finset, dedup_bind_dedup]

end multiset

end

lemma classes_of_roots_zero :
  classes_of_roots (splits_zero (algebra_map F E)) = 0 :=
by simp_rw [classes_of_roots, unique_factorization_monoid.normalized_factors_zero,
  multiset.pmap_zero]

section
/-
`monic_normalize` caused following instance defeq problem:
`(λ (a b : F), classical.prop_decidable (a = b)) = (λ (a b : F), rat.decidable_eq a b)`
`classical.prop_decidable` is in `monic_normalize`
-/
lemma monic_normalize' {K : Type*} [field K] [decidable_eq K] {p : K[X]}
  (hp0 : p ≠ 0) : monic (normalize p) :=
begin
  rw [ne.def, ← leading_coeff_eq_zero, ← ne.def, ← is_unit_iff_ne_zero] at hp0,
  rw [monic, leading_coeff_normalize, normalize_eq_one],
  apply hp0,
end

variables {α : Type*}
local infix ` ~ᵤ ` : 50 := associated
variables [cancel_comm_monoid_with_zero α] [decidable_eq α] [normalization_monoid α]
variables [unique_factorization_monoid α]

open unique_factorization_monoid
namespace unique_factorization_monoid

lemma associated_iff_normalized_factors_eq_normalized_factors {x y : α} (hx : x ≠ 0) (hy : y ≠ 0) :
  x ~ᵤ y ↔ normalized_factors x = normalized_factors y :=
begin
  split,
  { intro h,
    apply le_antisymm; rw [← dvd_iff_normalized_factors_le_normalized_factors],
    all_goals { simp [*, h.dvd, h.symm.dvd], }, },
  { intro h,
    apply associated_of_dvd_dvd; rw [dvd_iff_normalized_factors_le_normalized_factors],
    all_goals { simp [*, h.le, h.ge], }, },
end

end unique_factorization_monoid

end

lemma prod_classes_of_roots_map_minpoly_of_monic
  {q : F[X]} (q_splits : splits (algebra_map F E) q) (q0 : q ≠ 0)
  (q_monic : q.monic) :
  ((classes_of_roots q_splits).map (λ c, minpoly c)).prod = q :=
begin
  simp_rw [classes_of_roots, multiset.map_pmap],
  suffices :
    (multiset.pmap (λ (q : F[X]) (h : q.splits (algebra_map F E) ∧ irreducible q),
      q) (unique_factorization_monoid.normalized_factors q) _).prod = q,
  { refine eq.trans _ this, swap, congr' 1,
    rw [(λ _ _ _ _ _, iff.rfl : ∀ {α β} {f g : α → β} (a : α), f a = g a ↔ f a = g a)], -- hack
    -- I wonder if there is a better method
    refine multiset.pmap_congr' _ (λ d hd _ _, minpoly_class_of_roots_irreducible_of_monic _ _ _),
    swap, rw [← unique_factorization_monoid.normalize_normalized_factor _ hd],
    have : d ≠ 0 := (unique_factorization_monoid.irreducible_of_normalized_factor _ hd).ne_zero,
    exact monic_normalize' this, },
  rw [multiset.pmap_eq_map, multiset.map_id'],
  refine eq_of_monic_of_associated _ q_monic
    (unique_factorization_monoid.normalized_factors_prod q0),
  refine monic_multiset_prod_of_monic _ _ (λ d hd, monic_normalize' _),
  exact (unique_factorization_monoid.irreducible_of_factor _ hd).ne_zero,
end

lemma prod_classes_of_roots_map_minpoly
  {q : F[X]} (q_splits : splits (algebra_map F E) q) (q0 : q ≠ 0) :
  ((classes_of_roots q_splits).map (λ c, minpoly c)).prod = q * C q.leading_coeff⁻¹ :=
begin
  rw [← @prod_classes_of_roots_map_minpoly_of_monic p (q * C q.leading_coeff⁻¹)], rotate 1,
  { exact splits_mul _ q_splits (splits_C _ _), },
  { refine mul_ne_zero q0 _, rwa [ne.def, C_eq_zero, inv_eq_zero, leading_coeff_eq_zero], },
  { exact monic_mul_leading_coeff_inv q0, },
  congr' 2, dsimp only [classes_of_roots],
  have l0 := inv_ne_zero (leading_coeff_ne_zero.mpr q0),
  have ql0 := mul_ne_zero q0 (C_eq_zero.not.mpr l0),
  have : associated q (q * C q.leading_coeff⁻¹),
  { refine associated_mul_unit_right _ _ _,
    rwa [is_unit_C, is_unit_iff_ne_zero], },
  simp_rw [(unique_factorization_monoid.associated_iff_normalized_factors_eq_normalized_factors
    q0 ql0).mp this],
end

lemma leading_coeff_mul_prod_classes_of_roots_map_minpoly
  {q : F[X]} (q_splits : splits (algebra_map F E) q) :
  C q.leading_coeff * ((classes_of_roots q_splits).map (λ c, minpoly c)).prod = q :=
begin
  rcases eq_or_ne q 0 with rfl | q0, { rw [leading_coeff_zero, C_0, zero_mul], },
  rw [prod_classes_of_roots_map_minpoly q_splits q0, mul_left_comm, ← C_mul, mul_inv_cancel,
    C_1, mul_one],
  exact leading_coeff_ne_zero.mpr q0,
end

lemma aroots_eq_classes_of_roots_bind_orbit
  {q : F[X]} (q_splits : splits (algebra_map F E) q) :
  q.aroots E =
    (classes_of_roots q_splits).bind (λ c, c.orbit.to_finset.1) :=
begin
  rcases eq_or_ne q 0 with rfl | q0,
  { rw [classes_of_roots_zero, multiset.zero_bind, map_zero, roots_zero], },
  conv_lhs { rw [← leading_coeff_mul_prod_classes_of_roots_map_minpoly q_splits], },
  rw [map_mul, map_multiset_prod, map_C, roots_C_mul, roots_multiset_prod,
    multiset.bind_map, multiset.bind_map],
  simp_rw [roots_minpoly_eq_orbit_val],
  { intros h, simp_rw [multiset.mem_map] at h,
    obtain ⟨_, ⟨⟨y, _, rfl⟩, h⟩⟩ := h,
    rw [map_eq_zero] at h,
    exact minpoly.ne_zero y h, },
  { rwa [ring_hom.map_ne_zero, leading_coeff_ne_zero], },
end

lemma root_set_eq_classes_of_roots_bUnion_orbit
  {q : F[X]} (q_splits : splits (algebra_map F E) q) :
  q.root_set E =
    ⋃ c ∈ ((classes_of_roots q_splits).to_finset : set (gal_conj_classes F E)), (c : _).orbit :=
begin
  refine eq.trans _ (eq.trans
    (congr_arg (λ (m : multiset E), (m.to_finset : set E))
    (roots_eq_classes_of_roots_bind_orbit q_splits)) _),
  { exact root_set_def _ _, },
  convert_to _ = ⋃ (c : gal_conj_classes F E) (H : c ∈ ↑((classes_of_roots q_splits).to_finset)),
    (c.orbit.to_finset : set E),
  { simp_rw [set.coe_to_finset], },
  rw [← coe_bUnion, finset.bUnion, finset.coe_inj, multiset.to_finset_val],
  convert (multiset.to_finset_bind_dedup _ _).symm,
end
-/

end gal_conj_classes

end gal_conj_classes


/-
Copyright (c) 2020 Heather Macbeth. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Heather Macbeth, Frédéric Dupuis
-/
import Mathlib.PrePort
import Mathlib.Lean3Lib.init.default
import Mathlib.analysis.normed_space.hahn_banach
import Mathlib.analysis.normed_space.inner_product
import Mathlib.PostPort

universes u_1 u_2 u v

namespace Mathlib

/-!
# The topological dual of a normed space

In this file we define the topological dual of a normed space, and the bounded linear map from
a normed space into its double dual.

We also prove that, for base field `𝕜` with `[is_R_or_C 𝕜]`, this map is an isometry.

We then consider inner product spaces, with base field over `ℝ` (the corresponding results for `ℂ`
will require the definition of conjugate-linear maps). We define `to_dual_map`, a continuous linear
map from `E` to its dual, which maps an element `x` of the space to `λ y, ⟪x, y⟫`. We check
(`to_dual_map_isometry`) that this map is an isometry onto its image, and particular is injective.
We also define `to_dual'` as the function taking taking a vector to its dual for a base field `𝕜`
with `[is_R_or_C 𝕜]`; this is a function and not a linear map.

Finally, under the hypothesis of completeness (i.e., for Hilbert spaces), we prove the Fréchet-Riesz
representation (`to_dual_map_eq_top`), which states the surjectivity: every element of the dual
of a Hilbert space `E` has the form `λ u, ⟪x, u⟫` for some `x : E`.  This permits the map
`to_dual_map` to be upgraded to an (isometric) continuous linear equivalence, `to_dual`, between a
Hilbert space and its dual.

## References

* [M. Einsiedler and T. Ward, *Functional Analysis, Spectral Theory, and Applications*]
  [EinsiedlerWard2017]

## Tags

dual, Fréchet-Riesz
-/

namespace normed_space

/-- The topological dual of a normed space `E`. -/
def dual (𝕜 : Type u_1) [nondiscrete_normed_field 𝕜] (E : Type u_2) [normed_group E]
    [normed_space 𝕜 E] :=
  continuous_linear_map 𝕜 E 𝕜

protected instance dual.inhabited (𝕜 : Type u_1) [nondiscrete_normed_field 𝕜] (E : Type u_2)
    [normed_group E] [normed_space 𝕜 E] : Inhabited (dual 𝕜 E) :=
  { default := 0 }

/-- The inclusion of a normed space in its double (topological) dual. -/
def inclusion_in_double_dual' (𝕜 : Type u_1) [nondiscrete_normed_field 𝕜] (E : Type u_2)
    [normed_group E] [normed_space 𝕜 E] (x : E) : dual 𝕜 (dual 𝕜 E) :=
  linear_map.mk_continuous (linear_map.mk (fun (f : dual 𝕜 E) => coe_fn f x) sorry sorry) (norm x)
    sorry

@[simp] theorem dual_def (𝕜 : Type u_1) [nondiscrete_normed_field 𝕜] (E : Type u_2) [normed_group E]
    [normed_space 𝕜 E] (x : E) (f : dual 𝕜 E) :
    coe_fn (inclusion_in_double_dual' 𝕜 E x) f = coe_fn f x :=
  rfl

theorem double_dual_bound (𝕜 : Type u_1) [nondiscrete_normed_field 𝕜] (E : Type u_2)
    [normed_group E] [normed_space 𝕜 E] (x : E) : norm (inclusion_in_double_dual' 𝕜 E x) ≤ norm x :=
  sorry

/-- The inclusion of a normed space in its double (topological) dual, considered
   as a bounded linear map. -/
def inclusion_in_double_dual (𝕜 : Type u_1) [nondiscrete_normed_field 𝕜] (E : Type u_2)
    [normed_group E] [normed_space 𝕜 E] : continuous_linear_map 𝕜 E (dual 𝕜 (dual 𝕜 E)) :=
  linear_map.mk_continuous
    (linear_map.mk (fun (x : E) => inclusion_in_double_dual' 𝕜 E x) sorry sorry) 1 sorry

/-- If one controls the norm of every `f x`, then one controls the norm of `x`.
    Compare `continuous_linear_map.op_norm_le_bound`. -/
theorem norm_le_dual_bound {𝕜 : Type v} [is_R_or_C 𝕜] {E : Type u} [normed_group E]
    [normed_space 𝕜 E] (x : E) {M : ℝ} (hMp : 0 ≤ M)
    (hM : ∀ (f : dual 𝕜 E), norm (coe_fn f x) ≤ M * norm f) : norm x ≤ M :=
  sorry

/-- The inclusion of a normed space in its double dual is an isometry onto its image.-/
theorem inclusion_in_double_dual_isometry {𝕜 : Type v} [is_R_or_C 𝕜] {E : Type u} [normed_group E]
    [normed_space 𝕜 E] (x : E) : norm (coe_fn (inclusion_in_double_dual 𝕜 E) x) = norm x :=
  sorry

end normed_space

namespace inner_product_space

/--
Given some `x` in an inner product space, we can define its dual as the continuous linear map
`λ y, ⟪x, y⟫`. Consider using `to_dual` or `to_dual_map` instead in the real case.
-/
def to_dual' (𝕜 : Type u_1) {E : Type u_2} [is_R_or_C 𝕜] [inner_product_space 𝕜 E] :
    E →+ normed_space.dual 𝕜 E :=
  add_monoid_hom.mk
    (fun (x : E) =>
      linear_map.mk_continuous (linear_map.mk (fun (y : E) => inner x y) sorry sorry) (norm x)
        sorry)
    sorry sorry

@[simp] theorem to_dual'_apply (𝕜 : Type u_1) {E : Type u_2} [is_R_or_C 𝕜] [inner_product_space 𝕜 E]
    {x : E} {y : E} : coe_fn (coe_fn (to_dual' 𝕜) x) y = inner x y :=
  rfl

/-- In an inner product space, the norm of the dual of a vector `x` is `∥x∥` -/
@[simp] theorem norm_to_dual'_apply (𝕜 : Type u_1) {E : Type u_2} [is_R_or_C 𝕜]
    [inner_product_space 𝕜 E] (x : E) : norm (coe_fn (to_dual' 𝕜) x) = norm x :=
  sorry

theorem to_dual'_isometry (𝕜 : Type u_1) (E : Type u_2) [is_R_or_C 𝕜] [inner_product_space 𝕜 E] :
    isometry ⇑(to_dual' 𝕜) :=
  add_monoid_hom.isometry_of_norm (to_dual' 𝕜) (norm_to_dual'_apply 𝕜)

/--
Fréchet-Riesz representation: any `ℓ` in the dual of a Hilbert space `E` is of the form
`λ u, ⟪y, u⟫` for some `y : E`, i.e. `to_dual'` is surjective.
-/
theorem to_dual'_surjective (𝕜 : Type u_1) (E : Type u_2) [is_R_or_C 𝕜] [inner_product_space 𝕜 E]
    [complete_space E] : function.surjective ⇑(to_dual' 𝕜) :=
  sorry

/-- In a real inner product space `F`, the function that takes a vector `x` in `F` to its dual
`λ y, ⟪x, y⟫` is a continuous linear map. If the space is complete (i.e. is a Hilbert space),
consider using `to_dual` instead. -/
-- TODO extend to `is_R_or_C` (requires a definition of conjugate linear maps)

def to_dual_map {F : Type u_1} [inner_product_space ℝ F] :
    continuous_linear_map ℝ F (normed_space.dual ℝ F) :=
  linear_map.mk_continuous (linear_map.mk ⇑(to_dual' ℝ) sorry sorry) 1 sorry

@[simp] theorem to_dual_map_apply {F : Type u_1} [inner_product_space ℝ F] {x : F} {y : F} :
    coe_fn (coe_fn to_dual_map x) y = inner x y :=
  rfl

/-- In an inner product space, the norm of the dual of a vector `x` is `∥x∥` -/
@[simp] theorem norm_to_dual_map_apply {F : Type u_1} [inner_product_space ℝ F] (x : F) :
    norm (coe_fn to_dual_map x) = norm x :=
  norm_to_dual'_apply ℝ x

theorem to_dual_map_isometry {F : Type u_1} [inner_product_space ℝ F] : isometry ⇑to_dual_map :=
  add_monoid_hom.isometry_of_norm (to_dual' ℝ) norm_to_dual_map_apply

theorem to_dual_map_injective {F : Type u_1} [inner_product_space ℝ F] :
    function.injective ⇑to_dual_map :=
  isometry.injective to_dual_map_isometry

@[simp] theorem ker_to_dual_map {F : Type u_1} [inner_product_space ℝ F] :
    continuous_linear_map.ker to_dual_map = ⊥ :=
  iff.mpr linear_map.ker_eq_bot to_dual_map_injective

@[simp] theorem to_dual_map_eq_iff_eq {F : Type u_1} [inner_product_space ℝ F] {x : F} {y : F} :
    coe_fn to_dual_map x = coe_fn to_dual_map y ↔ x = y :=
  function.injective.eq_iff (iff.mp linear_map.ker_eq_bot ker_to_dual_map)

/--
Fréchet-Riesz representation: any `ℓ` in the dual of a real Hilbert space `F` is of the form
`λ u, ⟪y, u⟫` for some `y` in `F`.  See `inner_product_space.to_dual` for the continuous linear
equivalence thus induced.
-/
-- TODO extend to `is_R_or_C` (requires a definition of conjugate linear maps)

theorem range_to_dual_map {F : Type u_1} [inner_product_space ℝ F] [complete_space F] :
    continuous_linear_map.range to_dual_map = ⊤ :=
  iff.mpr linear_map.range_eq_top (to_dual'_surjective ℝ F)

/--
Fréchet-Riesz representation: If `F` is a Hilbert space, the function that takes a vector in `F` to
its dual is a continuous linear equivalence.  -/
def to_dual {F : Type u_1} [inner_product_space ℝ F] [complete_space F] :
    continuous_linear_equiv ℝ F (normed_space.dual ℝ F) :=
  continuous_linear_equiv.of_isometry (continuous_linear_map.to_linear_map to_dual_map)
    to_dual_map_isometry range_to_dual_map

/--
Fréchet-Riesz representation: If `F` is a Hilbert space, the function that takes a vector in `F` to
its dual is an isometry.  -/
def isometric.to_dual {F : Type u_1} [inner_product_space ℝ F] [complete_space F] :
    F ≃ᵢ normed_space.dual ℝ F :=
  isometric.mk (linear_equiv.to_equiv (continuous_linear_equiv.to_linear_equiv to_dual))
    (to_dual'_isometry ℝ F)

@[simp] theorem to_dual_apply {F : Type u_1} [inner_product_space ℝ F] [complete_space F] {x : F}
    {y : F} : coe_fn (coe_fn to_dual x) y = inner x y :=
  rfl

@[simp] theorem to_dual_eq_iff_eq {F : Type u_1} [inner_product_space ℝ F] [complete_space F]
    {x : F} {y : F} : coe_fn to_dual x = coe_fn to_dual y ↔ x = y :=
  function.injective.eq_iff (continuous_linear_equiv.injective to_dual)

theorem to_dual_eq_iff_eq' {F : Type u_1} [inner_product_space ℝ F] [complete_space F] {x : F}
    {x' : F} : (∀ (y : F), inner x y = inner x' y) ↔ x = x' :=
  sorry

@[simp] theorem norm_to_dual_apply {F : Type u_1} [inner_product_space ℝ F] [complete_space F]
    (x : F) : norm (coe_fn to_dual x) = norm x :=
  norm_to_dual_map_apply x

/-- In a Hilbert space, the norm of a vector in the dual space is the norm of its corresponding
primal vector. -/
theorem norm_to_dual_symm_apply {F : Type u_1} [inner_product_space ℝ F] [complete_space F]
    (ℓ : normed_space.dual ℝ F) : norm (coe_fn (continuous_linear_equiv.symm to_dual) ℓ) = norm ℓ :=
  sorry

end Mathlib


import data.finset

import lib.core.rel3
import config

variables {α : Type*} [linear_order α] (C : config α)

structure config.label (S : finset α) :=
(slope : α → α → Prop)
(decidable_slope : decidable_rel slope)
-- The direction looks odd, but it is written in perspective of
-- _where_ the edge ab is placed
(extend_left : ∀ {a b : α}, a ∈ S → b ∈ S → a < b → ¬slope a b →
  ∀ {c : α}, c ∈ S → b < c → C.cup3 a b c)
(extend_right : ∀ {a b : α}, a ∈ S → b ∈ S → a < b → slope a b →
  ∀ {c : α}, c ∈ S → c < a → C.cup3 c a b)

attribute [instance] config.label.decidable_slope

def cap4_free_slope {S : finset α} (h : ¬C.has_ncap 4 S) (a b : α) : Prop :=
  ∀ c : S, ↑c < a → C.cup3 c a b

instance decidable_cap4_free_slope {S : finset α} (h : ¬C.has_ncap 4 S) :
  decidable_rel (cap4_free_slope C h) :=
λ a b, by rw cap4_free_slope; simp; apply_instance

variable {C}

def cap4_free_label {S : finset α} (h : ¬C.has_ncap 4 S) : C.label S :=
begin
  use cap4_free_slope C h,
  apply_instance,
  { intros a b ha hb hab hn c hc hbc,
    by_contra h', apply hn, intros d hd,
    by_contra h'', apply h, use [[d, a, b, c]], simp [config.ncap], tauto },
  { intros a b ha hb hab hy c hc hca,
    exact hy ⟨c, hc⟩ hca },
end

variables {C} {S : finset α} {label : C.label S}

protected theorem config.cup.extend_left
  {l : list α} (l_cup : C.cup l)
  {a b : α} (s_ab : ¬label.slope a b)
  (ha : a ∈ S) (hab : a < b) (l_in_S : l.in S)
  (b_head_l : b ∈ l.head') : C.cup (a :: l) :=
begin
  cases l with b l,
  { simp at b_head_l, tauto },
  simp at b_head_l, subst b_head_l,
  cases l with c l,
  { simp, exact hab },
  simp at l_in_S, simp,
  refine ⟨_, _, _⟩; try {tauto},
  simp [config.cup] at l_cup,
  apply label.extend_left; tauto,
end

protected theorem config.cup.extend_right
  {l : list α} (l_cup : C.cup l)
  {a b : α} (s_ab : label.slope a b)
  (hab : a < b) (hb : b ∈ S) (l_in_S : l.in S)
  (a_last_l : a ∈ l.last') : C.cup (l ++ [b]) :=
begin
  by_cases hl : 2 ≤ l.length,
  { rcases list.take_last2 hl with ⟨c, a, l', eq_l⟩,
    rw eq_l at a_last_l, simp at a_last_l, subst a_last_l,
    rw eq_l, simp, rw ←eq_l,
    refine ⟨_, _, _⟩; try {tauto},
    simp [config.cup] at l_cup,
    rw eq_l at l_in_S, simp at l_in_S,
    rw eq_l at l_cup, simp at l_cup,
    apply label.extend_right; tauto },
  cases l with p l, simp,
  cases l with q l, simp at *, subst a_last_l; tauto,
  exfalso, apply hl, exact le_add_self,
end

protected theorem config.ncup.extend_left
  {n : ℕ} {l : list α} (l_ncup : C.ncup n l)
  {a b : α} (s_ab : ¬label.slope a b)
  (ha : a ∈ S) (hab : a < b) (l_in_S : l.in S)
  (b_head_l : b ∈ l.head') : C.ncup (n+1) (a :: l) :=
begin
  cases l_ncup with l_cup l_len, split,
  apply l_cup.extend_left s_ab; try {assumption},
  simp, assumption,
end

protected theorem config.ncup.extend_right
  {n : ℕ} {l : list α} (l_ncup : C.ncup n l)
  {a b : α} (s_ab : label.slope a b)
  (hab : a < b) (hb : b ∈ S) (l_in_S : l.in S)
  (a_last_l : a ∈ l.last') : C.ncup (n+1) (l ++ [b]) :=
begin
  cases l_ncup with l_cup l_len, split,
  apply l_cup.extend_right s_ab; try {assumption},
  simp, assumption,
end

variable (label)

open order_dual

protected def config.label.mirror :
  C.mirror.label S.mirror :=
⟨ λ a b, ¬(mirror2 label.slope a b),
  λ a b, @not.decidable _ (label.decidable_slope.mirror2 a b),
  begin
    intros a b a_in_S b_in_S hab hslope c c_in_S hbc,
    simp [mirror2] at hslope,
    simp [config.mirror, mirror3],
    simp [finset.mirror] at a_in_S b_in_S c_in_S,
    rcases a_in_S with ⟨oa, ⟨oa_in_S, oa_eq⟩⟩,
    rcases b_in_S with ⟨ob, ⟨ob_in_S, ob_eq⟩⟩,
    rcases c_in_S with ⟨oc, ⟨oc_in_S, oc_eq⟩⟩,
    rw ←oa_eq at hab,
    rw ←ob_eq at hab hbc,
    rw ←oc_eq at hbc,
    simp at hab hbc,
    rw [←oa_eq, ←ob_eq, ←oc_eq], simp,
    rw [←oa_eq, ←ob_eq] at hslope, simp at hslope,
    apply label.extend_right; tauto,
  end,
  begin
    intros a b a_in_S b_in_S hab hslope c c_in_S hca,
    simp [mirror2] at hslope,
    simp [config.mirror, mirror3],
    simp [finset.mirror] at a_in_S b_in_S c_in_S,
    rcases a_in_S with ⟨oa, ⟨oa_in_S, oa_eq⟩⟩,
    rcases b_in_S with ⟨ob, ⟨ob_in_S, ob_eq⟩⟩,
    rcases c_in_S with ⟨oc, ⟨oc_in_S, oc_eq⟩⟩,
    rw ←oa_eq at hab hca,
    rw ←ob_eq at hab,
    rw ←oc_eq at hca,
    simp at hab hca,
    rw [←oa_eq, ←ob_eq, ←oc_eq], simp,
    rw [←oa_eq, ←ob_eq] at hslope, simp at hslope,
    apply label.extend_left; tauto,
  end⟩

variable {label}

def mirror_slope {a b : α} :
  ¬label.mirror.slope (to_dual b) (to_dual a) ↔ label.slope a b :=
begin
  rw config.label.mirror, simp,
  rw mirror2, simp,
end