/-
Copyright (c) 2014 Jeremy Avigad. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Jeremy Avigad, Mario Carneiro
-/
import data.prod.basic
import data.subtype

/-!
# Basic definitions about `≤` and `<`

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

This file proves basic results about orders, provides extensive dot notation, defines useful order
classes and allows to transfer order instances.

## Type synonyms

* `order_dual α` : A type synonym reversing the meaning of all inequalities, with notation `αᵒᵈ`.
* `as_linear_order α`: A type synonym to promote `partial_order α` to `linear_order α` using
  `is_total α (≤)`.

### Transfering orders

- `order.preimage`, `preorder.lift`: Transfers a (pre)order on `β` to an order on `α`
  using a function `f : α → β`.
- `partial_order.lift`, `linear_order.lift`: Transfers a partial (resp., linear) order on `β` to a
  partial (resp., linear) order on `α` using an injective function `f`.

### Extra class

* `has_sup`: type class for the `⊔` notation
* `has_inf`: type class for the `⊓` notation
* `has_compl`: type class for the `ᶜ` notation
* `densely_ordered`: An order with no gap, i.e. for any two elements `a < b` there exists `c` such
  that `a < c < b`.

## Notes

`≤` and `<` are highly favored over `≥` and `>` in mathlib. The reason is that we can formulate all
lemmas using `≤`/`<`, and `rw` has trouble unifying `≤` and `≥`. Hence choosing one direction spares
us useless duplication. This is enforced by a linter. See Note [nolint_ge] for more infos.

Dot notation is particularly useful on `≤` (`has_le.le`) and `<` (`has_lt.lt`). To that end, we
provide many aliases to dot notation-less lemmas. For example, `le_trans` is aliased with
`has_le.le.trans` and can be used to construct `hab.trans hbc : a ≤ c` when `hab : a ≤ b`,
`hbc : b ≤ c`, `lt_of_le_of_lt` is aliased as `has_le.le.trans_lt` and can be used to construct
`hab.trans hbc : a < c` when `hab : a ≤ b`, `hbc : b < c`.

## TODO

- expand module docs
- automatic construction of dual definitions / theorems

## Tags

preorder, order, partial order, poset, linear order, chain
-/

open function

universes u v w
variables {ι : Type*} {α : Type u} {β : Type v} {γ : Type w} {π : ι → Type*} {r : α → α → Prop}

section preorder
variables [preorder α] {a b c : α}

lemma le_trans' : b ≤ c → a ≤ b → a ≤ c := flip le_trans
lemma lt_trans' : b < c → a < b → a < c := flip lt_trans
lemma lt_of_le_of_lt' : b ≤ c → a < b → a < c := flip lt_of_lt_of_le
lemma lt_of_lt_of_le' : b < c → a ≤ b → a < c := flip lt_of_le_of_lt

end preorder

section partial_order
variables [partial_order α] {a b : α}

lemma ge_antisymm : a ≤ b → b ≤ a → b = a := flip le_antisymm
lemma lt_of_le_of_ne' : a ≤ b → b ≠ a → a < b := λ h₁ h₂, lt_of_le_of_ne h₁ h₂.symm
lemma ne.lt_of_le : a ≠ b → a ≤ b → a < b := flip lt_of_le_of_ne
lemma ne.lt_of_le' : b ≠ a → a ≤ b → a < b := flip lt_of_le_of_ne'

end partial_order

attribute [simp] le_refl
attribute [ext] has_le

alias le_trans        ← has_le.le.trans
alias le_trans'       ← has_le.le.trans'
alias lt_of_le_of_lt  ← has_le.le.trans_lt
alias lt_of_le_of_lt' ← has_le.le.trans_lt'
alias le_antisymm     ← has_le.le.antisymm
alias ge_antisymm     ← has_le.le.antisymm'
alias lt_of_le_of_ne  ← has_le.le.lt_of_ne
alias lt_of_le_of_ne' ← has_le.le.lt_of_ne'
alias lt_of_le_not_le ← has_le.le.lt_of_not_le
alias lt_or_eq_of_le  ← has_le.le.lt_or_eq
alias decidable.lt_or_eq_of_le ← has_le.le.lt_or_eq_dec

alias le_of_lt        ← has_lt.lt.le
alias lt_trans        ← has_lt.lt.trans
alias lt_trans'       ← has_lt.lt.trans'
alias lt_of_lt_of_le  ← has_lt.lt.trans_le
alias lt_of_lt_of_le' ← has_lt.lt.trans_le'
alias ne_of_lt        ← has_lt.lt.ne
alias lt_asymm        ← has_lt.lt.asymm has_lt.lt.not_lt

alias le_of_eq        ← eq.le

attribute [nolint decidable_classical] has_le.le.lt_or_eq_dec

section
variables [preorder α] {a b c : α}

/-- A version of `le_refl` where the argument is implicit -/
lemma le_rfl : a ≤ a := le_refl a

@[simp] lemma lt_self_iff_false (x : α) : x < x ↔ false := ⟨lt_irrefl x, false.elim⟩

lemma le_of_le_of_eq (hab : a ≤ b) (hbc : b = c) : a ≤ c := hab.trans hbc.le
lemma le_of_eq_of_le (hab : a = b) (hbc : b ≤ c) : a ≤ c := hab.le.trans hbc
lemma lt_of_lt_of_eq (hab : a < b) (hbc : b = c) : a < c := hab.trans_le hbc.le
lemma lt_of_eq_of_lt (hab : a = b) (hbc : b < c) : a < c := hab.le.trans_lt hbc
lemma le_of_le_of_eq' : b ≤ c → a = b → a ≤ c := flip le_of_eq_of_le
lemma le_of_eq_of_le' : b = c → a ≤ b → a ≤ c := flip le_of_le_of_eq
lemma lt_of_lt_of_eq' : b < c → a = b → a < c := flip lt_of_eq_of_lt
lemma lt_of_eq_of_lt' : b = c → a < b → a < c := flip lt_of_lt_of_eq

alias le_of_le_of_eq  ← has_le.le.trans_eq
alias le_of_le_of_eq' ← has_le.le.trans_eq'
alias lt_of_lt_of_eq  ← has_lt.lt.trans_eq
alias lt_of_lt_of_eq' ← has_lt.lt.trans_eq'
alias le_of_eq_of_le  ← eq.trans_le
alias le_of_eq_of_le' ← eq.trans_ge
alias lt_of_eq_of_lt  ← eq.trans_lt
alias lt_of_eq_of_lt' ← eq.trans_gt

end

namespace eq
variables [preorder α] {x y z : α}

/-- If `x = y` then `y ≤ x`. Note: this lemma uses `y ≤ x` instead of `x ≥ y`, because `le` is used
almost exclusively in mathlib. -/
protected

lemma not_lt (h : x = y) : ¬ x < y := λ h', h'.ne h
lemma not_gt (h : x = y) : ¬ y < x := h.symm.not_lt

end eq

namespace has_le.le

@[nolint ge_or_gt] -- see Note [nolint_ge]
protected lemma ge [has_le α] {x y : α} (h : x ≤ y) : y ≥ x := h

section partial_order
variables [partial_order α] {a b : α}

lemma lt_iff_ne (h : a ≤ b) : a < b ↔ a ≠ b := ⟨λ h, h.ne, h.lt_of_ne⟩
lemma gt_iff_ne (h : a ≤ b) : a < b ↔ b ≠ a := ⟨λ h, h.ne.symm, h.lt_of_ne'⟩
lemma not_lt_iff_eq (h : a ≤ b) : ¬ a < b ↔ a = b := h.lt_iff_ne.not_left
lemma not_gt_iff_eq (h : a ≤ b) : ¬ a < b ↔ b = a := h.gt_iff_ne.not_left

lemma le_iff_eq (h : a ≤ b) : b ≤ a ↔ b = a := ⟨λ h', h'.antisymm h, eq.le⟩
lemma ge_iff_eq (h : a ≤ b) : b ≤ a ↔ a = b := ⟨h.antisymm, eq.ge⟩

end partial_order

lemma lt_or_le [linear_order α] {a b : α} (h : a ≤ b) (c : α) : a < c ∨ c ≤ b :=
(lt_or_ge a c).imp id $ λ hc, le_trans hc h

lemma le_or_lt [linear_order α] {a b : α} (h : a ≤ b) (c : α) : a ≤ c ∨ c < b :=
(le_or_gt a c).imp id $ λ hc, lt_of_lt_of_le hc h

lemma le_or_le [linear_order α] {a b : α} (h : a ≤ b) (c : α) : a ≤ c ∨ c ≤ b :=
(h.le_or_lt c).elim or.inl (λ h, or.inr $ le_of_lt h)

end has_le.le

namespace has_lt.lt

@[nolint ge_or_gt] -- see Note [nolint_ge]
protected lemma gt [has_lt α] {x y : α} (h : x < y) : y > x := h
protected lemma false [preorder α] {x : α} : x < x → false := lt_irrefl x

lemma ne' [preorder α] {x y : α} (h : x < y) : y ≠ x := h.ne.symm

lemma lt_or_lt [linear_order α] {x y : α} (h : x < y) (z : α) : x < z ∨ z < y :=
(lt_or_ge z y).elim or.inr (λ hz, or.inl $ h.trans_le hz)

end has_lt.lt

@[nolint ge_or_gt] -- see Note [nolint_ge]
protected lemma ge.le [has_le α] {x y : α} (h : x ≥ y) : y ≤ x := h

@[nolint ge_or_gt] -- see Note [nolint_ge]
protected lemma gt.lt [has_lt α] {x y : α} (h : x > y) : y < x := h

@[nolint ge_or_gt] -- see Note [nolint_ge]
theorem ge_of_eq [preorder α] {a b : α} (h : a = b) : a ≥ b := h.ge

@[simp, nolint ge_or_gt] -- see Note [nolint_ge]
lemma ge_iff_le [has_le α] {a b : α} : a ≥ b ↔ b ≤ a := iff.rfl
@[simp, nolint ge_or_gt] -- see Note [nolint_ge]
lemma gt_iff_lt [has_lt α] {a b : α} : a > b ↔ b < a := iff.rfl

lemma not_le_of_lt [preorder α] {a b : α} (h : a < b) : ¬ b ≤ a := (le_not_le_of_lt h).right

alias not_le_of_lt ← has_lt.lt.not_le

lemma not_lt_of_le [preorder α] {a b : α} (h : a ≤ b) : ¬ b < a := λ hba, hba.not_le h

alias not_lt_of_le ← has_le.le.not_lt

lemma ne_of_not_le [preorder α] {a b : α} (h : ¬ a ≤ b) : a ≠ b :=
λ hab, h (le_of_eq hab)

-- See Note [decidable namespace]
protected lemma decidable.le_iff_eq_or_lt [partial_order α] [@decidable_rel α (≤)]
  {a b : α} : a ≤ b ↔ a = b ∨ a < b := decidable.le_iff_lt_or_eq.trans or.comm

lemma le_iff_eq_or_lt [partial_order α] {a b : α} : a ≤ b ↔ a = b ∨ a < b :=
le_iff_lt_or_eq.trans or.comm

lemma lt_iff_le_and_ne [partial_order α] {a b : α} : a < b ↔ a ≤ b ∧ a ≠ b :=
⟨λ h, ⟨le_of_lt h, ne_of_lt h⟩, λ ⟨h1, h2⟩, h1.lt_of_ne h2⟩

lemma eq_iff_not_lt_of_le {α} [partial_order α] {x y : α} : x ≤ y → y = x ↔ ¬ x < y :=
by rw [lt_iff_le_and_ne, not_and, not_not, eq_comm]

-- See Note [decidable namespace]
protected lemma decidable.eq_iff_le_not_lt [partial_order α] [@decidable_rel α (≤)]
  {a b : α} : a = b ↔ a ≤ b ∧ ¬ a < b :=
⟨λ h, ⟨h.le, h ▸ lt_irrefl _⟩, λ ⟨h₁, h₂⟩, h₁.antisymm $
  decidable.by_contradiction $ λ h₃, h₂ (h₁.lt_of_not_le h₃)⟩

lemma eq_iff_le_not_lt [partial_order α] {a b : α} : a = b ↔ a ≤ b ∧ ¬ a < b :=
by haveI := classical.dec; exact decidable.eq_iff_le_not_lt

lemma eq_or_lt_of_le [partial_order α] {a b : α} (h : a ≤ b) : a = b ∨ a < b := h.lt_or_eq.symm
lemma eq_or_gt_of_le [partial_order α] {a b : α} (h : a ≤ b) : b = a ∨ a < b :=
h.lt_or_eq.symm.imp eq.symm id
lemma gt_or_eq_of_le [partial_order α] {a b : α} (hab : a ≤ b) : a < b ∨ b = a :=
(eq_or_gt_of_le hab).symm

alias decidable.eq_or_lt_of_le ← has_le.le.eq_or_lt_dec
alias eq_or_lt_of_le ← has_le.le.eq_or_lt
alias eq_or_gt_of_le ← has_le.le.eq_or_gt
alias gt_or_eq_of_le ← has_le.le.gt_or_eq

attribute [nolint decidable_classical] has_le.le.eq_or_lt_dec

lemma eq_of_le_of_not_lt [partial_order α] {a b : α} (hab : a ≤ b) (hba : ¬ a < b) : a = b :=
hab.eq_or_lt.resolve_right hba

lemma eq_of_ge_of_not_gt [partial_order α] {a b : α} (hab : a ≤ b) (hba : ¬ a < b) : b = a :=
(hab.eq_or_lt.resolve_right hba).symm

alias eq_of_le_of_not_lt ← has_le.le.eq_of_not_lt
alias eq_of_ge_of_not_gt ← has_le.le.eq_of_not_gt

lemma ne.le_iff_lt [partial_order α] {a b : α} (h : a ≠ b) : a ≤ b ↔ a < b :=
⟨λ h', lt_of_le_of_ne h' h, λ h, h.le⟩

lemma ne.not_le_or_not_le [partial_order α] {a b : α} (h : a ≠ b) : ¬ a ≤ b ∨ ¬ b ≤ a :=
not_and_distrib.1 $ le_antisymm_iff.not.1 h

-- See Note [decidable namespace]
protected lemma decidable.ne_iff_lt_iff_le [partial_order α] [decidable_eq α] {a b : α} :
  (a ≠ b ↔ a < b) ↔ a ≤ b :=
⟨λ h, decidable.by_cases le_of_eq (le_of_lt ∘ h.mp), λ h, ⟨lt_of_le_of_ne h, ne_of_lt⟩⟩

@[simp] lemma ne_iff_lt_iff_le [partial_order α] {a b : α} : (a ≠ b ↔ a < b) ↔ a ≤ b :=
by haveI := classical.dec; exact decidable.ne_iff_lt_iff_le

-- Variant of `min_def` with the branches reversed.
lemma min_def' [linear_order α] (a b : α) : min a b = if b ≤ a then b else a :=
begin
  rw [min_def],
  rcases lt_trichotomy a b with lt | eq | gt,
  { rw [if_pos lt.le, if_neg (not_le.mpr lt)], },
  { rw [if_pos eq.le, if_pos eq.ge, eq], },
  { rw [if_neg (not_le.mpr gt), if_pos gt.le], }
end
-- Variant of `min_def` with the branches reversed.
-- This is sometimes useful as it used to be the default.
lemma max_def' [linear_order α] (a b : α) : max a b = if b ≤ a then a else b :=
begin
  rw [max_def],
  rcases lt_trichotomy a b with lt | eq | gt,
  { rw [if_pos lt.le, if_neg (not_le.mpr lt)], },
  { rw [if_pos eq.le, if_pos eq.ge, eq], },
  { rw [if_neg (not_le.mpr gt), if_pos gt.le], }
end

lemma lt_of_not_le [linear_order α] {a b : α} (h : ¬ b ≤ a) : a < b :=
((le_total _ _).resolve_right h).lt_of_not_le h

lemma lt_iff_not_le [linear_order α] {x y : α} : x < y ↔ ¬ y ≤ x := ⟨not_le_of_lt, lt_of_not_le⟩

lemma ne.lt_or_lt [linear_order α] {x y : α} (h : x ≠ y) : x < y ∨ y < x := lt_or_gt_of_ne h

/-- A version of `ne_iff_lt_or_gt` with LHS and RHS reversed. -/
@[simp] lemma lt_or_lt_iff_ne [linear_order α] {x y : α} : x < y ∨ y < x ↔ x ≠ y :=
ne_iff_lt_or_gt.symm

lemma not_lt_iff_eq_or_lt [linear_order α] {a b : α} : ¬ a < b ↔ a = b ∨ b < a :=
not_lt.trans $ decidable.le_iff_eq_or_lt.trans $ or_congr eq_comm iff.rfl

lemma exists_ge_of_linear [linear_order α] (a b : α) : ∃ c, a ≤ c ∧ b ≤ c :=
match le_total a b with
| or.inl h := ⟨_, h, le_rfl⟩
| or.inr h := ⟨_, le_rfl, h⟩
end

lemma lt_imp_lt_of_le_imp_le {β} [linear_order α] [preorder β] {a b : α} {c d : β}
  (H : a ≤ b → c ≤ d) (h : d < c) : b < a :=
lt_of_not_le $ λ h', (H h').not_lt h

lemma le_imp_le_iff_lt_imp_lt {β} [linear_order α] [linear_order β] {a b : α} {c d : β} :
  (a ≤ b → c ≤ d) ↔ (d < c → b < a) :=
⟨lt_imp_lt_of_le_imp_le, le_imp_le_of_lt_imp_lt⟩

lemma lt_iff_lt_of_le_iff_le' {β} [preorder α] [preorder β] {a b : α} {c d : β}
  (H : a ≤ b ↔ c ≤ d) (H' : b ≤ a ↔ d ≤ c) : b < a ↔ d < c :=
lt_iff_le_not_le.trans $ (and_congr H' (not_congr H)).trans lt_iff_le_not_le.symm

lemma lt_iff_lt_of_le_iff_le {β} [linear_order α] [linear_order β] {a b : α} {c d : β}
  (H : a ≤ b ↔ c ≤ d) : b < a ↔ d < c :=
not_le.symm.trans $ (not_congr H).trans $ not_le

lemma le_iff_le_iff_lt_iff_lt {β} [linear_order α] [linear_order β] {a b : α} {c d : β} :
  (a ≤ b ↔ c ≤ d) ↔ (b < a ↔ d < c) :=
⟨lt_iff_lt_of_le_iff_le, λ H, not_lt.symm.trans $ (not_congr H).trans $ not_lt⟩

lemma eq_of_forall_le_iff [partial_order α] {a b : α}
  (H : ∀ c, c ≤ a ↔ c ≤ b) : a = b :=
((H _).1 le_rfl).antisymm ((H _).2 le_rfl)

lemma le_of_forall_le [preorder α] {a b : α}
  (H : ∀ c, c ≤ a → c ≤ b) : a ≤ b :=
H _ le_rfl

lemma le_of_forall_le' [preorder α] {a b : α}
  (H : ∀ c, a ≤ c → b ≤ c) : b ≤ a :=
H _ le_rfl

lemma le_of_forall_lt [linear_order α] {a b : α}
  (H : ∀ c, c < a → c < b) : a ≤ b :=
le_of_not_lt $ λ h, lt_irrefl _ (H _ h)

lemma forall_lt_iff_le [linear_order α] {a b : α} :
  (∀ ⦃c⦄, c < a → c < b) ↔ a ≤ b :=
⟨le_of_forall_lt, λ h c hca, lt_of_lt_of_le hca h⟩

lemma le_of_forall_lt' [linear_order α] {a b : α}
  (H : ∀ c, a < c → b < c) : b ≤ a :=
le_of_not_lt $ λ h, lt_irrefl _ (H _ h)

lemma forall_lt_iff_le' [linear_order α] {a b : α} :
  (∀ ⦃c⦄, a < c → b < c) ↔ b ≤ a :=
⟨le_of_forall_lt', λ h c hac, lt_of_le_of_lt h hac⟩

lemma eq_of_forall_ge_iff [partial_order α] {a b : α}
  (H : ∀ c, a ≤ c ↔ b ≤ c) : a = b :=
((H _).2 le_rfl).antisymm ((H _).1 le_rfl)

lemma eq_of_forall_lt_iff [linear_order α] {a b : α} (h : ∀ c, c < a ↔ c < b) : a = b :=
(le_of_forall_lt $ λ _, (h _).1).antisymm $ le_of_forall_lt $ λ _, (h _).2

lemma eq_of_forall_gt_iff [linear_order α] {a b : α} (h : ∀ c, a < c ↔ b < c) : a = b :=
(le_of_forall_lt' $ λ _, (h _).2).antisymm $ le_of_forall_lt' $ λ _, (h _).1

/-- A symmetric relation implies two values are equal, when it implies they're less-equal.  -/
lemma rel_imp_eq_of_rel_imp_le [partial_order β] (r : α → α → Prop) [is_symm α r] {f : α → β}
  (h : ∀ a b, r a b → f a ≤ f b) {a b : α} : r a b → f a = f b :=
λ hab, le_antisymm (h a b hab) (h b a $ symm hab)

/-- monotonicity of `≤` with respect to `→` -/
lemma le_implies_le_of_le_of_le {a b c d : α} [preorder α] (hca : c ≤ a) (hbd : b ≤ d) :
  a ≤ b → c ≤ d :=
λ hab, (hca.trans hab).trans hbd

section partial_order
variables [partial_order α]

/-- To prove commutativity of a binary operation `○`, we only to check `a ○ b ≤ b ○ a` for all `a`,
`b`. -/
lemma commutative_of_le {f : β → β → α} (comm : ∀ a b, f a b ≤ f b a) : ∀ a b, f a b = f b a :=
λ a b, (comm _ _).antisymm $ comm _ _

/-- To prove associativity of a commutative binary operation `○`, we only to check
`(a ○ b) ○ c ≤ a ○ (b ○ c)` for all `a`, `b`, `c`. -/
lemma associative_of_commutative_of_le {f : α → α → α} (comm : commutative f)
  (assoc : ∀ a b c, f (f a b) c ≤ f a (f b c)) :
  associative f :=
λ a b c, le_antisymm (assoc _ _ _) $ by { rw [comm, comm b, comm _ c, comm a], exact assoc _ _ _ }

end partial_order

@[ext]
lemma preorder.to_has_le_injective {α : Type*} :
  function.injective (@preorder.to_has_le α) :=
λ A B h, begin
  cases A, cases B,
  injection h with h_le,
  have : A_lt = B_lt,
  { funext a b,
    dsimp [(≤)] at A_lt_iff_le_not_le B_lt_iff_le_not_le h_le,
    simp [A_lt_iff_le_not_le, B_lt_iff_le_not_le, h_le], },
  congr',
end

@[ext]
lemma partial_order.to_preorder_injective {α : Type*} :
  function.injective (@partial_order.to_preorder α) :=
λ A B h, by { cases A, cases B, injection h, congr' }

@[ext]
lemma linear_order.to_partial_order_injective {α : Type*} :
  function.injective (@linear_order.to_partial_order α) :=
begin
  intros A B h,
  cases A, cases B, injection h,
  obtain rfl : A_le = B_le := ‹_›, obtain rfl : A_lt = B_lt := ‹_›,
  obtain rfl : A_decidable_le = B_decidable_le := subsingleton.elim _ _,
  obtain rfl : A_max = B_max := A_max_def.trans B_max_def.symm,
  obtain rfl : A_min = B_min := A_min_def.trans B_min_def.symm,
  congr
end

theorem preorder.ext {α} {A B : preorder α}
  (H : ∀ x y : α, (by haveI := A; exact x ≤ y) ↔ x ≤ y) : A = B :=
by { ext x y, exact H x y }

theorem partial_order.ext {α} {A B : partial_order α}
  (H : ∀ x y : α, (by haveI := A; exact x ≤ y) ↔ x ≤ y) : A = B :=
by { ext x y, exact H x y }

theorem linear_order.ext {α} {A B : linear_order α}
  (H : ∀ x y : α, (by haveI := A; exact x ≤ y) ↔ x ≤ y) : A = B :=
by { ext x y, exact H x y }

/-- Given a relation `R` on `β` and a function `f : α → β`, the preimage relation on `α` is defined
by `x ≤ y ↔ f x ≤ f y`. It is the unique relation on `α` making `f` a `rel_embedding` (assuming `f`
is injective). -/
@[simp] def order.preimage {α β} (f : α → β) (s : β → β → Prop) (x y : α) : Prop := s (f x) (f y)

infix ` ⁻¹'o `:80 := order.preimage

/-- The preimage of a decidable order is decidable. -/
instance order.preimage.decidable {α β} (f : α → β) (s : β → β → Prop) [H : decidable_rel s] :
  decidable_rel (f ⁻¹'o s) :=
λ x y, H _ _

/-! ### Order dual -/

/-- Type synonym to equip a type with the dual order: `≤` means `≥` and `<` means `>`. `αᵒᵈ` is
notation for `order_dual α`. -/
def order_dual (α : Type*) : Type* := α

notation α `ᵒᵈ`:std.prec.max_plus := order_dual α

namespace order_dual

instance (α : Type*) [h : nonempty α] : nonempty αᵒᵈ := h
instance (α : Type*) [h : subsingleton α] : subsingleton αᵒᵈ := h
instance (α : Type*) [has_le α] : has_le αᵒᵈ := ⟨λ x y : α, y ≤ x⟩
instance (α : Type*) [has_lt α] : has_lt αᵒᵈ := ⟨λ x y : α, y < x⟩

instance (α : Type*) [preorder α] : preorder αᵒᵈ :=
{ le_refl          := le_refl,
  le_trans         := λ a b c hab hbc, hbc.trans hab,
  lt_iff_le_not_le := λ _ _, lt_iff_le_not_le,
  .. order_dual.has_le α,
  .. order_dual.has_lt α }

instance (α : Type*) [partial_order α] : partial_order αᵒᵈ :=
{ le_antisymm := λ a b hab hba, @le_antisymm α _ a b hba hab, .. order_dual.preorder α }

instance (α : Type*) [linear_order α] : linear_order αᵒᵈ :=
{ le_total     := λ a b : α, le_total b a,
  decidable_le := (infer_instance : decidable_rel (λ a b : α, b ≤ a)),
  decidable_lt := (infer_instance : decidable_rel (λ a b : α, b < a)),
  min := @max α _,
  max := @min α _,
  min_def := funext₂ $ @max_def' α _,
  max_def := funext₂ $ @min_def' α _,
  .. order_dual.partial_order α }

instance : Π [inhabited α], inhabited αᵒᵈ := id

theorem preorder.dual_dual (α : Type*) [H : preorder α] :
  order_dual.preorder αᵒᵈ = H :=
preorder.ext $ λ _ _, iff.rfl

theorem partial_order.dual_dual (α : Type*) [H : partial_order α] :
  order_dual.partial_order αᵒᵈ = H :=
partial_order.ext $ λ _ _, iff.rfl

theorem linear_order.dual_dual (α : Type*) [H : linear_order α] :
  order_dual.linear_order αᵒᵈ = H :=
linear_order.ext $ λ _ _, iff.rfl

end order_dual

/-! ### `has_compl` -/

/-- Set / lattice complement -/
@[notation_class] class has_compl (α : Type*) := (compl : α → α)

export has_compl (compl)

postfix `ᶜ`:(max+1) := compl

instance Prop.has_compl : has_compl Prop := ⟨not⟩

instance pi.has_compl {ι : Type u} {α : ι → Type v} [∀ i, has_compl (α i)] :
  has_compl (Π i, α i) :=
⟨λ x i, (x i)ᶜ⟩

lemma pi.compl_def {ι : Type u} {α : ι → Type v} [∀ i, has_compl (α i)] (x : Π i, α i) :
  xᶜ = λ i, (x i)ᶜ := rfl

@[simp]
lemma pi.compl_apply {ι : Type u} {α : ι → Type v} [∀ i, has_compl (α i)] (x : Π i, α i) (i : ι)  :
  xᶜ i = (x i)ᶜ := rfl

instance is_irrefl.compl (r) [is_irrefl α r] : is_refl α rᶜ := ⟨@irrefl α r _⟩
instance is_refl.compl (r) [is_refl α r] : is_irrefl α rᶜ := ⟨λ a, not_not_intro (refl a)⟩

/-! ### Order instances on the function space -/

instance pi.has_le {ι : Type u} {α : ι → Type v} [∀ i, has_le (α i)] : has_le (Π i, α i) :=
{ le       := λ x y, ∀ i, x i ≤ y i }

lemma pi.le_def {ι : Type u} {α : ι → Type v} [∀ i, has_le (α i)] {x y : Π i, α i} :
  x ≤ y ↔ ∀ i, x i ≤ y i :=
iff.rfl

instance pi.preorder {ι : Type u} {α : ι → Type v} [∀ i, preorder (α i)] : preorder (Π i, α i) :=
{ le_refl  := λ a i, le_refl (a i),
  le_trans := λ a b c h₁ h₂ i, le_trans (h₁ i) (h₂ i),
  ..pi.has_le }

lemma pi.lt_def {ι : Type u} {α : ι → Type v} [∀ i, preorder (α i)] {x y : Π i, α i} :
  x < y ↔ x ≤ y ∧ ∃ i, x i < y i :=
by simp [lt_iff_le_not_le, pi.le_def] {contextual := tt}

instance pi.partial_order [Π i, partial_order (π i)] : partial_order (Π i, π i) :=
{ le_antisymm := λ f g h1 h2, funext $ λ b, (h1 b).antisymm (h2 b),
  ..pi.preorder }

section pi

/-- A function `a` is strongly less than a function `b`  if `a i < b i` for all `i`. -/
def strong_lt [Π i, has_lt (π i)] (a b : Π i, π i) : Prop := ∀ i, a i < b i

local infix ` ≺ `:50 := strong_lt

variables [Π i, preorder (π i)] {a b c : Π i, π i}

lemma le_of_strong_lt (h : a ≺ b) : a ≤ b := λ i, (h _).le

lemma lt_of_strong_lt [nonempty ι] (h : a ≺ b) : a < b :=
by { inhabit ι, exact pi.lt_def.2 ⟨le_of_strong_lt h, default, h _⟩ }

lemma strong_lt_of_strong_lt_of_le (hab : a ≺ b) (hbc : b ≤ c) : a ≺ c :=
λ i, (hab _).trans_le $ hbc _

lemma strong_lt_of_le_of_strong_lt (hab : a ≤ b) (hbc : b ≺ c) : a ≺ c :=
λ i, (hab _).trans_lt $ hbc _

alias le_of_strong_lt ← strong_lt.le
alias lt_of_strong_lt ← strong_lt.lt
alias strong_lt_of_strong_lt_of_le ← strong_lt.trans_le
alias strong_lt_of_le_of_strong_lt ← has_le.le.trans_strong_lt

end pi

section function
variables [decidable_eq ι] [Π i, preorder (π i)] {x y : Π i, π i} {i : ι} {a b : π i}

lemma le_update_iff : x ≤ function.update y i a ↔ x i ≤ a ∧ ∀ j ≠ i, x j ≤ y j :=
function.forall_update_iff _ (λ j z, x j ≤ z)

lemma update_le_iff : function.update x i a ≤ y ↔ a ≤ y i ∧ ∀ j ≠ i, x j ≤ y j :=
function.forall_update_iff _ (λ j z, z ≤ y j)

lemma update_le_update_iff :
  function.update x i a ≤ function.update y i b ↔ a ≤ b ∧ ∀ j ≠ i, x j ≤ y j :=
by simp [update_le_iff] {contextual := tt}

@[simp] lemma le_update_self_iff : x ≤ update x i a ↔ x i ≤ a := by simp [le_update_iff]
@[simp] lemma update_le_self_iff : update x i a ≤ x ↔ a ≤ x i := by simp [update_le_iff]
@[simp] lemma lt_update_self_iff : x < update x i a ↔ x i < a := by simp [lt_iff_le_not_le]
@[simp] lemma update_lt_self_iff : update x i a < x ↔ a < x i := by simp [lt_iff_le_not_le]

end function

instance pi.has_sdiff {ι : Type u} {α : ι → Type v} [∀ i, has_sdiff (α i)] :
  has_sdiff (Π i, α i) :=
⟨λ x y i, x i \ y i⟩

lemma pi.sdiff_def {ι : Type u} {α : ι → Type v} [∀ i, has_sdiff (α i)] (x y : Π i, α i) :
  (x \ y) = λ i, x i \ y i := rfl

@[simp]
lemma pi.sdiff_apply {ι : Type u} {α : ι → Type v} [∀ i, has_sdiff (α i)] (x y : Π i, α i) (i : ι) :
  (x \ y) i = x i \ y i := rfl

namespace function
variables [preorder α] [nonempty β] {a b : α}

@[simp] lemma const_le_const : const β a ≤ const β b ↔ a ≤ b := by simp [pi.le_def]
@[simp] lemma const_lt_const : const β a < const β b ↔ a < b := by simpa [pi.lt_def] using le_of_lt

end function

/-! ### `min`/`max` recursors -/

section min_max_rec

variables [linear_order α] {p : α → Prop} {x y : α}

lemma min_rec (hx : x ≤ y → p x) (hy : y ≤ x → p y) : p (min x y) :=
(le_total x y).rec (λ h, (min_eq_left h).symm.subst (hx h))
  (λ h, (min_eq_right h).symm.subst (hy h))

lemma max_rec (hx : y ≤ x → p x) (hy : x ≤ y → p y) : p (max x y) := @min_rec αᵒᵈ _ _ _ _ hx hy
lemma min_rec' (p : α → Prop) (hx : p x) (hy : p y) : p (min x y) := min_rec (λ _, hx) (λ _, hy)
lemma max_rec' (p : α → Prop) (hx : p x) (hy : p y) : p (max x y) := max_rec (λ _, hx) (λ _, hy)

lemma min_def_lt (x y : α) : min x y = if x < y then x else y :=
begin
  rw [min_comm, min_def, ← ite_not],
  simp only [not_le],
end

lemma max_def_lt (x y : α) : max x y = if x < y then y else x :=
begin
  rw [max_comm, max_def, ← ite_not],
  simp only [not_le],
end

end min_max_rec

/-! ### `has_sup` and `has_inf` -/

/-- Typeclass for the `⊔` (`\lub`) notation -/
@[notation_class] class has_sup (α : Type u) := (sup : α → α → α)
/-- Typeclass for the `⊓` (`\glb`) notation -/
@[notation_class] class has_inf (α : Type u) := (inf : α → α → α)

infix ` ⊔ ` := has_sup.sup
infix ` ⊓ ` := has_inf.inf

/-! ### Lifts of order instances -/

/-- Transfer a `preorder` on `β` to a `preorder` on `α` using a function `f : α → β`.
See note [reducible non-instances]. -/
@[reducible] def preorder.lift {α β} [preorder β] (f : α → β) : preorder α :=
{ le               := λ x y, f x ≤ f y,
  le_refl          := λ a, le_rfl,
  le_trans         := λ a b c, le_trans,
  lt               := λ x y, f x < f y,
  lt_iff_le_not_le := λ a b, lt_iff_le_not_le }

/-- Transfer a `partial_order` on `β` to a `partial_order` on `α` using an injective
function `f : α → β`. See note [reducible non-instances]. -/
@[reducible] def partial_order.lift {α β} [partial_order β] (f : α → β) (inj : injective f) :
  partial_order α :=
{ le_antisymm := λ a b h₁ h₂, inj (h₁.antisymm h₂), .. preorder.lift f }

/-- Transfer a `linear_order` on `β` to a `linear_order` on `α` using an injective
function `f : α → β`. This version takes `[has_sup α]` and `[has_inf α]` as arguments, then uses
them for `max` and `min` fields. See `linear_order.lift'` for a version that autogenerates `min` and
`max` fields. See note [reducible non-instances]. -/
@[reducible] def linear_order.lift {α β} [linear_order β] [has_sup α] [has_inf α] (f : α → β)
  (inj : injective f) (hsup : ∀ x y, f (x ⊔ y) = max (f x) (f y))
  (hinf : ∀ x y, f (x ⊓ y) = min (f x) (f y)) :
  linear_order α :=
{ le_total     := λ x y, le_total (f x) (f y),
  decidable_le := λ x y, (infer_instance : decidable (f x ≤ f y)),
  decidable_lt := λ x y, (infer_instance : decidable (f x < f y)),
  decidable_eq := λ x y, decidable_of_iff (f x = f y) inj.eq_iff,
  min := (⊓),
  max := (⊔),
  min_def := by { ext x y, apply inj, rw [hinf, min_def, min_default, apply_ite f], refl },
  max_def := by { ext x y, apply inj, rw [hsup, max_def, max_default, apply_ite f], refl },
  .. partial_order.lift f inj }

/-- Transfer a `linear_order` on `β` to a `linear_order` on `α` using an injective
function `f : α → β`. This version autogenerates `min` and `max` fields. See `linear_order.lift`
for a version that takes `[has_sup α]` and `[has_inf α]`, then uses them as `max` and `min`.
See note [reducible non-instances]. -/
@[reducible] def linear_order.lift' {α β} [linear_order β] (f : α → β) (inj : injective f) :
  linear_order α :=
@linear_order.lift α β _ ⟨λ x y, if f x ≤ f y then y else x⟩ ⟨λ x y, if f x ≤ f y then x else y⟩
  f inj (λ x y, (apply_ite f _ _ _).trans (max_def _ _).symm)
  (λ x y, (apply_ite f _ _ _).trans (min_def _ _).symm)

/-! ### Subtype of an order -/

namespace subtype

instance [has_le α] {p : α → Prop} : has_le (subtype p) := ⟨λ x y, (x : α) ≤ y⟩
instance [has_lt α] {p : α → Prop} : has_lt (subtype p) := ⟨λ x y, (x : α) < y⟩

@[simp] lemma mk_le_mk [has_le α] {p : α → Prop} {x y : α} {hx : p x} {hy : p y} :
  (⟨x, hx⟩ : subtype p) ≤ ⟨y, hy⟩ ↔ x ≤ y :=
iff.rfl

@[simp] lemma mk_lt_mk [has_lt α] {p : α → Prop} {x y : α} {hx : p x} {hy : p y} :
  (⟨x, hx⟩ : subtype p) < ⟨y, hy⟩ ↔ x < y :=
iff.rfl

@[simp, norm_cast]
lemma coe_le_coe [has_le α] {p : α → Prop} {x y : subtype p} : (x : α) ≤ y ↔ x ≤ y := iff.rfl

@[simp, norm_cast]
lemma coe_lt_coe [has_lt α] {p : α → Prop} {x y : subtype p} : (x : α) < y ↔ x < y := iff.rfl

instance [preorder α] (p : α → Prop) : preorder (subtype p) := preorder.lift (coe : subtype p → α)

instance partial_order [partial_order α] (p : α → Prop) :
  partial_order (subtype p) :=
partial_order.lift coe subtype.coe_injective

instance decidable_le [preorder α] [h : @decidable_rel α (≤)] {p : α → Prop} :
  @decidable_rel (subtype p) (≤) :=
λ a b, h a b

instance decidable_lt [preorder α] [h : @decidable_rel α (<)] {p : α → Prop} :
  @decidable_rel (subtype p) (<) :=
λ a b, h a b

/-- A subtype of a linear order is a linear order. We explicitly give the proofs of decidable
equality and decidable order in order to ensure the decidability instances are all definitionally
equal. -/
instance [linear_order α] (p : α → Prop) : linear_order (subtype p) :=
@linear_order.lift (subtype p) _ _ ⟨λ x y, ⟨max x y, max_rec' _ x.2 y.2⟩⟩
  ⟨λ x y, ⟨min x y, min_rec' _ x.2 y.2⟩⟩ coe subtype.coe_injective (λ _ _, rfl) (λ _ _, rfl)

end subtype

/-!
### Pointwise order on `α × β`

The lexicographic order is defined in `data.prod.lex`, and the instances are available via the
type synonym `α ×ₗ β = α × β`.
-/

namespace prod

instance (α : Type u) (β : Type v) [has_le α] [has_le β] : has_le (α × β) :=
⟨λ p q, p.1 ≤ q.1 ∧ p.2 ≤ q.2⟩

lemma le_def [has_le α] [has_le β] {x y : α × β} : x ≤ y ↔ x.1 ≤ y.1 ∧ x.2 ≤ y.2 := iff.rfl

@[simp] lemma mk_le_mk [has_le α] [has_le β] {x₁ x₂ : α} {y₁ y₂ : β} :
  (x₁, y₁) ≤ (x₂, y₂) ↔ x₁ ≤ x₂ ∧ y₁ ≤ y₂ :=
iff.rfl

@[simp] lemma swap_le_swap [has_le α] [has_le β] {x y : α × β} : x.swap ≤ y.swap ↔ x ≤ y :=
and_comm _ _

section preorder
variables [preorder α] [preorder β] {a a₁ a₂ : α} {b b₁ b₂ : β} {x y : α × β}

instance (α : Type u) (β : Type v) [preorder α] [preorder β] : preorder (α × β) :=
{ le_refl  := λ ⟨a, b⟩, ⟨le_refl a, le_refl b⟩,
  le_trans := λ ⟨a, b⟩ ⟨c, d⟩ ⟨e, f⟩ ⟨hac, hbd⟩ ⟨hce, hdf⟩,
    ⟨le_trans hac hce, le_trans hbd hdf⟩,
  .. prod.has_le α β }

@[simp] lemma swap_lt_swap : x.swap < y.swap ↔ x < y :=
and_congr swap_le_swap (not_congr swap_le_swap)

lemma mk_le_mk_iff_left : (a₁, b) ≤ (a₂, b) ↔ a₁ ≤ a₂ := and_iff_left le_rfl
lemma mk_le_mk_iff_right : (a, b₁) ≤ (a, b₂) ↔ b₁ ≤ b₂ := and_iff_right le_rfl

lemma mk_lt_mk_iff_left : (a₁, b) < (a₂, b) ↔ a₁ < a₂ :=
lt_iff_lt_of_le_iff_le' mk_le_mk_iff_left mk_le_mk_iff_left

lemma mk_lt_mk_iff_right : (a, b₁) < (a, b₂) ↔ b₁ < b₂ :=
lt_iff_lt_of_le_iff_le' mk_le_mk_iff_right mk_le_mk_iff_right

lemma lt_iff : x < y ↔ x.1 < y.1 ∧ x.2 ≤ y.2 ∨ x.1 ≤ y.1 ∧ x.2 < y.2 :=
begin
  refine ⟨λ h, _, _⟩,
  { by_cases h₁ : y.1 ≤ x.1,
    { exact or.inr ⟨h.1.1, h.1.2.lt_of_not_le $ λ h₂, h.2 ⟨h₁, h₂⟩⟩ },
    { exact or.inl ⟨h.1.1.lt_of_not_le h₁, h.1.2⟩ } },
  { rintro (⟨h₁, h₂⟩ | ⟨h₁, h₂⟩),
    { exact ⟨⟨h₁.le, h₂⟩, λ h, h₁.not_le h.1⟩ },
    { exact ⟨⟨h₁, h₂.le⟩, λ h, h₂.not_le h.2⟩ } }
end

@[simp] lemma mk_lt_mk : (a₁, b₁) < (a₂, b₂) ↔ a₁ < a₂ ∧ b₁ ≤ b₂ ∨ a₁ ≤ a₂ ∧ b₁ < b₂ := lt_iff

end preorder

/-- The pointwise partial order on a product.
    (The lexicographic ordering is defined in order/lexicographic.lean, and the instances are
    available via the type synonym `α ×ₗ β = α × β`.) -/
instance (α : Type u) (β : Type v) [partial_order α] [partial_order β] :
  partial_order (α × β) :=
{ le_antisymm := λ ⟨a, b⟩ ⟨c, d⟩ ⟨hac, hbd⟩ ⟨hca, hdb⟩,
    prod.ext (hac.antisymm hca) (hbd.antisymm hdb),
  .. prod.preorder α β }

end prod

/-! ### Additional order classes -/

/-- An order is dense if there is an element between any pair of distinct comparable elements. -/
class densely_ordered (α : Type u) [has_lt α] : Prop :=
(dense : ∀ a₁ a₂ : α, a₁ < a₂ → ∃ a, a₁ < a ∧ a < a₂)

lemma exists_between [has_lt α] [densely_ordered α] :
  ∀ {a₁ a₂ : α}, a₁ < a₂ → ∃ a, a₁ < a ∧ a < a₂ :=
densely_ordered.dense

instance order_dual.densely_ordered (α : Type u) [has_lt α] [densely_ordered α] :
  densely_ordered αᵒᵈ :=
⟨λ a₁ a₂ ha, (@exists_between α _ _ _ _ ha).imp $ λ a, and.symm⟩

@[simp] lemma densely_ordered_order_dual [has_lt α] : densely_ordered αᵒᵈ ↔ densely_ordered α :=
⟨by { convert @order_dual.densely_ordered αᵒᵈ _, casesI ‹has_lt α›, refl },
  @order_dual.densely_ordered α _⟩

instance [preorder α] [preorder β] [densely_ordered α] [densely_ordered β] :
  densely_ordered (α × β) :=
⟨λ a b, begin
  simp_rw prod.lt_iff,
  rintro (⟨h₁, h₂⟩ | ⟨h₁, h₂⟩),
  { obtain ⟨c, ha, hb⟩ := exists_between h₁,
    exact ⟨(c, _), or.inl ⟨ha, h₂⟩, or.inl ⟨hb, le_rfl⟩⟩ },
  { obtain ⟨c, ha, hb⟩ := exists_between h₂,
    exact ⟨(_, c), or.inr ⟨h₁, ha⟩, or.inr ⟨le_rfl, hb⟩⟩ }
end⟩

instance {α : ι → Type*} [Π i, preorder (α i)] [Π i, densely_ordered (α i)] :
  densely_ordered (Π i, α i) :=
⟨λ a b, begin
  classical,
  simp_rw pi.lt_def,
  rintro ⟨hab, i, hi⟩,
  obtain ⟨c, ha, hb⟩ := exists_between hi,
  exact ⟨a.update i c, ⟨le_update_iff.2 ⟨ha.le, λ _ _, le_rfl⟩, i, by rwa update_same⟩,
    update_le_iff.2 ⟨hb.le, λ _ _, hab _⟩, i, by rwa update_same⟩,
end⟩

lemma le_of_forall_le_of_dense [linear_order α] [densely_ordered α] {a₁ a₂ : α}
  (h : ∀ a, a₂ < a → a₁ ≤ a) :
  a₁ ≤ a₂ :=
le_of_not_gt $ λ ha,
  let ⟨a, ha₁, ha₂⟩ := exists_between ha in
  lt_irrefl a $ lt_of_lt_of_le ‹a < a₁› (h _ ‹a₂ < a›)

lemma eq_of_le_of_forall_le_of_dense [linear_order α] [densely_ordered α] {a₁ a₂ : α}
  (h₁ : a₂ ≤ a₁) (h₂ : ∀ a, a₂ < a → a₁ ≤ a) : a₁ = a₂ :=
le_antisymm (le_of_forall_le_of_dense h₂) h₁

lemma le_of_forall_ge_of_dense [linear_order α] [densely_ordered α] {a₁ a₂ : α}
  (h : ∀ a₃ < a₁, a₃ ≤ a₂) :
  a₁ ≤ a₂ :=
le_of_not_gt $ λ ha,
  let ⟨a, ha₁, ha₂⟩ := exists_between ha in
  lt_irrefl a $ lt_of_le_of_lt (h _ ‹a < a₁›) ‹a₂ < a›

lemma eq_of_le_of_forall_ge_of_dense [linear_order α] [densely_ordered α] {a₁ a₂ : α}
  (h₁ : a₂ ≤ a₁) (h₂ : ∀ a₃ < a₁, a₃ ≤ a₂) : a₁ = a₂ :=
(le_of_forall_ge_of_dense h₂).antisymm h₁

lemma dense_or_discrete [linear_order α] (a₁ a₂ : α) :
  (∃ a, a₁ < a ∧ a < a₂) ∨ ((∀ a, a₁ < a → a₂ ≤ a) ∧ (∀ a < a₂, a ≤ a₁)) :=
or_iff_not_imp_left.2 $ λ h,
  ⟨λ a ha₁, le_of_not_gt $ λ ha₂, h ⟨a, ha₁, ha₂⟩,
    λ a ha₂, le_of_not_gt $ λ ha₁, h ⟨a, ha₁, ha₂⟩⟩

/-- If a linear order has no elements `x < y < z`, then it has at most two elements. -/
lemma eq_or_eq_or_eq_of_forall_not_lt_lt {α : Type*} [linear_order α]
  (h : ∀ ⦃x y z : α⦄, x < y → y < z → false) (x y z : α) : x = y ∨ y = z ∨ x = z :=
begin
  by_contra hne, push_neg at hne,
  cases hne.1.lt_or_lt with h₁ h₁; cases hne.2.1.lt_or_lt with h₂ h₂;
    cases hne.2.2.lt_or_lt with h₃ h₃,
  exacts [h h₁ h₂, h h₂ h₃, h h₃ h₂, h h₃ h₁, h h₁ h₃, h h₂ h₃, h h₁ h₃, h h₂ h₁]
end

namespace punit
variables (a b : punit.{u+1})

instance : linear_order punit :=
by refine_struct
{ le := λ _ _, true,
  lt := λ _ _, false,
  max := λ _ _, star,
  min := λ _ _, star,
  decidable_eq := punit.decidable_eq,
  decidable_le := λ _ _, decidable.true,
  decidable_lt := λ _ _, decidable.false };
    intros; trivial <|> simp only [eq_iff_true_of_subsingleton, not_true, and_false] <|>
      exact or.inl trivial

lemma max_eq : max a b = star := rfl
lemma min_eq : min a b = star := rfl
@[simp] protected lemma le : a ≤ b := trivial
@[simp] lemma not_lt : ¬ a < b := not_false

instance : densely_ordered punit := ⟨λ _ _, false.elim⟩

end punit

section prop

/-- Propositions form a complete boolean algebra, where the `≤` relation is given by implication. -/
instance Prop.has_le : has_le Prop := ⟨(→)⟩

@[simp] lemma le_Prop_eq : ((≤) : Prop → Prop → Prop) = (→) := rfl

lemma subrelation_iff_le {r s : α → α → Prop} : subrelation r s ↔ r ≤ s := iff.rfl

instance Prop.partial_order : partial_order Prop :=
{ le_refl      := λ _, id,
  le_trans     := λ a b c f g, g ∘ f,
  le_antisymm  := λ a b Hab Hba, propext ⟨Hab, Hba⟩,
  ..Prop.has_le }

end prop

variables {s : β → β → Prop} {t : γ → γ → Prop}

/-! ### Linear order from a total partial order -/

/-- Type synonym to create an instance of `linear_order` from a `partial_order` and
`is_total α (≤)` -/
def as_linear_order (α : Type u) := α

instance {α} [inhabited α] : inhabited (as_linear_order α) :=
⟨ (default : α) ⟩

noncomputable instance as_linear_order.linear_order {α} [partial_order α] [is_total α (≤)] :
  linear_order (as_linear_order α) :=
{ le_total     := @total_of α (≤) _,
  decidable_le := classical.dec_rel _,
  .. (_ : partial_order α) }


/- Even more induction! -/
set_option trace.Meta.Tactic.simp true

variable (r : α → α → Prop)

-- The reflexive transitive closure of `r` as an inductive predicate
inductive RTC : α → α → Prop where
  -- Notice how declaring `r` as a `variable` instead of as a parameter instead of declaring it
  -- directly as a parameter of `RTC` means we don't have to write `RTC r a a` inside the
  -- declaration of `RTC`. This also works with recursive `def`s!
  | refl : RTC a a
  | trans : r a b → RTC b c → RTC a c

-- We have arbitrarily chosen a "left-biased" definition of `RTC.trans`, but can easily show the
-- mirror version by induction on the predicate
theorem RTC.trans' : RTC r a b → r b c → RTC r a c := by
  intros hab hbc
  induction hab with
  | refl => exact RTC.trans hbc RTC.refl
  -- `a/b/c` in the constructor `RTC.trans` are marked as *implicit* because we didn't specify them
  -- explicitly.
  -- Just like in other contexts, we can use `@` to specify/match implicit parameters in `induction`.
  | @trans a a' b haa' ha'b ih =>
    apply RTC.trans
    exact haa'
    exact (ih hbc)

open Nat

-- By the way, we can leave out `:= fun p1 ... => match p1, ... with` at `def`
def double : Nat → Nat
  | zero   => 0
  | succ n => succ (succ (double n))

-- The tactic injection proves that constructors like succ are injective and that they are distinct
theorem double.inj : double n = double m → n = m := by
  intro h
  -- Try to finish this proof. You might find that the inductive case is impossible to solve!
  -- Do you see a different approach? If not, read on!
  induction n generalizing m with
  | zero => cases m <;> trivial
  | succ n h1 =>
    cases m with
    | zero => contradiction
    | succ m =>
      rw [double] at h
      -- h: succ (succ (double n)) = double (succ m)
      injection h with h -- h: succ (double n) = succ (double m)
      injection h with h -- double n = double m
      rw [h1 h]

-- The issue with the above approach is that our inductive hypothesis is not sufficiently general!
-- When we begin induction, we have already fixed (introduced) a particular `m`, but for the inductive
-- step we need the inductive hypothesis for a *different* m.
-- We could avoid this by carefully introducing `m` (and `h`, which depends on it) only after `induction`:
-- ```
-- theorem double.inj : ∀ m, double n = double m → n = m := by
--   induction n with
--   | zero => intro m h; ...
--   ...
-- ```
-- `induction` even allows us to apply a tactic before *each* case:
-- ```
-- theorem double.inj : ∀ m, double n = double m → n = m := by
--   induction n with
--       intro m h
--   | zero => ...
--   ...
-- ```
-- However, it turns out that we do not have to change the theorem statement at all: if we simply say
-- ```
-- induction n generalizing m with
-- ```
-- then `induction` will automatically `revert` (yes, that's also a tactic) and re`intro`duce the variable(s)
-- before/after induction for us! So add `generalizing m` above, see how the inductive hypothesis is
-- affected, and then go finish that proof!

/- Partial & dependent maps -/

-- *Partial maps* are a useful data type for the semantics project and many other topics.
-- They map *some* keys of one type to values of another type.
abbrev Map (α β : Type) := α → Option β
-- We express partiality via the `Option` type, which either holds `some b` for `b : β`, or `none`.
-- Ctrl+click it for the whole definition.

namespace Map

def empty : Map α β := fun k => none

-- If we wanted a partial map for programming, we might choose a more efficient implementation such
-- as a search tree or a hash map. If, on the other hand, we are only interested in using it in a
-- formalization, a simple function like above is usually the better solution. For example, a
-- simple typing context `Γ` can be formalized as a partial map from variable names to their types.

-- The function-based definition makes defining operations such as a map update quite easy:

/-- Set the entry `k` of the map `m` to the value `v`. All other entries are unchanged. -/
def update [DecidableEq α] (m : Map α β) (k : α) (v : Option β) : Map α β :=
  fun x => if k = x then v else m x

-- def update [DecidableEq α] (m : Map α β) (k : α) (v : Option β) : Map α β :=
--   fun k' => if k = k' then v else m k'

-- A `scoped` notation is activated only when opening/inside the current namespace
scoped notation:max m "[" k " ↦ " v "]" => update m k v

theorem apply_update [DecidableEq α] (m : Map α β) : m[k ↦ v] k = v := by simp [update]

-- hint: use function extensionality (`apply funext`)
theorem update_self [DecidableEq α] (m : Map α β) : m[k ↦ m k] = m := by
-- funext {f₁ f₂ : ∀ (x : α), β x} (h : ∀ x, f₁ x = f₂ x) : f₁ = f₂
  funext k'  -- an abbreviation for `apply funext; intro k'`
  by_cases h : k = k' <;> simp [update, h]

end Map

-- One interesting generalization of partial maps we can express in Lean are *dependent maps* where
-- the *type* of the value may depend on the key:
abbrev DepMap (α : Type) (β : α → Type) := (k : α) → Option (β k)

namespace DepMap

def empty : DepMap α β := fun k => none

-- If we try to define `update` as above, it turns out that we run into a type error!
-- You may want to use the "dependent if" `if h : p then t else e` that makes a *proof* of
-- the condition `p` available in each branch: `h : p` in the `then` branch and `h : ¬p` in the
-- `else` branch. You should then be able to use rewriting (e.g. `▸`) to fix the type error.
def update [DecidableEq α] (m : DepMap α β) (k : α) (v : Option (β k)) : DepMap α β :=
  fun x => if h : k = x then h ▸ v else m x
    -- fun x => if k = x then v else m x

scoped notation:max m "[" k " ↦ " v "]" => update m k v

-- This one should be as before...
theorem apply_update [DecidableEq α] (m : DepMap α β) : m[k ↦ v] k = v := by simp [update]

-- ...but this one is where the fun starts: try replicating the corresponding `Map` proof...
theorem update_self [DecidableEq α] (m : DepMap α β) : m[k ↦ m k] = m := by
  funext k'  -- an abbreviation for `apply funext; intro k'`
  by_cases h : k = k'
  case inl =>
    rw [h]
    simp [update]
  case inr =>
    simp [h, update]
-- and you should end up with an unsolved goal containing a subterm of the shape `(_ : a = b) ▸ c`. This
-- is the rewrite from `update`; the proof is elided as `_` by default because, as we said in week 1, Lean
-- considers all proofs of a proposition as equal, so we really don't care what proof is displayed there.
-- So how do we get rid of the `▸`? We know it is something like a match  on `Eq.refl`; more formally,
-- both `▸` and such a match compile down to an application of `Eq`'s *recursor* (week 3).
-- We know matches/recursors reduce ("go away") when applied to a matching constructor application,
-- i.e. for `▸` we have `(rfl ▸ c) ≡ c`.
-- So why didn't `simp` reduce away `(_ : a = b) ▸` if it works for `rfl` and all proofs are the same?
-- Well, all proofs of a *single* proposition are the same, but `rfl` is not a proof of `a = b` unless
-- `a` and `b` are in fact the same term! Thus the general way to get rid of `(_ : a = b) ▸` is to
-- first rewrite the goal with a proof of the very equality `a = b`. After that, `simp`, or definitional
-- equality in general, will get rid of the `▸`.
-- Now, for technical reasons we should use `rw` instead of `simp` itself to do this rewrite. The short
-- answer as to why that is is that `simp` tries to be *too clever* in this case: it will rewrite `a = b`
-- on both sides of the `▸` individually, which usually makes it more flexible (week 4, slide pages 17 & 21),
-- but in this case unfortunately leads to a type-incorrect proof. The "naive" strategy of `rw`, which will
-- simply replace all `a` with `b` everywhere simultaneously by applying the `Eq` recursor once at the root,
-- turns out to be the better approach in this case.
-- Phew, that was a lot of typing (in the theoretic sense and on my keyboard). If you can't get the proof to
-- work, don't worry about it, we will not bother you with this kind of "esoteric" proof again. If, on the
-- other hand, you are interested in this kind of strong dependent typing, we may have an interesting variant
-- of the semantics project to offer you next week!

end DepMap

open List Nat

/- Insertion Sort -/

-- Let's implement insertion sort in Lean and show that the resulting `List` is indeed sorted.
-- To that end, we first assume that the type `α` is of the type class `LE`, meaning that we can use
-- the symbol `≤` (\le) as notation.
-- We also assume (notice that cool dot notation) that this relation is decidable:
variable [LE α] [DecidableRel ((· ≤ ·) : α → α → Prop)]

-- First, we want to define a predicate that holds if a list is sorted.
-- The predicate should have three constructors:
-- The empty list `[]` and the single element list `[a]` are sorted,
-- and we can add `a` to the front of a sorted list `b :: l`, if `a ≤ b`.
inductive Sorted : List α → Prop where
  | nil : Sorted []
  | single : Sorted [a]
  | cons_cons : a ≤ b → Sorted (b::l) → Sorted (a::b::l)

-- The main ingredient to insertion sort is a function `insertInOrder` which inserts
-- a single element `a` before the first entry `x` of a list for which `a ≤ x` holds.
-- Define that function by recursion on the list. Remember that `≤` is decidable.
-- def insertInOrder (a : α) (xs : List α) : List α :=
--   let rec helper (a : α) (xs : List α) (ys : List α) : List α :=
--     match xs with
--     | [] => ys ++ [a]
--     | x :: xs => if a ≤ x then ys ++ (a::x::xs) else helper a xs (ys ++ [x])
--   helper a xs []

def insertInOrder (a : α) (xs : List α) : List α :=
  match xs with
  | [] => [a]
  | x :: xs =>
    if a ≤ x then
      a :: x :: xs
    else
      x :: insertInOrder a xs

-- Now, check whether the function actually does what it should do.
#eval insertInOrder 4 [1, 3, 4, 6, 7]
#eval insertInOrder 4 [1, 2, 3]

-- Defining `insertionSort` itself is now an easy recursion.
-- def insertionSort (xs : List α) : List α :=
--   let rec helper (xs : List α) (ys : List α) : List α :=
--     match xs with
--     | [] => ys
--     | x :: xs => helper xs (insertInOrder x ys)
--   helper xs []

def insertionSort (xs : List α) : List α :=
  match xs with
  | []      => []
  | x :: xs => insertInOrder x (insertionSort xs)

-- Let's test the sorting algorithm next.
#eval insertionSort [6, 2, 4, 4, 1, 3, 64]
#eval insertionSort [1, 2, 3]
#eval insertionSort (Nat.repeat (fun xs => xs.length :: xs) 500 [])

-- Now we want to move on to actually verify that the algorithm does what it claims to do!
-- To prove this, we don't need the relation to be transitive, but we need to assume the following property:
variable (antisymm : ∀ {x y : α}, ¬ (x ≤ y) → y ≤ x)

-- Okay, now prove the statement itself!
-- Hints:
--   * You might at one point have the choice to either apply induction on a list or on a witness of `Sorted`.
--     Choose wisely.
--   * Remember the tactic `by_cases` from the fifth exercise!
theorem sorted_insertInOrder {xs : List α} (h : Sorted xs) : Sorted (insertInOrder x xs) := by
  induction h with
  | nil => exact Sorted.single
  | @single a =>
    simp only [insertInOrder]
    by_cases hxa : x ≤ a <;> simp only [hxa]
    case inl => exact Sorted.cons_cons hxa Sorted.single
    case inr => exact Sorted.cons_cons (antisymm hxa) Sorted.single
  | @cons_cons a b l hab hbl ih =>
    simp only [insertInOrder]
    by_cases hxa : x ≤ a <;> simp only [hxa]
    case inl => exact Sorted.cons_cons hxa (Sorted.cons_cons hab hbl)
    case inr =>
      by_cases hxb : x ≤ b <;> simp only [hxb]
      case inl => exact Sorted.cons_cons (antisymm hxa) (Sorted.cons_cons hxb hbl)
      case inr =>
        simp only [insertInOrder, hxb] at ih
        exact Sorted.cons_cons hab ih

theorem sorted_insertionSort (as : List α) : Sorted (insertionSort as) :=
  match as with
  | nil => Sorted.nil
  | x :: xs => sorted_insertInOrder antisymm (sorted_insertionSort xs)

-- Here's a "soft" question: Have we now fully verified that `insertionSort` is a sorting algorithm?
-- What other property would be an obvious one to verify (which you don't have to do here)?


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

List permutations.
-/
import data.list.basic data.list.set
open list setoid nat binary

variables {A B : Type}

inductive perm : list A → list A → Prop :=
| nil   : perm [] []
| skip  : Π (x : A) {l₁ l₂ : list A}, perm l₁ l₂ → perm (x::l₁) (x::l₂)
| swap  : Π (x y : A) (l : list A), perm (y::x::l) (x::y::l)
| trans : Π {l₁ l₂ l₃ : list A}, perm l₁ l₂ → perm l₂ l₃ → perm l₁ l₃

namespace perm
infix ~ := perm
theorem eq_nil_of_perm_nil {l₁ : list A} (p : [] ~ l₁) : l₁ = [] :=
have gen : ∀ (l₂ : list A) (p : l₂ ~ l₁), l₂ = [] → l₁ = [], from
  take l₂ p, perm.induction_on p
    (λ h, h)
    (by contradiction)
    (by contradiction)
    (λ l₁ l₂ l₃ p₁ p₂ r₁ r₂ e, r₂ (r₁ e)),
gen [] p rfl

theorem not_perm_nil_cons (x : A) (l : list A) : ¬ [] ~ (x::l) :=
have gen : ∀ (l₁ l₂ : list A) (p : l₁ ~ l₂), l₁ = [] → l₂ = (x::l) → false, from
  take l₁ l₂ p, perm.induction_on p
    (by contradiction)
    (by contradiction)
    (by contradiction)
    (λ l₁ l₂ l₃ p₁ p₂ r₁ r₂ e₁ e₂,
      begin
        rewrite [e₂ at *, e₁ at *],
        have e₃ : l₂ = [], from eq_nil_of_perm_nil p₁,
        exact (r₂ e₃ rfl)
      end),
assume p, gen [] (x::l) p rfl rfl

protected theorem refl [refl] : ∀ (l : list A), l ~ l
| []      := nil
| (x::xs) := skip x (refl xs)

protected theorem symm [symm] : ∀ {l₁ l₂ : list A}, l₁ ~ l₂ → l₂ ~ l₁ :=
take l₁ l₂ p, perm.induction_on p
  nil
  (λ x l₁ l₂ p₁ r₁, skip x r₁)
  (λ x y l, swap y x l)
  (λ l₁ l₂ l₃ p₁ p₂ r₁ r₂, trans r₂ r₁)

attribute perm.trans [trans]

theorem eqv (A : Type) : equivalence (@perm A) :=
mk_equivalence (@perm A) (@perm.refl A) (@perm.symm A) (@perm.trans A)

protected definition is_setoid [instance] (A : Type) : setoid (list A) :=
setoid.mk (@perm A) (perm.eqv A)

theorem mem_perm {a : A} {l₁ l₂ : list A} : l₁ ~ l₂ → a ∈ l₁ → a ∈ l₂ :=
assume p, perm.induction_on p
  (λ h, h)
  (λ x l₁ l₂ p₁ r₁ i, or.elim (eq_or_mem_of_mem_cons i)
    (suppose a = x,  by rewrite this; apply !mem_cons)
    (suppose a ∈ l₁, or.inr (r₁ this)))
  (λ x y l ainyxl, or.elim (eq_or_mem_of_mem_cons ainyxl)
    (suppose a = y, by rewrite this; exact (or.inr !mem_cons))
    (suppose a ∈ x::l, or.elim (eq_or_mem_of_mem_cons this)
      (suppose a = x, or.inl this)
      (suppose a ∈ l, or.inr (or.inr this))))
  (λ l₁ l₂ l₃ p₁ p₂ r₁ r₂ ainl₁, r₂ (r₁ ainl₁))

theorem not_mem_perm {a : A} {l₁ l₂ : list A} : l₁ ~ l₂ → a ∉ l₁ → a ∉ l₂ :=
assume p nainl₁ ainl₂, absurd (mem_perm (perm.symm p) ainl₂) nainl₁

theorem perm_app_left {l₁ l₂ : list A} (t₁ : list A) : l₁ ~ l₂ → (l₁++t₁) ~ (l₂++t₁) :=
assume p, perm.induction_on p
  !perm.refl
  (λ x l₁ l₂ p₁ r₁, skip x r₁)
  (λ x y l, !swap)
  (λ l₁ l₂ l₃ p₁ p₂ r₁ r₂, trans r₁ r₂)

theorem perm_app_right (l : list A) {t₁ t₂ : list A} : t₁ ~ t₂ → (l++t₁) ~ (l++t₂) :=
list.induction_on l
  (λ p, p)
  (λ x xs r p, skip x (r p))

theorem perm_app [congr] {l₁ l₂ t₁ t₂ : list A} : l₁ ~ l₂ → t₁ ~ t₂ → (l₁++t₁) ~ (l₂++t₂) :=
assume p₁ p₂, trans (perm_app_left t₁ p₁) (perm_app_right l₂ p₂)

theorem perm_app_cons (a : A) {h₁ h₂ t₁ t₂ : list A} : h₁ ~ h₂ → t₁ ~ t₂ → (h₁ ++ (a::t₁)) ~ (h₂ ++ (a::t₂)) :=
assume p₁ p₂, perm_app p₁ (skip a p₂)

theorem perm_cons_app (a : A) : ∀ (l : list A), (a::l) ~ (l ++ [a])
| []      := !perm.refl
| (x::xs) := calc
  a::x::xs ~ x::a::xs     : swap x a xs
       ... ~ x::(xs++[a]) : skip x (perm_cons_app xs)

theorem perm_cons_app_simp [simp] (a : A) : ∀ (l : list A), (l ++ [a]) ~ (a::l) :=
take l, perm.symm !perm_cons_app

theorem perm_app_comm [simp] {l₁ l₂ : list A} : (l₁++l₂) ~ (l₂++l₁) :=
list.induction_on l₁
  (by rewrite [append_nil_right, append_nil_left])
  (λ a t r, calc
    a::(t++l₂) ~ a::(l₂++t)   : skip a r
          ...  ~ l₂++t++[a]   : perm_cons_app
          ...  = l₂++(t++[a]) : append.assoc
          ...  ~ l₂++(a::t)   : perm_app_right l₂ (perm.symm (perm_cons_app a t)))

theorem length_eq_length_of_perm {l₁ l₂ : list A} : l₁ ~ l₂ → length l₁ = length l₂ :=
assume p, perm.induction_on p
  rfl
  (λ x l₁ l₂ p r, by rewrite [*length_cons, r])
  (λ x y l, by rewrite *length_cons)
  (λ l₁ l₂ l₃ p₁ p₂ r₁ r₂, eq.trans r₁ r₂)

theorem eq_singleton_of_perm_inv (a : A) {l : list A} : [a] ~ l → l = [a] :=
have gen : ∀ l₂, perm l₂ l → l₂ = [a] → l = [a], from
  take l₂, assume p, perm.induction_on p
    (λ e, e)
    (λ x l₁ l₂ p r e,
      begin
        injection e with e₁ e₂,
        rewrite [e₁, e₂ at p],
        have h₁ : l₂ = [], from eq_nil_of_perm_nil p,
        substvars
      end)
    (λ x y l e, by injection e; contradiction)
    (λ l₁ l₂ l₃ p₁ p₂ r₁ r₂ e, r₂ (r₁ e)),
assume p, gen [a] p rfl

theorem eq_singleton_of_perm (a b : A) : [a] ~ [b] → a = b :=
assume p,
begin
  injection eq_singleton_of_perm_inv a p with e₁,
  rewrite e₁
end

theorem perm_rev : ∀ (l : list A), l ~ (reverse l)
| []      := nil
| (x::xs) := calc
  x::xs ~ xs++[x]           : perm_cons_app x xs
    ... ~ reverse xs ++ [x] : perm_app_left [x] (perm_rev xs)
    ... = reverse (x::xs)   : by rewrite [reverse_cons, concat_eq_append]

theorem perm_rev_simp [simp] : ∀ (l : list A), (reverse l) ~ l :=
take l, perm.symm (perm_rev l)

theorem perm_middle (a : A) (l₁ l₂ : list A) : (a::l₁)++l₂ ~ l₁++(a::l₂) :=
calc
  (a::l₁) ++ l₂ = a::(l₁++l₂)   : rfl
           ...  ~ l₁++l₂++[a]   : perm_cons_app
           ...  = l₁++(l₂++[a]) : append.assoc
           ...  ~ l₁++(a::l₂)   : perm_app_right l₁ (perm.symm (perm_cons_app a l₂))

theorem perm_middle_simp [simp] (a : A) (l₁ l₂ : list A) : l₁++(a::l₂) ~ (a::l₁)++l₂ :=
perm.symm !perm_middle

theorem perm_cons_app_cons {l l₁ l₂ : list A} (a : A) : l ~ l₁++l₂ → a::l ~ l₁++(a::l₂) :=
assume p, calc
  a::l ~ l++[a]        : perm_cons_app
   ... ~ l₁++l₂++[a]   : perm_app_left [a] p
   ... = l₁++(l₂++[a]) : append.assoc
   ... ~ l₁++(a::l₂)   : perm_app_right l₁ (perm.symm (perm_cons_app a l₂))

open decidable
theorem perm_erase [decidable_eq A] {a : A} : ∀ {l : list A}, a ∈ l → l ~ a::(erase a l)
| []     h := absurd h !not_mem_nil
| (x::t) h :=
  by_cases
    (assume aeqx  : a = x, by rewrite [aeqx, erase_cons_head])
    (assume naeqx : a ≠ x,
      have aint : a ∈ t,             from mem_of_ne_of_mem naeqx h,
      have aux : t ~ a :: erase a t, from perm_erase aint,
      calc x::t ~ x::a::(erase a t)   : skip x aux
            ... ~ a::x::(erase a t)   : swap
            ... = a::(erase a (x::t)) : by rewrite [!erase_cons_tail naeqx])

theorem erase_perm_erase_of_perm [congr] [decidable_eq A] (a : A) {l₁ l₂ : list A} : l₁ ~ l₂ → erase a l₁ ~ erase a l₂ :=
assume p, perm.induction_on p
  nil
  (λ x t₁ t₂ p r,
    by_cases
      (assume aeqx  : a = x, by rewrite [aeqx, *erase_cons_head]; exact p)
      (assume naeqx : a ≠ x, by rewrite [*erase_cons_tail _ naeqx]; exact (skip x r)))
  (λ x y l,
    by_cases
      (assume aeqx : a = x,
        by_cases
          (assume aeqy  : a = y, by rewrite [-aeqx, -aeqy])
          (assume naeqy : a ≠ y, by rewrite [-aeqx, erase_cons_tail _ naeqy, *erase_cons_head]))
      (assume naeqx : a ≠ x,
        by_cases
          (assume aeqy  : a = y, by rewrite [-aeqy, erase_cons_tail _ naeqx, *erase_cons_head])
          (assume naeqy : a ≠ y, by rewrite[erase_cons_tail _ naeqx, *erase_cons_tail _ naeqy, erase_cons_tail _ naeqx];
                                    exact !swap)))
  (λ l₁ l₂ l₃ p₁ p₂ r₁ r₂, trans r₁ r₂)

theorem perm_induction_on {P : list A → list A → Prop} {l₁ l₂ : list A} (p : l₁ ~ l₂)
   (h₁ : P [] [])
   (h₂ : ∀ x l₁ l₂, l₁ ~ l₂ → P l₁ l₂ → P (x::l₁) (x::l₂))
   (h₃ : ∀ x y l₁ l₂, l₁ ~ l₂ → P l₁ l₂ → P (y::x::l₁) (x::y::l₂))
   (h₄ : ∀ l₁ l₂ l₃, l₁ ~ l₂ → l₂ ~ l₃ → P l₁ l₂ → P l₂ l₃ → P l₁ l₃)
   : P l₁ l₂ :=
have P_refl : ∀ l, P l l
  | []      := h₁
  | (x::xs) := h₂ x xs xs !perm.refl (P_refl xs),
perm.induction_on p h₁ h₂ (λ x y l, h₃ x y l l !perm.refl !P_refl) h₄

theorem xswap {l₁ l₂ : list A} (x y : A) : l₁ ~ l₂ → x::y::l₁ ~ y::x::l₂ :=
assume p, calc
  x::y::l₁  ~  y::x::l₁  : swap
        ... ~  y::x::l₂  : skip y (skip x p)

theorem perm_map [congr] (f : A → B) {l₁ l₂ : list A} : l₁ ~ l₂ → map f l₁ ~ map f l₂ :=
assume p, perm_induction_on p
  nil
  (λ x l₁ l₂ p r, skip (f x) r)
  (λ x y l₁ l₂ p r, xswap (f y) (f x) r)
  (λ l₁ l₂ l₃ p₁ p₂ r₁ r₂, trans r₁ r₂)

lemma perm_of_qeq {a : A} {l₁ l₂ : list A} : l₁≈a|l₂ → l₁~a::l₂ :=
assume q, qeq.induction_on q
  (λ h, !perm.refl)
  (λ b t₁ t₂ q₁ r₁, calc
     b::t₂ ~ b::a::t₁ : skip b r₁
       ... ~ a::b::t₁ : swap)

/- permutation is decidable if A has decidable equality -/
section dec
open decidable
variable [Ha : decidable_eq A]
include Ha

definition decidable_perm_aux : ∀ (n : nat) (l₁ l₂ : list A), length l₁ = n → length l₂ = n → decidable (l₁ ~ l₂)
| 0     l₁      l₂ H₁ H₂ :=
  have l₁n : l₁ = [], from eq_nil_of_length_eq_zero H₁,
  have l₂n : l₂ = [], from eq_nil_of_length_eq_zero H₂,
  by rewrite [l₁n, l₂n]; exact (inl perm.nil)
| (n+1) (x::t₁) l₂ H₁ H₂ :=
  by_cases
    (assume xinl₂ : x ∈ l₂,
      let t₂ : list A := erase x l₂ in
      have len_t₁ : length t₁ = n,         begin injection H₁ with e, exact e end,
      have length t₂ = pred (length l₂), from length_erase_of_mem xinl₂,
      have length t₂ = n,                by rewrite [this, H₂],
      match decidable_perm_aux n t₁ t₂ len_t₁ this with
      | inl p  := inl (calc
          x::t₁ ~ x::(erase x l₂) : skip x p
           ...  ~ l₂              : perm_erase xinl₂)
      | inr np := inr (λ p : x::t₁ ~ l₂,
        have erase x (x::t₁) ~ erase x l₂, from erase_perm_erase_of_perm x p,
        have t₁ ~ erase x l₂, by rewrite [erase_cons_head at this]; exact this,
        absurd this np)
      end)
    (assume nxinl₂ : x ∉ l₂,
      inr (λ p : x::t₁ ~ l₂, absurd (mem_perm p !mem_cons) nxinl₂))

definition decidable_perm [instance] : ∀ (l₁ l₂ : list A), decidable (l₁ ~ l₂) :=
λ l₁ l₂,
by_cases
  (assume eql : length l₁ = length l₂,
    decidable_perm_aux (length l₂) l₁ l₂ eql rfl)
  (assume neql : length l₁ ≠ length l₂,
    inr (λ p : l₁ ~ l₂, absurd (length_eq_length_of_perm p) neql))
end dec

-- Auxiliary theorem for performing cases-analysis on l₂.
-- We use it to prove perm_inv_core.
private theorem discr {P : Prop} {a b : A} {l₁ l₂ l₃ : list A} :
    a::l₁ = l₂++(b::l₃)                    →
    (l₂ = [] → a = b → l₁ = l₃ → P)        →
    (∀ t, l₂ = a::t → l₁ = t++(b::l₃) → P) → P :=
match l₂ with
| []   := λ e h₁ h₂, by injection e with e₁ e₂; exact h₁ rfl e₁ e₂
| h::t := λ e h₁ h₂,
  begin
    injection e with e₁ e₂,
    rewrite e₁ at h₂,
    exact h₂ t rfl e₂
  end
end

-- Auxiliary theorem for performing cases-analysis on l₂.
-- We use it to prove perm_inv_core.
private theorem discr₂ {P : Prop} {a b c : A} {l₁ l₂ l₃ : list A} :
    a::b::l₁ = l₂++(c::l₃)                     →
    (l₂ = [] → l₃ = b::l₁ → a = c → P)         →
    (l₂ = [a] → b = c → l₁ = l₃ → P)           →
    (∀ t, l₂ = a::b::t → l₁ = t++(c::l₃) → P)  → P :=
match l₂ with
| []   := λ e H₁ H₂ H₃,
  begin
    injection e with a_eq_c b_l₁_eq_l₃,
    exact H₁ rfl (eq.symm b_l₁_eq_l₃) a_eq_c
  end
| [h₁] := λ e H₁ H₂ H₃,
  begin
    rewrite [append_cons at e, append_nil_left at e],
    injection e  with a_eq_h₁ b_eq_c l₁_eq_l₃,
    rewrite [a_eq_h₁ at H₂, b_eq_c at H₂, l₁_eq_l₃ at H₂],
    exact H₂ rfl rfl rfl
  end
| h₁::h₂::t₂ := λ e H₁ H₂ H₃,
  begin
    injection e with a_eq_h₁ b_eq_h₂ l₁_eq,
    rewrite [a_eq_h₁ at H₃, b_eq_h₂ at H₃],
    exact H₃ t₂ rfl l₁_eq
  end
end

/- permutation inversion -/
theorem perm_inv_core {l₁ l₂ : list A} (p' : l₁ ~ l₂) : ∀ {a s₁ s₂}, l₁≈a|s₁ → l₂≈a|s₂ → s₁ ~ s₂ :=
perm_induction_on p'
  (λ a s₁ s₂ e₁ e₂,
    have innil : a ∈ [], from mem_head_of_qeq e₁,
    absurd innil !not_mem_nil)
  (λ x t₁ t₂ p (r : ∀{a s₁ s₂}, t₁≈a|s₁ → t₂≈a|s₂ → s₁ ~ s₂) a s₁ s₂ e₁ e₂,
    obtain (s₁₁ s₁₂ : list A) (C₁₁ : s₁ = s₁₁ ++ s₁₂) (C₁₂ : x::t₁ = s₁₁++(a::s₁₂)), from qeq_split e₁,
    obtain (s₂₁ s₂₂ : list A) (C₂₁ : s₂ = s₂₁ ++ s₂₂) (C₂₂ : x::t₂ = s₂₁++(a::s₂₂)), from qeq_split e₂,
    discr C₁₂
      (λ (s₁₁_eq : s₁₁ = []) (x_eq_a : x = a) (t₁_eq : t₁ = s₁₂),
        have s₁_p : s₁ ~ t₂, from calc
            s₁  = s₁₁ ++ s₁₂ : C₁₁
            ... = t₁         : by rewrite [-t₁_eq, s₁₁_eq, append_nil_left]
            ... ~ t₂         : p,
        discr C₂₂
          (λ (s₂₁_eq : s₂₁ = []) (x_eq_a : x = a) (t₂_eq: t₂ = s₂₂),
            proof calc
              s₁  ~ t₂         : s₁_p
              ... = s₂₁ ++ s₂₂ : by rewrite [-t₂_eq, s₂₁_eq, append_nil_left]
              ... = s₂         : by rewrite C₂₁
            qed)
          (λ (ts₂₁ : list A) (s₂₁_eq : s₂₁ = x::ts₂₁) (t₂_eq : t₂ = ts₂₁++(a::s₂₂)),
            proof calc
              s₁  ~ t₂             : s₁_p
              ... = ts₂₁++(a::s₂₂) : t₂_eq
              ... ~ (a::ts₂₁)++s₂₂ : !perm_middle
              ... = s₂₁ ++ s₂₂     : by rewrite [-x_eq_a, -s₂₁_eq]
              ... = s₂             : by rewrite C₂₁
            qed))
      (λ (ts₁₁ : list A) (s₁₁_eq : s₁₁ = x::ts₁₁) (t₁_eq : t₁ = ts₁₁++(a::s₁₂)),
        have t₁_qeq : t₁ ≈ a|(ts₁₁++s₁₂), by rewrite t₁_eq; exact !qeq_app,
        have s₁_eq : s₁ = x::(ts₁₁++s₁₂), from calc
          s₁  = s₁₁ ++ s₁₂       : C₁₁
          ... = x::(ts₁₁++ s₁₂)  : by rewrite s₁₁_eq,
        discr C₂₂
          (λ (s₂₁_eq : s₂₁ = []) (x_eq_a : x = a) (t₂_eq: t₂ = s₂₂),
            proof calc
              s₁  = a::(ts₁₁++s₁₂) : by rewrite [s₁_eq, x_eq_a]
              ... ~ ts₁₁++(a::s₁₂) : !perm_middle
              ... = t₁             : t₁_eq
              ... ~ t₂             : p
              ... = s₂             : by rewrite [t₂_eq, C₂₁, s₂₁_eq, append_nil_left]
            qed)
          (λ (ts₂₁ : list A) (s₂₁_eq : s₂₁ = x::ts₂₁) (t₂_eq : t₂ = ts₂₁++(a::s₂₂)),
            have t₂_qeq : t₂ ≈ a|(ts₂₁++s₂₂), by rewrite t₂_eq; exact !qeq_app,
            proof calc
              s₁  = x::(ts₁₁++s₁₂) : s₁_eq
              ... ~ x::(ts₂₁++s₂₂) : skip x (r t₁_qeq t₂_qeq)
              ... = s₂             : by rewrite [-append_cons, -s₂₁_eq, C₂₁]
            qed)))
  (λ x y t₁ t₂ p (r : ∀{a s₁ s₂}, t₁≈a|s₁ → t₂≈a|s₂ → s₁ ~ s₂) a s₁ s₂ e₁ e₂,
    obtain (s₁₁ s₁₂ : list A) (C₁₁ : s₁ = s₁₁ ++ s₁₂) (C₁₂ : y::x::t₁ = s₁₁++(a::s₁₂)), from qeq_split e₁,
    obtain (s₂₁ s₂₂ : list A) (C₂₁ : s₂ = s₂₁ ++ s₂₂) (C₂₂ : x::y::t₂ = s₂₁++(a::s₂₂)), from qeq_split e₂,
    discr₂ C₁₂
      (λ (s₁₁_eq : s₁₁ = [])  (s₁₂_eq : s₁₂ = x::t₁) (y_eq_a : y = a),
        have s₁_p : s₁ ~ x::t₂, from calc
            s₁  = s₁₁ ++ s₁₂ : C₁₁
            ... = x::t₁      : by rewrite [s₁₂_eq, s₁₁_eq, append_nil_left]
            ... ~ x::t₂      : skip x p,
        discr₂ C₂₂
          (λ (s₂₁_eq : s₂₁ = [])  (s₂₂_eq : s₂₂ = y::t₂) (x_eq_a : x = a),
            proof calc
              s₁  ~ x::t₂      : s₁_p
              ... = s₂₁ ++ s₂₂ : by rewrite [x_eq_a, -y_eq_a, -s₂₂_eq, s₂₁_eq, append_nil_left]
              ... = s₂         : by rewrite C₂₁
            qed)
          (λ (s₂₁_eq : s₂₁ = [x]) (y_eq_a : y = a) (t₂_eq : t₂ = s₂₂),
            proof calc
              s₁  ~ x::t₂      : s₁_p
              ... = s₂₁ ++ s₂₂ : by rewrite [t₂_eq, s₂₁_eq, append_cons]
              ... = s₂         : by rewrite C₂₁
            qed)
          (λ (ts₂₁ : list A) (s₂₁_eq : s₂₁ = x::y::ts₂₁) (t₂_eq : t₂ = ts₂₁++(a::s₂₂)),
            proof calc
              s₁  ~ x::t₂               : s₁_p
              ... = x::(ts₂₁++(y::s₂₂)) : by rewrite [t₂_eq, -y_eq_a]
              ... ~ x::y::(ts₂₁++s₂₂)   : skip x !perm_middle
              ... = s₂₁ ++ s₂₂          : by rewrite [s₂₁_eq, append_cons]
              ... = s₂                  : by rewrite C₂₁
            qed))
      (λ (s₁₁_eq : s₁₁ = [y]) (x_eq_a : x = a) (t₁_eq : t₁ = s₁₂),
        have s₁_p : s₁ ~ y::t₂, from calc
             s₁  = y::t₁ : by rewrite [C₁₁, s₁₁_eq, t₁_eq]
             ... ~ y::t₂ : skip y p,
        discr₂ C₂₂
          (λ (s₂₁_eq : s₂₁ = [])  (s₂₂_eq : s₂₂ = y::t₂) (x_eq_a : x = a),
            proof calc
              s₁  ~ y::t₂      : s₁_p
              ... = s₂₁ ++ s₂₂ : by rewrite [s₂₁_eq, s₂₂_eq]
              ... = s₂         : by rewrite C₂₁
            qed)
          (λ (s₂₁_eq : s₂₁ = [x]) (y_eq_a : y = a) (t₂_eq : t₂ = s₂₂),
            proof calc
              s₁  ~ y::t₂      : s₁_p
              ... = s₂₁ ++ s₂₂ : by rewrite [s₂₁_eq, t₂_eq, y_eq_a, -x_eq_a]
              ... = s₂         : by rewrite C₂₁
            qed)
          (λ (ts₂₁ : list A) (s₂₁_eq : s₂₁ = x::y::ts₂₁) (t₂_eq : t₂ = ts₂₁++(a::s₂₂)),
            proof calc
              s₁  ~ y::t₂               : s₁_p
              ... = y::(ts₂₁++(x::s₂₂)) : by rewrite [t₂_eq, -x_eq_a]
              ... ~ y::x::(ts₂₁++s₂₂)   : skip y !perm_middle
              ... ~ x::y::(ts₂₁++s₂₂)   : swap
              ... = s₂₁ ++ s₂₂          : by rewrite [s₂₁_eq]
              ... = s₂                  : by rewrite C₂₁
            qed))
      (λ (ts₁₁ : list A) (s₁₁_eq : s₁₁ = y::x::ts₁₁) (t₁_eq : t₁ = ts₁₁++(a::s₁₂)),
        have s₁_eq  : s₁ = y::x::(ts₁₁++s₁₂), by rewrite [C₁₁, s₁₁_eq],
        discr₂ C₂₂
          (λ (s₂₁_eq : s₂₁ = [])  (s₂₂_eq : s₂₂ = y::t₂) (x_eq_a : x = a),
            proof calc
              s₁  = y::a::(ts₁₁++s₁₂)   : by rewrite [s₁_eq, x_eq_a]
              ... ~ y::(ts₁₁++(a::s₁₂)) : skip y !perm_middle
              ... = y::t₁               : by rewrite t₁_eq
              ... ~ y::t₂               : skip y p
              ... = s₂₁ ++ s₂₂          : by rewrite [s₂₁_eq, s₂₂_eq]
              ... = s₂                  : by rewrite C₂₁
            qed)
          (λ (s₂₁_eq : s₂₁ = [x]) (y_eq_a : y = a) (t₂_eq : t₂ = s₂₂),
            proof calc
              s₁  = y::x::(ts₁₁++s₁₂)   : by rewrite s₁_eq
              ... ~ x::y::(ts₁₁++s₁₂)   : swap
              ... = x::a::(ts₁₁++s₁₂)   : by rewrite y_eq_a
              ... ~ x::(ts₁₁++(a::s₁₂)) : skip x !perm_middle
              ... = x::t₁               : by rewrite t₁_eq
              ... ~ x::t₂               : skip x p
              ... = s₂₁ ++ s₂₂          : by rewrite [t₂_eq, s₂₁_eq]
              ... = s₂                  : by rewrite C₂₁
            qed)
          (λ (ts₂₁ : list A) (s₂₁_eq : s₂₁ = x::y::ts₂₁) (t₂_eq : t₂ = ts₂₁++(a::s₂₂)),
            have t₁_qeq : t₁ ≈ a|(ts₁₁++s₁₂),    by rewrite t₁_eq; exact !qeq_app,
            have t₂_qeq : t₂ ≈ a|(ts₂₁++s₂₂),    by rewrite t₂_eq; exact !qeq_app,
            have p_aux  : ts₁₁++s₁₂ ~ ts₂₁++s₂₂, from r t₁_qeq t₂_qeq,
            proof calc
              s₁  = y::x::(ts₁₁++s₁₂)   : by rewrite s₁_eq
              ... ~ y::x::(ts₂₁++s₂₂)   : skip y (skip x p_aux)
              ... ~ x::y::(ts₂₁++s₂₂)   : swap
              ... = s₂₁ ++ s₂₂          : by rewrite s₂₁_eq
              ... = s₂                  : by rewrite C₂₁
            qed)))
  (λ t₁ t₂ t₃ p₁ p₂
     (r₁ : ∀{a s₁ s₂}, t₁ ≈ a|s₁ → t₂≈a|s₂ → s₁ ~ s₂)
     (r₂ : ∀{a s₁ s₂}, t₂ ≈ a|s₁ → t₃≈a|s₂ → s₁ ~ s₂)
     a s₁ s₂ e₁ e₂,
    have a ∈ t₁, from mem_head_of_qeq e₁,
    have a ∈ t₂, from mem_perm p₁ this,
    obtain (t₂' : list A) (e₂' : t₂≈a|t₂'), from qeq_of_mem this,
    calc s₁  ~ t₂' : r₁ e₁ e₂'
        ...  ~ s₂  : r₂ e₂' e₂)

theorem perm_cons_inv {a : A} {l₁ l₂ : list A} : a::l₁ ~ a::l₂ → l₁ ~ l₂ :=
assume p, perm_inv_core p (qeq.qhead a l₁) (qeq.qhead a l₂)

theorem perm_app_inv {a : A} {l₁ l₂ l₃ l₄ : list A} : l₁++(a::l₂) ~ l₃++(a::l₄) → l₁++l₂ ~ l₃++l₄ :=
assume p : l₁++(a::l₂) ~ l₃++(a::l₄),
  have p' : a::(l₁++l₂) ~ a::(l₃++l₄), from calc
    a::(l₁++l₂) ~ l₁++(a::l₂) : perm_middle
          ...   ~ l₃++(a::l₄) : p
          ...   ~ a::(l₃++l₄) : perm.symm (!perm_middle),
  perm_cons_inv p'

section foldl
  variables {f : B → A → B} {l₁ l₂ : list A}
  variable rcomm : right_commutative f
  include  rcomm

  theorem foldl_eq_of_perm : l₁ ~ l₂ → ∀ b, foldl f b l₁ = foldl f b l₂ :=
  assume p, perm_induction_on p
    (λ b, by rewrite *foldl_nil)
    (λ x t₁ t₂ p r b, calc
       foldl f b (x::t₁) = foldl f (f b x) t₁ : foldl_cons
               ...       = foldl f (f b x) t₂ : r (f b x)
               ...       = foldl f b (x::t₂)  : foldl_cons)
    (λ x y t₁ t₂ p r b, calc
       foldl f b (y :: x :: t₁) = foldl f (f (f b y) x) t₁ : by rewrite foldl_cons
                     ...        = foldl f (f (f b x) y) t₁ : by rewrite rcomm
                     ...        = foldl f (f (f b x) y) t₂ : r (f (f b x) y)
                     ...        = foldl f b (x :: y :: t₂) : by rewrite foldl_cons)
    (λ t₁ t₂ t₃ p₁ p₂ r₁ r₂ b, eq.trans (r₁ b) (r₂ b))
end foldl

section foldr
  variables {f : A → B → B} {l₁ l₂ : list A}
  variable lcomm : left_commutative f
  include  lcomm

  theorem foldr_eq_of_perm : l₁ ~ l₂ → ∀ b, foldr f b l₁ = foldr f b l₂ :=
  assume p, perm_induction_on p
    (λ b, by rewrite *foldl_nil)
    (λ x t₁ t₂ p r b, calc
       foldr f b (x::t₁) = f x (foldr f b t₁) : foldr_cons
               ...       = f x (foldr f b t₂) : by rewrite [r b]
               ...       = foldr f b (x::t₂)  : foldr_cons)
    (λ x y t₁ t₂ p r b, calc
       foldr f b (y :: x :: t₁) = f y (f x (foldr f b t₁)) : by rewrite foldr_cons
                  ...           = f x (f y (foldr f b t₁)) : by rewrite lcomm
                  ...           = f x (f y (foldr f b t₂)) : by rewrite [r b]
                  ...           = foldr f b (x :: y :: t₂) : by rewrite foldr_cons)
    (λ t₁ t₂ t₃ p₁ p₂ r₁ r₂ a, eq.trans (r₁ a) (r₂ a))
end foldr

theorem perm_erase_dup_of_perm [congr] [H : decidable_eq A] {l₁ l₂ : list A} : l₁ ~ l₂ → erase_dup l₁ ~ erase_dup l₂ :=
assume p, perm_induction_on p
  nil
  (λ x t₁ t₂ p r, by_cases
    (λ xint₁  : x ∈ t₁,
      have xint₂ : x ∈ t₂, from mem_of_mem_erase_dup (mem_perm r (mem_erase_dup xint₁)),
      by rewrite [erase_dup_cons_of_mem xint₁, erase_dup_cons_of_mem xint₂]; exact r)
    (λ nxint₁ : x ∉ t₁,
      have nxint₂ : x ∉ t₂, from
         assume xint₂ : x ∈ t₂, absurd (mem_of_mem_erase_dup (mem_perm (perm.symm r) (mem_erase_dup xint₂))) nxint₁,
      by rewrite [erase_dup_cons_of_not_mem nxint₂, erase_dup_cons_of_not_mem nxint₁]; exact (skip x r)))
  (λ y x t₁ t₂ p r, by_cases
    (λ xinyt₁  : x ∈ y::t₁, by_cases
      (λ yint₁  : y ∈ t₁,
        have yint₂  : y ∈ t₂,    from mem_of_mem_erase_dup (mem_perm r (mem_erase_dup yint₁)),
        have yinxt₂ : y ∈ x::t₂, from or.inr (yint₂),
        or.elim (eq_or_mem_of_mem_cons xinyt₁)
          (λ xeqy  : x = y,
            have xint₂ : x ∈ t₂, by rewrite [-xeqy at yint₂]; exact yint₂,
            begin
              rewrite [erase_dup_cons_of_mem xinyt₁, erase_dup_cons_of_mem yinxt₂,
                       erase_dup_cons_of_mem yint₁, erase_dup_cons_of_mem xint₂],
              exact r
            end)
          (λ xint₁ : x ∈ t₁,
            have xint₂ : x ∈ t₂, from mem_of_mem_erase_dup (mem_perm r (mem_erase_dup xint₁)),
            begin
              rewrite [erase_dup_cons_of_mem xinyt₁, erase_dup_cons_of_mem yinxt₂,
                       erase_dup_cons_of_mem yint₁, erase_dup_cons_of_mem xint₂],
              exact r
            end))
      (λ nyint₁ : y ∉ t₁,
        have nyint₂ : y ∉ t₂, from
          assume yint₂ : y ∈ t₂, absurd (mem_of_mem_erase_dup (mem_perm (perm.symm r) (mem_erase_dup yint₂))) nyint₁,
        by_cases
          (λ xeqy  : x = y,
            have nxint₂ : x ∉ t₂, by rewrite [-xeqy at nyint₂]; exact nyint₂,
            have yinxt₂ : y ∈ x::t₂, by rewrite [xeqy]; exact !mem_cons,
            begin
              rewrite [erase_dup_cons_of_mem xinyt₁, erase_dup_cons_of_mem yinxt₂,
                       erase_dup_cons_of_not_mem nyint₁, erase_dup_cons_of_not_mem nxint₂, xeqy],
              exact skip y r
            end)
          (λ xney : x ≠ y,
            have x ∈ t₁, from or_resolve_right xinyt₁ xney,
            have x ∈ t₂, from mem_of_mem_erase_dup (mem_perm r (mem_erase_dup this)),
            have y ∉ x::t₂, from
              suppose y ∈ x::t₂, or.elim (eq_or_mem_of_mem_cons this)
                (λ h, absurd h (ne.symm xney))
                (λ h, absurd h nyint₂),
            begin
              rewrite [erase_dup_cons_of_mem xinyt₁, erase_dup_cons_of_not_mem `y ∉ x::t₂`,
                       erase_dup_cons_of_not_mem nyint₁, erase_dup_cons_of_mem `x ∈ t₂`],
              exact skip y r
            end)))
    (λ nxinyt₁ : x ∉ y::t₁,
      have xney    : x ≠ y,  from ne_of_not_mem_cons nxinyt₁,
      have nxint₁  : x ∉ t₁, from not_mem_of_not_mem_cons nxinyt₁,
      have nxint₂  : x ∉ t₂, from
        assume xint₂ : x ∈ t₂, absurd (mem_of_mem_erase_dup (mem_perm (perm.symm r) (mem_erase_dup xint₂))) nxint₁,
      by_cases
        (λ yint₁  : y ∈ t₁,
          have yinxt₂ : y ∈ x::t₂, from or.inr (mem_of_mem_erase_dup (mem_perm r (mem_erase_dup yint₁))),
          begin
            rewrite [erase_dup_cons_of_not_mem nxinyt₁, erase_dup_cons_of_mem yinxt₂,
                     erase_dup_cons_of_mem yint₁, erase_dup_cons_of_not_mem nxint₂],
            exact skip x r
          end)
        (λ nyint₁ : y ∉ t₁,
          have nyinxt₂ : y ∉ x::t₂, from
            assume yinxt₂ : y ∈ x::t₂, or.elim (eq_or_mem_of_mem_cons yinxt₂)
              (λ h, absurd h (ne.symm xney))
              (λ h, absurd (mem_of_mem_erase_dup (mem_perm (perm.symm r) (mem_erase_dup h))) nyint₁),
          begin
            rewrite [erase_dup_cons_of_not_mem nxinyt₁, erase_dup_cons_of_not_mem nyinxt₂,
                     erase_dup_cons_of_not_mem nyint₁, erase_dup_cons_of_not_mem nxint₂],
            exact xswap x y r
          end)))
  (λ t₁ t₂ t₃ p₁ p₂ r₁ r₂, trans r₁ r₂)

section perm_union
variable [H : decidable_eq A]
include H

theorem perm_union_left {l₁ l₂ : list A} (t₁ : list A) : l₁ ~ l₂ → (union l₁ t₁) ~ (union l₂ t₁) :=
assume p, perm.induction_on p
  (by rewrite [nil_union])
  (λ x l₁ l₂ p₁ r₁, by_cases
     (λ xint₁  : x ∈ t₁, by rewrite [*union_cons_of_mem _ xint₁]; exact r₁)
     (λ nxint₁ : x ∉ t₁, by rewrite [*union_cons_of_not_mem _ nxint₁]; exact (skip _ r₁)))
  (λ x y l, by_cases
    (λ yint  : y ∈ t₁, by_cases
      (λ xint  : x ∈ t₁,
        by rewrite [*union_cons_of_mem _ xint, *union_cons_of_mem _ yint, *union_cons_of_mem _ xint])
      (λ nxint : x ∉ t₁,
        by rewrite [*union_cons_of_mem _ yint, *union_cons_of_not_mem _ nxint, union_cons_of_mem _ yint]))
    (λ nyint : y ∉ t₁, by_cases
      (λ xint  : x ∈ t₁,
        by rewrite [*union_cons_of_mem _ xint, *union_cons_of_not_mem _ nyint, union_cons_of_mem _ xint])
      (λ nxint : x ∉ t₁,
        by rewrite [*union_cons_of_not_mem _ nxint, *union_cons_of_not_mem _ nyint, union_cons_of_not_mem _ nxint]; exact !swap)))
  (λ l₁ l₂ l₃ p₁ p₂ r₁ r₂, trans r₁ r₂)

theorem perm_union_right (l : list A) {t₁ t₂ : list A} : t₁ ~ t₂ → (union l t₁) ~ (union l t₂) :=
list.induction_on l
  (λ p, by rewrite [*union_nil]; exact p)
  (λ x xs r p, by_cases
    (λ xint₁  : x ∈ t₁,
      have xint₂ : x ∈ t₂, from mem_perm p xint₁,
      by rewrite [union_cons_of_mem _ xint₁, union_cons_of_mem _ xint₂]; exact (r p))
    (λ nxint₁ : x ∉ t₁,
      have nxint₂ : x ∉ t₂, from not_mem_perm p nxint₁,
      by rewrite [union_cons_of_not_mem _ nxint₁, union_cons_of_not_mem _ nxint₂]; exact (skip _ (r p))))

theorem perm_union [congr] {l₁ l₂ t₁ t₂ : list A} : l₁ ~ l₂ → t₁ ~ t₂ → (union l₁ t₁) ~ (union l₂ t₂) :=
assume p₁ p₂, trans (perm_union_left t₁ p₁) (perm_union_right l₂ p₂)
end perm_union

section perm_insert
variable [H : decidable_eq A]
include H

theorem perm_insert [congr] (a : A) {l₁ l₂ : list A} : l₁ ~ l₂ → (insert a l₁) ~ (insert a l₂) :=
assume p, by_cases
 (λ ainl₁  : a ∈ l₁,
   have ainl₂ : a ∈ l₂, from mem_perm p ainl₁,
   by rewrite [insert_eq_of_mem ainl₁, insert_eq_of_mem ainl₂]; exact p)
 (λ nainl₁ : a ∉ l₁,
   have nainl₂ : a ∉ l₂, from not_mem_perm p nainl₁,
   by rewrite [insert_eq_of_not_mem nainl₁, insert_eq_of_not_mem nainl₂]; exact (skip _ p))
end perm_insert

section perm_inter
variable [H : decidable_eq A]
include H

theorem perm_inter_left {l₁ l₂ : list A} (t₁ : list A) : l₁ ~ l₂ → (inter l₁ t₁) ~ (inter l₂ t₁) :=
assume p, perm.induction_on p
  !perm.refl
  (λ x l₁ l₂ p₁ r₁, by_cases
    (λ xint₁  : x ∈ t₁, by rewrite [*inter_cons_of_mem _ xint₁]; exact (skip x r₁))
    (λ nxint₁ : x ∉ t₁, by rewrite [*inter_cons_of_not_mem _ nxint₁]; exact r₁))
  (λ x y l, by_cases
    (λ yint  : y ∈ t₁, by_cases
      (λ xint  : x ∈ t₁,
        by rewrite [*inter_cons_of_mem _ xint, *inter_cons_of_mem _ yint, *inter_cons_of_mem _ xint];
           exact !swap)
      (λ nxint : x ∉ t₁,
        by rewrite [*inter_cons_of_mem _ yint, *inter_cons_of_not_mem _ nxint, inter_cons_of_mem _ yint]))
    (λ nyint : y ∉ t₁, by_cases
      (λ xint  : x ∈ t₁,
        by rewrite [*inter_cons_of_mem _ xint, *inter_cons_of_not_mem _ nyint, inter_cons_of_mem _ xint])
      (λ nxint : x ∉ t₁,
        by rewrite [*inter_cons_of_not_mem _ nxint, *inter_cons_of_not_mem _ nyint,
                     inter_cons_of_not_mem _ nxint])))
  (λ l₁ l₂ l₃ p₁ p₂ r₁ r₂, trans r₁ r₂)

theorem perm_inter_right (l : list A) {t₁ t₂ : list A} : t₁ ~ t₂ → (inter l t₁) ~ (inter l t₂) :=
list.induction_on l
  (λ p, by rewrite [*inter_nil])
  (λ x xs r p, by_cases
    (λ xint₁  : x ∈ t₁,
      have xint₂ : x ∈ t₂, from mem_perm p xint₁,
      by rewrite [inter_cons_of_mem _ xint₁, inter_cons_of_mem _ xint₂]; exact (skip _ (r p)))
    (λ nxint₁ : x ∉ t₁,
      have nxint₂ : x ∉ t₂, from not_mem_perm p nxint₁,
      by rewrite [inter_cons_of_not_mem _ nxint₁, inter_cons_of_not_mem _ nxint₂]; exact (r p)))

theorem perm_inter [congr] {l₁ l₂ t₁ t₂ : list A} : l₁ ~ l₂ → t₁ ~ t₂ → (inter l₁ t₁) ~ (inter l₂ t₂) :=
assume p₁ p₂, trans (perm_inter_left t₁ p₁) (perm_inter_right l₂ p₂)
end perm_inter

/- extensionality -/
section ext
open eq.ops

theorem perm_ext : ∀ {l₁ l₂ : list A}, nodup l₁ → nodup l₂ → (∀a, a ∈ l₁ ↔ a ∈ l₂) → l₁ ~ l₂
| []       []       d₁ d₂ e := !perm.nil
| []       (a₂::t₂) d₁ d₂ e := absurd (iff.mpr (e a₂) !mem_cons) (not_mem_nil a₂)
| (a₁::t₁) []       d₁ d₂ e := absurd (iff.mp (e a₁) !mem_cons) (not_mem_nil a₁)
| (a₁::t₁) (a₂::t₂) d₁ d₂ e :=
  have a₁ ∈ a₂::t₂, from iff.mp (e a₁) !mem_cons,
  have ∃ s₁ s₂, a₂::t₂ = s₁++(a₁::s₂), from mem_split this,
  obtain (s₁ s₂ : list A) (t₂_eq : a₂::t₂ = s₁++(a₁::s₂)), from this,
  have dt₂'     : nodup (a₁::(s₁++s₂)), from nodup_head (by rewrite [t₂_eq at d₂]; exact d₂),
  have eqv      : ∀a, a ∈ t₁ ↔ a ∈ s₁++s₂, from
    take a, iff.intro
      (suppose  a ∈ t₁,
         have a ∈ a₂::t₂,       from iff.mp (e a) (mem_cons_of_mem _ this),
         have a ∈ s₁++(a₁::s₂), by rewrite [t₂_eq at this]; exact this,
         or.elim (mem_or_mem_of_mem_append this)
           (suppose a ∈ s₁, mem_append_left s₂ this)
           (suppose a ∈ a₁::s₂, or.elim (eq_or_mem_of_mem_cons this)
             (suppose a = a₁,
               have a₁ ∉ t₁, from not_mem_of_nodup_cons d₁,
               by subst a; contradiction)
             (suppose a ∈ s₂, mem_append_right s₁ this)))
      (suppose a ∈ s₁ ++ s₂, or.elim (mem_or_mem_of_mem_append this)
        (suppose a ∈ s₁,
           have a ∈ a₂::t₂, from by rewrite [t₂_eq]; exact (mem_append_left _ this),
           have a ∈ a₁::t₁, from iff.mpr (e a) this,
           or.elim (eq_or_mem_of_mem_cons this)
             (suppose a = a₁,
                have a₁ ∉ s₁++s₂, from not_mem_of_nodup_cons dt₂',
                have a₁ ∉ s₁,     from not_mem_of_not_mem_append_left this,
                by subst a; contradiction)
             (suppose a ∈ t₁, this))
        (suppose a ∈ s₂,
           have a ∈ a₂::t₂, from by rewrite [t₂_eq]; exact (mem_append_right _ (mem_cons_of_mem _ this)),
           have a ∈ a₁::t₁, from iff.mpr (e a) this,
           or.elim (eq_or_mem_of_mem_cons this)
             (suppose a = a₁,
               have a₁ ∉ s₁++s₂, from not_mem_of_nodup_cons dt₂',
               have a₁ ∉ s₂, from not_mem_of_not_mem_append_right this,
               by subst a; contradiction)
             (suppose a ∈ t₁, this))),
  have ds₁s₂ : nodup (s₁++s₂), from nodup_of_nodup_cons dt₂',
  have nodup t₁, from nodup_of_nodup_cons d₁,
  calc a₁::t₁ ~ a₁::(s₁++s₂) : skip a₁ (perm_ext this ds₁s₂ eqv)
         ...  ~ s₁++(a₁::s₂) : !perm_middle
         ...  = a₂::t₂       : by rewrite t₂_eq
end ext

theorem nodup_of_perm_of_nodup {l₁ l₂ : list A} : l₁ ~ l₂ → nodup l₁ → nodup l₂ :=
assume h, perm.induction_on h
  (λ h, h)
  (λ a l₁ l₂ p ih nd,
    have nodup l₁, from nodup_of_nodup_cons nd,
    have nodup l₂, from ih this,
    have a ∉ l₁,   from not_mem_of_nodup_cons nd,
    have a ∉ l₂,   from suppose a ∈ l₂, absurd (mem_perm (perm.symm p) this) `a ∉ l₁`,
    nodup_cons `a ∉ l₂` `nodup l₂`)
  (λ x y l₁ nd,
    have nodup (x::l₁),    from nodup_of_nodup_cons nd,
    have nodup l₁,         from nodup_of_nodup_cons this,
    have x ∉ l₁,           from not_mem_of_nodup_cons `nodup (x::l₁)`,
    have y ∉ x::l₁,        from not_mem_of_nodup_cons nd,
    have x ≠ y,            from suppose x = y, begin subst x, exact absurd !mem_cons `y ∉ y::l₁` end,
    have y ∉ l₁,           from not_mem_of_not_mem_cons `y ∉ x::l₁`,
    have x ∉ y::l₁,        from not_mem_cons_of_ne_of_not_mem `x ≠ y` `x ∉ l₁`,
    have nodup (y::l₁),    from nodup_cons `y ∉ l₁` `nodup l₁`,
    show nodup (x::y::l₁), from nodup_cons `x ∉ y::l₁` `nodup (y::l₁)`)
  (λ l₁ l₂ l₃ p₁ p₂ ih₁ ih₂ nd, ih₂ (ih₁ nd))

/- product -/
section product
theorem perm_product_left {l₁ l₂ : list A} (t₁ : list B) : l₁ ~ l₂ → (product l₁ t₁) ~ (product l₂ t₁) :=
assume p : l₁ ~ l₂, perm.induction_on p
  !perm.refl
  (λ x l₁ l₂ p r, perm_app (perm.refl (map _ t₁)) r)
  (λ x y l,
    let m₁ := map (λ b, (x, b)) t₁ in
    let m₂ := map (λ b, (y, b)) t₁ in
    let c  := product l t₁ in
    calc m₂ ++ (m₁ ++ c) = (m₂ ++ m₁) ++ c  : by rewrite append.assoc
                     ... ~ (m₁ ++ m₂) ++ c  : perm_app !perm_app_comm !perm.refl
                     ... =  m₁ ++ (m₂ ++ c) : by rewrite append.assoc)
  (λ l₁ l₂ l₃ p₁ p₂ r₁ r₂, trans r₁ r₂)

theorem perm_product_right (l : list A) {t₁ t₂ : list B} : t₁ ~ t₂ → (product l t₁) ~ (product l t₂) :=
list.induction_on l
  (λ p, by rewrite [*nil_product])
  (λ a t r p,
    perm_app (perm_map _ p) (r p))

theorem perm_product [congr] {l₁ l₂ : list A} {t₁ t₂ : list B} : l₁ ~ l₂ → t₁ ~ t₂ → (product l₁ t₁) ~ (product l₂ t₂) :=
assume p₁ p₂, trans (perm_product_left t₁ p₁) (perm_product_right l₂ p₂)
end product

/- filter -/
theorem perm_filter [congr] {l₁ l₂ : list A} {p : A → Prop} [decidable_pred p] :
  l₁ ~ l₂ → (filter p l₁) ~ (filter p l₂) :=
assume u, perm.induction_on u
  perm.nil
  (take x l₁' l₂',
    assume u' : l₁' ~ l₂',
    assume u'' : filter p l₁' ~ filter p l₂',
    decidable.by_cases
      (suppose p x, by rewrite [*filter_cons_of_pos _ this]; apply perm.skip; apply u'')
      (suppose ¬ p x, by rewrite [*filter_cons_of_neg _ this]; apply u''))
  (take x y l,
    decidable.by_cases
      (assume H1 : p x,
        decidable.by_cases
          (assume H2 : p y,
             begin
               rewrite [filter_cons_of_pos _ H1, *filter_cons_of_pos _ H2, filter_cons_of_pos _ H1],
               apply perm.swap
             end)
          (assume H2 : ¬ p y,
             by rewrite [filter_cons_of_pos _ H1, *filter_cons_of_neg _ H2, filter_cons_of_pos _ H1]))
      (assume H1 : ¬ p x,
        decidable.by_cases
          (assume H2 : p y,
             by rewrite [filter_cons_of_neg _ H1, *filter_cons_of_pos _ H2, filter_cons_of_neg _ H1])
          (assume H2 : ¬ p y,
             by rewrite [filter_cons_of_neg _ H1, *filter_cons_of_neg _ H2, filter_cons_of_neg _ H1])))
    (λ l₁ l₂ l₃ p₁ p₂ r₁ r₂, trans r₁ r₂)

section count
variable [decA : decidable_eq A]
include decA

theorem count_eq_of_perm {l₁ l₂ : list A} : l₁ ~ l₂ → ∀ a, count a l₁ = count a l₂ :=
suppose l₁ ~ l₂, perm.induction_on this
  (λ a, rfl)
  (λ x l₁ l₂ p h a, by rewrite [*count_cons, *h a])
  (λ x y l a, by_cases
     (suppose a = x, by_cases
       (suppose a = y, begin subst x, subst y end)
       (suppose a ≠ y, begin subst x, rewrite [count_cons_of_ne this, *count_cons_eq, count_cons_of_ne this] end))
     (suppose a ≠ x, by_cases
       (suppose a = y, begin subst y, rewrite [count_cons_of_ne this, *count_cons_eq, count_cons_of_ne this] end)
       (suppose a ≠ y, begin rewrite [count_cons_of_ne `a≠x`, *count_cons_of_ne `a≠y`, count_cons_of_ne `a≠x`] end)))
  (λ l₁ l₂ l₃ p₁ p₂ h₁ h₂ a, eq.trans (h₁ a) (h₂ a))
end count
end perm


import game.max.level08 -- hide

open_locale classical -- hide

noncomputable theory -- hide

namespace xena -- hide

/-
# Chapter ? : Max

## Level 9

We've done `max_le_iff`; here is `le_max_iff`.
-/

/- Lemma
If $a$, $b$, $c$ are real numbers,
then $a\leq\max(b,c)$ iff ($a\leq b$ or $a\leq c$).
-/

theorem le_max_iff {a b c : ℝ} : a ≤ max b c ↔ a ≤ b ∨ a ≤ c :=
begin
  split,
  { intro ha,
    cases le_total b c with hbc hcb,
    { rw max_eq_right hbc at ha,
      right,
      assumption,
    },
    { rw max_eq_left hcb at ha,
      left,
      assumption
    }
  },
  { intro habc,
    cases habc with hab hac,
    { apply le_trans hab,
      apply le_max_left},
    { apply le_trans hac,
      apply le_max_right},
  }
end

end xena --hide